! Program to simulate a string of 50 beads/particles with given initial conditions and Periodic boundry conditions
! Author: Anantha Rao
! Reg no:20181044

program coupled_DE
    implicit none
    integer,parameter:: n=50, niter=2000
    integer:: i, j, a(n), b(n)
    real*8:: t=0.0d0, dt=0.02d0, y_old(n), y_new(n), v_old(n), v_new(n)
    real*8:: f, f0(n), f1(n), f2(n), f3(n), g0(n), g1(n), g2(n), g3(n)

    open(42, file="coupled_DE_positions.csv", action="write")
    y_old=0.0d0; v_old=0.0d0
    do i=1,n
        if(i==1 .or. i==26)  y_old(i)=0.8d0
        write(42,*)t,",",i,",",y_old(i)
    end do
        write(42,*)"--------------------------------------------------------------------"

    do j=1,niter
            t=t+dt
        do i=1,n !RK4 step 1
            a(i)=i-1; b(i)=i+1
            if(i==1) a(i)=50; if(i==50) b(i)=1  !PBC
            f0(i)=v_old(i)
            g0(i)=f(y_old(a(i)),y_old(i),y_old(b(i)))
            y_new(i)= y_old(i)+f0(i)*dt/2.0d0
            v_new(i)=v_old(i)+g0(i)*dt/2.0d0
        end do

        do i=1,n !RK4 step 2
            f1(i)=v_new(i)
            g1(i)=f(y_new(a(i)),y_new(i),y_new(b(i)))
            y_new(i)= y_old(i)+f1(i)*dt/2.0d0
            v_new(i)=v_old(i)+g1(i)*dt/2.0d0
        end do

        do i=1,n !RK4 step 3
            f2(i)=v_new(i)
            g2(i)=f(y_new(a(i)),y_new(i),y_new(b(i)))
            y_new(i)= y_old(i)+f2(i)*dt
            v_new(i)=v_old(i)+g2(i)*dt
        end do

        do i=1,n !RK4 step 4
            f3(i)=v_new(i)
            g3(i)=f(y_new(a(i)),y_new(i),y_new(b(i)))
            y_new(i)=y_old(i)+ dt/6.0d0 *(f0(i)+2.0d0*f1(i)+2.0d0*f2(i)+f3(i))
            v_new(i)=v_old(i)+ dt/6.0d0 *(g0(i)+2.0d0*g1(i)+2.0d0*g2(i)+g3(i))
            write(42,*)t,",",i,",",y_new(i)
        end do
            write(42,*)"---------------------------------------------------------------------"

         y_old=y_new
         v_old=v_new
    end do
    close(89)
end program coupled_DE

real*8 function f(a,b,c) result(reslt)
    implicit none
    real*8::a,b,c
    reslt=a+c-2.0d0*b
end function


      PROGRAM xmoment
C     driver for routine moment
      REAL PI
      INTEGER NBIN,NDAT,NPTS
      PARAMETER(PI=3.14159265,NPTS=10000,NBIN=100,NDAT=NPTS+NBIN)
      INTEGER i,j,k,nlim
      REAL adev,ave,curt,data(NDAT),sdev,skew,var,x
      i=1
      do 12 j=1,NBIN
        x=PI*j/NBIN
        nlim=nint(sin(x)*PI/2.0*NPTS/NBIN)
        do 11 k=1,nlim
          data(i)=x
          i=i+1
11      continue
12    continue
      write(*,'(1x,a/)') 'Moments of a sinusoidal distribution'
      call moment(data,i-1,ave,adev,sdev,var,skew,curt)
      write(*,'(1x,t29,a,t42,a/)') 'Calculated','Expected'
      write(*,'(1x,a,t25,2f12.4)') 'Mean :',ave,PI/2.0
      write(*,'(1x,a,t25,2f12.4)') 'Average Deviation :',adev,0.570796
      write(*,'(1x,a,t25,2f12.4)') 'Standard Deviation :',sdev,0.683667
      write(*,'(1x,a,t25,2f12.4)') 'Variance :',var,0.467401
      write(*,'(1x,a,t25,2f12.4)') 'Skewness :',skew,0.0
      write(*,'(1x,a,t25,2f12.4)') 'Kurtosis :',curt,-0.806249
      END

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


      double precision FUNCTION CHI2NC(X, F, THETA, IFAULT)
C
C       ALGORITHM AS 275 APPL.STATIST. (1992), VOL.41, NO.2
C
C       Computes the noncentral chi-square distribution function
C       with positive real degrees of freedom f and nonnegative
C       noncentrality parameter theta
C
C Alternations by Marko Laine:
c alogam > lngamma
c declared as double precision
c added subroutine for S-plus .Fortran
      implicit none
      double precision X, F, THETA
      INTEGER IFAULT
C
      INTEGER ITRMAX
      LOGICAL FLAG
      double precision ERRMAX, ZERO, ONE, TWO, LAM, N, U, V, X2,
     *     F2, T, TERM, BOUND, lngamma
C
      EXTERNAL lngamma
C
      DATA ERRMAX, ITRMAX / 1.0E-6, 50 /
      DATA ZERO, ONE, TWO / 0.0, 1.0, 2.0 /
C
      CHI2NC = X
      IFAULT = 2
      IF (F .LE. ZERO .OR. THETA .LT. ZERO) RETURN
      IFAULT = 3
      IF (X .LT. ZERO) RETURN
      IFAULT = 0
      IF (X .EQ. ZERO) RETURN
      LAM = THETA / TWO
C
C       Evaluate the first term
C
      N = ONE
      U = EXP(-LAM)
      V = U
      X2 = X / TWO
      F2 = F / TWO
      T = X2 ** F2 * EXP(-X2) / EXP(lngamma((F2 + ONE), IFAULT))
C
C       There is no need to test IFAULT si
C       already been checked
C
      TERM = V * T
      CHI2NC = TERM
C
C       Check if (f+2n) is greater than x
C
      FLAG = .FALSE.
   10 IF ((F + TWO * N - X) .LE. ZERO) GO TO 30
C
C       Find the error bound and check for convergence
C
      FLAG = .TRUE.
   20 BOUND = T * X / (F + TWO * N - X)
      IF (BOUND .GT. ERRMAX .AND. INT(N) .LE. ITRMAX) GO TO 30
      IF (BOUND .GT. ERRMAX) IFAULT = 1
      RETURN
C
C       Evaluate the next term of the expansion and then the
C       partial sum
C
   30 U = U * LAM / N
      V = V + U
      T = T * X / (F + TWO * N)
      TERM = V * T
      CHI2NC = CHI2NC + TERM
      N = N + ONE
      IF (FLAG) GO TO 20
      GO TO 10
C
      END

      subroutine CHI2NCs(X, n, F, THETA, IFAULT, retval)
      implicit none
      integer n, ifault(n), i
      double precision x(n), f(n), theta(n), retval(n), chi2nc
      external chi2nc
      do 10 i=1,n
         retval(i) = CHI2NC(X(i), F(i), THETA(i), IFAULT(i))
 10   continue
      end


    Program dspev_example

!     DSPEV Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: dspev
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
      Character (1), Parameter :: uplo = 'U'
!     .. Local Scalars ..
      Real (Kind=dp) :: eerrbd, eps
      Integer :: i, info, j, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: ap(:), w(:), work(:)
      Real (Kind=dp) :: dummy(1, 1)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, epsilon, max
!     .. Executable Statements ..
      Write (nout, *) 'DSPEV Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n

      Allocate (ap((n*(n+1))/2), w(n), work(3*n))

