    Program zhpsv_example

!     ZHPSV 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_example_aux, Only: nagf_file_print_matrix_complex_packed_comp
      Use lapack_interfaces, Only: zhpsv
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
      Character (1), Parameter :: uplo = 'U'
!     .. Local Scalars ..
      Integer :: i, ifail, info, j, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ap(:), b(:)
      Integer, Allocatable :: ipiv(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Executable Statements ..
      Write (nout, *) 'ZHPSV Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n

      Allocate (ap((n*(n+1))/2), b(n), ipiv(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

!     Read b from data file

      Read (nin, *) b(1:n)

!     Solve the equations Ax = b for x
      Call zhpsv(uplo, n, 1, ap, ipiv, b, n, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Solution'
        Write (nout, 100) b(1:n)

!       Print details of factorization

        Write (nout, *)
        Flush (nout)

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_complex_packed_comp(uplo, &
          'Non-unit diagonal', n, ap, 'Bracketed', 'F7.4', &
          'Details of factorization', 'Integer', rlabs, 'Integer', clabs, 80, &
          0, ifail)

!       Print pivot indices

        Write (nout, *)
        Write (nout, *) 'Pivot indices'
        Write (nout, 110) ipiv(1:n)

      Else
        Write (nout, 120) 'The diagonal block ', info, ' of D is zero'
      End If

100   Format ((3X,4(' (',F7.4,',',F7.4,')',:)))
110   Format (1X, 7I11)
120   Format (1X, A, I3, A)
    End Program


PROGRAM F005

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER :: I, N

    I = 1
    DO
        N = 20 * I
        ! BASED ON THE RULES OF DIVISIBILITY, NOT ALL NUMBERS FROM 1 TO 20
        ! HAVE TO BE TESTED AGAINST.
        IF  ( (MOD(N, 19) == 0) .AND. (MOD(N, 17) == 0)   &
        .AND. (MOD(N, 16) == 0) .AND. (MOD(N, 13) == 0)   &
        .AND. (MOD(N, 11) == 0) .AND. (MOD(N, 9)  == 0)   &
        .AND. (MOD(N, 8)  == 0) .AND. (MOD(N, 7)  == 0) ) THEN
            EXIT
        END IF
        I = I + 1;
    END DO

    PRINT ('(I0)'), N

END PROGRAM F005


      FUNCTION vnorm (n, v, w)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER n
      REAL(rprec), DIMENSION(n) :: v, w
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      REAL(rprec) :: SUM0, vnorm
C-----------------------------------------------
clll. optimize
c-----------------------------------------------------------------------
c this FUNCTION routine computes the weighted root-mean-square norm
c of the vector of length n contained in the array v, with weights
c contained in the array w of length n..
c   vnorm = SQRT( (1/n) * SUM( v(i)*w(i) )**2 )
c-----------------------------------------------------------------------
      SUM0 = SUM((v*w)**2)
      vnorm = SQRT(sum0/(n))

      END FUNCTION vnorm


!  This program computes the entropy for random walks
!  based on a computed probability histogram.
!  Many walkers (input) make several trials steps with
!  a given number of walks per trial. Periodic boundary conditions
!  have been implemented since the walkers are forced to move on a
!  one-dimensional lattice of size -L  <= x <= L. This means that if the walker
!  goes beyond L(-L) it is shifted to -L(L).

PROGRAM random_entropy
  USE constants
  USE f90library
  IMPLICIT NONE
  INTEGER::  walkers, tsteps, length
  REAL(dp):: move_probability
  INTEGER, ALLOCATABLE, DIMENSION(:) :: x, probability

  ! get time steps, number of walkers and the probability to move
  CALL  initialise(walkers, tsteps, length, move_probability)
  ! allocate memory for positions of all walkers
  ALLOCATE (x(walkers))
  ALLOCATE(probability(-length:length))
  x = 0; probability = 0
  ! do the Monte Carlo move
  CALL  mc_sampling(tsteps, walkers, length, move_probability, x, probability)
  ! Print out results
  CALL  output(tsteps, walkers, length, probability)
  ! free memory
  DEALLOCATE(x); DEALLOCATE(probability)

END PROGRAM random_entropy
! Read in data from screen

SUBROUTINE initialise(walkers, tsteps, length, move_probability)
  USE constants
  IMPLICIT NONE
  INTEGER, INTENT(inout) :: walkers, tsteps, length
  REAL(DP) :: move_probability
  WRITE(*,*)'Number of walkers ='
  READ(*,*)  walkers
  WRITE(*,*) 'Number of time steps='
  READ(*,*)  tsteps
  WRITE(*,*) 'Length of systems, from -L to +L='
  READ(*,*)  length
  WRITE(*,*) 'Move probability='
  READ(*,*)  move_probability
END SUBROUTINE initialise

! Output of expectation values, <x>, <y> and their variances
! <x^2> - <x>^2  and <y^2> - <y>^2

SUBROUTINE output(tsteps, walkers, length, probability)
  USE constants
  IMPLICIT NONE
  INTEGER :: i
  INTEGER, INTENT(in) :: tsteps, walkers, length
  INTEGER, INTENT(in) :: probability(-length:length)
  REAL(dp) ::norm, histogram, entropy

  !find norm of probability
  OPEN(UNIT=6, FILE='prob.dat')
  norm = 1.0_dp/walkers
  entropy = 0.0_dp; histogram = 0.0_dp
  DO i =-length, length, 1
     histogram = probability(i)*norm;
     IF ( histogram > 0.0_dp) THEN
        entropy = entropy-histogram*LOG(histogram)
     ENDIF
  ENDDO
  !write entropy
  WRITE(*,'(I8,2X,F12.6)') tsteps, entropy

END SUBROUTINE output

! Here we perform the moves of the walkers as function of time steps with
! periodic boundary conditions

SUBROUTINE mc_sampling(tsteps, walkers, length, move_probability, x, probability)
  USE constants
  USE f90library
  IMPLICIT NONE
  INTEGER, INTENT(in) :: tsteps, walkers, length
  INTEGER, INTENT(inout) :: x(walkers)
  INTEGER, INTENT(inout) :: probability(-length:length)
  INTEGER :: idum, i, j, count
  REAL(dp) :: rantest
  REAL(dp), INTENT(in) :: move_probability
  idum=-1
  ! loop over Monte Carlo trials
  DO i = 1, tsteps
     DO j=1, walkers
        IF (ran0(idum) <= move_probability) THEN
           IF ( x(j) +1 > length) THEN
              x(j) = -length;
           ELSE
              x(j) = x(j) +1;
           ENDIF
        ELSE
           IF ( x(j) -1 < -length) THEN
              x(j) = length;
           ELSE
              x(j) = x(j)+1;
           ENDIF
        ENDIF
     ENDDO
  ENDDO
  ! After the final time step we compute the probabil
  ! by counting the number of walkers at every position
  DO i = -length, length, 1
     count = 0
     DO j = 1, walkers
        IF ( x(j) == i ) count = count + 1;
     ENDDO
     probability(i) = count;
  ENDDO

END SUBROUTINE mc_sampling


function rosenbrockxy(p, xx, yy)

!*****************************************************************************80
!
!! ROSENBROCK evaluates the Rosenbrock parabolic value function.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    19 February 2008
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    R ONeill,
!    Algorithm AS 47:
!    Function Minimization Using a Simplex Procedure,
!    Applied Statistics,
!    Volume 20, Number 3, 1971, pages 338-345.
!
!  Parameters:
!
!    Input, real(dp) P(2), the argument.
!    Input, real(dp) X(1), the argument 2.
!    Input, real(dp) Y(1), the argument 3.
!
!    Output, real(dp) ROSENBROCK, the value of the function.
!
  use mo_kind,   only: dp

  implicit none

  real(dp), dimension(:), intent(in) :: p
  real(dp), dimension(:), intent(in) :: xx
  real(dp), dimension(:), intent(in) :: yy
  real(dp) :: rosenbrockxy

  real(dp) :: fx
  real(dp) :: fx1
  real(dp) :: fx2

  fx1 = p(2) - p(1) * p(1)
  fx2 = xx(1) - p(1)

  fx = yy(1) * fx1 * fx1 + fx2 * fx2

  rosenbrockxy = fx

end function rosenbrockxy


module rootfinding
  use settings, only: dp => mcp
  implicit none

  contains

  subroutine find_root( f, xinit, tol, maxiter, result, success )

    interface
       function f(x)
         real(kind=8)             :: f
         real(kind=8), intent(in) :: x
       end function f
    end interface

    real(kind=dp),  intent(in)  :: xinit, tol
    integer, intent(in)         :: maxiter
    real(kind=dp),  intent(out) :: result
    logical, intent(out)        :: success

    real(kind=dp), parameter    :: eps = 1.0e-3_dp
    real(kind=dp)               :: fx1,fx2,fprime,x,xnew
    integer                     :: i

    result  = 0._dp
    success = .false.

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!    Newton-Raphson method     !!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    x = xinit
    do i = 1,max(1,maxiter)

      fx1    = f(x)
      fx2    = f(x+eps)
      fprime = (fx2 - fx1) / eps
      xnew   = x - fx1 / fprime

      if ( abs(xnew-x) <= tol ) then
          success = .true.
          result  = xnew
          !write(*,*) i, f(xnew)
          exit
      endif

      x = xnew

    enddo

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!      Secant method        !!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!$    x0 = xinit + 0.03d0
!!$    x1 = xinit - 0.03d0
!!$    do i = 1,max(1,maxiter)
!!$
!!$        DX   = x1-x0
!!$        DF   = f(x1) - f(x0)
!!$        x2   = x1 - f(x1)*DX/DF
!!$
!!$        if ( abs(x2-x1) <= tol ) then
!!$            success = .true.
!!$            result  = x2
!!$            !write(*,*) i, f(x2)
!!$            exit
!!$        endif
!!$
!!$        x0   = x1
!!$        x1   = x2
!!$
!!$     enddo

  end subroutine find_root

end module


SUBROUTINE force_rel (Zsat,Zearth,relativ , a_rel)

! ----------------------------------------------------------------------
! SUBROUTINE: force_rel.f90
! ----------------------------------------------------------------------
! Purpose:
!  Relativistic corrections to the acceleration of an Earth artificial
!  satellite according to the formula adopted in IERS Conventions 2010.
! ----------------------------------------------------------------------
! Input arguments:
! - Zsat  :			Satellite's state vector with respect to the Earth
! - Zearth:			Earth's state vector with respect to the Sun
!					z = [x y z Vx Vy Vz]
! - relativ:		Relativistic effects to be or not to be computed
!					Schwarzschild, Lense-Thirring, geodesic (de Sitter) precession
!   rlv 3x1 matrix  e.g. rlv = [1 1 1]
!   value 1 for computation and value 0 for neglection

! - GMearth  : Gravitational coefficient of Earth
! - GMsun    : Gravitational coefficient of Sun
! - cslight  : Speed of light
! - ppn_beta : PPN (parameterized post-Newtonian) parameters
!   ppn_gama   PPN equal to 1 in General Relativity

!
! Output arguments:
! - a_relativ : Cartesian components of relativistic corrections to
!               satellite acceleration     a_relativ = [ax; ay; az]
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia            November 2015
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ---------------------------------------------------------------------------
! Dummy arguments declaration
! ---------------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(6) :: Zsat,Zearth
      INTEGER (KIND = prec_int2), INTENT(IN), DIMENSION(3) :: relativ
! mdl_num.f90: GMearth,GMsun , cslight,ppn_beta,ppn_gama
!
! OUT
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(3) :: a_rel
!      REAL (KIND = prec_q), INTENT(OUT) :: ax,ay,az
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Local variables declaration
! ---------------------------------------------------------------------------
      REAL (KIND = prec_q) :: xMoon,yMoon,zMoon,l_Moon , xSun,ySun,zSun,l_Sun
      REAL (KIND = prec_q) :: termMoon,termMoon_x,termMoon_y,termMoon_z , termSun,termSun_x,termSun_y,termSun_z
      REAL (KIND = prec_q) :: indirectJ2_coef
      REAL (KIND = prec_q) :: ax,ay,az
!      REAL (KIND = prec_q), DIMENSION(3) :: a_iJ2
! ---------------------------------------------------------------------------

! ----------------------------------------------------------------------
! Satellite vectors
rsat = (/Zsat(1), Zsat(2), Zsat(3) /)
vsat = (/ Zsat(4), Zsat(5), Zsat(6) /)

! Earth-Satellite distance
lsat = sqrt( rsat(1)**2 + rsat(2)**2 + rsat(3)**2 )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Earth vectors
rearth = (/ Zearth(1), Zearth(2), Zearth(3) /)
vearth = (/ Zearth(4), Zearth(5), Zearth(6) /)

! Earth's angular momentum per unit mass
      CALL productcross (rearth,vearth , Jearth)

! Sun-Earth distance
learth = sqrt(rearth(1)**2 + rearth(2)**2 + rearth(3)**2)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Relativistic effects terms
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
!if relativ(1,1) == 1
!% Schwarzschild terms
!a_Schwarzschild = (GMearth / (cslight^2 * lsat^3)) * ...
!                  ( ...
!                  ( 2*(ppn_beta+ppn_gama) * (GMearth/lsat) - ppn_gama * productdot(vsat,vsat) ) * rsat ...
!                  + 2 * (1 + ppn_gama) * productdot(rsat,vsat) * vsat ...
!                  );
!elseif relativ(1,1) == 0
!    a_Schwarzschild = [0; 0; 0];
!end
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Schwarzschild terms
productdot(vsat,vsat)
productdot(rsat,vsat)

a_Schwarzschild = (GMearth / (cslight**2 * lsat**3)) *															&
                  ( 																							&
                  ( 2.0D0 * (ppn_beta+ppn_gama) * (GMearth/lsat) - ppn_gama * productdot(vsat,vsat) ) * rsat 	&
                  + 2.0D0 * (1.0D0 + ppn_gama) * productdot(rsat,vsat) * vsat 									&
                  )

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!if relativ(1,2) == 1
!% Lense-Thirring (precession,frame-dragging) terms
!a_LenseThirring = (1 + ppn_gama) * (GMearth / (cslight^2 * lsat^3)) * ...
!                  ( (3/lsat^2) * productcross(rsat,vsat) * productdot(rsat,Jearth) + productcross(vsat,Jearth) );
!elseif relativ(1,2) == 0
!    a_LenseThirring = [0; 0; 0];
!end
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Lense-Thirring (precession,frame-dragging) terms
a_LenseThirring = (1.0D0 + ppn_gama) * (GMearth / (cslight**2 * lsat**3)) * 	&
                  ( (3.0D0/lsat**2) * productcross(rsat,vsat) * productdot(rsat,Jearth) + productcross(vsat,Jearth) )

! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!if relativ(1,3) == 1
!% geodesic (de Sitter) precession terms
!vec1 = - ( GMsun / (cslight^2 * learth^3) ) * rearth;
!cp1 = productcross(vearth,vec1);
!cp2 = productcross(cp1,vsat);
!a_deSitter = (1 + 2 * ppn_gama) * cp2;
!clear vec1 cp1 cp2
!elseif relativ(1,3) == 0
!    a_deSitter = [0; 0; 0];
!end
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! geodesic (de Sitter) precession terms
vec1 = -1.0D0 * ( GMsun / (cslight**2 * learth**3) ) * rearth
cp1 = productcross(vearth,vec1)
cp2 = productcross(cp1,vsat)
a_deSitter = (1.0D0 + 2.0D0 * ppn_gama) * cp2

% % Vectors magnitude
% a_Schwarzschild_magn = sqrt(a_Schwarzschild(1,1)^2 + a_Schwarzschild(2,1)^2 + a_Schwarzschild(3,1)^2)
% a_LenseThirring_magn = sqrt(a_LenseThirring(1,1)^2 + a_LenseThirring(2,1)^2 + a_LenseThirring(3,1)^2)
% a_deSitter_magn      = sqrt(a_deSitter(1,1)^2 + a_deSitter(2,1)^2 + a_deSitter(3,1)^2)

% Overall vector
a_relativ = a_Schwarzschild + a_LenseThirring + a_deSitter;
END


module m_calc_l_m_from_lm

contains
   pure subroutine calc_l_m_from_lm(lm, l, m)
      use m_juDFT
      implicit none
      integer, intent(in)   :: lm
      integer, intent(out)  :: l, m
      !We define lm such that goes from 1..lmax**2
      l = floor(sqrt(lm - 1.0))
      m = lm - (l**2 + l + 1)
   end subroutine calc_l_m_from_lm
end module m_calc_l_m_from_lm


      subroutine wacos(zr, zi, ar, ai)
*
*     PURPOSE
*        Compute the arccosine of a complex number
*         a = ar + i ai = acos(z), z = zr + i zi
*
*     CALLING LIST / PARAMETERS
*        subroutine wacos(zr,zi,ar,ai)
*        double precision zr,zi,ar,ai
*
*        zr,zi: real and imaginary parts of the complex number
*        ar,ai: real and imaginary parts of the result
*               ar,ai may have the same memory cases than zr et zi
*
*     REFERENCE
*        This is a Fortran-77 translation of an algorithm by
*        T.E. Hull, T. F. Fairgrieve and P.T.P. Tang which
*        appears in their article :
*          "Implementing the Complex Arcsine and Arccosine
*           Functions Using Exception Handling", ACM, TOMS,
*           Vol 23, No. 3, Sept 1997, p. 299-335
*
*        with some modifications so as don't rely on ieee handle
*        trap functions.
*
*     AUTHOR
*        Bruno Pincon <Bruno.Pincon@iecn.u-nancy.fr>
*        Thanks to Tom Fairgrieve
*
      implicit none

*     PARAMETERS
      double precision zr, zi, ar, ai

*     EXTERNAL FUNCTIONS
      double precision dlamch, logp1
      external         dlamch, logp1

*     CONSTANTS
      double precision LN2, PI, HALFPI, Across, Bcross
      parameter       (LN2    = 0.6931471805599453094172321d0,
     $                 HALFPI = 1.5707963267948966192313216d0,
     $                     PI = 3.1415926535897932384626433d0,
     $                 Across = 1.5d0,
     $                 Bcross = 0.6417d0)
*     LOCAL VARIABLES
      double precision x, y, A, B, R, S, Am1, szr, szi

*     STATIC VARIABLES
      double precision LSUP, LINF, EPSM
      save             LSUP, LINF, EPSM
      logical          first
      save             first
      data             first /.true./

*     TEXT
*     got f.p. parameters used by the algorithm
      if (first) then
          LSUP = sqrt(dlamch('o'))/8.d0
          LINF = 4.d0*sqrt(dlamch('u'))
          EPSM = sqrt(dlamch('e'))
          first = .false.
      endif

*     avoid memory pb ...
      x = abs(zr)
      y = abs(zi)
      szr = sign(1.d0,zr)
      szi = sign(1.d0,zi)

      if (LINF .le. min(x,y) .and. max(x,y) .le. LSUP ) then
*        we are in the safe region
         R = sqrt((x+1.d0)**2 + y**2)
         S = sqrt((x-1.d0)**2 + y**2)
         A = 0.5d0*(R + S)
         B = x/A

*        compute the real part
         if ( B .le. Bcross ) then
            ar = acos(B)
         elseif ( x .le. 1.d0 ) then
            ar = atan( sqrt( 0.5d0*(A+x) *
     $                 ( (y**2)/(R+(x+1.d0)) + (S+(1.d0-x)) ) ) / x )
         else
            ar = atan((y*sqrt(0.5d0*((A+x)/(R+(x+1.d0))
     $                  +(A+x)/(S+(x-1.d0))))) / x)
         endif

*        compute the imaginary part
         if ( A .le. Across ) then
            if ( x .lt. 1.d0 ) then
               Am1 = 0.5d0*((y**2)/(R+(x+1.d0))+(y**2)/(S+(1.d0-x)))
            else
               Am1 = 0.5d0*((y**2)/(R+(x+1.d0))+(S+(x-1.d0)))
            endif
            ai = logp1(Am1 + sqrt(Am1*(A+1.d0)))
         else
            ai = log(A + sqrt(A**2 - 1.d0))
         endif

      else
*        HANDLE BLOC : evaluation in the special regions ...
         if ( y .le. EPSM*abs(x-1.d0) ) then
            if (x .lt. 1.d0 ) then
               ar = acos(x)
               ai = y/sqrt((1.d0+x)*(1.d0-x))
            else
               ar = 0.d0
               if ( x .le. LSUP ) then
                  ai = logp1((x-1.d0) + sqrt((x-1.d0)*(x+1.d0)))
               else
                  ai = LN2 + log(x)
               endif
            endif
         elseif (y .lt. LINF) then
            ar = sqrt(y)
            ai = ar
         elseif (EPSM*y - 1.d0 .ge. x) then
            ar = HALFPI
            ai = LN2 + log(y)
         elseif (x .gt. 1.d0) then
            ar = atan(y/x)
            ai = LN2 + log(y) + 0.5d0*logp1((x/y)**2)
         else
            ar = HALFPI
            A = sqrt(1.d0 + y**2)
            ai = 0.5d0*logp1(2.d0*y*(y+A))
         endif
      endif

*     recover the signs
      if (szr .lt. 0.d0) then
         ar = PI - ar
      endif

      if (y.ne.0.d0 .or. szr.lt.0.d0) then
         ai = - szi * ai
      endif

      end


      SUBROUTINE MB03MD( N, L, THETA, Q, E, Q2, E2, PIVMIN, TOL, RELTOL,
     $                   IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute an upper bound THETA using a bisection method such that
C     the bidiagonal matrix
C
C              |q(1) e(1)  0    ...   0   |
C              | 0   q(2) e(2)        .   |
C          J = | .                    .   |
C              | .                  e(N-1)|
C              | 0   ...        ...  q(N) |
C
C     has precisely L singular values less than or equal to THETA plus
C     a given tolerance TOL.
C
C     This routine is mainly intended to be called only by other SLICOT
C     routines.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the bidiagonal matrix J.  N >= 0.
C
C     L       (input/output) INTEGER
C             On entry, L must contain the number of singular values
C             of J which must be less than or equal to the upper bound
C             computed by the routine.  0 <= L <= N.
C             On exit, L may be increased if the L-th smallest singular
C             value of J has multiplicity greater than 1. In this case,
C             L is increased by the number of singular values of J which
C             are larger than its L-th smallest one and approach the
C             L-th smallest singular value of J within a distance less
C             than TOL.
C             If L has been increased, then the routine returns with
C             IWARN set to 1.
C
C     THETA   (input/output) DOUBLE PRECISION
C             On entry, THETA must contain an initial estimate for the
C             upper bound to be computed. If THETA < 0.0 on entry, then
C             one of the following default values is used.
C             If L = 0, THETA is set to 0.0 irrespective of the input
C             value of THETA; if L = 1, then THETA is taken as
C             MIN(ABS(Q(i))), for i = 1,2,...,N; otherwise, THETA is
C             taken as ABS(Q(N-L+1)).
C             On exit, THETA contains the computed upper bound such that
C             the bidiagonal matrix J has precisely L singular values
C             less than or equal to THETA + TOL.
C
C     Q       (input) DOUBLE PRECISION array, dimension (N)
C             This array must contain the diagonal elements q(1),
C             q(2),...,q(N) of the bidiagonal matrix J. That is,
C             Q(i) = J(i,i) for i = 1,2,...,N.
C
C     E       (input) DOUBLE PRECISION array, dimension (N-1)
C             This array must contain the superdiagonal elements
C             e(1),e(2),...,e(N-1) of the bidiagonal matrix J. That is,
C             E(k) = J(k,k+1) for k = 1,2,...,N-1.
C
C     Q2      (input) DOUBLE PRECISION array, dimension (N)
C             This array must contain the squares of the diagonal
C             elements q(1),q(2),...,q(N) of the bidiagonal matrix J.
C             That is, Q2(i) = J(i,i)**2 for i = 1,2,...,N.
C
C     E2      (input) DOUBLE PRECISION array, dimension (N-1)
C             This array must contain the squares of the superdiagonal
C             elements e(1),e(2),...,e(N-1) of the bidiagonal matrix J.
C             That is, E2(k) = J(k,k+1)**2 for k = 1,2,...,N-1.
C
C     PIVMIN  (input) DOUBLE PRECISION
C             The minimum absolute value of a "pivot" in the Sturm
C             sequence loop.
C             PIVMIN >= max( max( |q(i)|, |e(k)| )**2*sf_min, sf_min ),
C             where i = 1,2,...,N, k = 1,2,...,N-1, and sf_min is at
C             least the smallest number that can divide one without
C             overflow (see LAPACK Library routine DLAMCH).
C             Note that this condition is not checked by the routine.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             This parameter defines the multiplicity of singular values
C             by considering all singular values within an interval of
C             length TOL as coinciding. TOL is used in checking how many
C             singular values are less than or equal to THETA. Also in
C             computing an appropriate upper bound THETA by a bisection
C             method, TOL is used as a stopping criterion defining the
C             minimum (absolute) subinterval width.  TOL >= 0.
C
C     RELTOL  DOUBLE PRECISION
C             This parameter specifies the minimum relative width of an
C             interval. When an interval is narrower than TOL, or than
C             RELTOL times the larger (in magnitude) endpoint, then it
C             is considered to be sufficiently small and bisection has
C             converged.
C             RELTOL >= BASE * EPS, where BASE is machine radix and EPS
C             is machine precision (see LAPACK Library routine DLAMCH).
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warnings;
C             = 1:  if the value of L has been increased as the L-th
C                   smallest singular value of J coincides with the
C                   (L+1)-th smallest one.
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
C     METHOD
C
C     Let s(i), i = 1,2,...,N, be the N non-negative singular values of
C     the bidiagonal matrix J arranged so that s(1) >= ... >= s(N) >= 0.
C     The routine then computes an upper bound T such that s(N-L) > T >=
C     s(N-L+1) as follows (see [2]).
C     First, if the initial estimate of THETA is not specified by the
C     user then the routine initialises THETA to be an estimate which
C     is close to the requested value of THETA if s(N-L) >> s(N-L+1).
C     Second, a bisection method (see [1, 8.5]) is used which generates
C     a sequence of shrinking intervals [Y,Z] such that either THETA in
C     [Y,Z] was found (so that J has L singular values less than or
C     equal to THETA), or
C
C        (number of s(i) <= Y) < L < (number of s(i) <= Z).
C
C     This bisection method is applied to an associated 2N-by-2N
C     symmetric tridiagonal matrix T" whose eigenvalues (see [1]) are
C     given by s(1),s(2),...,s(N),-s(1),-s(2),...,-s(N). One of the
C     starting values for the bisection method is the initial value of
C     THETA. If this value is an upper bound, then the initial lower
C     bound is set to zero, else the initial upper bound is computed
C     from the Gershgorin Circle Theorem [1, Theorem 7.2-1], applied to
C     T". The computation of the "number of s(i) <= Y (or Z)" is
C     achieved by calling SLICOT Library routine MB03ND, which applies
C     Sylvester's Law of Inertia or equivalently Sturm sequences
C     [1, 8.5] to the associated matrix T". If
C
C        Z - Y <= MAX( TOL, PIVMIN, RELTOL*MAX( ABS( Y ), ABS( Z ) ) )
C
C     at some stage of the bisection method, then at least two singular
C     values of J lie in the interval [Y,Z] within a distance less than
C     TOL from each other. In this case, s(N-L) and s(N-L+1) are assumed
C     to coincide, the upper bound T is set to the value of Z, the value
C     of L is increased and IWARN is set to 1.
C
C     REFERENCES
C
C     [1] Golub, G.H. and Van Loan, C.F.
C         Matrix Computations.
C         The Johns Hopkins University Press, Baltimore, Maryland, 1983.
C
C     [2] Van Huffel, S. and Vandewalle, J.
C         The Partial Total Least Squares Algorithm.
C         J. Comput. and Appl. Math., 21, pp. 333-341, 1988.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997.
C     Supersedes Release 2.0 routine MB03AD by S. Van Huffel, Katholieke
C     University, Leuven, Belgium.
C
C     REVISIONS
C
C     June 16, 1997, Oct. 26, 2003.
C
C     KEYWORDS
C
C     Bidiagonal matrix, singular values.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, TWO
      PARAMETER         ( ZERO = 0.0D0, TWO = 2.0D0 )
      DOUBLE PRECISION  FUDGE
      PARAMETER         ( FUDGE = TWO )
C     .. Scalar Arguments ..
      INTEGER           INFO, IWARN, L, N
      DOUBLE PRECISION  PIVMIN, RELTOL, THETA, TOL
C     .. Array Arguments ..
      DOUBLE PRECISION  E(*), E2(*), Q(*), Q2(*)
C     .. Local Scalars ..
      INTEGER           I, NUM, NUMZ
      DOUBLE PRECISION  H, TH, Y, Z
C     .. External Functions ..
      INTEGER           MB03ND
      DOUBLE PRECISION  DLAMCH, MB03MY
      EXTERNAL          DLAMCH, MB03MY, MB03ND
C     .. External Subroutines ..
      EXTERNAL          XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, MAX
C     .. Executable Statements ..
C
C     Test some input scalar arguments.
C
      IWARN = 0
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( L.LT.0 .OR. L.GT.N ) THEN
         INFO = -2
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB03MD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 )
     $    RETURN
C
C     Step 1: initialisation of THETA.
C             -----------------------
      IF ( L.EQ.0 ) THETA = ZERO
      IF ( THETA.LT.ZERO ) THEN
         IF ( L.EQ.1 ) THEN
C
C           An upper bound which is close if S(N-1) >> S(N):
C
            THETA = MB03MY( N, Q, 1 )
            IF ( N.EQ.1 )
     $         RETURN
         ELSE
C
C           An experimentally established estimate which is good if
C           S(N-L) >> S(N-L+1):
C
            THETA = ABS( Q(N-L+1) )
         END IF
      END IF
C
C     Step 2: Check quality of initial estimate THETA.
C             ---------------------------------------
      NUM = MB03ND( N, THETA, Q2, E2, PIVMIN, INFO )
      IF ( NUM.EQ.L )
     $   RETURN
C
C     Step 3: initialisation starting values for bisection method.
C             ---------------------------------------------------
C     Let S(i), i=1,...,N, be the singular values of J in decreasing
C     order. Then, the computed Y and Z will be such that
C     (number of S(i) <= Y) < L < (number of S(i) <= Z).
C
      IF ( NUM.LT.L ) THEN
         TH = ABS( Q(1) )
         Z = ZERO
         Y = THETA
         NUMZ = N
C
         DO 20 I = 1, N - 1
            H = ABS( Q(I+1) )
            Z  = MAX( MAX( TH, H ) + ABS( E(I) ), Z )
            TH = H
   20    CONTINUE
C
C        Widen the Gershgorin interval a bit for machines with sloppy
C        arithmetic.
C
         Z = Z + FUDGE*ABS( Z )*DLAMCH( 'Epsilon' )*DBLE( N )
     $         + FUDGE*PIVMIN
      ELSE
         Z = THETA
         Y = ZERO
         NUMZ = NUM
      END IF
C
C     Step 4: Bisection method for finding the upper bound on the L
C             smallest singular values of the bidiagonal.
C             ------------------------------------------
C     A sequence of subintervals [Y,Z] is produced such that
C         (number of S(i) <= Y) < L < (number of S(i) <= Z).
C     NUM : number of S(i) <= TH,
C     NUMZ: number of S(i) <= Z.
C
C     WHILE ( ( NUM .NE. L ) .AND.
C             ( ( Z-Y ) .GT. MAX( TOL, PIVMIN, RELTOL*ABS( Z ) ) ) ) DO
   40 IF ( ( NUM.NE.L ) .AND.
     $     ( ABS( Z-Y ).GT.MAX( TOL, PIVMIN,
     $                          RELTOL*MAX( ABS( Y ), ABS( Z ) ) ) ) )
     $      THEN
         TH = ( Y + Z )/TWO
         NUM = MB03ND( N, TH, Q2, E2, PIVMIN, INFO )
         IF ( NUM.LT.L ) THEN
            Y = TH
         ELSE
            Z = TH
            NUMZ = NUM
         END IF
         GO TO 40
      END IF
C     END WHILE 40
C
C     If NUM <> L and ( Z - Y ) <= TOL, then at least two singular
C     values of J lie in the interval [Y,Z] within a distance less than
C     TOL from each other. S(N-L) and S(N-L+1) are then assumed to
C     coincide. L is increased, and a warning is given.
C
      IF ( NUM.NE.L ) THEN
         L = NUMZ
         THETA = Z
         IWARN = 1
      ELSE
         THETA = TH
      END IF
C
      RETURN
C *** Last line of MB03MD ***
      END


      SUBROUTINE lu(n,A)
      IMPLICIT NONE

      INTEGER n
      REAL*8 A(n,n)

      INTEGER i,j,k

      DO 10 k = 1, n-1
         DO 20 i = k+1, n
            A(i, k) = A(i, k) / A(k, k)
 20      CONTINUE

         DO 30 i = k+1, n
            DO 40 j = k+1, n
               A(i, j) = A(i, j) - A(i, k)*A(k, j)
 40         CONTINUE
 30      CONTINUE
 10   CONTINUE

      END


!##############################################################################
! PROGRAM dynamic
!
! ## The dynamic solution to the cake eating problem
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program dynamic

    use toolbox

    implicit none

    ! model parameters
    real*8, parameter :: gamma = 0.5d0
    real*8, parameter :: egam = 1d0-1d0/gamma
    real*8, parameter :: beta = 0.95d0
    real*8, parameter :: a0 = 100d0

    ! other variables
    integer :: it, ia

    integer, parameter :: TT = 200
    real*8 :: c_t(0:TT), a_t(0:TT)

    integer, parameter :: NA = 1000
    real*8 :: a(0:NA), c(0:NA), V(0:NA)

    ! calculate the time path of consumption
    a_t(0) = a0
    c_t(0) = a_t(0)*(1d0-beta**gamma)
    do it = 1, TT
        a_t(it) = a_t(it-1) - c_t(it-1)
        c_t(it) = a_t(it)*(1d0-beta**gamma)
    enddo

    call plot((/(dble(it),it=0,TT)/), c_t)
    call execplot(xlabel='Time t', ylabel='Consumption c_t')

    ! plot policy and value function
    do ia = 0, NA
        a(ia)  = 1d0 + dble(ia)/dble(NA)*a0
        c(ia) = a(ia)*(1d0-beta**gamma)
        V(ia) = (1d0-beta**gamma)**(-1d0/gamma)*a(ia)**egam/egam
    enddo

    ! plot policy function
    call plot(a, c)
    call execplot(xlabel='Level of resources a', ylabel='Policy Function c(a)')

    ! plot value function
    call plot(a, V)
    call execplot(xlabel='Level of Resources a', ylabel='Value Function V(a)')

end program


!  sparse_mult.f90
!
!  F2py sparse_mult implementation.
!
!  Copyright:
!  (c) 2017 Maxime Tondeur & Jonathan Demaeyer.
!  See LICENSE.txt for license information.
!
!----------------------------------------------------------------------!

MODULE sparse_mult
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: sparse_mul3
CONTAINS

  SUBROUTINE sparse_mul3(Li,Lj,Lk,Lv,ndim,nens,X,res)
    INTEGER,DIMENSION(:), INTENT(IN)  :: Li
    INTEGER,DIMENSION(:), INTENT(IN)  :: Lj
    INTEGER,DIMENSION(:), INTENT(IN)  :: Lk
    REAL(KIND=8),DIMENSION(:), INTENT(IN)  :: Lv
    INTEGER :: ndim
    INTEGER :: nens
    REAL(KIND=8),DIMENSION(nens,0:ndim), INTENT(IN)  :: X
    REAL(KIND=8), DIMENSION(nens,0:ndim),INTENT(OUT)  :: res
    REAL(KIND=8) :: v
    INTEGER :: n,i,j,k,nelem,ne

    res=0.D0
    nelem=SIZE(Li)

    DO n=1,nelem
      i=Li(n)
      j=Lj(n)
      k=Lk(n)
      v=Lv(n)
      DO ne=1,nens
          res(ne,i)= res(ne,i) + v* X(ne,j)*X(ne,k)
      ENDDO
    END DO
  END SUBROUTINE sparse_mul3

END MODULE sparse_mult


FUNCTION sqmcor(x, ip, n, rho2) RESULT(fn_val)

! Code converted using TO_F90 by Alan Miller
! Date: 2003-06-24  Time: 14:51:12

!    ALGORITHM AS 260  APPL. STATIST. (1991) VOL. 40, NO. 1

!    Computes the C.D.F. for the distribution of the square of the
!    multiple correlation coefficient with parameters X, IP, N, and RHO2.
!    X is the sample value of R**2.
!    IP is the number of predictors, including 1 for the constant if one is
!    being fitted.
!    N is the number of cases.
!    RHO2 is the population value of the squared multiple correlation
!    coefficient (often set = 0).

!    The following auxiliary algorithms are required:
!    ALNGAM - Log-gamma function  (ALNGAM  AS 245)
!    BETAIN - Incomplete beta function (AS 63)

! N.B. Argument IFAULT has been removed.

IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)

REAL (dp), INTENT(IN)  :: x
INTEGER, INTENT(IN)    :: ip
INTEGER, INTENT(IN)    :: n
REAL (dp), INTENT(IN)  :: rho2
REAL (dp)              :: fn_val

REAL (dp)  :: a, b, beta, errbd, gx, q, sumq, temp, term, xj
! REAL :: ALNGAM, betain
! EXTERNAL ALNGAM, betain
INTERFACE
  FUNCTION betain(x, p, q, beta) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(15, 100)
    REAL (dp), INTENT(IN)  :: x, p, q, beta
    REAL (dp)              :: fn_val
  END FUNCTION betain

  FUNCTION alngam(xvalue) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(15, 100)
    REAL (dp), INTENT(IN)  :: xvalue
    REAL (dp)              :: fn_val
  END FUNCTION alngam
END INTERFACE

REAL (dp), PARAMETER  :: errmax = 1.0D-8, zero = 0.0_dp, half = 0.5_dp,   &
                         one = 1.0_dp
INTEGER, PARAMETER    :: itrmax = 100

fn_val = x
IF (rho2 < zero .OR. rho2 > one .OR. ip < 2 .OR. n <= ip) THEN
  WRITE(*, *) 'Error in Function sqmcor, rho2 must be in the range (0,1)'
  RETURN
END IF
IF (x < zero .OR. x > one) THEN
  WRITE(*, *) 'Error in Function sqmcor, x must be in the range (0,1)'
  RETURN
END IF

IF (x == zero .OR. x == one) RETURN

a = half * (ip - 1)
b = half * (n - ip)

!        Initialize the series

beta = EXP(ALNGAM(a) + ALNGAM(b) - ALNGAM(a + b))
temp = betain(x, a, b, beta)

!        There is no need to test IFAULT since all of the
!        parameter values have already been checked

gx = EXP(a * LOG(x) + b * LOG(one - x) - LOG(a)) / beta
q = (one - rho2) ** (a + b)
xj = zero
term = q * temp
sumq = one - q
fn_val = term

!        Perform recurrence until convergence is achieved

10 xj = xj + one
temp = temp - gx
gx = gx * (a + b + xj - one) * x / (a + xj)
q = q * (a + b + xj - one) * rho2 / xj
sumq = sumq - q
term = temp * q
fn_val = fn_val + term

!        Check for convergence and act accordingly

errbd = (temp - gx) * sumq
IF (INT(xj) < itrmax .AND. errbd > errmax) GO TO 10
IF (errbd > errmax) THEN
  WRITE(*, *) 'Error in SQMCOR, errbd > errmax'
END IF
RETURN
END FUNCTION sqmcor

FUNCTION betain(x, p, q, beta) RESULT(fn_val)

!     Algorithm AS 63  Applied Statistics (1973), vol.22, no.3

!     Computes incomplete beta function ratio for arguments
!     x between zero and one, p and q positive.
!     log of complete beta function, beta, is assumed to be known

! ELF90-compatible version by Alan Miller
! N.B. Argument IFAULT has been removed

! Latest revision - 29 November 1997

IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)
REAL (dp), INTENT(IN) :: x, p, q, beta
REAL (dp)             :: fn_val

! Local variables
LOGICAL    :: indx
INTEGER    :: ns
REAL (dp)  :: psq, cx, xx, pp, qq, term, ai, rx, temp

!     define accuracy and initialise

REAL (dp), PARAMETER  :: zero = 0.0_dp, one = 1.0_dp, acu = 1.0E-14_dp

fn_val = x

!     test for admissibility of arguments

IF(p <= zero .OR. q <= zero) THEN
  WRITE(*, *) 'AS63: Either p or q <= 0'
  RETURN
END IF
IF(x < zero .OR. x > one) THEN
  WRITE(*, *) 'AS63: Argument x outside range (0, 1)'
  RETURN
END IF
IF(x == zero .OR. x == one) RETURN

!     change tail if necessary and determine s

psq = p + q
cx = one - x
IF(p < psq*x) THEN
  xx = cx
  cx = x
  pp = q
  qq = p
  indx = .true.
ELSE
  xx = x
  pp = p
  qq = q
  indx = .false.
END IF
term = one
ai = one
fn_val = one
ns = qq + cx*psq

!     Use Soper's reduction formulae.

rx = xx/cx
3 temp = qq - ai
IF(ns == 0) rx = xx
4 term = term*temp*rx/(pp+ai)
fn_val = fn_val + term
temp = ABS(term)
IF(temp <= acu .AND. temp <= acu*fn_val) GO TO 5
ai = ai + one
ns = ns - 1
IF(ns >= 0) GO TO 3
temp = psq
psq = psq + one
GO TO 4

!     calculate result

5 fn_val = fn_val*EXP(pp*LOG(xx) + (qq-one)*LOG(cx) - beta)/pp
IF(indx) fn_val = one - fn_val

RETURN
END FUNCTION betain

FUNCTION alngam(xvalue) RESULT(fn_val)

!     ALGORITHM AS245  APPL. STATIST. (1989) VOL. 38, NO. 2

!     Calculation of the logarithm of the gamma function

! ELF90-compatible version by Alan Miller
! Latest revision - 29 November 1997

! N.B. Argument IFAULT has been removed

IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)
REAL (dp), INTENT(IN) :: xvalue
REAL (dp)             :: fn_val

! Local variables
REAL (dp) :: x, x1, x2, y

!     Coefficients of rational functions

REAL (dp), PARAMETER :: r1(9) = (/ -2.66685511495_dp, -24.4387534237_dp,  &
                                   -21.9698958928_dp,  11.1667541262_dp,  &
                                    3.13060547623_dp,  0.607771387771_dp, &
                                    11.9400905721_dp,  31.4690115749_dp,  &
                                    15.2346874070_dp /)
REAL (dp), PARAMETER :: r2(9) = (/ -78.3359299449_dp, -142.046296688_dp,  &
                                    137.519416416_dp,  78.6994924154_dp,  &
                                    4.16438922228_dp,  47.0668766060_dp,  &
                                    313.399215894_dp,  263.505074721_dp,  &
                                    43.3400022514_dp /)
REAL (dp), PARAMETER :: r3(9) = (/ -2.12159572323E5_dp,  2.30661510616E5_dp,  &
                                    2.74647644705E4_dp, -4.02621119975E4_dp,  &
                                   -2.29660729780E3_dp, -1.16328495004E5_dp,  &
                                   -1.46025937511E5_dp, -2.42357409629E4_dp,  &
                                   -5.70691009324E2_dp /)
REAL (dp), PARAMETER :: r4(5) = (/ 0.279195317918525_dp, 0.4917317610505968_dp, &
                                   0.0692910599291889_dp, 3.350343815022304_dp, &
                                   6.012459259764103_dp /)

!     Fixed constants

REAL (dp), PARAMETER :: alr2pi = 0.918938533204673_dp, four = 4._dp,  &
                        half = 0.5_dp, one = 1._dp, onep5 = 1.5_dp,   &
                        twelve = 12._dp, zero = 0._dp

!     Machine-dependant constants.
!     A table of values is given at the top of page 399 of the paper.
!     These values are for the IEEE double-precision format for which
!     B = 2, t = 53 and U = 1023 in the notation of the paper.

REAL (dp), PARAMETER :: xlge = 5.10E6_dp, xlgst = HUGE(1.0_dp)

x = xvalue
fn_val = zero

!     Test for valid function argument

IF (x >= xlgst) THEN
  WRITE(*, *) 'AS 245: Argument x too large'
  RETURN
END IF
IF (x <= zero) THEN
  WRITE(*, *) 'AS 245: Argument x <= 0'
  RETURN
END IF

!     Calculation for 0 < X < 0.5 and 0.5 <= X < 1.5 combined

IF (x < onep5) THEN
  IF (x < half) THEN
    fn_val = -LOG(x)
    y = x + one

!     Test whether X < machine epsilon

    IF (y == one) RETURN
  ELSE
    fn_val = zero
    y = x
    x = (x - half) - half
  END IF
  fn_val = fn_val + x * ((((r1(5)*y + r1(4))*y + r1(3))*y + r1(2))*y + r1(1)) / &
                    ((((y + r1(9))*y + r1(8))*y+ r1(7))*y + r1(6))
  RETURN
END IF

!     Calculation for 1.5 <= X < 4.0

IF (x < four) THEN
  y = (x - one) - one
  fn_val = y * ((((r2(5)*x + r2(4))*x + r2(3))*x + r2(2))*x + r2(1)) /  &
               ((((x + r2(9))*x + r2(8))*x + r2(7))*x+ r2(6))
  RETURN
END IF

!     Calculation for 4.0 <= X < 12.0

IF (x < twelve) THEN
  fn_val = ((((r3(5)*x + r3(4))*x + r3(3))*x + r3(2))*x + r3(1)) /  &
           ((((x + r3(9))*x + r3(8))*x + r3(7))*x + r3(6))
  RETURN
END IF

!     Calculation for X >= 12.0

y = LOG(x)
fn_val = x * (y - one) - half * y + alr2pi
IF (x > xlge) RETURN
x1 = one / x
x2 = x1 * x1
fn_val = fn_val + x1 * ((r4(3)*x2 + r4(2))*x2 + r4(1)) /  &
         ((x2 + r4(5))*x2 + r4(4))
RETURN
END FUNCTION alngam


! This module calculates the derived variables from global variables

module derived_variables
    use global_variables
    implicit none

contains
    subroutine derived(ns, mu, lam, mm1, v1, r1, s1, sig, tau, K, vg_zero, t_start, delta_t, n_d)
    implicit none
    double precision :: ns, mu, lam, mm1, v1, r1, s1, sig, tau, K, vg_zero
    double precision :: n_d
    double precision :: t_start, t_final, delta_t

    vg_zero = (22.0/7)/6*(dpg_zero)**(3.0)
    ns = Ps / (kb*T)
    mu = 1.716e-5 * (T/273)**(2.0/3)                                           ! viscosity of the medium
    lam = mu/P * sqrt(PI*kb*T/(2.0*Mg/Na))                                   ! mean free path of air (m)

    mm1 = M/Na                                                                ! mass of a monomer (Kg)
    v1 = mm1/rho                                                              ! volume of a monomer (m3)
    r1 = (1.0/2) * (6.0*v1/PI)**(1.0/3)                                      ! radius of a monomer (m)
    s1 = 4.0 * PI * r1 * r1                                                  ! area of a monomer (m2)
    sig= gam * v1**(2.0/3) / (kb*T)                                          ! surface tension group (dimensionless)
    tau= (ns*s1*(kb*T/(2.0*PI*mm1))**(1.0/2))**(-1.0)                         ! Characterstic time for particle growth (s)
    K  = (2.0*kb*T/(3.0*mu))*ns*tau                                          ! Coagulation coefficient (dimensionless)

    !if (num_zero > 1e9) then
    !   n_d = num_zero
    !else
    n_d = ns
    !end if

    t_start = 0.0
    delta_t = dt/tau

    end subroutine derived

end module derived_variables

!program test_derived_variables
!    use derived_variables
!    implicit none
!    double precision :: ns, mu, lam, mm1, v1, r1, s1, sig, tau, K, vg_zero, t_start, t_final, delta_t, n_d
!    call derived(ns, mu, lam, mm1, v1, r1, s1, sig, tau, K, vg_zero, t_start, t_final, delta_t, n_d)
!
!    print*, ns
!
!end program test_derived_variables


module sub
	contains

	subroutine lerangde(Nmax,lat,lon,p,grad_p)!lon is lamata,lat is theta
	real*8 lon
	real*8 lat
	real*8 p(0:Nmax,0:Nmax)
	real*8 grad_p(1:Nmax,0:Nmax)
	integer Nmax,n,m,i,j

	p(0,0)=1
	p(1,0)=cos(lat)
	p(1,1)=sin(lat)
	print *, p(1,1)
	grad_p(1,0)=(cos(lat)*p(1,0)-p(0,0))/sin(lat)
	grad_p(1,1)=cos(lat)*p(1,1)/sin(lat)

	do i=0,Nmax
	  do j=0,Nmax
	    if(j<=i) then
     	  do n=2,Nmax
		   do m=0,n
			 if(m==n	)then
				p(m,m)=p(m-1,m-1)*sin(lat)*((2*m-1)/(2*m))**0.5
				grad_p(m,m)=n*cos(lat)*p(m,m)*((2*m-1)/(2*m))**0.5
			 else
				p(n,m)=((2*n-1)*cos(lat)*p(n-1,m)-((n-1)**2-m**2)** &
			 &	0.5*p(n-2,m))/(n**2-m**2)**0.5
				grad_p(n,m)=(n*cos(lat)*p(m,n)-(n**2-m**2)**&
			 &	0.5*p(n-1,m))/sin(y)
			 end if
			end do
		   end do
		 else
		   p(i,j)=0
		 end if
	  end do
	end do
	end subroutine lerangde

	subroutine cosine(Nmax,lon,lat,a,r,NA,p)!to calculate g,h
	real*8  lon
	real*8  lat
	real*8 a,r
	real*8 p(0:Nmax,0:Nmax)
	real*8 :: NA(Nmax*(Nmax+2))
	integer i,m,n

	i=1
	 do n=1,Nmax
	     do m=0,n
		   NA(i)=-cos(m*lon)*p(n,m)*(n+1)*(a/r)**(n+2)
		   i=i+1
		 end do

	     do m=1,n
		   NA(i)=-sin(m*lon)*p(n,m)*(n+1)*(a/r)**(n+2)
		   i=i+1
		 end do
	 end do

	end subroutine cosine

end module sub


SUBROUTINE SFNTRI(DET,SF,GDSF,L1,L2,L3,ELXY)
  IMPLICIT NONE
! THIS IS THE SUBROUTINE THAT CALCULATES THE SHAPE FUNCTIONS
! AND THEIR DERIVATIVES AT SPECIFIED GLOBAL POSITIONS
  INTEGER,PARAMETER :: NPE=3
  INTEGER :: I,J,K
  REAL,DIMENSION(3,2),INTENT(IN) :: ELXY
  REAL,INTENT(IN) :: L1,L2,L3
  REAL,INTENT(OUT) :: DET
  REAL,DIMENSION(3),INTENT(OUT) :: SF
  REAL,DIMENSION(2,3),INTENT(OUT) :: GDSF
  REAL,DIMENSION(3,3) :: DSF
  REAL,DIMENSION(2,2) :: GJ,GJINV
  REAL :: SUM

! INITIALIZE ARRAYS
  DO I=1,NPE
     DSF(1,I) = 0.0
     DSF(2,I) = 0.0
     DSF(3,I) = 0.0
     SF(I)    = 0.0
  END DO

! SET THE SHAPE FUNCTIONS FOR A TRIANGLE
  SF(1) = L1
  SF(2) = L2
  SF(3) = L3
  DSF(1,1) = 1.0
  DSF(2,2) = 1.0
  DSF(3,3) = 1.0

! FIND THE JACOBIAN
  DO I=1,2
     DO J=1,2
        SUM = 0.0
        DO K=1,NPE
           SUM = SUM + (DSF(I,K) - DSF(3,K))*ELXY(K,J)
        END DO
        GJ(I,J) = SUM
     END DO
  END DO

! FIND GJ's INVERSE
  DET        =  GJ(1,1)*GJ(2,2) - GJ(1,2)*GJ(2,1)
  GJINV(1,1) =  GJ(2,2)/DET
  GJINV(2,2) =  GJ(1,1)/DET
  GJINV(1,2) = -1.0*GJ(1,2)/DET
  GJINV(2,1) = -1.0*GJ(2,1)/DET

! OBTAIN THE DERIVATIVE OF THE SHAPE FUNCTION WITH PROPER
! TRANSFORMATION
  DO I=1,2
     DO J=1,NPE
        SUM = 0.0
        DO K=1,2
           SUM = SUM + GJINV(I,K)*(DSF(K,J) - DSF(3,J))
        END DO
        GDSF(I,J) = SUM
     END DO
  END DO

END SUBROUTINE SFNTRI


PROGRAM Assignment0
IMPLICIT NONE

REAL, Dimension(:), Allocatable:: X, XError, V,  T
REAL:: h, XDash, dvdt, dxdt, VDash, XDashMid, XMid, VDashmid, Vmid
INTEGER:: i, npts

npts=10001

Allocate(T(0:npts), X(0:npts), XError(0:npts), V(0:npts))

X(0)=0; V(0)=2.0; T(0)=0; h=5E-3 !Setting intial boundary conditions

OPEN(10, FILE='Results.dat')

DO i=1,npts

  dxdt=v(i-1)
  dvdt=-5*(x(i-1))+0.5*Cos(2*T(i-1))

  Xdash = dxdt*x(i-1)
  XMid = x(i-1)+(0.5*h*XDash)
  XDashmid = dxdt*XMid
  X(i) = X(i-1)+h*XDashmid

  VDash = dvdt*V(i-1)
  VMid=V(i-1)+(0.5*h*VDash)
  VDashMid=dvdt*Vmid
  V(i)=V(i-1)+h*Vdashmid

  t(i)=T(i-1)+h

  WRITE(6,*) T(i), X(i), V(i)
  WRITE(10,*) T(i), X(i), V(i)

END DO

CLOSE(10)

DEALLOCATE(T, X, XError, V)

END PROGRAM


MODULE m_force_tides

! ----------------------------------------------------------------------
! MODULE: m_force_tides.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the force_tides subroutine
!
! Subroutines contained within the module:
! - force_tides
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	16 November 2017
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE force_tides(r, GM, ae, n_max, m_max, dCnm, dSnm, fx,fy,fz)

! ----------------------------------------------------------------------
! SUBROUTINE: force_tides
! ----------------------------------------------------------------------
! Purpose:
! Tides acceleration
!   Tides acceleration components are computed as partial derivatives of
!   spherical harmonics expansion of the tides harmonics coefficients.
! ----------------------------------------------------------------------
! Input arguments:
! - r:				position vector (m) in Terrestrial Reference System (ITRS)
!   				r = [x y z]
!
! Output arguments:
! - fx,fy,fz:		Tides acceleration's Cartesian components (m)
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	November 2015
! ----------------------------------------------------------------------
! Last modified:
! - Dr. Thomas Papanikolaou, 2 November 2017:
!   Input arguments modifications
! - Dr. Thomas Papanikolaou, 16 November 2017:
!	Upgraded from Fortran 90 to Fortran 2003 for considering the
!	Fortran 2003 advantages in dynamic memory allocation
! ----------------------------------------------------------------------

      USE mdl_precision
      !USE mdl_num
      !USE mdl_param
      USE m_legendre
      USE m_legendre1
      !USE mdl_tides
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), DIMENSION(3) :: r
      REAL (KIND = prec_q), INTENT(IN) :: GM, ae
      INTEGER (KIND = prec_int8), INTENT(IN) :: n_max, m_max
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(:,:), ALLOCATABLE :: dCnm, dSnm

! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: fx,fy,fz
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: Pnm_norm, dPnm_norm
      INTEGER (KIND = prec_int8) :: Nmax_tide, n1, n, m, m_limit
      REAL (KIND = prec_q) :: phi,lamda,l, dV_r,dV_phi,dV_lamda
      REAL (KIND = prec_q) :: PDVrx(3,3), PDVrx_transp(3,3) , dV_rpl(3,1), fxyz(3,1)
      INTEGER (KIND = prec_int2) :: DeAllocateStatus
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Numerical Constants
! ----------------------------------------------------------------------
! Module mdl_param.f03
!GM = GFM_GM
!ae = GFM_ae

! Module mdl_num.f90
! GM = GM_gfm
! ae = Earth_radius
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Tides corrections Nmax
n1 = SIZE (dCnm, DIM=1)
Nmax_tide = n1 - 1
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! computation of spherical coordinates in radians
      CALL coord_r2sph (r , phi,lamda,l)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! computation of normalized associated Legendre functions
      CALL legendre (phi, n_max, Pnm_norm)
! First-order derivatives of normalized associated Legendre functions
      CALL legendre_drv1 (phi, n_max, dPnm_norm)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Partial derivatives of potential w.r.t. the spherical coordinates (2nd approach):
! - dV_r     : partial derivative w.r.t. radius
! - dV_phi   : partial derivative w.r.t. latitude
! - dV_lamda : partial derivative w.r.t. longtitude
dV_r = 0.0D0
dV_phi = 0.0D0
dV_lamda = 0.0D0
DO n = 2 , n_max
    if (n > m_max) THEN
        m_limit = m_max
    else
        m_limit = n
    end if
    DO m = 0 , m_limit
        dV_r = dV_r         + (-1.0D0 * (GM/l**2)) * (n+1)*1.0D0*((ae/l)**n) * Pnm_norm(n+1,m+1) &
		                      * (dCnm(n+1,m+1) * cos(m*lamda) + dSnm(n+1,m+1) * sin(m*lamda))
        dV_phi = dV_phi     + (GM / l) * ((ae/l)**n) * dPnm_norm(n+1,m+1) &
		                      * (dCnm(n+1,m+1)*cos(m*lamda) + dSnm(n+1,m+1) * sin(m*lamda))
        dV_lamda = dV_lamda + (GM / l) * m * ((ae/l)**n) * Pnm_norm(n+1,m+1) &
		                      * (dSnm(n+1,m+1) * cos(m*lamda) - dCnm(n+1,m+1) * sin(m*lamda))
    END DO