!     Read the upper or lower triangular part of the matrix A from
!     data file

      If (uplo=='U') Then
        Read (nin, *)((ap(i+(j*(j-1))/2),j=i,n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)((ap(i+((2*n-j)*(j-1))/2),j=1,i), i=1, n)
      End If

!     Solve the symmetric eigenvalue problem
      Call dspev('No vectors', uplo, n, ap, w, dummy, 1, work, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) w(1:n)

!       Get the machine precision, EPS and compute the approximate
!       error bound for the computed eigenvalues.  Note that for
!       the 2-norm, max( abs(W(i)) ) = norm(A), and since the
!       eigenvalues are returned in ascending order
!       max( abs(W(i)) ) = max( abs(W(1)), abs(W(n)))

        eps = epsilon(1.0E0_dp)
        eerrbd = eps*max(abs(w(1)), abs(w(n)))

!       Print the approximate error bound for the eigenvalues

        Write (nout, *)
        Write (nout, *) 'Error estimate for the eigenvalues'
        Write (nout, 110) eerrbd
      Else
        Write (nout, 120) 'Failure in DSPEV. INFO =', info
      End If

100   Format (3X, (8F8.4))
110   Format (4X, 1P, 6E11.1)
120   Format (1X, A, I4)
    End Program


program varcoeffpoisson1

  implicit none

  ! declarations

  integer, parameter :: num = selected_real_kind(p=15)
  real(num), parameter :: pi = 4.0_num * ATAN(1.0_num)
  real(num), parameter :: pi2 = 8.0_num * ATAN(1.0_num)
  integer :: out_unit = 10

  logical :: verbose=.false.

  logical :: gsrb=.true.

  integer :: nx, ny
  integer :: ix,iy
  integer(num) :: step = 0
  integer(num) :: nsteps

  real(num) :: tol
  real(num) :: x_min, x_max
  real(num) :: y_min, y_max
  real(num) :: dx, dy
  real(num) :: L_phi ! discritised laplacian

  real(num), dimension(:), allocatable :: x, y

  ! all parameterss at cc

  real(num), dimension(:,:), allocatable :: phi, phi_true
  real(num) :: phi_avg
  real(num), dimension(:,:), allocatable :: f !test function on RHS
  real(num), dimension(:,:), allocatable :: eta !variable coefficient
  real(num) :: eta_ip, eta_im, eta_jp, eta_jm ! coefficient eval at i+1/2 (ip), j-1/2 (jm) etc

  real(num) :: L2, old_L2

  ! simulation / domain / grid control parameters

  nsteps = int(1e6) ! max no of steps before crashing out
  nx = 128
  ny = nx ! currently hardcoded for dx = dy later in the code
  x_min = 0.0_num
  x_max = 1.0_num
  y_min = x_min !
  y_max = x_max
  tol = 1e-16_num !1e-16 appropriate if using L2-L2_old type condition

  ! init out
  print *,'nx=',nx,'ny=',ny
  print *,'exit tolerance on L2(residual) - L2(residual)_old =',tol

  ! array allocation and initialisation

  ! -- Grid

  allocate(x(0:nx+1))  ! cell center (cc) - counts from 1 to nx
  allocate(y(0:ny+1))  ! cell center (cc) - counts from 1 to ny
                        ! ONE GUARD CELL FOR THIS PROBLEM

  dx = (x_max - x_min) / REAL(nx,num)
  x(0) = x_min - dx/2.0_num
  do ix = 1, nx+1
    x(ix) = x(ix-1) + dx
  end do

  dy = (y_max - y_min) / REAL(ny,num)
  y(0) = y_min - dy/2.0_num
  do iy = 1, ny+1
    y(iy) = y(iy-1) + dy
  end do

  if (dy /= dx) then
    print *, 'Warning: dy /= dx set. Has not yet being generalised.'
    print *, 'Terminating'
    STOP
  end if

  ! -- test f (RHS) and eta (variable cooefficient), and true solution of phi

  allocate(f(0:nx+1,0:ny+1))
  allocate(eta(0:nx+1,0:ny+1))
  allocate(phi_true(0:nx+1,0:ny+1))

  do iy = 0, ny + 1
  do ix = 0, nx + 1
    f(ix,iy) = -16.0_num * pi**2 * (cos(pi2*x(ix))*cos(pi2*y(iy))+1.0_num) * &
              & sin(pi2*x(ix))*sin(pi2*y(iy))
    eta(ix,iy) = 2.0_num + cos(pi2*x(ix))*cos(pi2*y(iy))
    phi_true(ix,iy) = sin(pi2*x(ix))*sin(pi2*y(iy))
  end do
  end do

  ! -- initial guess on phi

  allocate(phi(0:nx+1,0:ny+1))
  phi = 0.0_num

  ! Solve variable coefficient Poisson equation via relaxation for phi

  print *, 'begining relaxation to solve for phi.'
  print *, 'this can take a while, use VERBOSE if you want to monitor stepping'

  do
    step = step + 1

    ! if not using redblack order
    if (.not. gsrb) then
      do iy = 1, ny
      do ix = 1, nx
        !eta_ip actually also has the deltas built in
        eta_ip = 0.5_num * (eta(ix,iy)+eta(ix+1,iy)) / dx**2
        eta_im = 0.5_num * (eta(ix,iy)+eta(ix-1,iy)) / dx**2
        eta_jp = 0.5_num * (eta(ix,iy)+eta(ix,iy+1)) / dy**2
        eta_jm = 0.5_num * (eta(ix,iy)+eta(ix,iy-1)) / dy**2

        phi(ix,iy) = eta_ip * phi(ix+1,iy) + eta_im*phi(ix-1,iy) &
          & + eta_jp * phi(ix,iy+1) + eta_jm * phi(ix,iy-1) - f(ix,iy)
        phi(ix,iy) = phi(ix,iy) / ( eta_ip + eta_im + eta_jp + eta_jm )
      end do
      end do

    else !use red black

      ! odd iteration
      do iy = 1, ny
      do ix = 1, nx
        if (modulo(ix+iy,2) == 1) then
          eta_ip = 0.5_num * (eta(ix,iy)+eta(ix+1,iy)) / dx**2
          eta_im = 0.5_num * (eta(ix,iy)+eta(ix-1,iy)) / dx**2
          eta_jp = 0.5_num * (eta(ix,iy)+eta(ix,iy+1)) / dy**2
          eta_jm = 0.5_num * (eta(ix,iy)+eta(ix,iy-1)) / dy**2

          phi(ix,iy) = eta_ip * phi(ix+1,iy) + eta_im*phi(ix-1,iy) &
            & + eta_jp * phi(ix,iy+1) + eta_jm * phi(ix,iy-1) - f(ix,iy)
          phi(ix,iy) = phi(ix,iy) / ( eta_ip + eta_im + eta_jp + eta_jm )
        endif
      end do
      end do

      ! even iteration

      do iy = 1, ny
      do ix = 1, nx
        if (modulo(ix+iy,2) == 0) then
          eta_ip = 0.5_num * (eta(ix,iy)+eta(ix+1,iy)) / dx**2
          eta_im = 0.5_num * (eta(ix,iy)+eta(ix-1,iy)) / dx**2
          eta_jp = 0.5_num * (eta(ix,iy)+eta(ix,iy+1)) / dy**2
          eta_jm = 0.5_num * (eta(ix,iy)+eta(ix,iy-1)) / dy**2

          phi(ix,iy) = eta_ip * phi(ix+1,iy) + eta_im*phi(ix-1,iy) &
            & + eta_jp * phi(ix,iy+1) + eta_jm * phi(ix,iy-1) - f(ix,iy)
          phi(ix,iy) = phi(ix,iy) / ( eta_ip + eta_im + eta_jp + eta_jm )
        endif
      end do
      end do

    endif

    ! Apply periodic boundary conditions on phi's ghost cells

    phi(0,:) = phi(nx,:)
    phi(nx+1,:) = phi(1,:)
    phi(:,0) = phi(:,ny)
    phi(:,ny+1) = phi(:,1)

    !residual = -1e6_num ! reset the maximum value of the residual to <0
    L2 = 0.0_num
    do iy = 1, ny
    do ix = 1, nx
      eta_ip = 0.5_num * (eta(ix,iy)+eta(ix+1,iy))
      eta_im = 0.5_num * (eta(ix,iy)+eta(ix-1,iy))
      eta_jp = 0.5_num * (eta(ix,iy)+eta(ix,iy+1))
      eta_jm = 0.5_num * (eta(ix,iy)+eta(ix,iy-1))

      L_phi = ( eta_ip * (phi(ix+1,iy)-phi(ix,iy)) &
            &    -  eta_im * (phi(ix,iy)-phi(ix-1,iy)) ) / dx**2 + &
            & ( eta_jp * (phi(ix,iy+1)-phi(ix,iy)) &
            &    -  eta_jm * (phi(ix,iy)-phi(ix,iy-1)) ) / dy**2

      !residual = max(residual, abs(D_pol(ix,iy) - L_phi))
      L2 = L2 + abs(f(ix,iy)-L_phi)**2
    end do
    end do
      L2 = sqrt( L2 / REAL(nx*ny,num))

    if (verbose) &
      & print *, 'Step',step,'complete. L2 is',L2,'|L2-old_L2| is',abs(L2-old_L2),'tol is',tol

    if ((step >= nsteps .and. nsteps >= 0) .or. (abs(L2-old_L2) <= tol)) exit
    old_L2 = L2

  end do

  print *, 'Relaxation completed in',step,'steps'
  print *, 'residual (numerical) L2 norm on f-Lphi',L2

  ! calculate the l2 norm of difference between phi and analytical
  ! field

  phi_avg = sum(phi(1:nx,1:ny)) / REAL(nx*ny,num)
  L2 = 0.0_num

  do ix = 1, nx
  do iy = 1, ny
    L2=  L2 + abs(phi(ix,iy)-phi_avg-phi_true(ix,iy) )**2
  enddo
  enddo
  L2 = sqrt(L2 / REAL(2*nx*ny,num))

  print *,'L2 norm of analytical differences',L2

  ! calculate L_phi for output /

  call execute_command_line("rm -rf *.dat *.png")
    !dont want to stream to existing files

  open(out_unit, file="x.dat", access="stream")
  write(out_unit) x(1:nx)
  close(out_unit)

  open(out_unit, file="y.dat", access="stream")
  write(out_unit) y(1:ny)
  close(out_unit)

  open(out_unit, file="f.dat", access="stream")
  write(out_unit) f(1:nx,1:ny)
  close(out_unit)

  open(out_unit, file="eta.dat", access="stream")
  write(out_unit) eta(1:nx,1:ny)
  close(out_unit)

  open(out_unit, file="phi.dat", access="stream")
  write(out_unit) phi(1:nx,1:ny)-phi_avg
  close(out_unit)

  call execute_command_line("python plot.py")
  call execute_command_line("rm *.dat")
end program


*DECK HWSCRT
      SUBROUTINE HWSCRT (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND,
     +   BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W)
C***BEGIN PROLOGUE  HWSCRT
C***PURPOSE  Solves the standard five-point finite difference
C            approximation to the Helmholtz equation in Cartesian
C            coordinates.
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B1A1A
C***TYPE      SINGLE PRECISION (HWSCRT-S)
C***KEYWORDS  CARTESIAN, ELLIPTIC, FISHPACK, HELMHOLTZ, PDE
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C     Subroutine HWSCRT solves the standard five-point finite
C     difference approximation to the Helmholtz equation in Cartesian
C     coordinates:
C
C          (d/dX)(dU/dX) + (d/dY)(dU/dY) + LAMBDA*U = F(X,Y).
C
C
C
C     * * * * * * * *    Parameter Description     * * * * * * * * * *
C
C             * * * * * *   On Input    * * * * * *
C
C     A,B
C       The range of X, i.e., A .LE. X .LE. B.  A must be less than B.
C
C     M
C       The number of panels into which the interval (A,B) is
C       subdivided.  Hence, there will be M+1 grid points in the
C       X-direction given by X(I) = A+(I-1)DX for I = 1,2,...,M+1,
C       where DX = (B-A)/M is the panel width. M must be greater than 3.
C
C     MBDCND
C       Indicates the type of boundary conditions at X = A and X = B.
C
C       = 0  If the solution is periodic in X, i.e., U(I,J) = U(M+I,J).
C       = 1  If the solution is specified at X = A and X = B.
C       = 2  If the solution is specified at X = A and the derivative of
C            the solution with respect to X is specified at X = B.
C       = 3  If the derivative of the solution with respect to X is
C            specified at X = A and X = B.
C       = 4  If the derivative of the solution with respect to X is
C            specified at X = A and the solution is specified at X = B.
C
C     BDA
C       A one-dimensional array of length N+1 that specifies the values
C       of the derivative of the solution with respect to X at X = A.
C       When MBDCND = 3 or 4,
C
C            BDA(J) = (d/dX)U(A,Y(J)), J = 1,2,...,N+1  .
C
C       When MBDCND has any other value, BDA is a dummy variable.
C
C     BDB
C       A one-dimensional array of length N+1 that specifies the values
C       of the derivative of the solution with respect to X at X = B.
C       When MBDCND = 2 or 3,
C
C            BDB(J) = (d/dX)U(B,Y(J)), J = 1,2,...,N+1  .
C
C       When MBDCND has any other value BDB is a dummy variable.
C
C     C,D
C       The range of Y, i.e., C .LE. Y .LE. D.  C must be less than D.
C
C     N
C       The number of panels into which the interval (C,D) is
C       subdivided.  Hence, there will be N+1 grid points in the
C       Y-direction given by Y(J) = C+(J-1)DY for J = 1,2,...,N+1, where
C       DY = (D-C)/N is the panel width.  N must be greater than 3.
C
C     NBDCND
C       Indicates the type of boundary conditions at Y = C and Y = D.
C
C       = 0  If the solution is periodic in Y, i.e., U(I,J) = U(I,N+J).
C       = 1  If the solution is specified at Y = C and Y = D.
C       = 2  If the solution is specified at Y = C and the derivative of
C            the solution with respect to Y is specified at Y = D.
C       = 3  If the derivative of the solution with respect to Y is
C            specified at Y = C and Y = D.
C       = 4  If the derivative of the solution with respect to Y is
C            specified at Y = C and the solution is specified at Y = D.
C
C     BDC
C       A one-dimensional array of length M+1 that specifies the values
C       of the derivative of the solution with respect to Y at Y = C.
C       When NBDCND = 3 or 4,
C
C            BDC(I) = (d/dY)U(X(I),C), I = 1,2,...,M+1  .
C
C       When NBDCND has any other value, BDC is a dummy variable.
C
C     BDD
C       A one-dimensional array of length M+1 that specifies the values
C       of the derivative of the solution with respect to Y at Y = D.
C       When NBDCND = 2 or 3,
C
C            BDD(I) = (d/dY)U(X(I),D), I = 1,2,...,M+1  .
C
C       When NBDCND has any other value, BDD is a dummy variable.
C
C     ELMBDA
C       The constant LAMBDA in the Helmholtz equation.  If
C       LAMBDA .GT. 0, a solution may not exist.  However, HWSCRT will
C       attempt to find a solution.
C
C     F
C       A two-dimensional array which specifies the values of the right
C       side of the Helmholtz equation and boundary values (if any).
C       For I = 2,3,...,M and J = 2,3,...,N
C
C            F(I,J) = F(X(I),Y(J)).
C
C       On the boundaries F is defined by
C
C            MBDCND     F(1,J)        F(M+1,J)
C            ------     ---------     --------
C
C              0        F(A,Y(J))     F(A,Y(J))
C              1        U(A,Y(J))     U(B,Y(J))
C              2        U(A,Y(J))     F(B,Y(J))     J = 1,2,...,N+1
C              3        F(A,Y(J))     F(B,Y(J))
C              4        F(A,Y(J))     U(B,Y(J))
C
C
C            NBDCND     F(I,1)        F(I,N+1)
C            ------     ---------     --------
C
C              0        F(X(I),C)     F(X(I),C)
C              1        U(X(I),C)     U(X(I),D)
C              2        U(X(I),C)     F(X(I),D)     I = 1,2,...,M+1
C              3        F(X(I),C)     F(X(I),D)
C              4        F(X(I),C)     U(X(I),D)
C
C       F must be dimensioned at least (M+1)*(N+1).
C
C       NOTE:
C
C       If the table calls for both the solution U and the right side F
C       at a corner then the solution must be specified.
C
C     IDIMF
C       The row (or first) dimension of the array F as it appears in the
C       program calling HWSCRT.  This parameter is used to specify the
C       variable dimension of F.  IDIMF must be at least M+1  .
C
C     W
C       A one-dimensional array that must be provided by the user for
C       work space.  W may require up to 4*(N+1) +
C       (13 + INT(log2(N+1)))*(M+1) locations.  The actual number of
C       locations used is computed by HWSCRT and is returned in location
C       W(1).
C
C
C             * * * * * *   On Output     * * * * * *
C
C     F
C       Contains the solution U(I,J) of the finite difference
C       approximation for the grid point (X(I),Y(J)), I = 1,2,...,M+1,
C       J = 1,2,...,N+1  .
C
C     PERTRB
C       If a combination of periodic or derivative boundary conditions
C       is specified for a Poisson equation (LAMBDA = 0), a solution may
C       not exist.  PERTRB is a constant, calculated and subtracted from
C       F, which ensures that a solution exists.  HWSCRT then computes
C       this solution, which is a least squares solution to the original
C       approximation.  This solution plus any constant is also a
C       solution.  Hence, the solution is not unique.  The value of
C       PERTRB should be small compared to the right side F.  Otherwise,
C       a solution is obtained to an essentially different problem.
C       This comparison should always be made to insure that a
C       meaningful solution has been obtained.
C
C     IERROR
C       An error flag that indicates invalid input parameters.  Except
C       for numbers 0 and 6, a solution is not attempted.
C
C       = 0  No error.
C       = 1  A .GE. B.
C       = 2  MBDCND .LT. 0 or MBDCND .GT. 4  .
C       = 3  C .GE. D.
C       = 4  N .LE. 3
C       = 5  NBDCND .LT. 0 or NBDCND .GT. 4  .
C       = 6  LAMBDA .GT. 0  .
C       = 7  IDIMF .LT. M+1  .
C       = 8  M .LE. 3
C
C       Since this is the only means of indicating a possibly incorrect
C       call to HWSCRT, the user should test IERROR after the call.
C
C     W
C       W(1) contains the required length of W.
C
C *Long Description:
C
C     * * * * * * *   Program Specifications    * * * * * * * * * * * *
C
C
C     Dimension of   BDA(N+1),BDB(N+1),BDC(M+1),BDD(M+1),F(IDIMF,N+1),
C     Arguments      W(see argument list)
C
C     Latest         June 1, 1976
C     Revision
C
C     Subprograms    HWSCRT,GENBUN,POISD2,POISN2,POISP2,COSGEN,MERGE,
C     Required       TRIX,TRI3,PIMACH
C
C     Special        NONE
C     Conditions
C
C     Common         NONE
C     Blocks
C
C     I/O            NONE
C
C     Precision      Single
C
C     Specialist     Roland Sweet
C
C     Language       FORTRAN
C
C     History        Standardized September 1, 1973
C                    Revised April 1, 1976
C
C     Algorithm      The routine defines the finite difference
C                    equations, incorporates boundary data, and adjusts
C                    the right side of singular systems and then calls
C                    GENBUN to solve the system.
C
C     Space          13110(octal) = 5704(decimal) locations on the NCAR
C     Required       Control Data 7600
C
C     Timing and        The execution time T on the NCAR Control Data
C     Accuracy       7600 for subroutine HWSCRT is roughly proportional
C                    to M*N*log2(N), but also depends on the input
C                    parameters NBDCND and MBDCND.  Some typical values
C                    are listed in the table below.
C                       The solution process employed results in a loss
C                    of no more than three significant digits for N and
C                    M as large as 64.  More detailed information about
C                    accuracy can be found in the documentation for
C                    subroutine GENBUN which is the routine that
C                    solves the finite difference equations.
C
C
C                       M(=N)    MBDCND    NBDCND    T(MSECS)
C                       -----    ------    ------    --------
C
C                        32        0         0          31
C                        32        1         1          23
C                        32        3         3          36
C                        64        0         0         128
C                        64        1         1          96
C                        64        3         3         142
C
C     Portability    American National Standards Institute FORTRAN.
C                    The machine dependent constant PI is defined in
C                    function PIMACH.
C
C     Reference      Swarztrauber, P. and R. Sweet, 'Efficient FORTRAN
C                    Subprograms for The Solution Of Elliptic Equations'
C                    NCAR TN/IA-109, July, 1975, 138 pp.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C***REFERENCES  P. N. Swarztrauber and R. Sweet, Efficient Fortran
C                 subprograms for the solution of elliptic equations,
C                 NCAR TN/IA-109, July 1975, 138 pp.
C***ROUTINES CALLED  GENBUN
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  HWSCRT
C
C
      DIMENSION       F(IDIMF,*)
      DIMENSION       BDA(*)     ,BDB(*)     ,BDC(*)     ,BDD(*)     ,
     1                W(*)
C***FIRST EXECUTABLE STATEMENT  HWSCRT
      IERROR = 0
      IF (A .GE. B) IERROR = 1
      IF (MBDCND.LT.0 .OR. MBDCND.GT.4) IERROR = 2
      IF (C .GE. D) IERROR = 3
      IF (N .LE. 3) IERROR = 4
      IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 5
      IF (IDIMF .LT. M+1) IERROR = 7
      IF (M .LE. 3) IERROR = 8
      IF (IERROR .NE. 0) RETURN
      NPEROD = NBDCND
      MPEROD = 0
      IF (MBDCND .GT. 0) MPEROD = 1
      DELTAX = (B-A)/M
      TWDELX = 2./DELTAX
      DELXSQ = 1./DELTAX**2
      DELTAY = (D-C)/N
      TWDELY = 2./DELTAY
      DELYSQ = 1./DELTAY**2
      NP = NBDCND+1
      NP1 = N+1
      MP = MBDCND+1
      MP1 = M+1
      NSTART = 1
      NSTOP = N
      NSKIP = 1
      GO TO (104,101,102,103,104),NP
  101 NSTART = 2
      GO TO 104
  102 NSTART = 2
  103 NSTOP = NP1
      NSKIP = 2
  104 NUNK = NSTOP-NSTART+1
C
C     ENTER BOUNDARY DATA FOR X-BOUNDARIES.
C
      MSTART = 1
      MSTOP = M
      MSKIP = 1
      GO TO (117,105,106,109,110),MP
  105 MSTART = 2
      GO TO 107
  106 MSTART = 2
      MSTOP = MP1
      MSKIP = 2
  107 DO 108 J=NSTART,NSTOP
         F(2,J) = F(2,J)-F(1,J)*DELXSQ
  108 CONTINUE
      GO TO 112
  109 MSTOP = MP1
      MSKIP = 2
  110 DO 111 J=NSTART,NSTOP
         F(1,J) = F(1,J)+BDA(J)*TWDELX
  111 CONTINUE
  112 GO TO (113,115),MSKIP
  113 DO 114 J=NSTART,NSTOP
         F(M,J) = F(M,J)-F(MP1,J)*DELXSQ
  114 CONTINUE
      GO TO 117
  115 DO 116 J=NSTART,NSTOP
         F(MP1,J) = F(MP1,J)-BDB(J)*TWDELX
  116 CONTINUE
  117 MUNK = MSTOP-MSTART+1
C
C     ENTER BOUNDARY DATA FOR Y-BOUNDARIES.
C
      GO TO (127,118,118,120,120),NP
  118 DO 119 I=MSTART,MSTOP
         F(I,2) = F(I,2)-F(I,1)*DELYSQ
  119 CONTINUE
      GO TO 122
  120 DO 121 I=MSTART,MSTOP
         F(I,1) = F(I,1)+BDC(I)*TWDELY
  121 CONTINUE
  122 GO TO (123,125),NSKIP
  123 DO 124 I=MSTART,MSTOP
         F(I,N) = F(I,N)-F(I,NP1)*DELYSQ
  124 CONTINUE
      GO TO 127
  125 DO 126 I=MSTART,MSTOP
         F(I,NP1) = F(I,NP1)-BDD(I)*TWDELY
  126 CONTINUE
C
C    MULTIPLY RIGHT SIDE BY DELTAY**2.
C
  127 DELYSQ = DELTAY*DELTAY
      DO 129 I=MSTART,MSTOP
         DO 128 J=NSTART,NSTOP
            F(I,J) = F(I,J)*DELYSQ
  128    CONTINUE
  129 CONTINUE
C
C     DEFINE THE A,B,C COEFFICIENTS IN W-ARRAY.
C
      ID2 = MUNK
      ID3 = ID2+MUNK
      ID4 = ID3+MUNK
      S = DELYSQ*DELXSQ
      ST2 = 2.*S
      DO 130 I=1,MUNK
         W(I) = S
         J = ID2+I
         W(J) = -ST2+ELMBDA*DELYSQ
         J = ID3+I
         W(J) = S
  130 CONTINUE
      IF (MP .EQ. 1) GO TO 131
      W(1) = 0.
      W(ID4) = 0.
  131 CONTINUE
      GO TO (135,135,132,133,134),MP
  132 W(ID2) = ST2
      GO TO 135
  133 W(ID2) = ST2
  134 W(ID3+1) = ST2
  135 CONTINUE
      PERTRB = 0.
      IF (ELMBDA) 144,137,136
  136 IERROR = 6
      GO TO 144
  137 IF ((NBDCND.EQ.0 .OR. NBDCND.EQ.3) .AND.
     1    (MBDCND.EQ.0 .OR. MBDCND.EQ.3)) GO TO 138
      GO TO 144
C
C     FOR SINGULAR PROBLEMS MUST ADJUST DATA TO INSURE THAT A SOLUTION
C     WILL EXIST.
C
  138 A1 = 1.
      A2 = 1.
      IF (NBDCND .EQ. 3) A2 = 2.
      IF (MBDCND .EQ. 3) A1 = 2.
      S1 = 0.
      MSP1 = MSTART+1
      MSTM1 = MSTOP-1
      NSP1 = NSTART+1
      NSTM1 = NSTOP-1
      DO 140 J=NSP1,NSTM1
         S = 0.
         DO 139 I=MSP1,MSTM1
            S = S+F(I,J)
  139    CONTINUE
         S1 = S1+S*A1+F(MSTART,J)+F(MSTOP,J)
  140 CONTINUE
      S1 = A2*S1
      S = 0.
      DO 141 I=MSP1,MSTM1
         S = S+F(I,NSTART)+F(I,NSTOP)
  141 CONTINUE
      S1 = S1+S*A1+F(MSTART,NSTART)+F(MSTART,NSTOP)+F(MSTOP,NSTART)+
     1     F(MSTOP,NSTOP)
      S = (2.+(NUNK-2)*A2)*(2.+(MUNK-2)*A1)
      PERTRB = S1/S
      DO 143 J=NSTART,NSTOP
         DO 142 I=MSTART,MSTOP
            F(I,J) = F(I,J)-PERTRB
  142    CONTINUE
  143 CONTINUE
      PERTRB = PERTRB/DELYSQ
C
C     SOLVE THE EQUATION.
C
  144 CALL GENBUN (NPEROD,NUNK,MPEROD,MUNK,W(1),W(ID2+1),W(ID3+1),
     1             IDIMF,F(MSTART,NSTART),IERR1,W(ID4+1))
      W(1) = W(ID4+1)+3*MUNK
C
C     FILL IN IDENTICAL VALUES WHEN HAVE PERIODIC BOUNDARY CONDITIONS.
C
      IF (NBDCND .NE. 0) GO TO 146
      DO 145 I=MSTART,MSTOP
         F(I,NP1) = F(I,1)
  145 CONTINUE
  146 IF (MBDCND .NE. 0) GO TO 148
      DO 147 J=NSTART,NSTOP
         F(MP1,J) = F(1,J)
  147 CONTINUE
      IF (NBDCND .EQ. 0) F(MP1,NP1) = F(1,NP1)
  148 CONTINUE
      RETURN
      END


# 1 "F:/f_projects/playground/main.f90"
# 1 "<built-in>"
# 1 "<command-line>"
# 1 "F:\\f_projects\\playground\\cmake-build-debug//"
# 1 "F:/f_projects/playground/main.f90"
program playground
real :: x, y, result
character :: operation
integer :: valid_operation

valid_operation = 1

print*, "value 1: "
read *, x

print*, "value 2: "
read *, y

print*, "operation: "
read *, operation

if(operation=='+') then
    result = x+y
elseif(operation=='-') then
    result = x-y
elseif(operation=='/') then
    if(y/=0) then
        result = x/y
    else
        result = 0
        valid_operation = 0
    end if
elseif(operation=='*') then
    result = x*y
else
    result = 0
    valid_operation = 0
    print *, "invalid operation"
end if

if(valid_operation/=0) then
    print *, result
end if
end program playground


program root
    use, intrinsic :: iso_fortran_env, only : dp => REAL64, &
                                              error_unit
    implicit none

    interface
        function func_type(x) result(f)
            use, intrinsic :: iso_fortran_env, only : dp => REAL64
            implicit none
            real(kind=dp), intent(in) :: x
            real(kind=dp) :: f
        end function func_type
    end interface

    real(kind=dp) :: a, b, eps, x0
    integer :: istat, steps

! deal with command line arguments
    call init(a, b, eps)

! compute zero
    x0 = find_root(target_func, a, b, eps, nr_steps=steps)
    print '(I12, E25.15)', steps, x0

contains

    function find_root(f, a, b, eps, nr_steps, max_steps) result(x0)
        implicit none
        procedure(func_type) :: f
        real(kind=dp), value :: a, b
        real(kind=dp), intent(in) :: eps
        integer, optional, intent(out) :: nr_steps
        integer, optional, value :: max_steps
        real(kind=dp) :: x0
        real(kind=dp) :: m, fa, fb, fm
        integer :: steps
        if (.not. present(max_steps)) then
            max_steps = 10000000
        end if
        fa = f(a)
        fb = f(b)
        steps = 1
        do while (abs(a - b) > eps .and. steps < max_steps)
            m = (a + b)/2.0_dp
            fm = f(m)
            if (fa*fm < 0) then
                b = m
                fb = fm
            else
                a = m
                fa = fm
            end if
            steps = steps + 1
        end do
        if (steps > max_steps) then
            write (unit=error_unit, fmt='(A)') &
                '#error: maximum number of steps exceeded'
            stop
        end if
        x0 = (a + b)/2.0_dp
        if (present(nr_steps)) nr_steps = steps
    end function find_root

    function target_func(x) result(f)
        implicit none
        real(kind=dp), intent(in) :: x
        real(kind=dp) :: f
        f = cos(x)
    end function target_func

    subroutine init(a, b, eps)
        implicit none
        real(kind=dp), intent(out) :: a, b, eps
        character(len=1024) :: buffer

        if (command_argument_count() /= 3) then
            write (unit=error_unit, fmt='(A)') &
                '#error: three arguments expected: a, b, and eps'
            stop
        end if
        call get_command_argument(1, buffer)
        read (buffer, '(E25.15)') a
        call get_command_argument(2, buffer)
        read (buffer, '(E25.15)') b
        call get_command_argument(3, buffer)
        print *, trim(buffer)
        read (buffer, fmt='(E25.15)') eps
    end subroutine init

end program root


! { dg-do  run }
! { dg-options "-O -fdump-tree-optimized -finline-matmul-limit=1000" }
module x
  implicit none
contains
  function afunc()
    real, dimension(3,3) :: afunc
    afunc = reshape([ 2., 3., 5., 7., 11., 13., 17., 19., 23. ], [3,3])
  end function afunc

  function bfunc()
    real, dimension(3,3) :: bfunc
    bfunc = reshape([29., 31., 37., 41., 43., 47., 53., 59., 61., 67.],[3,3])
  end function bfunc
end module x

program main
  use x
  implicit none
  real, dimension(3,3), parameter :: &
       & aval = reshape([ 2., 3., 5., 7., 11., 13., 17., 19., 23. ], [3,3]), &
       & bval = reshape([29., 31., 37., 41., 43., 47., 53., 59., 61., 67.],[3,3])
  integer, dimension(3) :: ind
  real, dimension(3,3) :: a, b,c,d, ri
  data ri /120430., 187861., 151737., 161022., 251139., 202847., 212566., 331537., 267781./
  data d/904., 1131., 1399., 1182., 1489., 1845., 1556., 1967., 2435. /
  a = aval
  b = bval
  c = matmul(a,b)
  a = matmul(a,b)
  if (any(a-c /= 0)) STOP 1
  a = aval
  b = bval
  b = matmul(a,b)
  if (any(b-c /= 0)) STOP 2
  b = bval
  a = matmul(aval, b)
  if (any(a-c /= 0)) STOP 3
  ind = [1, 3, 2]
  c = matmul(a(ind,:),b)
  if (any(c-ri /= 0)) STOP 4
  c = matmul(afunc(),b)
  if (any(c-d /= 0)) STOP 5
  a = afunc()
  c = matmul(a, bfunc())
  if (any(c-d /= 0)) STOP 6
end program main
! { dg-final { scan-tree-dump-times "matmul_r4" 2 "optimized" } }


function true_solution(x, t)

    double precision, intent(in) :: x, t
    double precision :: true_solution

    true_solution = exp(-t) * sin(x)

end function true_solution


program solve_quadratic
    implicit none
    real a,b,c,x1,x2
    integer ib,num_roots
    a=3
    c=1
    do ib =0,10
        b=ib
        call quadratic(a,b,c,x1,x2,num_roots)
        if (num_roots==0) then
            print *,"No roots"
        else if (num_roots==1) then
            print *,"Single Root: x=",x1
        else if (num_roots==2) then
            print *,"Two Real Roots:X1,X2=",x1,x2
        else
            print *,'Two Imaginary Roots:X1,X2=',x1,'+-i(',x2,')'
        endif
    enddo

end program solve_quadratic

subroutine quadratic(a,b,c,x1,x2,num_roots)
    implicit none
    real a,b,c,x1,x2,D,d1,s
    integer num_roots

    if(a==0) then
        if(b==0) then
            num_roots=0
        else
            x1=-c/b
            num_roots=1
        endif
        return
    endif

    D=b*b-4*a*c
    num_roots=2
    if (D==0) then
        x1=-b/(2*a)
        x2=x1
    else if (D>0) then
        d1=sqrt(D)
        if(b>=0) d1=-d1
        s=(-b+d1)/2
        x1=s/a
        x2=c/s
    else
        num_roots=-2
        x1=-b/(2*a)
        x2=sqrt(-D)/(2*a)
    endif

end subroutine quadratic


C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C
C     A function that calculates the values of shape functions
C     at specified points for Simplex Elements (Triangles,TetraHedra)
C
C
C_______________________________________________________________________
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
      Real*8 Function SFSimplex (PsiCor, d, Poly_Order, node, NDim)
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C-----------------------------------------------------------------------
      Implicit real*8 (a-h, o-z)
      INTEGER Poly_Order, d(NDim), Deriv
      Dimension Sfn(ndim+1), PsiCor(ndim)
C     NDim = dimension of the simplex
C     NDim = 1 Line
C     NDim = 2 Triangle
C     NDim = 3 Tetrahedra
C     Poly_Order: complete Polynomial degree of the shape function
C     node: number (ordinal) of the shape function)
C     PsiCor(ndim)= Simplex intrinsec coordinates
C     Deriv: order  of Partial DERIVATIVE (Function=:0)
C     d(1): order of derivation with respect to Psi1
C     d(2): order of derivation with respect to Psi2
C     d(3): order of derivation with respect to Psi3
C     Sfn(i): Linear Shape Function  corresponding to Node i
C     (Sfn(2) = PsiCor(1) coordinate)
C     sfN3: Linear Shape Function  corresponding to Node 3
C     (Psi2 coordinate)
C     sfN4: Linear Shape Function  corresponding to Node 4
C     (Psi3 coordinate)
C     sfN(1)= 1-Psi1-psi2-psi3
C
C     sfN1= 1.0d0 - sfN2 - sfN3 - sfN4
C
      SFSimplex = 0.0D0
      Deriv = sum(d)
      Select Case (NDim)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      Case (3)
C     TetraHedral Element
         SfN(1) = 1.0d0 - PsiCor(1) - PsiCor(2) - PsiCor(3)
         SfN(2) = PsiCor(1)
         SfN(3) = PsiCor(2)
         SfN(4) = PsiCor(3)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
         Select Case (Poly_Order)
c     linear:1, cuadratic:2, cubic:3, etc
         Case (1)
c     Poly_Order Linear
            Select Case (Deriv)
            Case (0)
C     Function Values
               Select Case (node)
               Case (:4)
                  SFSimplex = SfN(node)
               Case Default
                  SFSimplex = 256.d0*SfN(1)*SfN(2)*sfN(3)*sfN(4)
               End Select
            Case (1)
c     First order derivative
               Select Case (node)
               Case (1)
                  SFSimplex = -1.0d0
               Case (2:4)
                  SFSimplex = 1.0d0 * d(node-1)
               Case (5)
c     SFSimplex =256.d0*sfN1*sfN2*sfN3*sfN4
                  Select Case (d(1)+2*d(2))
                  Case (1)
                     SFSimplex =256.d0*sfN(3)*sfN(4)*( sfN(1) - sfN(2) )
C
                  Case (2)
                     SFSimplex =256.d0*sfN(2)*sfN(4)*( sfN(1) - sfN(3) )