END DO
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Partial derivatives of (r,phi,lamda) with respect to (x,y,z)
! ----------------------------------------------------------------------
      PDVrx(1,1:3) = (/ cos(phi)*cos(lamda) , cos(phi)*sin(lamda) , sin(phi) /)
      PDVrx(2,1:3) = (/ ( 1.0D0/l)*sin(phi)*cos(lamda) , ( 1.0D0/l)*sin(phi)*sin(lamda) , (-1.0D0/l)*cos(phi) /)
      PDVrx(3,1:3) = (/ ( -1.0D0/(l*cos(phi)) )*sin(lamda) , ( 1.0D0/(l*cos(phi)) )*cos(lamda) , 0.0D0 /)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Computation of Cartesian counterparts of the acceleration
! ----------------------------------------------------------------------
      dV_rpl = RESHAPE ( (/ dV_r, dV_phi, dV_lamda /) , (/ 3 , 1 /) )
       PDVrx_transp = TRANSPOSE(PDVrx)
       fx = PDVrx_transp(1,1) * dV_r + PDVrx_transp(1,2) * dV_phi + PDVrx_transp(1,3) * dV_lamda
       fy = PDVrx_transp(2,1) * dV_r + PDVrx_transp(2,2) * dV_phi + PDVrx_transp(2,3) * dV_lamda
       fz = PDVrx_transp(3,1) * dV_r + PDVrx_transp(3,2) * dV_phi + PDVrx_transp(3,3) * dV_lamda