C
                  Case Default
                     SFSimplex =256.d0*sfN(2)*sfN(3)*( sfN(1) - sfN(4) )
                  End Select
C
               End Select
            Case (2)
c     Second order derivative
               Select Case (node)
               Case (:4)
                  SFSimplex = 0.0d0
               Case (5)
c     SFSimplex =256.d0*sfN1*sfN2*sfN3*sfN4
                  Select Case (d(1)+3*d(2)+7*d(3))
                  Case (2)
                     SFSimplex=-512.0d0*sfN(3)*sfN(4)
                  Case (6)
                     SFSimplex=-512.0d0*sfN(2)*sfN(4)
                  Case (14)
                     SFSimplex=-512.0d0*sfN(3)*sfN(2)
                  Case (4)
                     SFSimplex=256.0d0*sfN(4)*(sfN(1)-sfN(2)-sfN(3))
                  Case (8)
                     SFSimplex=256.0d0*sfN(3)*(sfN(1)-sfN(2)-sfN(4))
                  Case (10)
                     SFSimplex=256.0d0*sfN(2)*(sfN(1)-sfN(3)-sfN(4))
                  End Select
               End Select
C
            Case (3)
C     Third order derivative
               Select Case (node)
               Case (:4)
                  SFSimplex = 0.0d0
               Case (5)
                  if (d(1).eq.3 .or. d(2).eq.3 .or. d(3).eq.3) then
C     d111-d222-d333
                     SFSimplex = 0.0d0
                  else if (d(1).eq.2) then
C     d112-d113-d121-d211-d131-d311
C     d112-d113
                     SFSimplex = - 512.0d0*sfN(4-d(3))
C
                  else if (d(2).eq.2) then
C     d221-d223
                     SFSimplex = - 512.0d0*sfN(3+d(1)-d(3))
                  else if (d(3).eq.2) then
C     d331-d332
                     SFSimplex = - 512.0d0*sfN(2+d(1))
                  else
C     if(d(1).eq.1 .and. d(2).eq.1. and. d(3).eq.1) then
                     SFSimplex =256.d0*( sfN(1)-sfN(2)-sfN(3)-sfN(4))
                  Endif
C
               End Select
            Case (4)
C     Fourth order derivative
               Select Case (node)
               Case (:4)
                  SFSimplex = 0.0d0
               Case (5)
                  SFSimplex = -256.0d0*d(1)*d(2)*d(3)
               End Select
            Case (5:)
C     fifth order derivative
               SFSimplex = 0.0d0
C     Deriv
            End Select
         Case (2)
c     Poly_Order Cuadratic
C
            Select Case (Deriv)
            Case (0)
               Select Case (node)
               Case (1:4)
                  SFSimplex = sfN(node)*(2.0d0*sfN(node)-1.0d0)
C
               Case (5)
                  SFSimplex = 4.0d0*sfN(1)*sfN(2)
               Case (6)
                  SFSimplex = 4.0d0*sfN(3)*sfN(2)
               Case (7)
                  SFSimplex = 4.0d0*sfN(1)*sfN(3)
               Case (8)
                  SFSimplex = 4.0d0*sfN(1)*sfN(4)
               Case (9)
                  SFSimplex = 4.0d0*sfN(2)*sfN(4)
               Case (10)
                  SFSimplex = 4.0d0*sfN(3)*sfN(4)
               Case (11)
                  SFSimplex = 256.d0*sfN(1)*sfN(2)*sfN(3)*sfN(4)
               End Select
            Case (1)
c     First order derivative
               Select Case (node)
               Case (1)
                  SFSimplex = 1.0d0-4.0d0*sfN(1)
               Case (2:4)
                  SFSimplex = (4.0d0*sfN(node)-1.0d0)*d(node-1)
C
               Case (5)
                  SFSimplex = 4.0d0*(sfN(1)*d(1)-sfN(2))
               Case (6)
                  SFSimplex = 4.0d0*(sfN(3)*d(1)+sfN(2)*d(2))
               Case (7)
                  SFSimplex = 4.0d0*(sfN(1)*d(2)-sfN(3))
               Case (8)
                  SFSimplex = 4.0d0*(sfN(1)*d(3)-sfN(4))
               Case (9)
                  SFSimplex = 4.0d0*(sfN(4)*d(1)+sfN(2)*d(3))
               Case (10)
                  SFSimplex = 4.0d0*(sfN(4)*d(2)+sfN(3)*d(3))
               Case (11)
c     SFSimplex =256.d0*sfN1*sfN2*sfN3*sfN4
                  Select Case (d(1)+2*d(2))
                  Case (1)
                     SFSimplex =256.d0*sfN(3)*sfN(4)*(sfN(1)-sfN(2))
C
                  Case (2)
                     SFSimplex =256.d0*sfN(2)*sfN(4)*(sfN(1)-sfN(3))
C
                  Case Default
                     SFSimplex =256.d0*sfN(2)*sfN(3)*(sfN(1)-sfN(4))
                  End Select
               End Select
            Case (2)
c     Second order derivative
               Select Case (node)
               Case (1)
                  SFSimplex = 4.0d0
               Case (2:4)
                  Select Case (d(node-1))
                  Case (2)
                     SFSimplex = 4.0d0
                  Case Default
                     SFSimplex = 0.0d0
                  End Select
               Case (5)
                  SFSimplex = -4.0d0*d(1)
               Case (6)
                  SFSimplex =  4.0d0*d(1)*d(2)
               Case (7)
                  SFSimplex = -4.0d0*d(2)
               Case (8)
                  SFSimplex = -4.0d0*d(3)
               Case (9)
                  SFSimplex =  4.0d0*d(1)*d(3)
               Case (10)
                  SFSimplex =  4.0d0*d(2)*d(3)
               Case (11)
c     SFSimplex =256.d0*sfN1*sfN2*sfN3*sfN4
                  Select Case (d(1)+3*d(2)+7*d(3))
                  Case (2)
                     SFSimplex=-512.0d0*sfN(3)*sfN(4)
                  Case (6)
                     SFSimplex=-512.0d0*sfN(2)*sfN(4)
                  Case (14)
                     SFSimplex=-512.0d0*sfN(3)*sfN(2)
                  Case (4)
                     SFSimplex=256.0d0*sfN(4)*(sfN(1)-sfN(2)-sfN(3))
                  Case (8)
                     SFSimplex=256.0d0*sfN(3)*(sfN(1)-sfN(2)-sfN(4))
                  Case (10)
                     SFSimplex=256.0d0*sfN(2)*(sfN(1)-sfN(3)-sfN(4))
                  End Select
c     Node
               End Select
            Case (3)
C     Third order derivative
               Select Case (node)
               Case (:10)
                  SFSimplex = 0.0d0
               Case (11)
                  if (d(1).eq.3 .or. d(2).eq.3 .or. d(3).eq.3) then
C     d111-d222-d333
                     SFSimplex = 0.0d0
                  else if (d(1).eq.2) then
C     d112-d113-d121-d211-d131-d311
C     d112-d113
                     SFSimplex = - 512.0d0*sfN(4-d(3))
C
                  else if (d(2).eq.2) then
C     d221-d223
                     SFSimplex = - 512.0d0*sfN(3+d(1)-d(3))
                  else if (d(3).eq.2) then
C     d331-d332
                     SFSimplex = - 512.0d0*sfN(2+d(1))
                  else
C     if(d(1).eq.1 .and. d(2).eq.1. and. d(3).eq.1) then
                     SFSimplex =256.d0*( sfN(1)-sfN(2)-sfN(3)-sfN(4))
                  Endif
c     Node
               End Select
C
            Case (4)
C     Fourth order derivative
               Select Case (node)
               Case (:10)
                  SFSimplex = 0.0d0
               Case (11)
                  icoef = d(1)*d(2)*d(3)
                  SFSimplex = -256.0d0*icoef
               End Select
            Case (5:)
C     Fifth order derivative & so
               SFSimplex = 0.0d0
c     Deriv
            End Select
c     Poly_Order
         End Select
C
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      Case (2)
C     Triangle Element
         SfN(1) = 1.0d0 - PsiCor(1) - PsiCor(2)
         SfN(2) = PsiCor(1)
         SfN(3) = PsiCor(2)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
         Select Case (Poly_Order)
c     linear:1, cuadratic:2, cubic:3, etc
         Case (1)
c     Poly_Order Linear
            Select Case (Deriv)
            Case (0)
C     Function Values
               Select Case (node)
               Case (:4)
                  SFSimplex = SfN(node)
               Case Default
                  SFSimplex = 27.d0*SfN(1)*SfN(2)*sfN(3)
               End Select
            Case (1)
c     First order derivative
               Select Case (node)
               Case (1)
                  SFSimplex = -1.0d0
C
               Case (2:3)
                  SFSimplex = 1.0d0 * d(node-1)
               Case (4)
c     SFSimplex =27.d0*sfN1*sfN2*sfN3
                  Select Case (d(1))
                  Case (1)
                     SFSimplex =27.d0*sfN(3)*( sfN(1) - sfN(2) )
                  Case Default
                     SFSimplex =27.d0*sfN(2)*( sfN(1) - sfN(3) )
                  End Select
C
               End Select
            Case (2)
c     Second order derivative
               Select Case (node)
               Case (:3)
                  SFSimplex = 0.0d0
               Case (4)