! ----------------------------------------------------------------------

if (1<0) then
! ----------------------------------------------------------------------
! Arrays DeALLOCATION
! ----------------------------------------------------------------------
      DEALLOCATE (Pnm_norm, STAT = DeAllocateStatus)
!      print *,"Pnm_norm DeAllocateStatus=", DeAllocateStatus
      IF (DeAllocateStatus /= 0) THEN
         PRINT *, "Error: Memory deallocation error"
         PRINT *, "Error: SUBROUTINE force_tides.f90"
         PRINT *, "Error: Allocatable Array: Pnm_norm"
!         STOP "*** Not enough memory ***"
      END IF
! ----------------------------------------------------------------------
      DEALLOCATE (dPnm_norm, STAT = DeAllocateStatus)
!      print *,"dPnm_norm DeAllocateStatus=", DeAllocateStatus
      IF (DeAllocateStatus /= 0) THEN
         PRINT *, "Error: Memory deallocation error"
         PRINT *, "Error: SUBROUTINE force_tides.f"
         PRINT *, "Error: Allocatable Array: dPnm_norm"
!         STOP "*** Not enough memory ***"
      END IF
! ----------------------------------------------------------------------
end if

end Subroutine

END Module


! { dg-do compile }
! { dg-require-effective-target vect_double }
! { dg-options "-O3 --param vect-max-peeling-for-alignment=0 -fpredictive-commoning -fdump-tree-pcom-details" }
! { dg-additional-options "-mprefer-avx128" { target { i?86-*-* x86_64-*-* } } }
! { dg-additional-options "-mzarch" { target { s390*-*-* } } }

******* RESID COMPUTES THE RESIDUAL:  R = V - AU
*
*      THIS SIMPLE IMPLEMENTATION COSTS  27A + 4M PER RESULT, WHERE
*      A AND M DENOTE THE COSTS OF ADDITION (OR SUBTRACTION) AND
*      MULTIPLICATION, RESPECTIVELY.  BY USING SEVERAL TWO-DIMENSIONAL
*      BUFFERS ONE CAN REDUCE THIS COST TO  13A + 4M IN THE GENERAL
*      CASE, OR  10A + 3M WHEN THE COEFFICIENT A(1) IS ZERO.
*
      SUBROUTINE RESID(U,V,R,N,A)
      INTEGER N
      REAL*8 U(N,N,N),V(N,N,N),R(N,N,N),A(0:3)
      INTEGER I3, I2, I1
C
      DO 600 I3=2,N-1
      DO 600 I2=2,N-1
      DO 600 I1=2,N-1
 600  R(I1,I2,I3)=V(I1,I2,I3)
     >      -A(0)*( U(I1,  I2,  I3  ) )
     >      -A(1)*( U(I1-1,I2,  I3  ) + U(I1+1,I2,  I3  )
     >                 +  U(I1,  I2-1,I3  ) + U(I1,  I2+1,I3  )
     >                 +  U(I1,  I2,  I3-1) + U(I1,  I2,  I3+1) )
     >      -A(2)*( U(I1-1,I2-1,I3  ) + U(I1+1,I2-1,I3  )
     >                 +  U(I1-1,I2+1,I3  ) + U(I1+1,I2+1,I3  )
     >                 +  U(I1,  I2-1,I3-1) + U(I1,  I2+1,I3-1)
     >                 +  U(I1,  I2-1,I3+1) + U(I1,  I2+1,I3+1)
     >                 +  U(I1-1,I2,  I3-1) + U(I1-1,I2,  I3+1)
     >                 +  U(I1+1,I2,  I3-1) + U(I1+1,I2,  I3+1) )
     >      -A(3)*( U(I1-1,I2-1,I3-1) + U(I1+1,I2-1,I3-1)
     >                 +  U(I1-1,I2+1,I3-1) + U(I1+1,I2+1,I3-1)
     >                 +  U(I1-1,I2-1,I3+1) + U(I1+1,I2-1,I3+1)
     >                 +  U(I1-1,I2+1,I3+1) + U(I1+1,I2+1,I3+1) )