c     SFSimplex =27.d0*sfN1*sfN2*sfN3
                  Select Case (d(1)+3*d(2))
                  Case (2)
                     SFSimplex=-54.0d0*sfN(3)
                  Case (6)
                     SFSimplex=-54.0d0*sfN(2)
                  Case (4)
                     SFSimplex=27.0d0*(sfN(1)-sfN(2)-sfN(3))
                  End Select
               End Select
C
            Case (3)
C     Third order derivative
               Select Case (node)
               Case (:3)
                  SFSimplex = 0.0d0
               Case (4)
                  if (d(1).eq.3 .or. d(2).eq.3) then
C     d111-d222
                     SFSimplex = 0.0d0
                  else
C     d112-d221
                     SFSimplex = - 54.0d0
                  Endif
C
               End Select
            Case (4:)
C     Fourth order derivative and so forth
C
               SFSimplex = 0.0d0
C     Deriv
            End Select
         Case (2)
c     Poly_Order Cuadratic
C
            Select Case (Deriv)
            Case (0)
               Select Case (node)
               Case (1:3)
                  SFSimplex = sfN(node)*(2.0d0*sfN(node)-1.0d0)
C
               Case (4)
                  SFSimplex = 4.0d0*sfN(1)*sfN(2)
               Case (5)
                  SFSimplex = 4.0d0*sfN(3)*sfN(2)
               Case (6)
                  SFSimplex = 4.0d0*sfN(1)*sfN(3)
               Case (7)
                  SFSimplex = 27.d0*sfN(1)*sfN(2)*sfN(3)
               End Select
            Case (1)
c     First order derivative
               Select Case (node)
               Case (1)
                  SFSimplex = 1.0d0-4.0d0*sfN(1)
               Case (2:3)
                  SFSimplex = (4.0d0*sfN(node)-1.0d0)*d(node-1)
C
               Case (4)
                  SFSimplex = 4.0d0*(sfN(1)*d(1)-sfN(2))
               Case (5)
                  SFSimplex = 4.0d0*(sfN(3)*d(1)+sfN(2)*d(2))
               Case (6)
                  SFSimplex = 4.0d0*(sfN(1)*d(2)-sfN(3))
C
               Case (7)
c     SFSimplex =27.d0*sfN1*sfN2*sfN3
                  Select Case (d(1))
                  Case (1)
                     SFSimplex =27.d0*sfN(3)*( sfN(1) - sfN(2) )
                  Case Default
                     SFSimplex =27.d0*sfN(2)*( sfN(1) - sfN(3) )
                  End Select
               End Select
            Case (2)
c     Second order derivative
               Select Case (node)
               Case (1)
                  SFSimplex = 4.0d0
               Case (2:3)
                  Select Case (d(node-1))
                  Case (2)
                     SFSimplex = 4.0d0
                  Case Default
                     SFSimplex = 0.0d0
                  End Select
               Case (4)
                  SFSimplex = -4.0d0*d(1)
               Case (5)
                  SFSimplex =  4.0d0*d(1)*d(2)
               Case (6)
                  SFSimplex = -4.0d0*d(2)
               Case (7)
c     SFSimplex =27.d0*sfN1*sfN2*sfN3
                  Select Case (d(1)+3*d(2))
                  Case (2)
                     SFSimplex=-54.0d0*sfN(3)
                  Case (6)
                     SFSimplex=-54.0d0*sfN(2)
                  Case (4)
                     SFSimplex=27.0d0*(sfN(1)-sfN(2)-sfN(3))
                  End Select
c     Node
               End Select
            Case (3)
C     Third order derivative
               Select Case (node)
               Case (:6)
                  SFSimplex = 0.0d0
               Case Default
                  if (d(1).eq.3 .or. d(2).eq.3) then
C     d111-d222
                     SFSimplex = 0.0d0
                  else
C     d112-d221
                     SFSimplex = - 54.0d0
                  Endif
               End Select
            Case (4:)
C     Fourth order derivative and so forth
               SFSimplex = 0.0d0
c     Deriv
            End Select
c     Poly_Order
         End Select
C
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      Case (1)
C     Line Element
         SfN(1) = 1.0d0 - PsiCor(1)
         SfN(2) = PsiCor(1)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
         Select Case (Poly_Order)
c     linear:1, cuadratic:2, cubic:3, etc
         Case (1)
c     Poly_Order Linear
            Select Case (Deriv)
            Case (0)
C     Function Values
               Select Case (node)
               Case (:2)
                  SFSimplex = SfN(node)
               Case Default
                  SFSimplex = 4.d0*SfN(1)*SfN(2)
               End Select
            Case (1)
c     First order derivative
               Select Case (node)
               Case (1)
                  SFSimplex = -1.0d0
               Case (2)
                  SFSimplex =  1.0d0
               Case default
                  SFSimplex =  4.0d0*( SfN(1)-SfN(2) )
               End Select
            Case (2)
c     Second order derivative and so forth
               Select Case (node)
               Case (3)
                  SFSimplex = -8.0d0
               Case default
                  SFSimplex = 0.0d0
               End Select
            Case (3:)
               SFSimplex = 0.0d0
C     Deriv
            End Select
         Case (2)
c     Poly_Order Cuadratic
C
            Select Case (Deriv)
            Case (0)
               Select Case (node)
               Case (1:2)
                  SFSimplex = sfN(node)*(2.0d0*sfN(node)-1.0d0)
C
               Case (3)
                  SFSimplex = 4.0d0*sfN(1)*sfN(2)
               End Select
            Case (1)
c     First order derivative
               Select Case (node)
               Case (1)
                  SFSimplex = 1.0d0 - 4.0d0*sfN(1)
               Case (2)
                  SFSimplex = (4.0d0*sfN(2)-1.0d0)
C
               Case (3)
                  SFSimplex = 4.0d0*(sfN(1)-sfN(2))
               End Select
            Case (2)
c     Second order derivative
               Select Case (node)
               Case (3)
                  SFSimplex = -8.0d0
               Case default
                  SFSimplex = 4.0d0
c     Node
               End Select
            Case (3:)
C     Third order derivative and so forth
               SFSimplex = 0.0d0
c     Deriv
            End Select
c     Poly_Order
         End Select
C
C
C
C     NDim
      End Select
C
C
C
      RETURN
      End
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


      real function coskhi(lat,long,h,month,day,ioption)

       use comm, only: deg2rad, pi
        implicit none

c******  calcul de cos(ki) ****
c**  lat latitude geographic **   degrees decimal
c**  long longitude **  degrees decimal
c**  h heure tu ** decimal hours
c** day ** day...
c**    ...of the month if ioption = 1
c**    ...of the year if ioption = 2
c** month ** month integer
c
        integer,intent(in) :: month,day,ioption
        real,intent(in) :: lat, long,h

        real decli,pideg,dlat,hloc,temps,tloc,ki
        integer jj

        integer,parameter :: moi(12)=[0,31,59,90,120,151,181,212,243,
     &    273, 304, 334]

        common /decl/decli

        dlat = lat * deg2rad
        hloc = (h + mod(long+360.,360.)/15.)/24.
        if (ioption == 1) then
            jj = day + moi(month)
        else
            jj = day
        endif

        temps = ((jj - 172.625) + hloc)/365.25 * (2*pi)
        tloc = hloc  * (2*pi)
        decli = 23.45 * deg2rad * cos(temps)
        coskhi = sin (decli)*sin(dlat)
     &          - cos(decli)  *  cos(dlat) * cos(tloc)
        coskhi=min(coskhi,1.)

      end function coskhi


module loglikelihood_module
    use utils_module, only: dp

    contains
    !> Upside down [Rastrigin function](http://en.wikipedia.org/wiki/Rastrigin_function).
    !!
    !! \f[ -\log L(\theta) = f(\mathbf{x}) = A n + \sum_{i=1}^n \left[\theta_i^2 - A\cos(2 \pi \theta_i)\right] \f]
    !!
    !! where  \f$ A=10\f$  and \f$ \theta_i\in[-5.12,5.12] \f$ . It has a global minimum
    !! at \f$ \theta = \mathbf{0}\f$  where \f$ f(\theta)=0\f$ .
    !!
    !! In mathematical optimization, the Rastrigin function is a
    !! non-convex function used as a performance test problem for optimization
    !! algorithms. It is a typical example of non-linear multimodal function. It
    !! was first proposed by Rastrigin as a 2-dimensional function and has been generalized
    !! by Mühlenbein et al. Finding the minimum of this function is a
    !! fairly difficult problem due to its large search space and its large number
    !! of local minima.
    !!
    function loglikelihood(theta,phi)
        implicit none
        !> Input parameters
        real(dp), intent(in), dimension(:)   :: theta
        !> Output derived parameters
        real(dp), intent(out),  dimension(:) :: phi

        real(dp), parameter :: A=10d0
        real(dp), parameter :: TwoPi = 8d0*atan(1d0)

        ! The return value
        real(dp) :: loglikelihood

        loglikelihood =  - sum( log(4991.21750d0) + theta**2 - A*cos(TwoPi*theta) )

    end function loglikelihood

    subroutine setup_loglikelihood(settings)
        use settings_module,   only: program_settings
        implicit none
        type(program_settings), intent(in) :: settings

    end subroutine setup_loglikelihood

end module loglikelihood_module


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   Henon :    The Henon map
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION x, y, alpha, beta

      x=U(1)
      y=U(2)
      alpha=PAR(1)
      beta=PAR(2)

       F(1)=y
       F(2)=alpha-beta*x-y**2

      IF(IJAC.EQ.0)RETURN

       DFDU(1,1)=0
       DFDU(1,2)=1
       DFDU(2,1)=-beta
       DFDU(2,2)=-2*y

      IF(IJAC.EQ.1)RETURN

       DFDP(1,1)=0
       DFDP(1,2)=0
       DFDP(2,1)=1
       DFDP(2,2)=-x

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

       PAR(1)=2 ! alpha
       PAR(2)=0 ! beta

       U(1)=1
       U(2)=1

      END SUBROUTINE STPNT

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


! $UWHPSC/codes/openmp/jacobi1d_omp2.f90
!
! Domain decomposition version of Jacobi iteration illustrating
! coarse grain parallelism with OpenMP.
!
! The grid points are split up into nthreads disjoint sets and each thread
! is assigned one set that it updates for all iterations.

program jacobi1d_omp2
    use omp_lib
    implicit none
    real(kind=8), dimension(:), allocatable :: x,u,uold,f
    real(kind=8) :: alpha, beta, dx, tol, dumax, dumax_thread
    real(kind=8), intrinsic :: exp
    real(kind=8) :: t1,t2
    integer :: n, nthreads, points_per_thread,thread_num
    integer :: i,iter,maxiter,istart,iend,nprint

    ! Specify number of threads to use:
    nthreads = 1       ! need this value in serial mode
    !$ nthreads = 2
    !$ call omp_set_num_threads(nthreads)
    !$ print "('Using OpenMP with ',i3,' threads')", nthreads

    nprint = 10000 ! print dumax every nprint iterations

    print *, "Input n ... "
    read *, n

    ! allocate storage for boundary points too:
    allocate(x(0:n+1), u(0:n+1), uold(0:n+1), f(0:n+1))

    open(unit=20, file="heatsoln.txt", status="unknown")

    call cpu_time(t1)

    ! grid spacing:
    dx = 1.d0 / (n+1.d0)

    ! boundary conditions:
    alpha = 20.d0
    beta = 60.d0

    ! tolerance and max number of iterations:
    tol = 0.1 * dx**2
    print *, "Convergence tolerance: tol = ",tol
    maxiter = 100000
    print *, "Maximum number of iterations: maxiter = ",maxiter

    ! Determine how many points to handle with each thread.
    ! Note that dividing two integers and assigning to an integer will
    ! round down if the result is not an integer.
    ! This, together with the min(...) in the definition of iend below,
    ! insures that all points will get distributed to some thread.
    points_per_thread = (n + nthreads - 1) / nthreads
    print *, "points_per_thread = ",points_per_thread

    ! Start of the parallel block...
    ! ------------------------------

    ! This is the only time threads are forked in this program:

    !$omp parallel private(thread_num, iter, istart, iend, i, dumax_thread)

    thread_num = 0     ! needed in serial mode
    !$ thread_num = omp_get_thread_num()    ! unique for each thread

    ! Determine start and end index for the set of points to be
    ! handled by this thread:
    istart = thread_num * points_per_thread + 1
    iend = min((thread_num+1) * points_per_thread, n)

    !$omp critical
    print '("Thread ",i2," will take i = ",i6," through i = ",i6)', &
          thread_num, istart, iend
    !$omp end critical

    ! Initialize:
    ! -----------

    ! each thread sets part of these arrays:
    do i=istart, iend
        ! grid points:
        x(i) = i*dx
        ! source term:
        f(i) = 100.*exp(x(i))
        ! initial guess:
        u(i) = alpha + x(i)*(beta-alpha)
        enddo

    ! boundary conditions need to be added:
    u(0) = alpha
    u(n+1) = beta

    uold = u   ! initialize, including boundary values

    ! Jacobi iteratation:
    ! -------------------

    do iter=1,maxiter

        ! initialize uold to u (note each thread does part!)
        uold(istart:iend) = u(istart:iend)

        !$omp single
        dumax = 0.d0     ! global max initialized by one thread
        !$omp end single

        ! Make sure all of uold is initialized before iterating
        !$omp barrier
        ! Make sure uold is consitent in memory:
        !$omp flush

        dumax_thread = 0.d0   ! max seen by this thread
        do i=istart,iend
            u(i) = 0.5d0*(uold(i-1) + uold(i+1) + dx**2*f(i))
            dumax_thread = max(dumax_thread, abs(u(i)-uold(i)))
            enddo

        !$omp critical
        ! update global dumax using value from this thread:
        dumax = max(dumax, dumax_thread)
        !$omp end critical

        ! make sure all threads are done with dumax:
        !$omp barrier

        !$omp single
        ! only one thread will do this print statement:
        if (mod(iter,nprint)==0) then
            print '("After ",i8," iterations, dumax = ",d16.6,/)', iter, dumax
            endif
        !$omp end single

        ! check for convergence:
        ! note that all threads have same value of dumax
        ! at this point, so they will all exit on the same iteration.

        if (dumax .lt. tol) exit

        ! need to synchronize here so no thread resets dumax = 0
        ! at start of next iteration before all have done the test above.
        !$omp barrier

        enddo

    print '("Thread number ",i2," finished after ",i9, &
            " iterations, dumax = ", e16.6)', &
          thread_num,iter,dumax

    !$omp end parallel

    call cpu_time(t2)
    print '("CPU time = ",f12.8, " seconds")', t2-t1

    ! Write solution to heatsoln.txt:
    write(20,*) "          x                  u"
    do i=0,n+1
        write(20,'(2e20.10)'), x(i), u(i)
        enddo

    print *, "Solution is in heatsoln.txt"

    close(20)