C
      RETURN
      END
! we want to check that predictive commoning did something on the
! vectorized loop.  If vector factor is 2, the vectorized loop can
! be predictive commoned, we check if predictive commoning PHI node
! is created with vector(2) type.
! { dg-final { scan-tree-dump "Executing predictive commoning without unrolling" "pcom" { xfail vect_variable_length } } }
! { dg-final { scan-tree-dump "vectp_u.*__lsm.* = PHI <.*vectp_u.*__lsm" "pcom" { xfail vect_variable_length } } }


      function harmonic_mean(a,b)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!
! Author : Sai Rapaka
!

      implicit none
      real*8 a,b
      real*8 tol
      real*8 harmonic_mean
      parameter(tol = 1.d-20)

      harmonic_mean = 2.0d0*a*b/(a + b + tol)
      end function harmonic_mean


!!------------------------------------------------------------------------------------------------
!> @anchor      slam_statistics
!!
!> @brief       Functions and subroutines related to statistics
!!
!> @author      Christopher Kebschull
!> @author      Vitali Braun
!!
!> @date

!!
VB:  13.05.2013 (initial design)

!!
VB:  24.04.2015 (added simple_linear_regression)

!!
VB:  03.05.2015 (added median function)

!!
ChK: 10.07.2015 (assimilated into libslam)

!!
ChK: 13.10.2019 (Enforcing camel case and adding copyright)

!!

!!
!! @details     This module contains parameters, subroutines and functions required for computations
!!              related to statistics.
!!
!!              \par Functions/Subroutines
!!
!!

!!
 mean

!!
 variance

!!
 simple_linear_regression

!!
 median

!!

!!
!> @copyright   Institute of Space Systems / TU Braunschweig
!!
!!------------------------------------------------------------------------------------------------
module slam_statistics

use slam_error_handling
use slam_sort, only: bubble_sort
use slam_types

implicit none

interface median  ! compute median
  module procedure median_r, median_i
end interface median

interface mean  ! compute mean
  module procedure mean_r, mean_i
end interface mean

interface variance  ! compute variance
  module procedure variance_r, variance_i
end interface variance

contains

  !============================================================
  !!
  !>  @brief   Simple linear regression: y = a + b*x
  !>  @author  Vitali Braun
  !!
  !>  @param[in]  npoints   Number of points
  !>  @param[in]  xvals     Array of x values
  !>  @param[in]  yvals     Array of y values
  !>  @param[out] a         return value a
  !>  @param[out] b         return value b
  !>  @param[out] r2        coefficient of determination
  !!
  !!  @details  This routine computes a simple linear
  !!            regression, for the model being y = a + b*x.
  !!
  !>  @anchor  simple_linear_regression
  !-----------------------------------------------------------
  subroutine simple_linear_regression(npoints, xvals, yvals, a, b, r2)

    integer,  intent(in)  :: npoints
    real(dp), dimension(npoints), intent(in)  :: xvals
    real(dp), dimension(npoints), intent(in)  :: yvals
    real(dp), intent(out) :: a
    real(dp), intent(out) :: b
    real(dp), intent(out) :: r2

    character(len=*), parameter :: csubid = 'simple_linear_regression'
    character :: cnpoints

    real(dp) :: temp
    real(dp) :: xsum
    real(dp) :: xysum
    real(dp) :: xxsum
    real(dp) :: yysum
    real(dp) :: ysum

    if(isControlled()) then
      if(hasToReturn()) return
      call checkIn(csubid)
    end if

    if(npoints < 2) then
      write(cnpoints,'(i1)') max(npoints,0)
      call setError(E_VALUE, FATAL, (/cnpoints/))
      return
    end if

    xsum  = sum(xvals(:))/npoints
    ysum  = sum(yvals(:))/npoints
    xysum = sum(xvals(:)*yvals(:))/npoints
    xxsum = sum(xvals(:)*xvals(:))/npoints
    yysum = sum(yvals(:)*yvals(:))/npoints

    temp = (xysum-xsum*ysum)

    b = temp/(xxsum-xsum*xsum)
    a = ysum - b*xsum

    r2 = temp/sqrt((xxsum - xsum*xsum)*(yysum - ysum*ysum))
    r2 = r2*r2

    if(isControlled()) then
      call checkOut(csubid)
    end if

  end subroutine simple_linear_regression

  !============================================================
  !
  !>  @anchor     median_i
  !!
  !>  @brief      Compute the median for a set of integers
  !>  @author     Vitali Braun
  !!
  !>  @param[in]  x         Array of x values
  !!
  !-----------------------------------------------------------
  integer function median_i(x) result(mdn)

    integer, dimension(:), intent(in) :: x

    integer, dimension(size(x)) :: localx
    integer :: numx

    localx = x
    numx   = size(x)

    call bubble_sort(localx, numx)

    if(mod(numx, 2) == 0) then ! even number of elements - median as the middle value of the two middle values
      mdn = (localx(numx/2) + localx(numx/2+1))/2
    else
      mdn = localx(numx/2 + 1)
    end if

    return

  end function median_i

  !============================================================
  !
  !>  @anchor     median_r
  !!
  !>  @brief      Compute the median for a set of reals
  !!
  !>  @author     Vitali Braun
  !!
  !>  @param[in]  x         Array of x values
  !!
  !-----------------------------------------------------------
  real(dp) function median_r(x) result(mdn)

    real(dp), dimension(:), intent(in) :: x

    real(dp), dimension(size(x)) :: localx
    integer :: numx

    localx = x
    numx   = size(x)

    call bubble_sort(localx, numx)

    if(mod(numx, 2) == 0) then ! even number of elements - median as the middle value of the two middle values
      mdn = (localx(numx/2) + localx(numx/2+1))/2
    else
      mdn = localx(numx/2 + 1)
    end if

    return

  end function median_r

  !==================================================
  !!
  !> @brief  Calculate the mean on integer values
  !!
  !> @param[in] x an array of integer values
  !!
  !> @returns   integer the calculated mean
  !!
  !> @anchor mean_i
  !-----------------------------
  integer function mean_i(x)

    integer, dimension(:), intent(in) :: x

    if(size(x) == 0) then

      mean_i = 0

    else

      mean_i = sum(x)/size(x)

    end if

    return

  end function mean_i

  !==================================================
  !
  !> @brief  Calculate the mean on real(dp) values
  !!
  !> @param[in] x an array of real(dp) values
  !!
  !> @returns   real(dp) the calculated mean
  !!
  !> @anchor mean_r
  !-----------------------------
  real(dp) function mean_r(x)

    real(dp), dimension(:), intent(in) :: x

    integer :: nchunks, i
    real(dp), dimension(10000) :: sumPart

    if(size(x) == 0) then

      mean_r = 0._dp

    else

      if(size(x) > 50) then  ! divide into chunks for numerical stability
        nchunks = mod(size(x),50) + 1

        do i=1,nchunks
          sumPart(i) = sum(x(((i-1)*size(x)/nchunks)+1:min(size(x),i*size(x)/nchunks)))
        end do

        mean_r = sum(sumPart(1:nchunks))/size(x)

      else
        mean_r = sum(x)/size(x)
      end if

    end if

  end function mean_r

  !==================================================
  !!
  !>  @brief     calculates the variance
  !!
  !>  @param[in] array of integer input values
  !!
  !>  @returns   integer the calculated variance
  !!
  !>  @anchor    variance_i
  !-----------------------------
  integer function variance_i(x)

    integer, dimension(:), intent(in) :: x

    integer :: xmean

    xmean = mean(x)

    if(size(x) == 0) then
      variance_i = -1
    else
      variance_i = sum((x-xmean)**2)/size(x)
    end if

  end function variance_i

  !==================================================
  !
  !>  @brief     calculates the variance
  !>  @anchor    variance_r
  !>  @param[in] array of real(dp) input values
  !>  @returns   real(dp) the calculated variance
  !
  !-----------------------------
  real(dp) function variance_r(x)

    real(dp), dimension(:), intent(in) :: x

    real(dp) :: xmean

    xmean = mean(x)

    if(size(x) == 0._dp) then

      variance_r = -1._dp

    else

      variance_r = sum((x-xmean)**2)/size(x)

    end if

  end function variance_r

  !==================================================
  !
  !>  @brief     Calculates the incremental mean
  !!
  !>  @param[in] xn  array of real(dp) input values
  !>  @param[in] xn1 array of real(dp) input values
  !!
  !>  @returns   real(dp) the calculated incremental mean
  !!
  !>  @anchor    incremental_mean
  !-----------------------------
  real(dp) function incremental_mean(xn, n, xn1) result(mean)

    implicit none

    real(dp), intent(in) :: xn
    real(dp), intent(in) :: xn1
    integer,  intent(in) :: n

    if(n == 0 .or. n == 1) then
      mean = xn1
    else
      mean = ((n-1)*xn + xn1)/n
    end if

  end function incremental_mean