end program jacobi1d_omp2


      FUNCTION VDC(N,BASE)	!Calculates a Van der Corput number...
Converts 1234 in decimal to 4321 in V, and P = 10000.
       INTEGER N	!For this integer,
       INTEGER BASE	!In this base.
       INTEGER I	!A copy of N that can be damaged.
       INTEGER P	!Successive powers of BASE.
       INTEGER V	!Accumulates digits.
        P = 1		! = BASE**0
        V = 0		!Start with no digits, as if N = 0.
        I = N		!Here we go.
        DO WHILE (I .NE. 0)	!While something remains,
          V = V*BASE + MOD(I,BASE)	!Extract its low-order digit.
          I = I/BASE			!Reduce it by a power.
          P = P*BASE			!And track the power.
        END DO			!Thus extract the digits in reverse order: right-to-left.
        VDC = V/FLOAT(P)	!The power is one above the highest digit.
      END FUNCTION VDC	!Numerology is weird.

      PROGRAM POKE
      INTEGER FIRST,LAST	!Might as well document some constants.
      PARAMETER (FIRST = 0,LAST = 9)	!Thus, the first ten values.
      INTEGER I,BASE		!Steppers.
      REAL VDC			!Stop the compiler moaning about undeclared items.

      WRITE (6,1) FIRST,LAST,(I, I = FIRST,LAST)	!Announce.
    1 FORMAT ("Calculates values ",I0," to ",I0," of the ",
     1 "Van der Corput sequence, in various bases."/
     2 "Base",666I9)

      DO BASE = 2,13	!A selection of bases.
        WRITE (6,2) BASE,(VDC(I,BASE), I = FIRST,LAST)	!Show the specified span.
    2   FORMAT (I4,666F9.6)	!Aligns with FORMAT 1.
      END DO		!On to the next base.

      END


module dyn_prog_coins_mod
    use, intrinsic :: iso_fortran_env, only : error_unit
    implicit none

    private

    public :: nr_change_coins, change_coins

contains

    function nr_change_coins(amount, coins) result(nr_coins)
        implicit none
        integer, value :: amount
        integer, dimension(:), intent(in) :: coins
        integer :: nr_coins
        integer, dimension(:), allocatable :: array
        integer :: status, coin_nr, coin, i
        integer, parameter :: infinity = huge(amount)

        allocate (array(0:amount), stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt='(A)') 'error: can not allocate array'
            stop 1
        end if
        array = infinity
        array(0) = 0

        do coin_nr = 1, size(coins)
            coin = coins(coin_nr)
            do i = coin, ubound(array, 1)
                array(i) = min(array(i), 1 + array(i - coin))
            end do
        end do

        nr_coins = array(amount)
        deallocate (array)
    end function nr_change_coins

    function compute_change(matrix, coins) result(change)
        implicit none
        integer, dimension(:), intent(in) :: coins
        integer, dimension(:, :), allocatable, intent(in) :: matrix
        integer, dimension(:), allocatable :: change
        integer :: i, j, status

        allocate (change(size(coins)), stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt='(A)') 'error: can not allocate change'
            stop 1
        end if
        change = 0
        i = ubound(matrix, 1)
        j = ubound(matrix, 2)
        do while (matrix(i, j) /= 0)
            if (i > 0) then
                do while (matrix(i, j) == matrix(i - 1, j))
                    i = i - 1
                end do
            end if
            change(i) = change(i) + 1
            j = j - coins(i)
        end do
    end function compute_change

    function change_coins(amount, coins) result(change)
        implicit none
        integer, value :: amount
        integer, dimension(:), intent(in) :: coins
        integer, dimension(:), allocatable :: change
        integer :: status, coin_nr, coin, i
        integer, dimension(:, :), allocatable :: matrix

        allocate (matrix(size(coins), 0:amount), stat=status)
        matrix = 0
        matrix(1, 1:) = [ (i, i=1, amount) ]
        do coin_nr = 2, ubound(matrix, 1)
            coin = coins(coin_nr)
            do i = 1, ubound(matrix, 2)
                if (i < coin) then
                    matrix(coin_nr, i) = matrix(coin_nr - 1, i)
                else
                    matrix(coin_nr, i) = min(matrix(coin_nr - 1, i), 1 + matrix(coin_nr, i - coin))
                end if
            end do
        end do
        change = compute_change(matrix, coins)
        deallocate (matrix)
    end function change_coins

end module dyn_prog_coins_mod


      PROGRAM xlfit
C     driver for routine lfit
      INTEGER NPT,NTERM
      REAL SPREAD
      PARAMETER(NPT=100,SPREAD=0.1,NTERM=5)
      INTEGER i,idum,j,ia(NTERM)
      REAL chisq,gasdev
      REAL x(NPT),y(NPT),sig(NPT),a(NTERM),covar(NTERM,NTERM)
      EXTERNAL funcs
      idum=-911
      do 12 i=1,NPT
        x(i)=0.1*i
        call funcs(x(i),a,NTERM)
        y(i)=0.
        do 11 j=1,NTERM
          y(i)=y(i)+j*a(j)
11      continue
        y(i)=y(i)+SPREAD*gasdev(idum)
        sig(i)=SPREAD
12    continue
      do 13 i=1,NTERM
        ia(i)=1
13    continue
      call lfit(x,y,sig,NPT,a,ia,NTERM,covar,NTERM,chisq,funcs)
      write(*,'(/1x,t4,a,t22,a)') 'Parameter','Uncertainty'
      do 14 i=1,NTERM
        write(*,'(1x,t5,a,i1,a,f8.6,f11.6)') 'A(',i,') = ',
     *       a(i),sqrt(covar(i,i))
14    continue
      write(*,'(/3x,a,e12.6)') 'Chi-squared = ',chisq
      write(*,'(/3x,a)') 'Full covariance matrix'
      do 15 i=1,NTERM
        write(*,'(1x,6e12.2)') (covar(i,j),j=1,NTERM)
15    continue
      write(*,'(/1x,a)') 'press RETURN to continue...'
      read(*,*)
C     now check results of restricting fit parameters
      do 16 i=2,NTERM,2
        ia(i)=0
16    continue
      call lfit(x,y,sig,NPT,a,ia,NTERM,covar,NTERM,chisq,funcs)
      write(*,'(/1x,t4,a,t22,a)') 'Parameter','Uncertainty'
      do 17 i=1,NTERM
        write(*,'(1x,t5,a,i1,a,f8.6,f11.6)') 'A(',i,') = ',
     *       a(i),sqrt(covar(i,i))
17    continue
      write(*,'(/3x,a,e12.6)') 'Chi-squared = ',chisq
      write(*,'(/3x,a)') 'Full covariance matrix'
      do 18 i=1,NTERM
        write(*,'(1x,6e12.2)') (covar(i,j),j=1,NTERM)
18    continue
      END
      SUBROUTINE funcs(x,afunc,ma)
      INTEGER i,ma
      REAL x,afunc(ma)
      afunc(1)=1.
      afunc(2)=x
      do 11 i=3,ma
        afunc(i)=sin(i*x)
11    continue
      return
      END

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


program main
    implicit none
    real*8::h,y,x,z,K,L,u_limit,M,t
    real*8::var_a,var_b,var_c
    real*8::x1,y1,z1

    !================================
    !constants
    var_a=0.2
    var_b=0.2
    var_c=5.7

    t=0
    h=0.003333*4
    u_limit=200
    ! initial conditions
    x=10.1
    y=-0.01
    z=9.0
    !second point
    x1=10.001
    y1=-0.01
    z1=9.0

    OPEN(20,file='rossler_attractor.dat')
    do while(t<=u_limit)
        CALL KLM(x,y,z,f,g,h,K,L,M)
        x=x+M
        y=y+K
        z=z+L
        CALL KLM(x1,y1,z1,f,g,h,K,L,M)
        x1=x1+M
        y1=y1+K
        z1=z1+L

        t=t+h
        write(20,*)x,y,z,x1,y1,z1
    enddo
    CLOSE(20)

    contains

    real*8 function f2(x,y,z) !derivative of x
        real*8::x,y,z
        f2 = -y-z
    end function f2

    real*8 function f(x,y,z) !derivative of y
        real*8::x,y,z
        f = x+var_a*y
    end function f

    real*8 function g(x,y,z) !derivative of z
        real*8::x,y,z
        g = var_b+z*(x-var_c)
    end function g

    subroutine KLM(x,y,z,f,g,h,K,L,M) !subroutine for Runge Kutta (order 4)
        real*8::x,f,g,y,z,k1,k2,k3,k4,h,K,L,l1,l2,l3,l4,M,m1,m2,m3,m4
        m1=h*f2(x,y,z)
        k1=h*f(x,y,z)
        l1=h*g(x,y,z)

        m2=h*f2(x+h/2,y+k1/2,z+l1/2)
        k2=h*f(x+h/2,y+k1/2,z+l1/2)
        l2=h*g(x+h/2,y+k1/2,z+l1/2)

        m3=h*f2(x+h/2,y+k2/2,z+l2/2)
        k3=h*f(x+h/2,y+k2/2,z+l2/2)
        l3=h*g(x+h/2,y+k2/2,z+l2/2)

        m4 = h*f2(x+h,y+k3,z+l3)
        k4 = h*f(x+h,y+k3,z+l3)
        l4 = h*g(x+h,y+k3,z+l3)

        K = (k1+k4)/6  + (k2+k3)/3
        L = (l1+l4)/6 + (l2+l3)/3
        M = (m1+m4)/6 + (m2+m3)/3

    end subroutine KLM
end program main


program test_rk4
      use numerical_integration
      implicit none

      integer :: i
      integer, parameter :: n=100
      real(kind=dp), parameter :: pi = 4.0d0*atan(1.0d0)
      real(kind=dp), parameter :: dx = pi/(n-1)
      external :: deriv_sine, deriv_sho
      real(kind=dp) :: x(n) , y(n, 2)

      x(1)  = 0.0d0; y(1, :) = [ 1.0d0, 0.0d0]
      call rk4(x, y, dx, n, 2, deriv_sho)
      do i=1,n
        write(*, *) x(i), y(i, 1), y(i, 2)
      end do
end program test_rk4

subroutine deriv_sine(x,y,dydx)
      use numerical_integration
      implicit none
      integer, parameter :: n_eq = 1
      real(kind=dp), intent(in) :: x, y(n_eq)
      real(kind=dp), dimension(n_eq), intent(out) :: dydx

      dydx = cos(x)

end subroutine deriv_sine

subroutine deriv_sho(x,y,dydx)
      use numerical_integration
      implicit none
      integer, parameter :: n_eq = 2
      real(kind=dp), intent(in) :: x, y(n_eq)
      real(kind=dp), dimension(n_eq), intent(out) :: dydx

      dydx(1) = y(2)
      dydx(2) = -y(1)

end subroutine deriv_sho


module source
   implicit none

   public:: init_source, sourcefunc

   private

   abstract interface
      function sourcefunc_iface(r,p,x,t)
         real,intent(in):: r,p,x,t
         real:: sourcefunc_iface
      end function sourcefunc_iface
   end interface

   procedure (sourcefunc_iface), pointer:: sourcefunc => null()

   contains

   subroutine init_source()
      use input
      implicit none

      select case (source_type)
      case ("test1d")
         sourcefunc => source_test1d
      case default
         print*, "ERROR: source_type=",source_type," not recognized."
         stop
      end select

   end subroutine init_source

   real function source_test1d(r,p,x,t)
      implicit none
      real,intent(in)::r,p,x,t
      real:: fac
      fac = 0.75*(1.0-r**2) - 1.5*r**3 + exp(-r**2)*(r-1.0)
      source_test1d = 0.25*(1.0-r**2)*cos(t/3.0) - 3.0 - 3.0*sin(t/3.0)*fac
   end function source_test1d