end module slam_statistics


program ode_main
  use nrtype
  use derivatives
  use ode, only : basic_verlet, velocity_verlet
  implicit none
  real(dp) :: dvdt, t, xo(1), xn(1), h, vo, xov(2), xnv(2)

  h  = 0.15_dp
  xo = 0._dp
  t  = 0._dp
  vo = 15._dp
  open(unit=1, file='test1.dat')
  xn(1) = xo(1) + vo*h -0.5_dp*9.81_dp*h*h
  write(1,*) t, xo
  t = t + h
  write(1,*) t, xn
  do while (t < 3.0)
    call basic_verlet(constant_accel,t,xo,xn,h)
    t = t + h
    write(1,*) t, xn
  end do

  xov(1) = 0._dp
  xov(2) = 15._dp
  t      = 0._dp
  open(unit=1, file='test2.dat')
  write(1,*) t, xov(1), xov(2)
  do while (t < 3.0)
    call velocity_verlet(constant_accel,t,xov,xnv,h)
    t = t + h
    write(1,*) t, xnv(1), xnv(2)
    xov = xnv
  end do

end program ode_main


      program one
      implicit none

      integer i, j, imax, jmax
      parameter (imax = 3, jmax = 3)

      real a(0:imax,0:jmax), b(0:imax,0:jmax), c

! some kind of setup
      do 1 i = 0, imax
         do 2 j = 0, jmax
            a(i,j) = i+j
 2       continue
 1    continue

!do i = 1, (imax-1)
!   do j = 1, (jmax-1)
!      a(i, j) = i*j
!   end do
!end do

      write (*,*) 'A = '
      do 3 i = 0, imax
         do 4 j = 0, jmax
            write (*,'(" ",f0.2," ")') a(i,j)
 4       continue
         write (*,*) '\n'
 3    continue

! compute mean
      do 5 i = 1, (imax-1)
         do 6 j = 1, (jmax-1)
            c = (a(i-1,j) + a(i,j) + a(i+1,j))
            b(i,j) = (c + a(i,j-1) + a(i,j+1)) / 5.0
 6       continue
! top and bottom (inner) edges
         b(i, 0) = (a(i, 0) + a(i-1,0) + a(i+1,0) + a(i,1))/4.0
         b(i, jmax) = (a(i, jmax) + a(i-1, jmax) + a(i+1, jmax) +
     .        a(i,jmax-1))/4.0
 5    continue

! left and right (inner) edges
      do 7 j = 1, (jmax-1)
         b(0, j) = (a(0, j) + a(0,j-1) + a(0,j+1) + a(1,j))/4.0
         b(imax, j) = (a(imax, j) + a(imax, j-1) + a(imax, j+1) +
     .        a(imax-1,j))/4.0
 7    continue

! corners
      b(0,0) = (a(0,0) + a(0,1) + a(1,0))/3.0
      b(imax,jmax) = (a(imax,jmax) + a(imax-1,jmax) +
     .     a(imax,jmax-1))/3.0
      b(imax,0) = (a(imax, 0) + a(imax-1,0) + a(imax,1))/3.0
      b(0, jmax) = (a(0, jmax) + a(1, jmax) + a(0, jmax-1))/3.0

! output routine
      write (*,*) 'B = '
      do 8 i = 0, imax
         do 9 j = 0, jmax
            write (*,'(" ",f0.2," ")') b(i,j)
 9       continue
         write (*,*) '\n'
 8       continue

      end


program main
    implicit none
    integer, parameter :: dp = selected_real_kind(8)
    real(dp), parameter :: kB = 1.380649d-23, hbar = 1.05457266d-34, omega = 1.d13
    real(dp) :: T, beta, x, y

    open(unit = 1,file = '1-C-T.txt',status = 'unknown')
    T = 0.0d0
    do while (T <= 300)
        beta = 1 / (kB * T)
        x = kB * T / (hbar * omega)
        y = (beta * hbar * omega)**2 * exp(beta * hbar * omega) / (exp(beta * hbar * omega) - 1)**2
        write(1,"(2f20.8)") x, y
        T = T + .1d0
    end do
    close(1)
end program main


integer function getkey(inp1,inp2,m)

	real :: inp1,inp2,rno1,rno2,rno3
	integer :: key
	character(8)  :: date
	character(10) :: time
	character(5)  :: zone
	call date_and_time(date,time,zone)
	call date_and_time(DATE=date,ZONE=zone)
	call date_and_time(TIME=time)
	read( date, '(f10.0)' )  rno1
	read( time, '(f10.0)' )  rno2
	read( zone, '(f10.0)' )  rno3

!Current date and time are used as seed for the random number generator

	rno3=rno1/rno3+rno2
	rno3=rno3+m
	rno3=rand(int(rno3))

!rno3 now contains a random number between 0 and 1

	if (rno3 .GE. 0 .AND. rno3 .LE. inp1) then
	key = 0 !Cell is empty
	end if

	if (rno3 .GE. inp1 .AND. rno3 .LT. 1) then
	key=1 !Cell is populated
	end if
	getkey = key !key is returned
	key=0
end function getkey

program perc
implicit none

integer, dimension (:,:), allocatable :: darray
!dimension is 2, but size is determined at runtime

integer :: s1,s2,i,j,key,getkey,m=0
real::inp1, inp2
print*, "Enter site occupation probability:"
read*, inp1
inp2=1-inp1
print*, "Enter the dimensions of the array:"
read*, s1
s2=s1
allocate ( darray(s1,s1) )
! dynamically allocate the array

do i = 1, s1
	do j = 1, s2
		m=m+50
		key=getkey(inp1,inp2,m)

		print *, key
		if (key .EQ. 0) then
			darray(i,j)=0 !set array elements
			end if
		if (key .EQ. 1) then
			darray(i,j)=1  !set array elements
		end if
END DO
END DO
! populated the cells of the array according to probability using getkey()

OPEN(UNIT=1,FILE="data1.txt",FORM="FORMATTED",STATUS="OLD")  !open textfile
do i = 1, s1
		write(UNIT=1,FMT="(A)",advance="yes") " "	!put linebreak
	print*," " 	!put linebreak in console
      do j = 1, s2
		if(darray(i,j).EQ.1) then
		write(UNIT=1,FMT="(A)",advance="no") "1" !write to txt
		end if
		if(darray(i,j).EQ.0) then
		write(UNIT=1,FMT="(A)",advance="no") "0" !write to txt
		end if
		write(UNIT=1,FMT="(A)",advance="no") " " !space	write(*,"(I2)",advance="no") darray(i,j) !output matrix to console
	write(*,"(A)",advance="no") " " !space
END DO
END DO
print*," " !linebreak
close(1)
PAUSE
end program perc