end module source


      SUBROUTINE MC01SD( DP, P, S, T, MANT, E, IWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To scale the coefficients of the real polynomial P(x) such that
C     the coefficients of the scaled polynomial Q(x) = sP(tx) have
C     minimal variation, where s and t are real scalars.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     DP      (input) INTEGER
C             The degree of the polynomial P(x).  DP >= 0.
C
C     P       (input/output) DOUBLE PRECISION array, dimension (DP+1)
C             On entry, this array must contain the coefficients of P(x)
C             in increasing powers of x.
C             On exit, this array contains the coefficients of the
C             scaled polynomial Q(x) in increasing powers of x.
C
C     S       (output) INTEGER
C             The exponent of the floating-point representation of the
C             scaling factor s = BASE**S, where BASE is the base of the
C             machine representation of floating-point numbers (see
C             LAPACK Library Routine DLAMCH).
C
C     T       (output) INTEGER
C             The exponent of the floating-point representation of the
C             scaling factor t = BASE**T.
C
C     MANT    (output) DOUBLE PRECISION array, dimension (DP+1)
C             This array contains the mantissas of the standard
C             floating-point representation of the coefficients of the
C             scaled polynomial Q(x) in increasing powers of x.
C
C     E       (output) INTEGER array, dimension (DP+1)
C             This array contains the exponents of the standard
C             floating-point representation of the coefficients of the
C             scaled polynomial Q(x) in increasing powers of x.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (DP+1)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if on entry, P(x) is the zero polynomial.
C
C     METHOD
C
C     Define the variation of the coefficients of the real polynomial
C
C                                         2                DP
C        P(x) = p(0) + p(1) * x + p(2) * x  + ... + p(DP) x
C
C     whose non-zero coefficients can be represented as
C                          e(i)
C        p(i) = m(i) * BASE     (where 1 <= ABS(m(i)) < BASE)
C
C     by
C
C        V = max(e(i)) - min(e(i)),
C
C     where max and min are taken over the indices i for which p(i) is
C     non-zero.
C                                        DP         i    i
C     For the scaled polynomial P(cx) = SUM p(i) * c  * x  with
C                                       i=0
C                j
C     c  = (BASE) , the variation V(j) is given by
C
C       V(j) = max(e(i) + j * i) - min(e(i) + j * i).
C
C     Using the fact that V(j) is a convex function of j, the routine
C     determines scaling factors s = (BASE)**S and t = (BASE)**T such
C     that the coefficients of the scaled polynomial Q(x) = sP(tx)
C     satisfy the following conditions:
C
C       (a) 1 <= q(0) < BASE and
C
C       (b) the variation of the coefficients of Q(x) is minimal.
C
C     Further details can be found in [1].
C
C     REFERENCES
C
C     [1] Dunaway, D.K.
C         Calculation of Zeros of a Real Polynomial through
C         Factorization using Euclid's Algorithm.
C         SIAM J. Numer. Anal., 11, pp. 1087-1104, 1974.
C
C     NUMERICAL ASPECTS
C
C     Since the scaling is performed on the exponents of the floating-
C     point representation of the coefficients of P(x), no rounding
C     errors occur during the computation of the coefficients of Q(x).
C
C     FURTHER COMMENTS
C
C     The scaling factors s and t are BASE dependent.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MC01GD by A.J. Geurts.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary polynomial operations, polynomial operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER           DP, INFO, S, T
C     .. Array Arguments ..
      INTEGER           E(*), IWORK(*)
      DOUBLE PRECISION  MANT(*), P(*)
C     .. Local Scalars ..
      LOGICAL           OVFLOW
      INTEGER           BETA, DV, I, INC, J, LB, M, UB, V0, V1
C     .. External Functions ..
      INTEGER           MC01SX
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH, MC01SX
C     .. External Subroutines ..
      EXTERNAL          MC01SW, MC01SY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, NINT
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      IF( DP.LT.0 ) THEN
         INFO = -1
C
C        Error return.
C
         CALL XERBLA( 'MC01SD', -INFO )
         RETURN
      END IF
C
      INFO = 0
      LB = 1
C     WHILE ( LB <= DP+1 and P(LB) = 0 ) DO
   20 IF ( LB.LE.DP+1 ) THEN
         IF ( P(LB).EQ.ZERO ) THEN
            LB = LB + 1
            GO TO 20
         END IF
      END IF
C     END WHILE 20
C
C     LB = MIN( i: P(i) non-zero).
C
      IF ( LB.EQ.DP+2 ) THEN
         INFO = 1
         RETURN
      END IF
C
      UB = DP + 1
C     WHILE ( P(UB) = 0 ) DO
   40 IF ( P(UB).EQ.ZERO ) THEN
         UB = UB - 1
         GO TO 40
      END IF
C     END WHILE 40
C
C     UB = MAX(i: P(i) non-zero).
C
      BETA = DLAMCH( 'Base' )
C
      DO 60 I = 1, DP + 1
         CALL MC01SW( P(I), BETA, MANT(I), E(I) )
   60 CONTINUE
C
C     First prescaling.
C
      M = E(LB)
      IF ( M.NE.0 ) THEN
C
         DO 80 I = LB, UB
            IF ( MANT(I).NE.ZERO ) E(I) = E(I) - M
   80    CONTINUE
C
      END IF
      S = -M
C
C     Second prescaling.
C
      IF ( UB.GT.1 ) M = NINT( DBLE( E(UB) )/DBLE( UB-1 ) )
C
      DO 100 I = LB, UB
         IF ( MANT(I).NE.ZERO ) E(I) = E(I) - M*(I-1)
  100 CONTINUE
C
      T = -M
C
      V0 = MC01SX( LB, UB, E, MANT )
      J = 1
C
      DO 120 I = LB, UB
         IF ( MANT(I).NE.ZERO ) IWORK(I) = E(I) + (I-1)
  120 CONTINUE
C
      V1 = MC01SX( LB, UB, IWORK, MANT )
      DV = V1 - V0
      IF ( DV.NE.0 ) THEN
         IF ( DV.GT.0 ) THEN
            J = 0
            INC = -1
            V1 = V0
            DV = -DV
C
            DO 130 I = LB, UB
               IWORK(I) = E(I)
  130       CONTINUE
C
         ELSE
            INC = 1
         END IF
C        WHILE ( DV < 0 ) DO
  140    IF ( DV.LT.0 ) THEN
            V0 = V1
C
            DO 150 I = LB, UB
               E(I) = IWORK(I)
  150       CONTINUE
C
            J = J + INC
C
            DO 160 I = LB, UB
               IWORK(I) = E(I) + INC*(I-1 )
  160       CONTINUE
C
            V1 = MC01SX( LB, UB, IWORK, MANT )
            DV = V1 - V0
            GO TO 140
         END IF
C        END WHILE 140
         T = T + J - INC
      END IF
C
C     Evaluation of the output parameters.
C
      DO 180 I = LB, UB
         CALL MC01SY( MANT(I), E(I), BETA, P(I), OVFLOW )
  180 CONTINUE
C
      RETURN
C *** Last line of MC01SD ***
      END


module conversion
   use global
   implicit none
   private

   public :: n2ijk, ijk2n, xy2ijk, ijk2xy, ijk2c, n2xy, xy2n, n2c
contains

   elemental subroutine n2ijk(n, i, j, k)
      integer, intent(in) :: n
      integer, intent(out) :: i, j, k

      integer :: m
      m = n - 1

      k = modulo(m, 2)
      j = modulo(m / 2, s%l)
      i = m / (2 * s%l)
   end subroutine n2ijk

   elemental subroutine ijk2n(i, j, k, n)
      integer, intent(in) :: i, j, k
      integer, intent(out) :: n

      n = 2 * (i * s%l + j) + k + 1
   end subroutine ijk2n

   elemental subroutine xy2ijk(x, y, i, j, k)
      real(dp), intent(in) :: x, y
      integer, intent(out) :: i, j, k

      real(dp) :: a, b

      a = x / sqrt(3.0_dp) - y / 3.0_dp
      b = y / 1.5_dp

      i = modulo(floor(a), s%l)
      j = modulo(floor(b), s%l)
      k = int(modulo(a, 1.0_dp) + modulo(b, 1.0_dp))
   end subroutine xy2ijk

   elemental subroutine ijk2xy(i, j, k, x, y)
      integer, intent(in) :: i, j, k
      real(dp), intent(out) :: x, y

      x = 0.5_dp * sqrt(3.0_dp) * (modulo(2 * i + j + k, 2 * s%l) + 1)
      y = 1.5_dp * j + 0.5_dp * k + 0.5_dp
   end subroutine ijk2xy

   elemental subroutine ijk2c(i, j, k, c)
      integer, intent(inout) :: i, j, k
      integer, intent(out) :: c

      integer :: x, y

      x = modulo(2 * i + j + k, 2 * s%l)
      y = 3 * j + k

      c = 3 * s%l * x + y + 1
   end subroutine ijk2c

   elemental subroutine n2xy(n, x, y)
      integer, intent(in) :: n
      real(dp), intent(out) :: x, y

      integer :: i, j, k

      call n2ijk(n, i, j, k)
      call ijk2xy(i, j, k, x, y)
   end subroutine n2xy

   elemental subroutine xy2n(x, y, n)
      real(dp), intent(in) :: x, y
      integer, intent(out) :: n

      integer :: i, j, k

      call xy2ijk(x, y, i, j, k)
      call ijk2n(i, j, k, n)
   end subroutine xy2n

   elemental subroutine n2c(n, c)
      integer, intent(in) :: n
      integer, intent(out) :: c

      integer :: i, j, k

      call n2ijk(n, i, j, k)
      call ijk2c(i, j, k, c)
   end subroutine n2c
end module conversion


program main
    use plantFEM
    implicit none

    integer(int32),parameter :: sample=10000
    integer(int32),parameter :: division=10

    type(Random_)::random
    type(IO_) :: f

    real(real64) :: list(sample)
    integer(int32) :: i
    real(real64),allocatable :: histogram(:,:)

    call random%init()

    ! generate a set of random number
    do i=1,sample
        ! Uniform random numbers
        !list(i) = random%random()

        ! binomial distribution
        list(i) = random%random(distribution="binomial")
    enddo

    ! get histogram
    histogram = random%histogram(list=list,division=division)

    call print(histogram)

    ! Data
    call f%open("./"//"test"//".txt",'w')
    do i=1,size(histogram,1)
        write(f%fh,*) histogram(i,:)
    enddo
    call f%close()

    ! Gnuplot-script
    call f%open("./"//"test"//".gp",'w')
    call f%write("set yr[0:]")
    call f%write("plot 'test,txt' with boxes")
    call f%write("pause -1")
    call f%close()

    ! plot
    call execute_command_line("gnuplot ./test.gp")

end program main


!> @brief       A collection of statistical functions
!> @author      Robert Schuster
!> @details     all functions are only implemented for real(kind=8) values
module fplus_statistic
    use fplus_fillvalue
    use fplus_array_tools
    implicit none
    private

    ! list of public functions
    public :: cumulative_distribution_function, invers_cumulative_distribution_function

    ! cdf for 1d and 2d arrays
    interface cumulative_distribution_function
        module procedure cumulative_distribution_function_1d
        module procedure cumulative_distribution_function_2d
    end interface

    ! invers cdf for 1d and 2d arrays
    interface invers_cumulative_distribution_function
        module procedure invers_cumulative_distribution_function_1d
        module procedure invers_cumulative_distribution_function_2d
    end interface

contains

    ! The cumulative density function =============================================================

    !> @brief           Evaluates the cumulative distribution function at one point
    !> @param[in]       array   an array of values
    !> @paran[in]       value   the value for which the cdf sould be evaluated
    !> @returns         the fraction of the array with values smaller than the value argument
    real function cumulative_distribution_function_1d(array, value) result (res)
        real (kind=8), dimension(:), intent(in) :: array
        real (kind=8), intent(in) :: value
        res = cumulative_distribution_function_intern(array, size(array), value)
    end function

    !> @brief           Evaluates the cumulative distribution function at one point
    !> @param[in]       array   an array of values
    !> @paran[in]       value   the value for which the cdf sould be evaluated
    !> @returns         the fraction of the array with values smaller than the value argument
    real function cumulative_distribution_function_2d(array, value) result (res)
        real (kind=8), dimension(:,:), intent(in) :: array
        real (kind=8), intent(in) :: value
        res = cumulative_distribution_function_intern(array, product(shape(array)), value)
    end function

    !> @brief           Evaluates the cumulative distribution function at one point
    !> @param[in]       array   an array of values
    !> @paran[in]       value   the value for which the cdf sould be evaluated
    !> @returns         the fraction of the array with values smaller than the value argument
    real function cumulative_distribution_function_intern(array, n, value) result (res)
        real (kind=8), dimension(*), intent(in) :: array
        integer :: n
        real (kind=8), intent(in) :: value

        !local variables
        integer :: i

        ! loop over all array elements
        res = 0.0_8
        do i = 1, n
            if (array(i) <= value) res = res + 1.0_8
        end do
        res = res / real(n, 8)
    end function

    ! The invers cumulative density function ======================================================

    !> @brief           Find the value in the array with a cdf as close as possible to the specified value
    !> @param[in]       array   an array of values
    !> @paran[in]       value   the value for which the cdf sould be evaluated
    real(kind=8) function invers_cumulative_distribution_function_1d(array, value) result (res)
        real (kind=8), dimension(:), intent(in) :: array
        real (kind=8), intent(in) :: value
        res = invers_cumulative_distribution_function_intern(array, size(array), value)
    end function

    !> @brief           Find the value in the array with a cdf as close as possible to the specified value
    !> @param[in]       array   an array of values
    !> @paran[in]       value   the value for which the cdf sould be evaluated
    real(kind=8) function invers_cumulative_distribution_function_2d(array, value) result (res)
        real (kind=8), dimension(:,:), intent(in) :: array
        real (kind=8), intent(in) :: value
        res = invers_cumulative_distribution_function_intern(array, product(shape(array)), value)
    end function

    !> @brief           Find the value in the array with a cdf as close as possible to the specified value
    !> @param[in]       array   an array of values
    !> @paran[in]       value   the value for which the cdf sould be evaluated
    real(kind=8) recursive function invers_cumulative_distribution_function_intern(array, n, value, lb, ub) result (res)
        real (kind=8), dimension(*), intent(in) :: array
        integer :: n
        real (kind=8), intent(in) :: value
        integer, optional :: lb, ub

        !local variables
        integer :: i, ilb, iub, i2, mid
        real (kind=8) :: amin, amax, cdf1, cdf2
        real (kind=8), dimension(:), allocatable, save :: temp
        integer, save :: level

        ! the bound are needed for the recursive algorithm
        if (present(lb)) then
            ilb = lb
        else
            ilb = 1
        end if
        if (present(ub)) then
            iub = ub
        else
            iub = n
        end if

        ! find min and max of the array
        if (.not.present(lb) .and. .not.present(ub)) then
            amin = minval(array(1:n))
            amax = maxval(array(1:n))
            ! is the value within the range of values
            if (value >= 1.0_8) then
                res = amax
                return
            end if
            if (value <= 0.0_8) then
                res = amin
                return
            end if
        end if

        ! create an temporal copy of the array and sort it
        if (.not. allocated(temp)) then
            temp = array(1:n)
            call qsort(temp)
            level = 1
        else
            level = level +1
        end if

        ! devide the array into two parts
        if (iub - ilb > 2) then
            mid = (ilb + iub) / 2
            cdf1 = cumulative_distribution_function(temp, temp(mid))
            ! we found the search value
            if (cdf1 == value) then
                res = temp(mid)
                level = level - 1
                return
            end if
            ! take a look at the lower half of the array
            if (cdf1 > value) then
                res = invers_cumulative_distribution_function_intern(array, n, value, ilb, mid)
            end if
            ! take a look at the upper half of the array
            if (cdf1 < value) then
                res = invers_cumulative_distribution_function_intern(array, n, value, mid, iub)
            end if
        else
        ! loop over all array elements
            cdf1 = fplus_fill_realk8
            do i = ilb, iub
                ! calculate the cdf for the current array element
                cdf2 = cumulative_distribution_function(temp, temp(i))
                !write(0,*) cdf2
                if (abs(cdf1-value) > abs(cdf2-value)) then
                    cdf1 = cdf2
                    i2 = i
                end if
            end do
            res = temp(i2)
        end if

        ! reduce the level and deallocate the temporal array
        level = level - 1
        if (level == 0 .and. allocated(temp)) deallocate(temp)
    end function

end module


MODULE RayNormals

   IMPLICIT NONE
   REAL (KIND=8)                :: RL                 ! length of part of the tangent vector

CONTAINS

  SUBROUTINE RayNormal( t, phi, c, e1, e2 )

    ! Computes the ray normals

    REAL (KIND=8), INTENT( IN  ) :: t( 3 )             ! tangent vector (NOT normalized)
    REAL (KIND=8), INTENT( IN  ) :: phi                ! torsion
    REAL (KIND=8), INTENT( IN  ) :: c                  ! sound speed
    REAL (KIND=8), INTENT( OUT ) :: e1( 3 ), e2( 3 )   ! ray unit normals

    RL = NORM2( t( 1 : 2 ) )

    IF ( phi /= 0 ) THEN
       !  e1
       e1( 1 ) = ( c * t( 1 ) * t( 3 ) * COS( phi ) + t( 2 ) * SIN( phi ) ) / RL
       e1( 2 ) = ( c * t( 2 ) * t( 3 ) * COS( phi ) - t( 1 ) * SIN( phi ) ) / RL
       e1( 3 ) = -c * RL * COS( phi )

       !  e2
       e2( 1 ) = ( c * t( 1 ) * t( 3 ) * SIN( phi ) - t( 2 ) * COS( phi ) ) / RL
       e2( 2 ) = ( c * t( 2 ) * t( 3 ) * SIN( phi ) + t( 1 ) * COS( phi ) ) / RL
       e2( 3 ) = -c * RL * SIN( phi )
    ELSE
       e1 = [ c * t( 1 ) * t( 3  ) / RL, c * t( 2 ) * t( 3 ) / RL, -c * RL ]
       e2 = [ -t( 2 ) / RL,              t( 1 ) / RL,              0.0D0   ]
    END IF

    RETURN
  END SUBROUTINE RayNormal

  !**********************************************************************!

  SUBROUTINE RayNormal_unit( t, phi, e1, e2 )

    ! Computes the ray normals
    ! Same as routine RayNormal except this version assumes t is already normalized

    REAL (KIND=8), INTENT( IN  ) :: t( 3 )             ! tangent vector (normalized)
    REAL (KIND=8), INTENT( IN  ) :: phi                ! torsion
    REAL (KIND=8), INTENT( OUT ) :: e1( 3 ), e2( 3 )   ! ray normals

    RL = NORM2( t( 1 : 2 ) )

    !  e1
    e1( 1 ) = ( t( 1 ) * t( 3 ) * COS( phi ) + t( 2 ) * SIN( phi ) ) / RL
    e1( 2 ) = ( t( 2 ) * t( 3 ) * COS( phi ) - t( 1 ) * SIN( phi ) ) / RL
    e1( 3 ) = -RL * COS( phi )

    !  e2
    e2( 1 ) = ( t( 1 ) * t( 3 ) * SIN( phi ) - t( 2 ) * COS( phi ) ) / RL
    e2( 2 ) = ( t( 2 ) * t( 3 ) * SIN( phi ) + t( 1 ) * COS( phi ) ) / RL
    e2( 3 ) = -RL * SIN( phi )

    RETURN
  END SUBROUTINE RayNormal_unit

END MODULE RayNormals


c     program DRCCOEF
c>> 1994-07-15 CLL
c>> 1987-12-09 DRCCOEF  Lawson  Initial Code.
c     Demo driver for CCOEF
c     C. L. Lawson & S. Chiu, JPL, 1987 Feb 17.
c     ------------------------------------------------------------------
      integer  I, NDEG1, NDEG2
      complex  RT1(3), RT2(2), ZC(4)
c
      data RT1 / (1.E0, 1.E0), (1.E0, -1.E0), (3.E0, 0.E0)/
      data RT2 / (2.E0, 1.E0), (3.E0, 2.E0)/
      data NDEG1, NDEG2 / 3, 2 /
c     ------------------------------------------------------------------
  100 format(1X/1X,A,I3)
  200 format(1X,A/(2(1X,:,'(',1X,G13.6,', ',G13.6,')',1X)))
c
      call CCOEF(NDEG1,RT1,ZC)
      print 100,'Degree   =',NDEG1
      print 200,'Roots    =',RT1
      print 200,'Coeffs   =',(ZC(I),I=1,NDEG1+1)
      print '(/)'
c
      call CCOEF(NDEG2,RT2,ZC)
      print 100,'Degree   =',NDEG2
      print 200,'Roots    =',RT2
      print 200,'Coeffs   =',(ZC(I),I=1,NDEG2+1)
      end


module test
implicit none
contains
    function testf1(x)
        double precision, intent(in) :: x(:)
        double precision             :: testf1

        testf1 = sum(x**2)
    end function testf1

    subroutine testg1(gx, x)
        double precision, intent(out) :: gx(:)
        double precision, intent(in)  :: x(:)

        gx(:) = 2*x(:)
    end subroutine testg1

    subroutine testh1(hx, x)
        double precision, intent(out) :: hx(:, :)
        double precision, intent(in)  :: x(:)

        integer :: i, n
        n = size(x)

        hx(:, :) = 0.d0
        do i = 1, n
            hx(i, i) = 2
        end do
    end subroutine testh1

    ! x1 + x2 - 1 = 0
    subroutine c1(cx, x)
        double precision, intent(out) :: cx(:)
        double precision, intent(in)  :: x(:)

        cx(1) = x(1) + x(2) - 1
    end subroutine c1

    subroutine dc1(dcx, x)
        double precision, intent(out) :: dcx(:, :)
        double precision, intent(in)  :: x(:)

        dcx(1, 1) = 1
        dcx(1, 2) = 1
    end subroutine dc1

    subroutine d2c1(d2cx, x)
        double precision, intent(out) :: d2cx(:, :, :)
        double precision, intent(in)  :: x(:)

        d2cx(1, 1, 1) = 0
        d2cx(1, 1, 2) = 0
        d2cx(1, 2, 1) = 0
        d2cx(1, 2, 2) = 0
    end subroutine d2c1

    function testf2(x)
        double precision, intent(in) :: x(:)
        double precision             :: testf2

        testf2 = sum(x**2)
    end function testf2

    subroutine testg2(gx, x)
        double precision, intent(out) :: gx(:)
        double precision, intent(in)  :: x(:)

        gx(:) = 2*x(:)
    end subroutine testg2

    subroutine testh2(hx, x)
        double precision, intent(out) :: hx(:, :)
        double precision, intent(in)  :: x(:)

        integer :: i, n
        n = size(x)

        hx(:, :) = 0.d0
        do i = 1, n
            hx(i, i) = 2
        end do
    end subroutine testh2

    ! x1 + x2 - 1 = 0
    subroutine c2(cx, x)
        double precision, intent(out) :: cx(:)
        double precision, intent(in)  :: x(:)

        cx(1) = (x(1) + x(2) - 1)**3
    end subroutine c2

    subroutine dc2(dcx, x)
        double precision, intent(out) :: dcx(:, :)
        double precision, intent(in)  :: x(:)

        dcx(1, 1) = 3*(x(1) + x(2) - 1)**2
        dcx(1, 2) = 3*(x(1) + x(2) - 1)**2
    end subroutine dc2

    subroutine d2c2(d2cx, x)
        double precision, intent(out) :: d2cx(:, :, :)
        double precision, intent(in)  :: x(:)

        d2cx(1, 1, 1) = 6*(x(1) + x(2) - 1)
        d2cx(1, 1, 2) = 6*(x(1) + x(2) - 1)
        d2cx(1, 2, 1) = 6*(x(1) + x(2) - 1)
        d2cx(1, 2, 2) = 6*(x(1) + x(2) - 1)
    end subroutine d2c2

    function testf3(x)
        double precision, intent(in) :: x(:)
        double precision             :: testf3

        testf3 = sum(x**2)
    end function testf3

    subroutine testg3(gx, x)
        double precision, intent(out) :: gx(:)
        double precision, intent(in)  :: x(:)

        gx(:) = 2*x(:)
    end subroutine testg3

    subroutine testh3(hx, x)
        double precision, intent(out) :: hx(:, :)
        double precision, intent(in)  :: x(:)

        integer :: i, n
        n = size(x)

        hx(:, :) = 0.d0
        do i = 1, n
            hx(i, i) = 2
        end do
    end subroutine testh3

    ! x1 + x2 - 1 = 0
    subroutine c3(cx, x)
        double precision, intent(out) :: cx(:)
        double precision, intent(in)  :: x(:)

        cx(1) = x(1) - 1
        cx(2) = x(2)
    end subroutine c3

    subroutine dc3(dcx, x)
        double precision, intent(out) :: dcx(:, :)
        double precision, intent(in)  :: x(:)

        dcx(1, 1) = 1
        dcx(1, 2) = 0

        dcx(2, 1) = 0
        dcx(2, 2) = 1
    end subroutine dc3

    subroutine d2c3(d2cx, x)
        double precision, intent(out) :: d2cx(:, :, :)
        double precision, intent(in)  :: x(:)

        d2cx(1, 1, 1) = 0
        d2cx(1, 1, 2) = 0
        d2cx(1, 2, 1) = 0
        d2cx(1, 2, 2) = 0

        d2cx(2, 1, 1) = 0
        d2cx(2, 1, 2) = 0
        d2cx(2, 2, 1) = 0
        d2cx(2, 2, 2) = 0
    end subroutine d2c3

    function testf4(x)
        double precision, intent(in) :: x(:)
        double precision             :: testf4

        testf4 = sum(x**2)
    end function testf4

    subroutine testg4(gx, x)
        double precision, intent(out) :: gx(:)
        double precision, intent(in)  :: x(:)

        gx(:) = 2*x(:)
    end subroutine testg4

    subroutine testh4(hx, x)
        double precision, intent(out) :: hx(:, :)
        double precision, intent(in)  :: x(:)

        integer :: i, n
        n = size(x)

        hx(:, :) = 0.d0
        do i = 1, n
            hx(i, i) = 2
        end do
    end subroutine testh4

    ! x1 + x2 - 1 = 0
    subroutine c4(cx, x)
        double precision, intent(out) :: cx(:)
        double precision, intent(in)  :: x(:)

        cx(1) = (x(1) - 1)**2 + (x(2) - 1)**2 - 1
        cx(2) = (x(1) - 1)**2 + (x(2) + 1)**2 - 1
    end subroutine c4

    subroutine dc4(dcx, x)
        double precision, intent(out) :: dcx(:, :)
        double precision, intent(in)  :: x(:)

        dcx(1, 1) = 2*(x(1) - 1)
        dcx(1, 2) = 2*(x(2) - 1)

        dcx(2, 1) = 2*(x(1) - 1)
        dcx(2, 2) = 2*(x(2) + 1)
    end subroutine dc4

    subroutine d2c4(d2cx, x)
        double precision, intent(out) :: d2cx(:, :, :)
        double precision, intent(in)  :: x(:)

        d2cx(1, 1, 1) = 2
        d2cx(1, 1, 2) = 0
        d2cx(1, 2, 1) = 0
        d2cx(1, 2, 2) = 2

        d2cx(2, 1, 1) = 2
        d2cx(2, 1, 2) = 0
        d2cx(2, 2, 1) = 0
        d2cx(2, 2, 2) = 2
    end subroutine d2c4

end module test