      SUBROUTINE DOT(L,X,Y,P)
      DIMENSION X(1),Y(1)                                               DOT40010
C
C     DOT IS THE DOT PRODUCT OF TWO VECTORS
C     REFERENCE: EAR MULTICHANNEL VOLUME, P. 20.
C                                                                       DOT70040
C     INPUTS ARE                                                        DOT70070
C        L=LENGTH OF THE VECTORS X AND Y                                DOT70080
C        X=THE VECTOR X, X(1),X(2),...,X(L)                             DOT70090
C        Y=THE VECTOR Y Y(1),Y(2),...,Y(L)                              DOT70100
C     OUTPUTS ARE                                                       DOT70110
C        P=DOT PRODUCT OF X AND Y
C
C                L                                                      DOT70160
C COMPUTES    P= SUM(X(I)*Y(I))   IF  L  GRTHN 0                        DOT70170
C                I=1                                                    DOT70180
C                                                                       DOT70190
C             P= 0                IF  L  EQLSTHN 0                      DOT70200
C                                                                       DOT70210
      P=0.0                                                             DOT70220
      IF (L)3,3,1                                                       DOT70230
    1 DO 2 I=1,L                                                        DOT70240
    2 P=P+X(I)*Y(I)                                                     DOT70250
    3 RETURN                                                            DOT70260
      END                                                               DOT70270


program energy
  != unit :: speed = m/s

 != unit (m / s** (2)) :: gravity
 != unit (m) :: height
 != unit (kg) :: mass
  real, parameter :: mass = 3.00, gravity = 9.81, height = 4.20
 != unit (kg m** (2) / s** (2)) :: potential_energy
  real :: potential_energy

 != unit (1) :: half
 != unit (speed) :: velocity
  real, parameter :: half = 0.5, velocity = 4.00
 != unit (kg m** (2) / s** (2)) :: kinetic_energy
 != unit (kg m** (2) / s** (2)) :: total_energy
  real :: kinetic_energy, total_energy

  potential_energy = mass * gravity * height
  kinetic_energy = half * mass * square(velocity)

  total_energy = potential_energy + kinetic_energy

  contains

  real function square(x)
    real x
    square = x * x
  end function square
end program energy


      SUBROUTINE svdcmp(A, M, N, MP, NP, W, V)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER :: M, N, MP, NP
      REAL(rprec), DIMENSION(MP,NP), INTENT(inout), TARGET :: A
      REAL(rprec), DIMENSION(MIN(MP,NP)) :: W
      REAL(rprec), DIMENSION(NP,NP)      :: V
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec) :: ZERO = 0, ONE = 1, TWO = 2
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: I, L, K, J, ITS, NM
      INTEGER :: M1, N1
      REAL(rprec), DIMENSION(MP*NP) :: RV1
      REAL(rprec), POINTER          :: A1(:,:)
      REAL(rprec) :: G, SCALE, ANORM, S, F, H, C, Y, Z, X
      LOGICAL :: LTRANS
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      REAL(rprec) , EXTERNAL :: PYTHAG
C-----------------------------------------------
!
!     COMPUTES THE SVD DECOMPOSITION OF THE MATRIX A SUCH
!     THAT A = U * W * VT, WHERE U=A ON OUTPUT. W IS A DIAGONAL
!     MATRIX OF SINGULAR VALUES.
!
!     TAKEN FROM NUMERICAL RECIPES. GENERALIZED BY SPH TO ACCEPT M < N CASE,
!     BY ANALYZING TRANSPOSE AND SWITCHING U,V AT END
!
      IF (M .GT. MP) STOP 'M > MP IN SVDCMP'
      IF (N .GT. NP) STOP 'N > NP IN SVDCMP'
!      IF (M .LT. N)  STOP 'M < N IN SVDCMP'
      LTRANS = (M .LT. N)
      IF (LTRANS) THEN
         M1 = N;  N1 = M
         ALLOCATE (A1(M1,N1))
         A1 = TRANSPOSE(A)
      ELSE
         M1 = M;  N1 = N
         A1 => A
      END IF

!     1. Householder reduction to bidiagonal form

      G = zero
      SCALE = zero
      ANORM = zero
      DO I = 1, N1
         L = I + 1
         RV1(I) = SCALE*G
         G = zero
         S = zero
         SCALE = zero
         IF (I .le. M1) THEN
            SCALE = SUM(ABS(A1(I:M1,I)))
            IF (SCALE .ne. zero) THEN
               A1(I:M1,I) = A1(I:M1,I)/SCALE
               S = SUM(A1(I:M1,I)*A1(I:M1,I))
               F = A1(I,I)
               G = -SIGN(SQRT(S),F)
               H = F*G - S
               A1(I,I) = F - G
               IF (I .ne. N1) THEN
                  DO J = L, N1
                     S = SUM(A1(I:M1,I)*A1(I:M1,J))
                     F = S/H
                     A1(I:M1,J) = A1(I:M1,J) + F*A1(I:M1,I)
                  END DO
               ENDIF
               A1(I:M1,I) = SCALE*A1(I:M1,I)
            ENDIF
         ENDIF
         W(I) = SCALE*G
         G = zero
         S = zero
         SCALE = zero
         IF (I.le.M1 .AND. I.ne.N1) THEN
            SCALE = SUM(ABS(A1(I,L:N1)))
            IF (SCALE .ne. zero) THEN
               A1(I,L:N1) = A1(I,L:N1)/SCALE
               S = SUM(A1(I,L:N1)*A1(I,L:N1))
               F = A1(I,L)
               G = -SIGN(SQRT(S),F)
               H = F*G - S
               A1(I,L) = F - G
               RV1(L:N1) = A1(I,L:N1)/H
               IF (I .ne. M1) THEN
                  DO J = L, M1
                     S = SUM(A1(J,L:N1)*A1(I,L:N1))
                     A1(J,L:N1) = A1(J,L:N1) + S*RV1(L:N1)
                  END DO
               ENDIF
               A1(I,L:N1) = SCALE*A1(I,L:N1)
            ENDIF
         ENDIF
         ANORM = MAX(ANORM,ABS(W(I))+ABS(RV1(I)))
      END DO

!     2. Accumulation of right-hand (V) transformations
      DO I = N1, 1, -1
         IF (I .lt. N1) THEN
            IF (G .ne. zero) THEN
               V(L:N1,I) = (A1(I,L:N1)/A1(I,L))/G
               DO J = L, N1
                  S = SUM(A1(I,L:N1)*V(L:N1,J))
                  V(L:N1,J) = V(L:N1,J) + S*V(L:N1,I)
               END DO
            ENDIF
            V(I,L:N1) = zero
            V(L:N1,I) = zero
         ENDIF
         V(I,I) = one
         G = RV1(I)
         L = I
      END DO

!     3. Accumulation of left-hand (A) transformations
      DO I = N1, 1, -1
         L = I + 1
         G = W(I)
         IF (I .lt. N1) THEN
            A1(I,L:N1) = zero
         ENDIF
         IF (G .ne. zero) THEN
            G = one/G
            IF (I .ne. N1) THEN
               DO J = L, N1
                  S = SUM(A1(L:M1,I)*A1(L:M1,J))
                  F = (S/A1(I,I))*G
                  A1(I:M1,J) = A1(I:M1,J) + F*A1(I:M1,I)
               END DO
            ENDIF
            A1(I:M1,I) = A1(I:M1,I)*G
         ELSE
            A1(I:M1,I) = zero
         ENDIF
         A1(I,I) = A1(I,I) + one
      END DO

!     4. Diagonalization of the bidiagonal form
!     4a.Loop over singular values
      L49: DO K = N1, 1, -1
!        4b. Loop over allowed iterations
         DO ITS = 1, 50
!           4c. Test for splitting
            DO L = K, 1, -1
               NM = L - 1
               IF (ABS(RV1(L)) + ANORM .eq. ANORM) GO TO 2
               IF (ABS(W(NM)) + ANORM .eq. ANORM) EXIT
            END DO
!           4d. Cancellation of RV1(L), if L>1
            C = zero
            S = one
            DO I = L, K
               F = S*RV1(I)
               IF (ABS(F) + ANORM .ne. ANORM) THEN
                  G = W(I)
                  H = PYTHAG(F,G)
c              H=SQRT(F*F+G*G)
                  W(I) = H
                  H = one/H
                  C = G*H
                  S = -F*H

                  CALL ROTATE_SVD (A1(1,NM), A1(1,I), C, S, M1)
!                  DO J = 1, M
!                     Y = A(J,NM)
!                    Z = A(J,I)
!                    A(J,NM) = Y*C + Z*S
!                    A(J,I)  =-Y*S + Z*C
!                  END DO

               ENDIF
            END DO
    2       CONTINUE
            Z = W(K)

!          4e. Convergence, make singular value non-negative
            IF (L .eq. K) THEN
               IF (Z .lt. zero) THEN
                  W(K) = -Z
                  V(:N1,K) = -V(:N1,K)
               ENDIF
               CYCLE  L49
            ENDIF
            IF (ITS .eq. 50) THEN
               WRITE (*, '(2A)') 'PAUSE ',
     1            'No convergence in 50 iterations'
               READ *
            ENDIF
!           4f. Shift from bottom 2 X 2 minor
            X = W(L)
            NM = K - 1
            Y = W(NM)
            G = RV1(NM)
            H = RV1(K)
            F = ((Y - Z)*(Y + Z) + (G - H)*(G + H))/(TWO*H*Y)
            G = PYTHAG(F,one)
c          G=SQRT(F*F + one)
            F = ((X - Z)*(X + Z) + H*(Y/(F + SIGN(G,F)) - H))/X

!           4f. Next QR transformation
            C = one
            S = one
            DO J = L, NM
               I = J + 1
               G = RV1(I)
               Y = W(I)
               H = S*G
               G = C*G
               Z = PYTHAG(F,H)
c            Z=SQRT(F*F+H*H)
               RV1(J) = Z
               C = F/Z
               S = H/Z
               F = X*C + G*S
               G =-X*S + G*C
               H = Y*S
               Y = Y*C

               CALL ROTATE_SVD (V(1,J), V(1,I), C, S, N1)
!               DO JJ = 1, N
!                  X = V(JJ,J)
!                  Z = V(JJ,I)
!                  V(JJ,J) = X*C + Z*S
!                  V(JJ,I) =-X*S + Z*C
!               END DO
               Z = PYTHAG(F,H)
c            Z=SQRT(F*F+H*H)
               W(J) = Z

!              4g. Rotation can be arbitrary if Z=0
               IF (Z .ne. zero) THEN
                  Z = one/Z
                  C = F*Z
                  S = H*Z
               ENDIF
               F = C*G + S*Y
               X =-S*G + C*Y
               CALL ROTATE_SVD(A1(1,J), A1(1,I), C, S, M1)
!               DO JJ = 1, M
!                  Y = A(JJ,J)
!                  Z = A(JJ,I)
!                  A(JJ,J) = Y*C + Z*S
!                  A(JJ,I) =-Y*S + Z*C
!               END DO
            END DO
            RV1(L) = zero
            RV1(K) = F
            W(K) = X
         END DO
      END DO L49

      IF (LTRANS) THEN
         A(1:M,1:M) = V(1:N1,1:N1)  !U is now square: M X M
         V(1:N,1:M) = A1(1:N,1:M)   !V not square anymore, but N X M
         DEALLOCATE (A1)
      END IF

      END SUBROUTINE SVDCMP

      SUBROUTINE ROTATE_SVD (A, B, C, S, M)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(in) :: M
      REAL(rprec), INTENT(inout) :: A, B
      REAL(rprec), INTENT(in)    :: C, S
C-----------------------------------------------
      REAL(rprec) :: YTEMP
C-----------------------------------------------
      YTEMP = A
      A = YTEMP*C + B*S
      B =-YTEMP*S + B*C

      END SUBROUTINE ROTATE_SVD


C NCLFORTSTART
      subroutine thorn2(t,ntim,tmsg,lat,etp,ier)
      implicit none
C                                        INPUT
      integer ntim, ier
      double precision t(ntim), lat, tmsg
C                                        OUTPUT
      double precision etp(ntim)
C NCLEND
C --------------------------------------------------------------------
C Computation of evapotranspiration using the method of Thornthwaite
C --------------------------------------------------------------------
C                       This allows missing values
C --------------------------------------------------------------------
C Original C-code: http://sac.csic.es/spei/spei_index.html
C --------------------------------------------------------------------
C                                        LOCAL
      integer          nt, nmo, nmos, nyrs, knt
      double precision J, J2, J3, c, N, K(12), pi, rad, tmo
      double precision tanlat, tanLatMonth, omega
     +              ,  tanDelta(12), days(12), julian(12)

      data days     /  31,28,31,30,31,30,31,31,30,31,30,31/
      data julian   /  16, 45.5, 75  ,105.5,136  ,166.5
     +              , 197,228  ,258.5,289  ,319.5,350  /
      data pi       /3.14159265358979d0/
      data rad      /0.0174532925d0/

C  average solar declination angle for each month of the year

      data tanDelta / -0.37012566,-0.23853358,-0.04679872, 0.16321764

     +              ,  0.32930908, 0.40677729, 0.3747741 , 0.239063
     +              ,  0.04044485,-0.16905776,-0.33306377,-0.40743608 /

      nmos = 12
      nyrs = ntim/nmos

      do nt=1,ntim
         etp(nt) = tmsg
      end do

      ier  = 0
      if (mod(ntim,nyrs).ne.0) then
          ier = 1
          return
      end if

c calculate climatological monthly temperatures and use these
c .   to calculate a climatological annual temp. efficiency index (J)

      J   = 0.0d0
      do nmo=1,nmos
         knt = 0
         tmo = 0.0d0
c                               ! every 12-th value (eg: all Januaries)
        do nt=nmo,ntim,nmos
           if (t(nt).ne.tmsg) then
               tmo = tmo + t(nt)
               knt = knt + 1
           end if
        end do
c                               ! monthly climatology
         if (knt.gt.0) then
             tmo = tmo/knt
             if (tmo.gt.0.0d0) J = J + (tmo/5d0)**1.514
         end if
      end do
c                               ! if J=0 ... nothing else matters
      if (J.eq.0.0d0) then
          do nt=1,ntim
             if (t(nt).ne.tmsg) then
                 etp(nt) = 0.0d0
             end if
          end do
          return
      end if

C Compute exponent (c)

      J2 = J*J
      J3 = J*J2
      c  = 0.000000675d0*J3 - 0.0000771d0*J2 + 0.01792d0*J + 0.49239d0

C Compute K: monthly correction factor which is a function of latitude

       tanLat = tan(rad*lat)
       do nmo=1,nmos
          tanLatMonth = tanLat*tanDelta(nmo)
          if (tanLatMonth.gt.-1.0d0 .and. tanLatMonth.lt.1.0d0) then
              omega = acos(-tanLatMonth)
          elseif (tanLatMonth.le.-1.0d0) then
               omega = 0
          else
               omega = pi
          end if
          N = 24d0*omega/pi    !  monthly average number of sun hours
          K(nmo) = (N/12d0)*days(nmo)/30d0
       end do

C Calculate evapotranspiration

        do nmo=1,nmos
          do nt=nmo,ntim,nmos
             if (t(nt).ne.tmsg) then
                 if (t(nt).gt.0.0d0) then
                     etp(nt) = K(nmo)*16*((10*t(nt)/J))**c
                 else
                     etp(nt) = 0.0d0
                 end if
             end if
          end do
        end do

      end


Program Hickerson
! 3 February 2014
! not all Fortran compilers provide REAL*16 and INTEGER*8
implicit none
real(kind=kind(1q0)) :: s
integer(kind=kind(1_8)) :: i,n,f,is

do n = 1, 17
      s = 0.5q0 / log(2q0)
      do i = 1,n
         s = (s * i) / log(2q0)
      end do

      is = s
      f = (s-is)*10                 !first digit after decimal point
      if (f == 0 .or. f == 9) then
         write(*,10)n,s,''
      else
         write(*,10)n,s,' NOT'
      endif
end do
10 format('h(',i2,') = ',F23.3,' is',A,' an almost-integer')
end program Hickerson


!file: coord_desc_init.f90
subroutine coord_desc_init(prec, corr, latent, weight, & !outputs
                           observation, dims_pop, & !inputs :: data
                           lambda_ridge, prec_init, weight_init, & !inputs :: parameters
                           num_pop, dim_obs, num_trial) !inputs :: dimensions

    implicit none

    !inputs :: dimensions
    integer, intent(in) :: num_pop, dim_obs, num_trial

    !inputs :: data
    real(8), dimension(dim_obs, num_trial), intent(in) :: observation
    integer, dimension(num_pop), intent(in) :: dims_pop

    !inputs :: parameters
    real(8), dimension(num_pop), intent(in) :: lambda_ridge
    real(8), dimension(num_pop, num_pop), intent(in) :: prec_init
    real(8), dimension(dim_obs), intent(in) :: weight_init

!f2py real(8) optional, dimension(num_pop, num_pop), intent(in) :: prec_init = 0
!f2py real(8) optional, dimension(dim_obs), intent(in) :: weight_init = 1

    !outputs
    real(8), dimension(num_pop, num_pop), intent(out) :: prec, corr
    real(8), dimension(num_pop, num_trial), intent(out) :: latent
    real(8), dimension(dim_obs), intent(out) :: weight

    !local variables
    integer :: i, j, info, ind_from, ind_to
    integer, dimension(num_pop) :: ipiv
    real(8), dimension(num_pop) :: latent_mean, std, work

    external DGETRF
    external DGETRI

    if (sum(dims_pop) /= dim_obs) then
        stop 'Dimensions of population does not match with observation'
    end if

    !initialie correlation
    weight = weight_init
    do i = 1, num_pop
        ind_from = sum(dims_pop(:i-1)) + 1
        ind_to = sum(dims_pop(:i))

        latent(i,:) = sum(spread(weight(ind_from:ind_to), 2, num_trial) * &
                          observation(ind_from:ind_to,:), 1)
        latent_mean(i) = sum(latent(i,:)) / num_trial

        std(i) = sqrt(dot_product(latent(i,:), latent(i,:)) / num_trial - &
                      latent_mean(i) * latent_mean(i) + lambda_ridge(i))
        weight(ind_from:ind_to) = weight(ind_from:ind_to) / std(i)
        latent(i,:) = latent(i,:) / std(i)
        latent_mean(i) = latent_mean(i) / std(i)

        corr(i,i) = 1
        do j = 1, i-1
            corr(i,j) = dot_product(latent(i,:), latent(j,:)) / num_trial - &
                        latent_mean(i) * latent_mean(j)
            corr(j,i) = corr(i,j)
        end do
    end do

    !initialize precision
    if (all(prec_init == 0)) then
        prec = corr

        call DGETRF(num_pop, num_pop, prec, num_pop, ipiv, info)

        if (info /= 0) then
            stop 'Initial correlation is numerically singular!'
        end if

        call DGETRI(num_pop, prec, num_pop, ipiv, work, num_pop, info)

        if (info /= 0) then
            stop 'Initial correlation inversion failed!'
        end if
    else
        prec = prec_init
    end if

end subroutine coord_desc_init


module hybrid
use MyUtility
! This module is for solving system of nonlinear equations using modified Powell's
! Hybrid method. Original code is from in MINPACK.

! subroutine list
! FsolveHybrid    : main subroutine to perform the modified Powell's Hybrid
!                   method. It calls UpdateDelta, dogleg, QRfactorization, QRupdate
!                   and GetJacobian.
! UpdateDelta     : It updates Delta, the size of the trust region
! dogleg          : It finds the next step p within the trust region
! QRfactorization : It performs QR factorization
! QRupdate        : It updates QR factorization after the Broyden's update
! applyGivens     : It apply Givens transformation. It is called by QRupdate.
!
! FsolveHybridTest: Sample subroutine to illustrate the usage of FsolveHybrid
!                   It contains funstest1 and funstest2.
!                   Just call FsolveHybrid from the main program.

! Last Updated : Feb 17, 2009

contains
	subroutine FsolveHybrid(fun, x0, xout, xtol, info, fvalout, JacobianOut, &
		JacobianStep, display, MaxFunCall, factor, NoUpdate,deltaSpeed)
	! Solve system of nonlinear equations using modified Powell's Hybrid method.
	implicit none
		INTERFACE
			SUBroutine  fun (x, fval0)
			use myutility;
			implicit none
			real(kind=db), intent(IN), dimension(:)  :: x
			real(kind=db), intent(OUT), dimension(:) :: fval0
			end subroutine fun
		END INTERFACE

	!. Declearation of variables
	real(kind=db), intent(IN), dimension(:)  :: x0         ! Initial value
	real(kind=db), intent(OUT),dimension(size(x0)) :: xout ! solution
	real(kind=db), intent(IN),  optional     :: xtol       ! Relative tol of X
	integer      , intent(OUT), optional     :: info       ! Information on output

	! output function value and Jacobian
	real(kind=db), intent(OUT), dimension(size(x0)),          optional :: fvalOut
	real(kind=db), intent(OUT), dimension(size(x0),size(x0)), optional :: JacobianOut

	real(kind=db), intent(IN), optional :: JacobianStep ! Relative step for Derivative
	real(kind=db), intent(IN), optional :: factor       ! inital value of delta
	integer      , intent(IN), optional :: display      ! Controls display on iteration
	integer      , intent(IN), optional :: MaxFunCall   ! Max number of Function call
	integer      , intent(IN), optional :: NoUpdate     ! Jacobian Recalculation info
	real(kind=db), intent(IN), optional :: deltaSpeed   ! How fast Delta should decrease

	integer  :: n                  ! number of variables
	integer  :: IterationCount     ! number of iterations
	integer  :: FunctionCount      ! number of function calls
	integer  :: GoodJacobian       ! number of concective sucessfull iterations
	integer  :: BadJacobian        ! number of concective failing iterations
	integer  :: SlowJacobian       ! Degree of slowness after repeated Jacobian Update
	integer  :: SlowFunction       ! number of concective failure of improving
	integer  :: info2              ! information for the termination
	integer  :: i                  ! index for the loop
	integer  :: display2           ! varible to control displaying information
	integer  :: MaxFunCall2        ! Maximum number of Function call
	integer  :: NoUpdate2          ! variable to control Jacobian Update
	integer  :: DirectionFlag      ! Flag for the output of dogleg
	integer  :: UpdateJacobian     ! Mark for the updating Jacobian

	real(kind=db) :: temp
	real(kind=db) :: Delta             ! size of trust region
	real(kind=db) :: pnorm             ! norm of step
	real(kind=db) :: ActualReduction   ! 1 - norm(fvalold)/norm(fvalnew)
	real(kind=db) :: ReductionRatio    ! ActuanReduction / PredictedReduction
	real(kind=db) :: xtol2             ! torelance of x
	real(kind=db) :: JacobianStep2     ! Finite difference step size
	real(kind=db) :: factor2           ! initial value of delta
	real(kind=db) :: DeltaOld          ! Used for display purpose
	real(kind=db) :: deltaSpeed2       ! How fast Delta should decrease

	real(kind=db), dimension(size(x0))  :: xbest         ! best x so far
	real(kind=db), dimension(size(x0))  :: xold          ! x befor update
	real(kind=db), dimension(size(x0))  :: xnew          ! xold + p
	real(kind=db), dimension(size(x0))  :: fvalbest      ! fun(xbest)
	real(kind=db), dimension(size(x0))  :: fvalpredicted ! fun(xold)+ J*p
	real(kind=db), dimension(size(x0))  :: fvalold       ! fun(xold)
	real(kind=db), dimension(size(x0))  :: fvalnew       ! fun(xold+p)
	real(kind=db), dimension(size(x0))  :: p             ! predicted direction
	real(kind=db), dimension(size(x0))  :: Psidiag       ! Normaization coefs
	real(kind=db), dimension(size(x0))  :: Qtfval        ! Q^T * fvalbest

	real(kind=db), dimension(size(x0),size(x0)) :: Q,R    ! results of QR factorization
	real(kind=db), dimension(size(x0),size(x0)) :: J      ! Jacobian
	real(kind=db), dimension(size(x0),size(x0)) :: PsiInv ! Inverse of nomarization mat

	CHARACTER(LEN=79) :: st1, st2 ! used for output
	CHARACTER(LEN=6)  :: st6      ! used for output
	CHARACTER(LEN=12) :: st12     ! used for output

	!. Initialize values
	! counters
	IterationCount = 0
	FunctionCount  = 0
	GoodJacobian   = 0
	BadJacobian    = 0
	SlowFunction   = 0
	SlowJacobian   = 0
	info2          = 0
	n              = size(x0)

	! Set default values for optional inputs
	xtol2         = p0001
	display2      = 0
	MaxFunCall2   = n*100
	NoUpdate2     = 0
	factor2       = 100
	deltaSpeed2   = 0.25_db

	if (present(xtol))         xtol2        = xtol
	if (present(display))      display2     = display
	if (present(MaxFunCall))   MaxFunCall2  = MaxFunCall
	if (present(NoUpdate))     NoUpdate2    = NoUpdate
	if (present(factor))       factor2      = factor
	if (present(deltaSpeed))   deltaSpeed2  = deltaSpeed

	JacobianStep2 = xtol * p1
	if (present(JacobianStep)) JacobianStep2  = JacobianStep

	! Jacobian and function values
	xbest = x0
	call fun(xbest, fvalbest) ! output: fvalbest
	FunctionCount = FunctionCount + 1
	call GetJacobian(J, fun, xbest, JacobianStep2,fvalbest) ! output : J
	FunctionCount = FunctionCount + n
	call QRfactorization(J,Q,R) ! output: Q, R
	Qtfval = matmul(transpose(Q),fvalbest)

	! calculate normalzation matrix Psi
	PsiInv  = 0
	do i = 1, n
		! normalization factor is R(i,i) unless R(i,i) = 0
		temp = 1
		if(R(i,i) /= zero) temp = abs(R(i,i))
		PsiInv(i,i) = 1/temp
		PsiDiag(i) = temp
	end do

	! calculate initial value of Delta
	Delta = factor2 * norm(PsiDiag * xbest)
	if(Delta == 0 ) Delta = 1

	! check initial guess is good or not
	if (norm(fvalbest) == zero) info2 = 1

	! display first line
	if(display2 ==1) then
		write(*,*) 'FsolveHybrid:'
	    st1= "       Norm      Actual  Trust-Region     Step  Jacobian   Direction"
     	st2= " iter  f(x)    Reduction    Size          Size  Recalculate Type"
		write(*,*) st1
		write(*,*) st2
		st1 = "('   0 ',1G11.5)"
		write(*,st1) norm(fvalbest)
	end if

	! ****************************
	!         main loop
	! ****************************
	do
		IterationCount = IterationCount + 1

		! old values are values at the start of the iteration
		fvalold = fvalbest
		xold    = xbest

		!. *** calculate the best direction ***
		call dogleg(p,Q,matmul(R,PsiInv),Delta,Qtfval,DirectionFlag)
		! output: p, DirectionFlag
		p = matmul(PsiInv, p)

		!. update the trust region
		call fun(xold + p, fvalnew)
		FunctionCount = FunctionCount +1
		fvalpredicted = fvalbest + matmul(Q,matmul(R,p))
		DeltaOld = Delta
		call UpdateDelta(Delta,GoodJacobian,BadJacobian,&
			ActualReduction, ReductionRatio,fvalold,fvalnew,&
			fvalpredicted, PsiDiag*p,deltaSpeed2 )
		! output: Delta, GoodJacobian, BadJacobian,
		!         ActualReduction, ReductionRatio

		! get the best value so far
		if(norm(fvalnew) < norm(fvalold) .and. ReductionRatio > p0001) then
			xbest = xold +p
			fvalbest = fvalnew
		end if

		!. *** Check convergence ***
		! Sucessful Convergence
		if(Delta < xtol*norm(PsiDiag*xbest) .or. norm(fvalbest) == 0) info2 = 1

		! Too much function call
		if(FunctionCount > MaxFunCall2) info = 2

		! tol is too small
		if(Delta < 100 * epsilon(Delta) * norm(PsiDiag * xbest)) info2 = 3

		! Not successful based on Jacobian
		if(ActualReduction > p1) SlowJacobian = 0
		if(SlowJacobian == 5) info2 = 4
		! if Jacobian is recalculated every time, we do not performe this test
		if(noupdate2  == 1) SlowJacobian = 0

		! Not sucessful based on Function Value
		SlowFunction = SlowFunction + 1
		if(ActualReduction > p01) SlowFunction = 0
		if( SlowFunction == 10) info2 = 5

		!.***  Update Jacobian ***
		pnorm = norm(p)
		UpdateJacobian = 0
		if(BadJacobian == 2 .or. pnorm == 0 .or. noupdate == 1) then
			! calculate Jacobian using finite difference
			call GetJacobian(J, fun, xbest, JacobianStep2,fvalbest) ! output : J
			FunctionCount = FunctionCount + n
			call QRfactorization(J,Q,R) ! output: Q, R
			Qtfval = matmul(transpose(Q),fvalbest)

			! recalculate normalzation matrix Psi
			do i = 1, n
				! normalization factor is R(i,i) unless R(i,i) = 0
				temp = 1
				if(R(i,i) /= zero) temp = abs(R(i,i))
				PsiInv(i,i) = min(PsiInv(i,i), 1/temp)
				PsiDiag(i) = 1/PsiInv(i,i)
			end do

			! take care of counts
			BadJacobian = 0
			SlowJacobian = SlowJacobian +1
			UpdateJacobian = 1
		else if (ReductionRatio > p0001) then
			! Broyden's Rank 1 update
			call QRupdate(Q,R,fvalnew - fvalpredicted,p/((pnorm)**2))
			Qtfval = matmul(transpose(Q),fvalbest)
		end if

		! display iteration
		if(display2 ==1) then
			st1 = "(1I4,' ',1G11.5,' ',1G11.5,' ', 1G11.5,' ', 1G11.5,' ',  2A)"
			st6 = "      "
			if(UpdateJacobian == 1) st6 = ' Yes  '
			select case (DirectionFlag)
				case (1)
					st12 = 'Newton'
				case (2)
					st12 = 'Cauchy'
				case (3)
					st12 = 'Combination'
			end select
			write(*,st1) IterationCount, norm(fvalbest), 100.0_db * ActualReduction, &
				 DeltaOld, norm(PsiDiag *p),st6, st12
		end if

		! exit check
		if( info2 /= 0) exit
	end do

	!. prepare output
	xout = xbest
	fvalOut = fvalbest
	JacobianOut = J

	! display result
	if(display2 ==1) then
		select case (info2)
			case (0)
				write(*,*) 'Bad input'
			case (1)
				if(norm(fvalbest)>p1) then
					write(*,*) ' Trust Region shrinks enough so no progress is possible.'
					write(*,*) ' Make sure function value is close to zero enough'
				else
					write(*,*) ' Sucessful convergence'
				end if
			case (2)
				write(*,*) ' Too much Function call'
			case (3)
				write(*,*) ' Tol too small'
			case (4)
				write(*,*) ' Too much Jacobian '
			case (5)
				write(*,*) ' Slow Objective function Improvement'
		end select
		if (norm(fvalbest)<xtol .and. info2 /= 1) then
 		   write(*,*) ' Note: Function value is fairly small.'
 		   write(*,*) '       although it is not required torelance.'
 		   write(*,*) '       It might be converged.'
		end if
	end if

	end subroutine FsolveHybrid

	pure subroutine UpdateDelta(Delta,GoodJacobian,BadJacobian, &
	 	ActualReduction, ReductionRatio, oldfval,newfval,predictedfval,p, deltaSpeed2)
	! update Trust region Delta

	implicit none
	real(kind=db), intent(INOUT) 	:: Delta			! Trust region size
	integer, intent(INOUT) 			:: GoodJacobian		! number of sucessful iteration
	integer, intent(INOUT) 			:: BadJacobian		! number of bad iteration
	real(kind=db), intent(IN), dimension(:) :: oldfval	! f(xold)
	real(kind=db), intent(IN), dimension(:) :: newfval	! f(xold+p)
	real(kind=db), intent(IN), dimension(:) :: predictedfval	! f(xold) + J^T*p
	real(kind=db), intent(IN), dimension(:) :: p		! suggested direction
	real(kind=db), intent(IN)  :: deltaSpeed2    		! How fast delta decreases
	real(kind=db), intent(OUT) :: ActualReduction		! reduction for actual fval
	real(kind=db), intent(OUT) :: ReductionRatio		! ActRed/PredictedRed

	real(kind=db) :: pnorm					! norm(p)

	real(kind=db) :: PredictedReduction		! scaled reduction for predicted fval

	! prepare comparison of values
	PredictedReduction = 1 - (norm(predictedfval) / norm(oldfval))**2
	ActualReduction    = 1 - (norm(newfval)       / norm(oldfval))**2
	pnorm = norm(p)

	! calculate the ratio of actual to predicted reduction
	ReductionRatio = 0 ! special case if PredictedReduction = 0
	if (PredictedReduction /= 0) &
		ReductionRatio = ActualReduction/PredictedReduction

	if (ReductionRatio < p1 ) then
		! prediction was not good.  shrink trust region
		Delta = Delta * deltaSpeed2
		BadJacobian = BadJacobian +1
		GoodJacobian = 0
	else
		BadJacobian = 0
		GoodJacobian = 1+GoodJacobian
		if (GoodJacobian>1 .or. ReductionRatio > p5 ) then
			! prediction was fair. expand trust egion
			Delta = max(Delta, two * pnorm)

		else if (abs(1 -ReductionRatio) < p1 ) then
			! prediction was very good. (the ratio is close to one).
			! Expand trust region
			Delta = two * pnorm
		end if
	end if

	end subroutine updateDelta

	pure subroutine dogleg(p,Q,R,delta,Qtf,flag)
	! find linear combination of newton direction and steepest descent
	! direction.

	! flag : it indicates the type of the p (optional)
	! flag = 1  : newton direction
	! flag = 2  : Steepest descent direction
	! flag = 3  : Linear combination of bot

	implicit none
	real(kind=db), intent(out), dimension(:) :: p	! output direction
	real(kind=db), intent(in),  &
		dimension(size(p),size(p)) 	::  Q, R		! QR decomposition of Jacobian
	real(kind=db), intent(in)		:: delta        ! trust region parameter
	real(kind=db), intent(in),  &
				dimension(size(p))  :: Qtf			! Q^T * f(x)
	integer, intent(out), optional 	:: flag 		! flag about the type of p

	integer 							:: i, tempflag
	integer 							:: n		! number of variables = size(p)
	real(kind=db) 						:: gnorm, mu, nunorm, theta, mugnorm, temp
	real(kind=db) 						:: Jgnorm
	real(kind=db), dimension(size(p)) 	:: nu		! Newton direction
	real(kind=db), dimension(size(p)) 	:: g		! Steepest descent direction
	real(kind=db), dimension(size(p)) 	:: mug

	n = size(p)

	! ******************************
	! calculate newton direction
	! ******************************
	! prepare a small value in case diagonal element of R is zero
	temp = epsilon(mu) * maxval(abs(diag(R)))

	nu(n) = -1* Qtf(n) /temp       ! this is special value in case
	if (R(n,n) /= zero) nu(n) =  -1* Qtf(n) / R(n,n)  ! normal case

	! solve backwards
	do i = n-1, 1, -1
		if (R(i,i)==0) then
			! special value
			nu(i) = (-1*Qtf(i) - dot_product(R(i,i+1:n),nu(i+1:n))) / temp
		else
			! normal value
			nu(i) = (-1*Qtf(i) - dot_product(R(i,i+1:n),nu(i+1:n))) / R(i,i)
		end if
	end do
	nunorm = norm(nu)

	if (nunorm < delta) then
		! newton direction
		p = nu
		tempflag = 1
	else
		! newton direction was not accepted.
		g = - one * matmul(transpose(R),Qtf)   ! Steepest descent
		gnorm = norm(g)
		Jgnorm = norm(matmul(Q,matmul(R,g)))

		if (Jgnorm == 0) then
			! special attention if steepest direction is zero
			p = delta * nu/nunorm
			flag = 3

		else if ((gnorm**2) *gnorm / (Jgnorm**2) > delta) then
			! accept steepest descent direction
			p = delta *g /gnorm
			tempflag = 2
		else
			! linear combination of both
			! calculate the weight of each direction
			mu = gnorm**2  / Jgnorm**2
			mug = mu *g
			mugnorm = norm(mug)
			theta = (delta**2 - mugnorm**2) / (dot_product(mug, nu-mug) +  &
				((dot_product(nu,mug)-delta**2)**2 + (nunorm**2-delta**2)  &
					* (delta**two - mugnorm**2))**p5)

			p = (1-theta) * mu * g + theta*nu
			tempflag = 3

		end if
	end if

	if (present(flag)) flag = tempflag
	end subroutine dogleg

	subroutine QRfactorization(A,Q,R)
	! Calculate QR factorizaton using Householder transformation.
	! You can obtain better speed and stability by using LAPACK routine.

	! It finds ortogonal matrix Q and upper triangular R such that
	!
	!               A  = Q * [R; ZeroMatrix]
	!
	! Arguments for this subroutine
	! A: m by n (m>=n) input matrix for the QR factorization to be computed
	! Q: m by m output orthogonal matrix
	! R: m by n output upper triangular matrix.
	!
	! Written by Yoki Okawa
	! Date: Feb 10, 08

	implicit none

	real(kind=db), INTENT(IN), dimension(:,:)    :: A
	real(kind=db), INTENT(INOUT), dimension(:,:) :: Q,R
	real(kind=db), allocatable,  dimension(:,:)  :: X2

	real(kind=db), dimension(size(A,1))     :: u
	real(kind=db), dimension(size(A,1),size(A,1))     :: P

	integer :: m, n, mQ1,mQ2, nR, mR,i,j

	m = size(A,1)		! number of rows in A
	n = size(A,2)		! number of columns in A

	! check size of the outputs
	mQ1 = size(Q,1)     ! number of rows in Q
	mQ2 = size(Q,2)		! number of columns in Q
	mR = size(R,1)      ! number of rows in R
	nR = size(R,2)		! number of columns in R
	if (n /= nR .or. m /= mQ1 .or. m /= mQ2  .or. m/=mR ) then
	    call myerror &
	    ('QRfactorization : output matrix dimensions do not match with inputs')
	end if

	if (m<n) then
		call myerror &
	('QRfactorization : number of rows must be equal or greater than number of columns')
	end if

	! main loop
	R = A
	Q = eye(M)
	do i = 1, n
		! checke if all elements are already zero
		u(i:m) = R(i:M,i)
		u(i) = u(i) - norm(R(i:M,i))
		if(norm(u) == 0 ) then
			continue
		end if

		! no need for nth column if m == n
		if( (m==n).and. (i==n) )then
			exit
		end if

		P = eye(M) ! P is identity at the left top part

		! right bottom (m-i+1) by (m-i+1) part of P contains numbers
		P(i:m,i:m) = eye(M-i+1) - &
			two*outer(u(i:m),u(i:m))/( norm(u(i:m))**two)

		R  = matmul(P , R) ! eliminate column i
		Q = matmul(Q , P)  ! update Q

	end do

	end subroutine QRfactorization

	pure subroutine QRupdate(Q,R,u,v)
	! update QR factorization when QR -> QR +u*v
	! Q: (inout) n by n Orthogonal matrix
	! R: (inout) n by n upper triangular matrix
	! u,v: n dimensional vector

	implicit none
	real(kind=db), intent(INOUT), dimension(:,:) :: Q,R
	real(kind=db), intent(IN), dimension(:)      :: u, v

 	integer :: N                        ! dimension of Q or R
 	real(kind=db), allocatable, dimension(:)   :: w  ! Qt * w
 	real(kind=db), allocatable, dimension(:,:) ::Qt  ! transpose(Q)
 	integer :: i, j
 	real(kind=db) :: s,c, t, wnorm       ! sin, cos, tan

 	N = size(u)
 	allocate(w(N))
 	allocate(Qt(N,N))

 	Qt = transpose(Q)
	w = matmul(Qt,u)
 	wnorm = norm(w)   ! norm of w

 	! make w to unit vector
 	do i = N, 2,-1
 		! calculate cos and sin
 		if (w(i-1) == zero) then
 			c = zero
 			s = one
 		else
 			t = w(i)/w(i-1)
 			c = one /( (t**2+one)**p5)
 			s = t * c
 		end if

 		call applyGivens(R,c,s,i-1,i)
 		call applyGivens(Qt,c,s,i-1,i)
 		w(i-1) = c *w(i-1) + s* w(i)
 		w(i) = c*w(i) - s*w(i-1)
	end do

 	! update R
 	R(1,:) = R(1,:) + w(1) *v

 	! Transform upper Hessenberg matrix R to upper triangular matrix
 	! H in the documentation is currentry R
 	do i = 1, N-1
 		if (R(i,i) == zero) then
 			c = zero
 			s = one
 		else
 			t = R(i+1,i)/R(i,i)
 			c = one /( (t**2+one)**p5)
 			s = t * c
 		end if
 		call applyGivens(R,c,s,i,i+1)
 		call applyGivens(Qt,c,s,i,i+1)
	end do

 	Q = transpose(Qt)

	end subroutine QRupdate

	pure subroutine applyGivens(A,c2,s2,i2,j2)
	! apply givens transformation with cos, sin, index i and j to matrix A.
	! A <- P * A, P: givens transformation.
	! P(i2,j2) = -s2; P(j2, i2) = s2; P(i2,i2) = P(j2,j2) = c2

	implicit none
	real(kind=db), intent(INOUT), dimension(:,:) :: A
	real(kind=db), intent(IN) :: c2, s2
	real(kind=db), allocatable, dimension(:) :: ai, aj
	integer, intent(IN) :: i2, j2
	integer :: N

	! store original input
	N = size(A,2)
	allocate(ai(N))
	allocate(aj(N))

	ai = A(i2,:)
	aj = A(j2,:)

	! only row i and row j changes
	A(i2,:) = A(i2,:) + (c2-1) * ai
	A(i2,:) = A(i2,:) + s2 * aj

	! change in row j
	A(j2,:) = A(j2,:) - s2 * ai
	A(j2,:) = A(j2,:) + (c2-1) * aj

	end subroutine applyGivens

	subroutine GetJacobian(Jacobian, fun, x0, xrealEPS,fval)
	! Calculate Jacobian using forward difference
	! Jacobian(i,j) : derivative of fun(i) with respect to x(j)
	!
	! n : number of dimensions of fun
	! m : number of dimensions of x0
	! fun:      function to evaluate (actually, subroutine)
	! x0 :      position to evaluate
	! xreleps : relative amount of x to change
	! fval :    value of fun(x) ( used to save time)

	implicit none
	INTERFACE
		subroutine fun(x, fval0)
		use myutility;
		implicit none
		real(kind=db), intent(IN), dimension(:)  :: x
		real(kind=db), intent(OUT), dimension(:) :: fval0
		end subroutine fun
	END INTERFACE

	real(kind=db), intent(in), dimension(:)		:: x0, fval
	real(kind=db), intent(out), &
		dimension(size(fval),size(x0) ) 		:: Jacobian
	real(kind=db), intent(in)             		:: xrealEPS

	real(kind=db), dimension(size(fval))		:: fval0, fval1
	real(kind=db) 								:: xdx
	real(kind=db), dimension(size(x0)) 			:: xtemp
	integer :: j , m

	m = size(x0)  ! number of variables

	! main loop (make it forall for speed)
	do  j = 1,m
		! special treatment if x0 = 0
		if(x0(j) == 0) then
			xdx = 0.001_db
		else
			xdx = x0(j) * (one + xrealEPS)
		end if

		xtemp = x0
		xtemp(j) = xdx

		call fun(xtemp, fval1) ! evaluate function at xtemp
		Jacobian(:,j) = (fval1 - fval) / (xdx - x0(j))
	end do

	end subroutine GetJacobian

	subroutine FsolveHybridTest
	! test  subroutine FsolveHybrid

	implicit none
	real(kind=db), dimension(2,2) :: jacob, Q, R
	real(kind=db), dimension(2) :: xout2, fval
	integer ::fsolveinfo

	call FsolveHybrid( &
		fun          = funstest1, &         ! Function to be solved
		x0           =(/-1.2_db,1.0_db/), & ! Initial value
		xout         =xout2, &              ! output
		xtol         =0.00001_db, &         ! error torelance
		info         =fsolveinfo, &         ! info for the solution
		fvalout      =fval,  &              ! f(xout)
		JacobianOut  =jacob, &              ! Jacobian at x = xout
		JacobianStep =0.000001_db,  &       ! Stepsize for the Jacobian
		display      =1,  &                 ! Control for the display
		MaxFunCall   = 1000, &              ! Max number of function call
		factor       =1.0_db, &             ! Initial value of delta
		NoUpdate     = 0)                   ! control for update of Jacobian

	write(*,*) ' '
	write(*,*) 'Solution:'
	call VectorWrite(xout2)
	write(*,*) ' '
	write(*,*) 'Function Value at the solution:'
	call VectorWrite(fval)

	contains
		subroutine funstest1(x, fval0)
		! badly scaled function if we start from (-1.2, 1.0)
		! solution x1 = x2 = 1
		implicit none
		real(kind=db), intent(IN), dimension(:) :: x
		real(kind=db), intent(OUT), dimension(:) :: fval0

		fval0(1) = 10_db*(x(2) - x(1)**2)
		fval0(2) = 1 - x(1)

		end subroutine funstest1

		subroutine funstest2(x, fval0)
		! a little difficult function
		! solution x = [0.50, 1.00. 1.50 ]  (+ 2pi*n)

		implicit none
		real(kind=db), intent(IN), dimension(:) :: x
		real(kind=db), intent(OUT), dimension(:) :: fval0

		fval0(1) = 1.20_db * sin(x(1)) -1.40_db*cos(x(2))+ 0.70_db*sin(x(3)) &
					- 0.517133908732486_db

		fval0(2) = 0.80_db * cos(x(1)) -0.50_db*sin(x(2))+ 1.00_db*cos(x(3)) &
					- 0.352067758776053_db

		fval0(3) = 3.50_db * sin(x(1)) -4.25_db*cos(x(2))+ 2.80_db*cos(x(3))  &
					+ 0.4202312501553165_db

		end subroutine funstest2
	end subroutine FsolveHybridTest

end module hybrid


program jump

    use jump_integration
    use eispack

    implicit none

    real (kind = 8) interval, x_test
    integer (kind = 4) row, col, test

    real (kind = 8), dimension(:, :), allocatable :: realMatrix, imagMatrix

    real (kind = 8), dimension(:), allocatable :: w
    real (kind = 8), dimension(:, :), allocatable :: zi, zr

    integer ( kind = 4 ) ierr
    real (kind = 8), dimension(:), allocatable ::  points

    complex (kind = 8) tempVar

    integer         :: MODEL_N
    real(kind = 8)  :: MODEL_P_CUTOFF
    real(kind = 8)  :: MODEL_ALPHA
    real(kind = 8)  :: MODEL_X_LOW
    real(kind = 8)  :: MODEL_X_HIGH
    integer         :: MODEL_X_STEPS
    integer         :: MODEL_FUN_TYPE
    integer         :: MODEL_FAST_MODE

    integer         :: n_args, iarg
    character(len=16), dimension(7) :: args

    character(8)  :: date
    character(10) :: time

    character(255) :: datetime
    character(255) :: logfile
    character(255) :: datafile
    character(255) :: gpltfile
    character(255) :: plotfile
    character(255) :: mlabfile
    character(255) :: cwd
    character(255) :: n_char
    character(255) :: p_char
    character(255) :: a_char

    write(*,'(a)') "********************"
    write(*,'(a)') "JUMP MODEL TEST"
    write(*,'(a)') "********************"
    write(*,*) ""

    ! Find out how many arguments have been provided. If it's not 8, warning
    n_args = command_argument_count()
    if (n_args /= 8) then
      write(*,'(a,I3)') "WARNING: Expected 8 arguments, but got", n_args
      write(*,*) ""
      write(*,*) "Usage:"
      write(*,*) "  ./backflow <n> <p_cutoff> <alpha> <x_low> <x_high> <x_steps> <fun_type> <fast_mode>"
      write(*,*) ""
      write(*,*) "Example:"
      write(*,*) "  ./backflow 1000 200.0 0.1 -1.0 1.0 100 1 1"
      write(*,*) ""
      write(*,*) "Using default parameters"
      write(*,*) ""

      MODEL_N          =  150
      MODEL_P_CUTOFF   =   50.0D0
      MODEL_ALPHA      =    0.1D0
      MODEL_X_LOW      = -  0.5D0
      MODEL_X_HIGH     =    0.5D0
      MODEL_X_STEPS    =    6
      MODEL_FUN_TYPE   =    1
      MODEL_FAST_MODE  =    1
    else
        ! If we got the right number of arguments, put them into an array of characters
        do iarg=1, n_args
          call get_command_argument(iarg, args(iarg))
        end do

        ! Read from the array of arguments into the appropriate variables
        read(args(1), *) MODEL_N
        read(args(2), *) MODEL_P_CUTOFF
        read(args(3), *) MODEL_ALPHA
        read(args(4), *) MODEL_X_LOW
        read(args(5), *) MODEL_X_HIGH
        read(args(6), *) MODEL_X_STEPS
        read(args(7), *) MODEL_FUN_TYPE
        read(args(8), *) MODEL_FAST_MODE
    end if

    write(n_char, '(i0)') MODEL_N
    write(p_char, '(i0)') int(MODEL_P_CUTOFF)
    write(a_char, '(i0)') int(1000*MODEL_ALPHA)

    call date_and_time(date = date, time = time)
    call getcwd(cwd)

    datetime = date(1:4)//"_"//date(5:6)//"_"//date(7:8)
    datetime = trim(datetime)//"__"//time(1:2)//"_"//time(3:4)//"_"//time(5:6)
    datetime = trim(datetime)//"__N_"//trim(n_char)//"__P_"//trim(p_char)//"__A_"//trim(a_char)

    logfile  = trim(cwd)//"/out/log__"//trim(datetime)//".txt"
    datafile = trim(cwd)//"/out/data__"//trim(datetime)//".csv"
    gpltfile = trim(cwd)//"/out/gplt__"//trim(datetime)//".plt"
    plotfile = trim(cwd)//"/out/plot__"//trim(datetime)//".pdf"
    mlabfile = trim(cwd)//"/out/mlab__"//trim(datetime)//".m"

    open(1, file = logfile, status = 'new')
    open(2, file = datafile, status = 'new')
    open(4, file = mlabfile, status = 'new')

    ! Write some information about the parameters being used this run
    write(*,'(a)') "********************"
    write(*,'(a)') ""
    write(*,'(a)') "Running with parameters:"
    write(*,'(a,I7)')    "  MODEL_N        = ", MODEL_N
    write(*,'(a,F12.4)') "  MODEL_P_CUTOFF = ", MODEL_P_CUTOFF
    write(*,'(a,F12.4)') "  MODEL_ALPHA    = ", MODEL_ALPHA
    write(*,'(a,F12.4)') "  MODEL_X_LOW    = ", MODEL_X_LOW
    write(*,'(a,F12.4)') "  MODEL_X_HIGH   = ", MODEL_X_HIGH
    write(*,'(a,I7)')    "  MODEL_X_STEPS  = ", MODEL_X_STEPS
    write(*,'(a,I7)')    "  FUN_TYPE       = ", MODEL_FUN_TYPE
    write(*,'(a)') ""
    write(*,'(a)') "********************"
    write(*,*) ""

    ! Write some information about the parameters being used this run
    write(1,'(a)') "********************"
    write(1,'(a)') ""
    write(1,'(a)') "Running with parameters:"
    write(1,'(a,I7)')    "  MODEL_N        = ", MODEL_N
    write(1,'(a,F12.4)') "  MODEL_P_CUTOFF = ", MODEL_P_CUTOFF
    write(1,'(a,F12.4)') "  MODEL_ALPHA    = ", MODEL_ALPHA
    write(1,'(a,F12.4)') "  MODEL_X_LOW    = ", MODEL_X_LOW
    write(1,'(a,F12.4)') "  MODEL_X_HIGH   = ", MODEL_X_HIGH
    write(1,'(a,I7)')    "  MODEL_X_STEPS  = ", MODEL_X_STEPS
    write(1,'(a,I7)')    "  FUN_TYPE       = ", MODEL_FUN_TYPE
    write(1,'(a)') ""
    write(1,'(a)') "********************"
    write(1,*) ""

    allocate(points(MODEL_X_STEPS + 1))
    allocate(realMatrix(MODEL_N, MODEL_N))
    allocate(imagMatrix(MODEL_N, MODEL_N))

    allocate(w(MODEL_N))
    allocate(zi(MODEL_N, MODEL_N))
    allocate(zr(MODEL_N, MODEL_N))

    interval = (MODEL_X_HIGH - (MODEL_X_LOW)) / MODEL_X_STEPS

    call JumpModel(MODEL_N, MODEL_P_CUTOFF, MODEL_ALPHA, MODEL_FUN_TYPE)
    call GeneratePlotFile(gpltfile, datafile, plotfile, MODEL_X_LOW, MODEL_X_HIGH)

    write(*,'(a,F12.4)') "backflow1 (bf1): MODEL_ALPHA = ", - MODEL_ALPHA
    write(*,'(a,F12.4)') "backflow2 (bf2): MODEL_ALPHA = ", MODEL_ALPHA
    write(*,*) ""

    write(1,'(a,F12.4)') "backflow1 (bf1): MODEL_ALPHA = ", - MODEL_ALPHA
    write(1,'(a,F12.4)') "backflow2 (bf2): MODEL_ALPHA = ", MODEL_ALPHA
    write(1,*) ""

    write(4,'(a)') "POINTS = ["

!Previously, started  writting here; may comment it all

! do test = 0, MODEL_X_STEPS
!     x_test = MODEL_X_LOW + test*interval
!
!     write(*, fmt = '(A, F6.2, A)', advance = "no") "x = ", x_test, ", bf1 = "
!     write(1, fmt = '(A, F6.2, A)', advance = "no") "x = ", x_test, ", bf1 = "
!     write(2, fmt = '(F6.2, A)', advance = "no") x_test, "; "
!     write(4, fmt = '(F6.2, A)', advance = "no") x_test, ", "
!
!     call SetAlpha(- MODEL_ALPHA)
!
!     call GaussianCurrentKernel(0.1D0, x_test)
!
!     do row = 1, MODEL_N
!         do col = 1, row
!             tempVar = BasisMatrixElement(row - 1, col - 1)
!
!             realMatrix(row, col) = DREAL(tempVar)
!             imagMatrix(row, col) = DIMAG(tempVar)
!         end do
!
! !            print*, "Row = ", row
!     end do
!
!     call ch(MODEL_N, realMatrix, imagMatrix, w, .FALSE., zr,zi,ierr)
!
!     write(*, fmt = '(F12.8, A)', advance = "no") w(1), ", bf2 = "
!     write(1, fmt = '(F12.8, A)', advance = "no") w(1), ", bf2 = "
!     write(2, fmt = '(F12.8, A)', advance = "no") w(1), "; "
!     write(4, fmt = '(F12.8, A)', advance = "no") w(1), ", "
!
!     call SetAlpha(MODEL_ALPHA)
!
!     call GaussianCurrentKernel(0.1D0, x_test)
!
!     do row = 1, MODEL_N
!         do col = 1, row
!             tempVar = BasisMatrixElement(row - 1, col - 1)
!
!             realMatrix(row, col) = DREAL(tempVar)
!             imagMatrix(row, col) = DIMAG(tempVar)
!         end do
!
! !            print*, "Row = ", row
!     end do
!
!     call ch(MODEL_N, realMatrix, imagMatrix, w, .FALSE., zr,zi,ierr)
!
!     write(*, fmt = '(F12.8)') w(1)
!     write(1, fmt = '(F12.8)') w(1)
!     write(2, fmt = '(F12.8)') w(1)
!     write(4, fmt = '(F12.8 a)') w(1), ";"
!
!     call system("gnuplot -p "//trim(gpltfile))
!
! end do

!finished original writing process here
!from here I call the code for working out the fixed conservation of momentum

do test = 0, MODEL_X_STEPS
    x_test = MODEL_X_LOW + test*interval

    write(*, fmt = '(A, F6.2, A)', advance = "no") "x = ", x_test, ", bf1 = "
    write(1, fmt = '(A, F6.2, A)', advance = "no") "x = ", x_test, ", bf1 = "
    write(2, fmt = '(F6.2, A)', advance = "no") x_test, "; "
    write(4, fmt = '(F6.2, A)', advance = "no") x_test, ", "

    call SetAlpha(- MODEL_ALPHA)

    call GaussianCurrentKernel(0.1D0, x_test)

    do row = 1, MODEL_N
        do col = 1, row
            tempVar = BasisMatrixElement(row - 1, col - 1)

            realMatrix(row, col) = DREAL(tempVar)
            imagMatrix(row, col) = DIMAG(tempVar)
        end do

!            print*, "Row = ", row
    end do

    call ch(MODEL_N, realMatrix, imagMatrix, w, .FALSE., zr,zi,ierr)

    write(*, fmt = '(F12.8, A)', advance = "no") w(1), ", bf2 = "
    write(1, fmt = '(F12.8, A)', advance = "no") w(1), ", bf2 = "
    write(2, fmt = '(F12.8, A)', advance = "no") w(1), "; "
    write(4, fmt = '(F12.8, A)', advance = "no") w(1), ", "

    call SetAlpha(MODEL_ALPHA)

    call GaussianCurrentKernel(0.1D0, x_test)

    do row = 1, MODEL_N
        do col = 1, row
            tempVar = BasisMatrixElement(row - 1, col - 1)

            realMatrix(row, col) = DREAL(tempVar)
            imagMatrix(row, col) = DIMAG(tempVar)
        end do

!            print*, "Row = ", row
    end do

    call ch(MODEL_N, realMatrix, imagMatrix, w, .FALSE., zr,zi,ierr)

    write(*, fmt = '(F12.8, A)', advance = "no") w(1), ", bf3 = "
    write(1, fmt = '(F12.8, A)', advance = "no") w(1), ", bf3 = "
    write(2, fmt = '(F12.8, A)', advance = "no") w(1), "; "
    write(4, fmt = '(F12.8, A)', advance = "no") w(1), ", "

    !!!

        call SetAlpha(- MODEL_ALPHA)

        call GaussianCurrentKernel(0.1D0, x_test)

        do row = 1, MODEL_N
            do col = 1, row
                tempVar = BasisMatrixElement2(row - 1, col - 1)

                realMatrix(row, col) = DREAL(tempVar)
                imagMatrix(row, col) = DIMAG(tempVar)
            end do

    !            print*, "Row = ", row
        end do

        call ch(MODEL_N, realMatrix, imagMatrix, w, .FALSE., zr,zi,ierr)

        write(*, fmt = '(F12.8, A)', advance = "no") w(1), ", bf4 = "
        write(1, fmt = '(F12.8, A)', advance = "no") w(1), ", bf4 = "
        write(2, fmt = '(F12.8, A)', advance = "no") w(1), "; "
        write(4, fmt = '(F12.8, A)', advance = "no") w(1), ", "

        call SetAlpha(MODEL_ALPHA)

        call GaussianCurrentKernel(0.1D0, x_test)

        do row = 1, MODEL_N
            do col = 1, row
                tempVar = BasisMatrixElement2(row - 1, col - 1)

                realMatrix(row, col) = DREAL(tempVar)
                imagMatrix(row, col) = DIMAG(tempVar)
            end do

        !            print*, "Row = ", row
        end do

        call ch(MODEL_N, realMatrix, imagMatrix, w, .FALSE., zr,zi,ierr)

        write(*, fmt = '(F12.8)') w(1)
        write(1, fmt = '(F12.8)') w(1)
        write(2, fmt = '(F12.8)') w(1)
        write(4, fmt = '(F12.8 a)') w(1), ";"

    !!!

    call system("gnuplot -p "//trim(gpltfile))

end do
!until here

    write(4, fmt = '(a)') "];"
    write(4, fmt = '(a)') ""
    write(4, fmt = '(a)') "plot(POINTS(:,1), POINTS(:,2:3:4:5));"
!edited the line above for more plotting graphs
    close(1)
    close(2)
    close(4)

end program


program attractors
  use ode
  use dyn_sys
  implicit none
  real(dp) :: t, start, finish, step, min_step, desired_error
  real(dp) :: y(3)
  integer  :: i, nstepwrite

  open(unit = 1, file = "parameters.dat")

  ! Chen
  ! Read integration parameters
  read(1,*) start, finish, step, min_step, desired_error, nstepwrite
  read(1,*) a, c, b
  read(1,*) y
  open(unit = 2, file = "chen.dat")

  ! Write initial conditions.
  write(2,*) y
  t = 0._dp
  i = 0

  ! Integrate
  dchen: do while (t < finish)
    call rkcka(chen, t, y, desired_error, step, min_step)
    i = i + 1
    if(mod(i, nstepwrite) == 0) write(2,*) y
  end do dchen
  close(2)

  ! Lu Chen
  ! Read integration parameters.
  read(1,*) start, finish, step, min_step, desired_error, nstepwrite
  read(1,*) a, c, b, u
  read(1,*) y
  open(2, file = "lu_chen.dat")

  write(2,*) y
  t = 0._dp
  i = 0
  dlu_chen:do while (t < finish)
    call rkcka(lu_chen, t, y, desired_error, step, min_step)
    i = i + 1
    if(mod(i, nstepwrite) == 0) write(2,*) y
  end do dlu_chen
  close(2)

  ! Modified Chaotic Chua
  ! Read integration parameters.
  read(1,*) start, finish, step, min_step, desired_error, nstepwrite
  read(1,*) alpha, beta, a, b, c, d
  read(1,*) y
  open(2, file = "mc_chua.dat")

  write(2,*) y
  t = 0._dp
  i = 0
  dmc_chua:do while (t < finish)
    call rkcka(mc_Chua, t, y, desired_error, step, min_step)
    i = i + 1
    if(mod(i, nstepwrite) == 0) write(2,*) y
  end do dmc_chua
  close(2)

end program attractors


c=======================================================================
c
c     subroutine VHORET
c
c     Arithmetic h-returns for one assets
c
c      r(t+h) = [ price(t+h) - price(t)]/price(t+h) for t = 1,...,n-h
c
c-----------------------------------------------------------------------
      SUBROUTINE vhoret ( n, X, h, R, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n    : number of value(s) (n > h)                  integer
c            X    : asset values (>0) (n)                        double
c            h    : horizon (h > 0)                             integer
c
c     OUTPUT
c            R    : arithmetic returns  (n-h)                    double
c            info : diagnostic argument                         integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, h, info
      DOUBLE PRECISION X(*), R(*)
c
c     local variables
      INTEGER i
      DOUBLE PRECISION value, myzero
      PARAMETER ( myzero = 1.E-30 )
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
c
c     test if the number of values > h)
      IF (n .le. h) THEN
        info = -2
        RETURN
      ENDIF
c
c     arithmetic return(s)
      DO i = 1,n-h
         value = X(i)
         IF (value .lt. myzero) THEN
            info = -103
            RETURN
         ENDIF
         R(i) = ( X(i + h)- value ) / value
      ENDDO
c
      RETURN
      END


      FUNCTION RAN(ISEED)
      PARAMETER(IA=7141,IC=54773,IM=259200)
      ISEED=MOD(ISEED*IA+IC,IM)
      RAN=FLOAT(ISEED)/FLOAT(IM)
      RETURN
      END


module mod_diff

    use iso_fortran_env, only: int32, real32
    implicit none
    private
    public diff_centered

contains

    pure function diff_centered(levels) result(diff)
        real(real32), intent(in) :: levels(:)
        real(real32) :: diff(size(levels))
        integer :: imax

        imax = size(levels)

        diff(1) =  .5 * (levels(2) - levels(imax))
        diff(2:imax-1) = .5 * (levels(3:imax) - levels(1:imax-2))
        diff(imax) = .5 * (levels(1) - levels(imax-1))
    end function diff_centered

end module mod_diff


subroutine inverse(N,A,inv_A)
!
!   Copyright 2017, Viktor Reshiak, All rights reserved.
!
!
!   Purpose
!   =======
!   Find inverse of a matrix
!
!
!   Method
!   ======
!   wrapper to MKL LAPACK
!
!
!   IN
!   ==
!   1) N  - dimension of the matrix
!   2) A  - matrix
!
!
	implicit none

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! dummy arguments

    integer(kind=4), intent(in)                            :: N
       real(kind=8), intent(in),  dimension(N,N)           :: A
       real(kind=8), intent(out), dimension(N,N), optional :: inv_A

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	! parameters of the sumsl/smsno solver

    integer, dimension(N)   :: ipiv
    integer, dimension(2*N) :: work
    integer                 :: info

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    if ( present(inv_A) ) then
        inv_A = A
        call dgetrf( N, N, inv_A, N, ipiv, info )
        call dgetri( N, inv_A, N, ipiv, work, 2*N, info )
    else
        call dgetrf( N, N, A, N, ipiv, info )
        call dgetri( N, A, N, ipiv, work, 2*N, info )
    endif

end subroutine inverse


! binenc_mod.f90 -- A Binomial-coefficient-based state encoding algorithm
!
! Copyright (C) 2008 Jason Blevins <jrblevin@sdf.lonestar.org>
! All rights reserved.
!
! This software may be modified and distributed under the terms
! of the BSD license.  See the LICENSE file for details.
!
! Description:
!
! This is a Fortran 2003 implementation of the Binomial coefficient
! based state vector encoding method described in Section 3 of the
! paper
!
!   Pakes A., G. Gowrisankaran, and P. McGuire (1993).  "Implementing
!   the Pakes-McGuire Algorithm for Computing Markov Perfect
!   Equilibria in Gauss."  Mimeo, Yale University.
!
! This algorithm implements a bijective mapping from the state space
! $\mathcal X$ of all vectors $x$ of length $N$ where each component
! of $x$ may take the values $0, 1, \dots, M$ and where the components
! are sorted in descending order: $x_1 \ge x_2 \ge \dots \ge x_n$.
! The encode function maps $x$ to an integer between 1 and
! $o(\mathcal X)$ while the decode function implements the inverse
! mapping.
!
! Caveats:
!
! It is important that the state vector be sorted before calling
! encode.  This code is intended as an example and as such no error
! checking is performed.

module binenc_mod
implicit none

  private
  public :: binenc_init, binenc_free
  public :: encode, decode
  public :: n_state

  ! Binomial coefficient matrix
  integer, allocatable, dimension(:,:) :: binom

  integer :: n_state
  integer :: N_
  integer :: M_

contains

  ! Allocate memory and initialize the Binomial coefficient matrix
  ! used for encoding and decoding.
  subroutine binenc_init(N, M)
    integer, intent(in) :: N, M
    integer :: i

    ! Store the dimensions
    N_ = N
    M_ = M

    ! Allocate memory for storing Binomial coefficients.
    allocate(binom(N + M + 1, N + M + 2))

    ! Generate the matrix of binomial coefficients to use for encoding
    ! and decoding market structures.
    binom = 0

    ! Upper-diagonal entries are 1.
    do i = 1, N + M + 1
       binom(i,i+1) = 1
    end do

    ! Construct the binomial coefficients.
    do i = 2, N + M + 1
       binom(i,2:i) = binom(i-1,2:i) + binom(i-1,1:i-1)
    end do

    ! Get the number of states (See Claim 1 on page 26 of Pakes,
    ! Gowrisankaran, and McGuire, 1993).
    n_state = binom(N + M + 1, N + 2)
  end subroutine binenc_init

  ! Free allocated memory
  subroutine binenc_free
    deallocate(binom)
  end subroutine binenc_free

  ! Implements a bijective mapping taking vectors in the state space
  ! to the integers between 0 and n_state.  The vector x must be
  ! sorted in decreasing order (e.g., [ 5, 5, 4, 2, 0 ] ).
  function encode(x) result(ix)
    integer, dimension(N_), intent(in) :: x
    integer :: ix
    integer :: n

    ix = 1
    do n = 1, N_
       ix = ix + binom(x(n) + N_ + 1 - n, x(n) + 1)
    end do
  end function encode

  ! Bijectively maps the integers from 0 to n_state to vectors in the
  ! state space.
  function decode(ix) result(x)
    integer, intent(in) :: ix
    integer, dimension(N_) :: x
    integer :: digit, n, code

    code = ix - 1
    do n = 1, N_
       digit = 0
       do while (binom(digit + N_ - n + 2, digit + 2) <= code)
          digit = digit + 1
       end do

       x(n) = digit
       code = code - binom(digit + N_ - n + 1, digit + 1)
    end do
  end function decode

end module binenc_mod


program ex2p4
    use MC_randoms
    implicit none
    integer(kind=ik), parameter :: N=100000, NTAB=32
    integer(kind=ik) :: i, j, k
    real(kind=rk), dimension(N) :: C=0, x
    real(kind=rk), dimension(NTAB) :: RN_TAB
    real(kind=rk) :: sqrmean=0, meanpow=0, numerator=0, RN, iy

    !-----------------------------------------------------------------------------------
    !LCG without the shuffle
    !-----------------------------------------------------------------------------------

    !Initialization of RN's and variables that don't change with k
    call seed_lcg(int(876123, ik))
    x = [(rand_lcg(), i=1, N, 1)]

    !<x_i>^2
    sqrmean = sum(x)/N
    sqrmean = sqrmean*sqrmean

    !<x_i^2>
    do i=1, N
        meanpow=meanpow+x(i)*x(i)
    end do
    meanpow=meanpow/N

    !Function itself
    do k=1, N-1

        !<x_(i+k)*x_i> term and numerator
        do i=1, N-k
            numerator=numerator+x(i+k)*x(i)
        end do
        numerator=numerator/(N-k)-sqrmean

        !Combine the values and reset the numerator
        C(k)=numerator/(meanpow-sqrmean)
        numerator=0
    end do

    !Save the results
    open(1,action="write",file="data_lcg.txt",status="replace")
    do i=1, N-1
        write(1,*) i, c(i)
    end do
    close(1)

    !-----------------------------------------------------------------------------------
    !Park-Miller similarly to LCG
    !-----------------------------------------------------------------------------------

    call seed_pm(int(987123, ik))

    !Variables
    x = [(rand_pm(), i=1, N, 1)]
    sqrmean = sum(x)/N
    sqrmean = sqrmean*sqrmean
    do i=1, N
        meanpow=meanpow+x(i)*x(i)
    end do
    meanpow=meanpow/N

    !Function
    do k=1, N-1
        do i=1, N-k
            numerator=numerator+x(i+k)*x(i)
        end do
        numerator=numerator/(N-k)-sqrmean
        C(k)=numerator/(meanpow-sqrmean)
        numerator=0
    end do

    !Saving
    open(1,action="write",file="data_pm.txt",status="replace")
    do i=1, N-1
        write(1,*) i, c(i)
    end do
    close(1)

    !-----------------------------------------------------------------------------------
    !LCG with the shuffle
    !-----------------------------------------------------------------------------------

    call seed_lcg(int(879961, ik))

    !Shuffle:
    !Generate a table and pick the first number
    RN_TAB=[(rand_lcg(), j=1, NTAB, 1)]
    iy=RN_TAB(1)

    !Use the table to generate an array for the correlation test
    do i=1, N

        !New random number to replace a value from the table
        RN=rand_lcg()

        !Random number from the table with iy
        !iy*(NTAB-1) sets the interval of possible numbers to [0,31] so we add one to it
        iy=RN_TAB(int(iy*(NTAB-1))+1)

        !Change the "taken" value to the new RN and store the taken value for the test
        RN_TAB(int(iy*(NTAB-1)+1))=RN
        x(i)=iy
    end do

    !Correlation test as before:
    sqrmean = sum(x)/N
    sqrmean = sqrmean*sqrmean
    do i=1, N
        meanpow=meanpow+x(i)*x(i)
    end do
    meanpow=meanpow/N

    !Function
    do k=1, N-1
        do i=1, N-k
            numerator=numerator+x(i+k)*x(i)
        end do
        numerator=numerator/(N-k)-sqrmean
        C(k)=numerator/(meanpow-sqrmean)
        numerator=0
    end do

    !Saving
    open(1,action="write", file="data_lcg_shuffle.txt", status="replace")
    do i=1, N-1
        write(1,*) i, c(i)
    end do
    close(1)

end program ex2p4


 module LibMod
  use PrecisionMod
  implicit none
!
  contains
!
!----------------------------------------
  subroutine InverseUsingLapack(A)
   use MathConstantsMod, only : zero, one
   implicit none
   complex(dpc), dimension(:,:) :: A
!
   integer(i4b) :: n, lda, lwork, info, i0, j0
   Complex(dpc) :: det,tmp
   integer(i4b), dimension(:), pointer :: ipiv
   complex(dpc), dimension(:), pointer :: work
   character(len=1) :: uplo = 'U'
!
   n  = size(A, dim=1)
   i0 = lbound(A, dim=1)
   j0 = lbound(A, dim=2)
   if (n .eq. 1) then
     A(i0,j0)= One/A(i0,j0)
!   else if (n .eq. 2) then
!     det = A(i0,j0) * A(i0+1, j0+1) - A(i0+1,j0) * A(i0, j0+1)
!     if (abs(det) < 1.0E-9) then
!       write(*,*) A
!       stop 'InverseUsingLapack: det(A) is zero'
!     end if
!     tmp = A(i0,j0)
!     A(i0,j0) = A(i0+1, j0+1)
!     A(i0+1, j0+1) = tmp
!     A(i0+1,j0) = -One*A(i0+1,j0)
!     A(i0, j0+1)= -One*A(i0, j0+1)
!     A = A/det
   else
     lda = n
     lwork = 2*n
     allocate(ipiv(n), work(lwork))
     call zgetrf( n, n, a, lda, ipiv, info )
      if (info .ne. 0) then
       write(*,*) "******* ERROR *******"
       write(*,*) "from ZGETRF library info = ",info
       stop
      end if

     call zgetri( n, a, lda, ipiv, work, lwork, info )
!!    call zhetrf(uplo, n, a, lda, ipiv, work, lwork, info)
!!     call zhetri(uplo, n, a, lda, ipiv, work, info)
     if (info .ne. 0) then
       write(*,*) "******* ERROR *******"
       write(*,*) "from ZGETRI library info = ",info
       stop
     end if
     deallocate(ipiv, work)
   end if
!

  end subroutine InverseUsingLapack
!
!----------------------------------------
 end module LibMod


module integration

  use pde
  use global_module

  implicit none

  real(kind=8), dimension(Neq,Nx) :: U_new ! Working variable

  contains

  ! ========================================================================

  subroutine forward_Euler_step(U, dt)

    ! This function performs one step of the Forward Euler explicit time integrator

    implicit none

    real(kind=8), dimension(Neq,Nx), intent(inout)  :: U

    real(kind=8), intent(in) :: dt
    integer :: i, j, eqID

    real(kind=8), dimension(Neq) :: F_W, F_E

    ! First, assign BCs. Wall BCs need to be updated in time, taking the value
    ! from neighboring cells.
    call assign_BCs(U) ! See the pde.f03 module

    ! Update solution using the forward Euler integrator - INTERNAL CELLS only
    do i = 5, Nx-4

      call compute_fluxes(U, i, F_W, F_E)

      ! Advect remaining stuff
      U_new(:,i) = U(:,i) - dt/dx*(F_E - F_W)  ! No source term

      ! Check that the solution did not diverge
      do eqID = 1, Neq
        if (isnan(U_new(eqID,i))) then
          print*, 'Solution diverged, try with a smaller time step! Aborting.'
          print*, 'Solution that diverged: ', U_new(:,i)
          print*, 'in cell i = ', i
          stop
        end if
      end do

    end do

    ! Save solution (internal cells ONLY! Do not overwrite ghost cells!)
    U(:,5:Nx-4) = U_new(:,5:Nx-4)

  end subroutine

  ! ========================================================================

  subroutine midpoint_Euler_step(U, dt)

    ! This function performs one step of the Forward Euler explicit time integrator

    implicit none

    real(kind=8), dimension(Neq,Nx), intent(inout)  :: U

    real(kind=8), intent(in) :: dt
    integer :: i, j, eqID

    real(kind=8), dimension(Neq) :: F_W, F_E

    ! First, assign BCs. Wall BCs need to be updated in time, taking the value
    ! from neighboring cells.
    call assign_BCs(U) ! See the pde.f03 module

    U_new = U ! Init (for ghost cells)

    ! Compute first half step - Create U_new (it is actually "U_half")
    do i = 5, Nx-4 ! Only internal cells
      call compute_fluxes(U, i, F_W, F_E)
      U_new(:,i) = U(:,i) - dt/2.0/dx*(F_E - F_W)  ! No source term
    end do

    call assign_BCs(U_new) ! See the pde.f03 module

    ! Now compute the second half step:
    ! use U_new to compute the fluxes (!!!), then update U.
    do i = 5, Nx-4 ! Internal cells only

      call compute_fluxes(U_new, i, F_W, F_E)

      ! Update U
      U(:,i) = U(:,i) - dt/dx*(F_E - F_W)  ! No source term

      ! Check that the solution did not diverge
      do eqID = 1, Neq
        if (isnan(U(eqID,i))) then
          print*, 'Solution diverged, try with a smaller time step! Aborting.'
          print*, 'Solution that diverged: ', U_new(:,i)
          print*, 'in cell i = ', i
          stop
        end if
      end do

    end do

    ! Save solution (internal cells ONLY! Do not overwrite ghost cells!)
    ! Nope, U was already updated.

  end subroutine

  ! ========================================================================

  subroutine RK3_step(U, dt)

    ! This function performs one time integration step using the
    ! 3rd order Runge Kutta explicit method of Gottlieb & Shu (1998)

    implicit none

    real(kind=8), dimension(Neq,Nx), intent(inout)  :: U

    real(kind=8), intent(in) :: dt
    integer :: i, j, eqID

    real(kind=8), dimension(Neq,Nx) :: U1, U2
    real(kind=8), dimension(Neq)    :: F_W, F_E

    ! First, assign BCs. Wall BCs need to be updated in time, taking the value
    ! from neighboring cells.
    call assign_BCs(U) ! See the pde.f03 module

    ! Update solution using the forward Euler integrator - INTERNAL CELLS only

    U1 = U ! Init
    U2 = U ! Init

    do i = 5, Nx-4 ! Internal cells only
      call compute_fluxes(U, i, F_W, F_E)
      U1(:,i) = U(:,i) - dt/dx*(F_E - F_W)  ! No source term
    end do
    call assign_BCs(U1) ! See the pde.f03 module

    do i = 5, Nx-4
      call compute_fluxes(U1, i, F_W, F_E)
      U2(:,i) = 3.0d0/4.0d0*U(:,i) + 1.0d0/4.0d0*U1(:,i) - 1.0d0/4.0d0*dt/dx*(F_E - F_W)  ! No source term
    end do
    call assign_BCs(U2) ! See the pde.f03 module

    do i = 5, Nx-4
      call compute_fluxes(U2, i, F_W, F_E)
      U_new(:,i) = 1.0d0/3.0d0*U(:,i) + 2.0d0/3.0d0*U2(:,i) - 2.0d0/3.0d0*dt/dx*(F_E - F_W)  ! No source term

      ! Check that the solution did not diverge
      do eqID = 1, Neq
        if (isnan(U_new(eqID,i))) then
          print*, 'Solution diverged, try with a smaller time step! Aborting.'
          print*, 'Solution that diverged: ', U_new(:,i)
          print*, 'in cell i = ', i
          stop
        end if
      end do

    end do

    ! Save solution (internal cells ONLY! Do not overwrite ghost cells!)
    U(:,5:Nx-4) = U_new(:,5:Nx-4)

  end subroutine

  ! ========================================================================

  subroutine RK4_step(U, dt)

    ! This function performs one time integration step using the
    ! 3rd order Runge Kutta explicit method of Gottlieb & Shu (1998)

    implicit none

    real(kind=8), dimension(Neq,Nx), intent(inout)  :: U

    real(kind=8), intent(in) :: dt
    integer :: i, j, eqID

    real(kind=8), dimension(Neq,Nx) :: U1, U2, U3
    real(kind=8), dimension(Neq)    :: F0_W, F0_E, F1_W, F1_E, F2_W, F2_E, F3_W, F3_E

    ! First, assign BCs. Wall BCs need to be updated in time, taking the value
    ! from neighboring cells.
    call assign_BCs(U) ! See the pde.f03 module

    ! Update solution using the forward Euler integrator - INTERNAL CELLS only

    U1 = U ! Init
    U2 = U ! Init
    U3 = U ! Init

print*, "WRONG! NEED TO USE TILDE OPERATOR!!!! WRONGGGGG"
print*, "WRONG! NEED TO USE TILDE OPERATOR!!!! WRONGGGGG"
print*, "WRONG! NEED TO USE TILDE OPERATOR!!!! WRONGGGGG"
print*, "WRONG! NEED TO USE TILDE OPERATOR!!!! WRONGGGGG"
print*, "WRONG! NEED TO USE TILDE OPERATOR!!!! WRONGGGGG"
print*, "WRONG! NEED TO USE TILDE OPERATOR!!!! WRONGGGGG"
print*, "WRONG! NEED TO USE TILDE OPERATOR!!!! WRONGGGGG"
print*, "WRONG! NEED TO USE TILDE OPERATOR!!!! WRONGGGGG"
print*, "WRONG! NEED TO USE TILDE OPERATOR!!!! WRONGGGGG"
print*, "WRONG! NEED TO USE TILDE OPERATOR!!!! WRONGGGGG"
print*, "WRONG! NEED TO USE TILDE OPERATOR!!!! WRONGGGGG"

    do i = 5, Nx-4
      call compute_fluxes(U, i, F0_W, F0_E)
      U1(:,i) = U(:,i) - dt/(2.0d0*dx)*(F0_E - F0_W)  ! No source term
    end do
    call assign_BCs(U1) ! See the pde.f03 module

    do i = 5, Nx-4
      call compute_fluxes(U1, i, F1_W, F1_E)
      U2(:,i) = 2.0d0/5.0d0*U(:,i) + 2.0/5.0*dt/dx*(F0_E - F0_W) &
              + 3.0d0/5.0d0*U1(:,i) - 3.0d0/5.0d0*dt/dx*(F1_E - F1_W)  ! No source term
    end do
    call assign_BCs(U2) ! See the pde.f03 module

    do i = 5, Nx-4
      call compute_fluxes(U2, i, F2_W, F2_E)
      U3(:,i) = 831.0d0/20000.0d0*U(:,i) + 1769.0d0/40000.0d0*dt/dx*(F0_E - F0_W) &
              + 4669.0d0/20000.0d0*U1(:,i) + 161.0d0/600.0d0*dt/dx*(F1_E - F1_W)  &
              + 29.0d0/40.0d0*U2(:,i) - 5.0d0/6.0d0*dt/dx*(F2_E - F2_W) ! No source term
    end do
    call assign_BCs(U3) ! See the pde.f03 module

    do i = 5, Nx-4
      call compute_fluxes(U3, i, F3_W, F3_E)
      U_new(:,i) = 1.0d0/3.0d0*U(:,i) + 1.0d0/3.0d0*U1(:,1) - 1.0d0/3.0d0*dt/dx*(F1_E - F1_W) &
                 + 1.0d0/3.0d0*U3(:,i) - 1.0d0/6.0d0*dt/dx*(F3_E - F3_W)  ! No source term

      ! Check that the solution did not diverge
      do eqID = 1, Neq
        if (isnan(U_new(eqID,i))) then
          print*, 'Solution diverged, try with a smaller time step! Aborting.'
          print*, 'Solution that diverged: ', U_new(:,i)
          print*, 'in cell i = ', i
          stop
        end if
      end do

    end do

    ! Save solution (internal cells ONLY! Do not overwrite ghost cells!)
    U(:,5:Nx-4) = U_new(:,5:Nx-4)

  end subroutine

  ! ========================================================================

  subroutine compute_fluxes(U, i, F_W, F_E)

    ! A subroutine to select which fluxes I want to use. Just for simpler
    ! implementation

    implicit none

    real(kind=8), dimension(Neq,Nx), intent(in)  :: U
    real(kind=8), dimension(Neq),    intent(out) :: F_W, F_E
    integer, intent(in) :: i

    if (flux_type_Rusanov .eqv. .true.) then

      call compute_fluxes_Rusanov(U, i, F_W, F_E)

    else if (flux_type_HLL .eqv. .true.) then

      call compute_fluxes_HLL(U, i, F_W, F_E)

    else

      write(*,*) "Attention! No flux type was selected! See global_module file!"
      write(*,*) "ABORTING!"
      stop

    end if

  end subroutine

  ! ========================================================================

  subroutine compute_fluxes_HLL(U, i, F_W, F_E)

    ! Computes HLL numerical fluxes for the cell "i"
    ! 'F_W' and 'F_E' are the complete fluxes at the cell interfaces, to be then
    ! added in the time-discretized PDE.
    ! The variables 'F_L' and 'F_R' are temporary variables used for the
    ! fluxes at the left and right of an interface.

    implicit none

    real(kind=8), dimension(Neq,Nx), intent(in)  :: U
    real(kind=8), dimension(Neq),    intent(out) :: F_W, F_E
    integer, intent(in) :: i

    integer :: eqID
    real(kind=8), dimension(Neq) :: U_im3, U_im2, U_im1, U_i, U_ip1, U_ip2, U_ip3
    real(kind=8), dimension(Neq) :: U_L, U_R, F_L, F_R
    real(kind=8) :: ws_min_L, ws_max_L, ws_min_R, ws_max_R, ws_min, ws_max ! wave speeds

    U_im3 = U(:,i-3)
    U_im2 = U(:,i-2)
    U_im1 = U(:,i-1)
    U_i   = U(:,i)
    U_ip1 = U(:,i+1)
    U_ip2 = U(:,i+2)
    U_ip3 = U(:,i+3)

    ! ---- West interface -----

    call reconstruct_sol_interface(U_im3, U_im2, U_im1, U_i, U_ip1, U_ip1, U_L, U_R) ! UL and UR are sol across the west interface
    call compute_flux_ws_x(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_x(U_R, F_R, ws_max_R, ws_min_R)

    ws_min = MIN(ws_min_L, ws_min_R)
    ws_max = MAX(ws_max_L, ws_max_R)

    ! HLL fluxes
    if (ws_min .ge. 0.0) then
      F_W = F_L
    else if (ws_max .lt. 0.0) then
      F_W = F_R
    else
      F_W = (ws_min*ws_max*(U_R - U_L) + ws_max*F_L - ws_min*F_R)/(ws_max - ws_min);
    end if

    ! Update global maximum wave speed (used for setting the time step)
    ws_max = MAX(ABS(ws_max_R), ABS(ws_min_R), ABS(ws_max_L), ABS(ws_min_L))
    ws_maxabs = MAX(ws_maxabs, ws_max)

    ! ---- East interface -----

    call reconstruct_sol_interface(U_im2, U_im1, U_i, U_ip1, U_ip2, U_ip3, U_L, U_R) ! UL and UR are sol across the east interface
    call compute_flux_ws_x(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_x(U_R, F_R, ws_max_R, ws_min_R)

    ws_min = MIN(ws_min_L, ws_min_R)
    ws_max = MAX(ws_max_L, ws_max_R)

    ! HLL fluxes
    if (ws_min .ge. 0.0) then
      F_E = F_L
    else if (ws_max .lt. 0.0) then
      F_E = F_R
    else
      F_E = (ws_min*ws_max*(U_R - U_L) + ws_max*F_L - ws_min*F_R)/(ws_max - ws_min);
    end if

    ! Update global maximum wave speed (used for setting the time step)
    ws_max = MAX(ABS(ws_max_R), ABS(ws_min_R), ABS(ws_max_L), ABS(ws_min_L))
    ws_maxabs = MAX(ws_maxabs, ws_max)

  end subroutine

  ! ========================================================================

  subroutine compute_fluxes_Rusanov(U, i, F_W, F_E)

    ! Computes HLL numerical fluxes for the cell "i"
    ! 'F_W' and 'F_E' are the complete fluxes at the cell interfaces, to be then
    ! added in the time-discretized PDE.
    ! The variables 'F_L' and 'F_R' are temporary variables used for the
    ! fluxes at the left and right of an interface.

    implicit none

    real(kind=8), dimension(Neq,Nx), intent(in)  :: U
    real(kind=8), dimension(Neq),    intent(out) :: F_W, F_E
    integer, intent(in) :: i

    integer :: eqID
    real(kind=8), dimension(Neq) :: U_im3, U_im2, U_im1, U_i, U_ip1, U_ip2, U_ip3
    real(kind=8), dimension(Neq) :: U_L, U_R, F_L, F_R
    real(kind=8) :: ws_min_L, ws_max_L, ws_min_R, ws_max_R, ws_min, ws_max ! wave speeds

    U_im3 = U(:,i-3)
    U_im2 = U(:,i-2)
    U_im1 = U(:,i-1)
    U_i   = U(:,i)
    U_ip1 = U(:,i+1)
    U_ip2 = U(:,i+2)
    U_ip3 = U(:,i+3)

    ! ---- West interface -----

    call reconstruct_sol_interface(U_im3, U_im2, U_im1, U_i, U_ip1, U_ip2, U_L, U_R) ! UL and UR are sol across the west interface
    call compute_flux_ws_x(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_x(U_R, F_R, ws_max_R, ws_min_R)

    ws_max = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

    ! West interface
    F_W    = 0.5*(F_R + F_L) - ws_max/2.0*(U_R-U_L) ! Rusanov flux

    ws_maxabs = MAX(ws_maxabs, ws_max)

    ! ---- East interface -----

    call reconstruct_sol_interface(U_im2, U_im1, U_i, U_ip1, U_ip2, U_ip3, U_L, U_R) ! UL and UR are sol across the west interface
    call compute_flux_ws_x(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_x(U_R, F_R, ws_max_R, ws_min_R)

    ws_max = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

    ! West interface
    F_E    = 0.5*(F_R + F_L) - ws_max/2.0*(U_R-U_L) ! Rusanov flux

    ws_maxabs = MAX(ws_maxabs, ws_max)

  end subroutine

  ! =========================================================================

  subroutine reconstruct_sol_interface(U_m3, U_m2, U_m1, U_p1, U_p2, U_p3, U_L, U_R)

  ! Takes the four points around an interface (minus_1, minus_2, plus_1, plus_2) and
  ! computes the left and right states using first order or MUSCL TVD-limited reconstruction

    real(kind=8), dimension(Neq), intent(in)  :: U_m3, U_m2, U_m1, U_p1, U_p2, U_p3
    real(kind=8), dimension(Neq), intent(out) :: U_L, U_R

    ! Working variables
    integer      :: eID              ! equation ID
    real(kind=8) :: theta_L, theta_R ! ratio of consecutive gradients
    real(kind=8), dimension(Neq) :: P_m3, P_m2, P_m1, P_p1, P_p2, P_p3, P_L, P_R ! primitive variables

    real(kind=8) :: d0, d1, b0, b1, a0, a1, omega0, omega1, P0, P1 ! WENO 3rd order
    real(kind=8) :: b2, a2, omega2, P2                             ! additional for WENO 5th order

    if (space_order .EQ. 1) then ! ============================================================================
    ! ***** First order solution *****

      U_L = U_m1
      U_R = U_p1

    else if (space_order .EQ. 2) then ! ============================================================================
      ! ***** Second order solution - MUSCL with TVD slope limiter *****

      ! Perform reconstruction in primitive variables
      call compute_primitive_from_conserved(U_m2, P_m2)
      call compute_primitive_from_conserved(U_m1, P_m1)
      call compute_primitive_from_conserved(U_p1, P_p1)
      call compute_primitive_from_conserved(U_p2, P_p2)

      do eID = 1, Neq ! Loop on the quantities

        ! Compute ratio of consecutive gradients
        theta_L = (P_p1(eID) - P_m1(eID))/(P_m1(eID) - P_m2(eID) + 1.0d-15) ! Add a small tolerance
        theta_R = (P_p2(eID) - P_p1(eID))/(P_p1(eID) - P_m1(eID) + 1.0d-15) ! Add a small tolerance

        ! Limited linear reconstruction
        P_L(eID) = P_m1(eID) + phi_limiter(theta_L)*(P_m1(eID) - P_m2(eID))/2.0
        P_R(eID) = P_p1(eID) - phi_limiter(1.0d0/(theta_R+1.0d-10))*(P_p2(eID) - P_p1(eID))/2.0

      end do

      ! Compute conservative variables
      call compute_conserved_from_primitive(P_L, U_L)
      call compute_conserved_from_primitive(P_R, U_R)

    else if (space_order .EQ. 3) then  ! ============================================================================
      ! ***** Third order solution - WENO 3 *****

      ! Perform reconstruction in primitive variables
      call compute_primitive_from_conserved(U_m2, P_m2)
      call compute_primitive_from_conserved(U_m1, P_m1)
      call compute_primitive_from_conserved(U_p1, P_p1)
      call compute_primitive_from_conserved(U_p2, P_p2)

      do eID = 1, Neq ! Loop on the quantities

        ! ---------- APPROXIMATE v_int^L (left state) ------------

        d0 = 2.0d0/3.0d0
        d1 = 1.0d0/3.0d0

        b0 = (P_p1(eID) - P_m1(eID))**2
        b1 = (P_m1(eID) - P_m2(eID))**2

        a0 = d0/(1.0d-6 + b0)**2
        a1 = d1/(1.0d-6 + b1)**2

        omega0 = a0/(a0+a1) ! Rescale
        omega1 = a1/(a0+a1) ! Rescale

        ! Approximate v for r=0 and r=1
        P0 = 0.5d0*P_m1(eID) + 0.5d0*P_p1(eID)
        P1 = -0.5d0*P_m2(eID) + 3.0d0/2.0d0*P_m1(eID)

        P_L(eID) = omega0*P0 + omega1*P1

        ! ---------- APPROXIMATE v_int^R (right state) ------------

        b0 = (P_p1(eID) - P_m1(eID))**2
        b1 = (P_p2(eID) - P_p1(eID))**2

        a0 = d0/(1.0d-6 + b0)**2
        a1 = d1/(1.0d-6 + b1)**2

        omega0 = a0/(a0+a1) ! Rescale
        omega1 = a1/(a0+a1) ! Rescale

        ! Approximate v for r=0 and r=1
        P0 = 0.5d0*P_m1(eID) + 0.5d0*P_p1(eID)
        P1 = -0.5d0*P_p2(eID) + 3.0d0/2.0d0*P_p1(eID)

        P_R(eID) = omega0*P0 + omega1*P1;

      end do

      ! Compute conservative variables
      call compute_conserved_from_primitive(P_L, U_L)
      call compute_conserved_from_primitive(P_R, U_R)

    else if (space_order .EQ. 5) then  ! ============================================================================
      ! ***** Fifth order solution - WENO 5 *****

      ! Perform reconstruction in primitive variables
      call compute_primitive_from_conserved(U_m2, P_m2)
      call compute_primitive_from_conserved(U_m1, P_m1)
      call compute_primitive_from_conserved(U_p1, P_p1)
      call compute_primitive_from_conserved(U_p2, P_p2)

      do eID = 1, Neq ! Loop on the quantities

        call compute_primitive_from_conserved(U_m3, P_m3)
        call compute_primitive_from_conserved(U_p3, P_p3)

        ! ---------- APPROXIMATE v_int^L (left state) ------------

        b0 = 13.0d0/12.0d0*(P_m3(eID)-2.0*P_m2(eID) + P_m1(eID))**2 &
           + 1.0d0/4.0d0*(P_m3(eID)-4.0*P_m2(eID)+3.0*P_m1(eID))**2

        b1 = 13.0d0/12.0d0*(P_m2(eID)-2.0*P_m1(eID) + P_p1(eID))**2 &
           + 1.0d0/4.0d0*(P_m2(eID)-P_p1(eID))**2

        b2 = 13.0d0/12.0d0*(P_m1(eID)-2.0*P_p1(eID) + P_m2(eID))**2 &
           + 1.0d0/4.0d0*(3.0*P_m1(eID)-4.0*P_p1(eID)+P_p2(eID))**2

        a0 = 1.0d0/10.0d0*(1.0d0/(1.0d-6 + b0)**2)
        a1 = 6.0d0/10.0d0*(1.0d0/(1.0d-6 + b1)**2)
        a2 = 3.0d0/10.0d0*(1.0d0/(1.0d-6 + b2)**2)

        omega0 = a0/(a0+a1+a2)
        omega1 = a1/(a0+a1+a2)
        omega2 = a2/(a0+a1+a2)

        P_L(eID) = omega0*(2.0d0/6.0d0*P_m3(eID) - 7.0d0/6.0d0*P_m2(eID) + 11.0d0/6.0d0*P_m1(eID)) &
                 + omega1*(-1.0d0/6.0d0*P_m2(eID) + 5.0d0/6.0d0*P_m1(eID) + 2.0d0/6.0d0*P_p1(eID)) &
                 + omega2*(2.0d0/6.0d0*P_m1(eID) + 5.0d0/6.0d0*P_p1(eID) - 1.0d0/6.0d0*P_p2(eID))

        ! ---------- APPROXIMATE v_int^R (right state) ------------

        b0 = 13.0d0/12.0d0*(P_p1(eID)-2.0*P_p2(eID) + P_p3(eID))**2 &
           + 1.0d0/4.0d0*(3.0*P_p1(eID)-4.0*P_p2(eID)+P_p3(eID))**2

        b1 = 13.0d0/12.0d0*(P_m1(eID)-2.0*P_p1(eID) + P_p2(eID))**2 &
           + 1.0d0/4.0d0*(P_m1(eID)-P_p2(eID))**2

        b2 = 13.0d0/12.0d0*(P_m2(eID)-2.0*P_m1(eID) + P_p1(eID))**2 &
           + 1.0d0/4.0d0*(P_m2(eID)-4.0*P_m1(eID)+3.0*P_p1(eID))**2

        a0 = 1.0d0/10.0d0*(1.0d0/(1.0d-6 + b0)**2)
        a1 = 6.0d0/10.0d0*(1.0d0/(1.0d-6 + b1)**2)
        a2 = 3.0d0/10.0d0*(1.0d0/(1.0d-6 + b2)**2)

        omega0 = a0/(a0+a1+a2)
        omega1 = a1/(a0+a1+a2)
        omega2 = a2/(a0+a1+a2)

        P_R(eID) = omega2*(-1.0d0/6.0d0*P_m2(eID) + 5.0d0/6.0d0*P_m1(eID) + 2.0d0/6.0d0*P_p1(eID)) &
                 + omega1*(2.0d0/6.0d0*P_m1(eID)  + 5.0d0/6.0d0*P_p1(eID) - 1.0d0/6.0d0*P_p2(eID)) &
                 + omega0*(11.0d0/6.0d0*P_p1(eID) - 7.0d0/6.0d0*P_p2(eID) + 2.0d0/6.0d0*P_p3(eID))

      end do

      ! Compute conservative variables
      call compute_conserved_from_primitive(P_L, U_L)
      call compute_conserved_from_primitive(P_R, U_R)

    else

      write(*,*) "Attention! Order of the space integration not implemented! Check global_module file!"
      write(*,*) "Aborting!"
      stop

    end if

  end subroutine

  ! ========================================================================

  real(kind=8) function phi_limiter(theta)

    real(kind=8), intent(in) :: theta ! ratio of consecutive gradients

    phi_limiter = (theta*theta + theta)/(theta*theta + 1.0) ! van Albada symmetric limiter
    ! phi_limiter = (theta + abs(theta))/(1.0 + abs(theta)) ! van Leer limiter

  end function

end module


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine shape6tri(xi,et,xl,xsj,xs,shp,iflag)
!
!     iflag=1: calculate only the value of the shape functions
!     iflag=2: calculate the value of the shape functions,
!              their derivatives w.r.t. the local coordinates
!              and the Jacobian vector (local normal to the
!              surface)
!     iflag=3: calculate the value of the shape functions, the
!              value of their derivatives w.r.t. the global
!              coordinates and the Jacobian vector (local normal
!              to the surface)
!     iflag=4: calculate the value of the shape functions, the
!              value of their 1st and 2nd order derivatives
!              w.r.t. the local coordinates, the Jacobian vector
!              (local normal to the surface)
!
!     shape functions and derivatives for a 6-node quadratic
!     isoparametric triangular element. 0<=xi,et<=1,xi+et<=1
!
      implicit none
!
      integer i,j,k,iflag
!
      real*8 shp(7,6),xs(3,7),xsi(2,3),xl(3,6),sh(3),xsj(3),xi,et
!
      intent(in) xi,et,xl,iflag
!
      intent(out) shp,xs,xsj
!
!     shape functions and their glocal derivatives for an element
!     described with two local parameters and three global ones.
!
!     shape functions
!
      shp(4,1)=2.d0*(0.5d0-xi-et)*(1.d0-xi-et)
      shp(4,2)=xi*(2.d0*xi-1.d0)
      shp(4,3)=et*(2.d0*et-1.d0)
      shp(4,4)=4.d0*xi*(1.d0-xi-et)
      shp(4,5)=4.d0*xi*et
      shp(4,6)=4.d0*et*(1.d0-xi-et)
!
      if(iflag.eq.1) return
!
!     local derivatives of the shape functions: xi-derivative
!
      shp(1,1)=4.d0*(xi+et)-3.d0
      shp(1,2)=4.d0*xi-1.d0
      shp(1,3)=0.d0
      shp(1,4)=4.d0*(1.d0-2.d0*xi-et)
      shp(1,5)=4.d0*et
      shp(1,6)=-4.d0*et
!
!     local derivatives of the shape functions: eta-derivative
!
      shp(2,1)=4.d0*(xi+et)-3.d0
      shp(2,2)=0.d0
      shp(2,3)=4.d0*et-1.d0
      shp(2,4)=-4.d0*xi
      shp(2,5)=4.d0*xi
      shp(2,6)=4.d0*(1.d0-xi-2.d0*et)
!
!     computation of the local derivative of the global coordinates
!     (xs)
!
      do i=1,3
        do j=1,2
          xs(i,j)=0.d0
          do k=1,6
            xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k)
          enddo
        enddo
      enddo
!
!     computation of the jacobian vector
!
      xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2)
      xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1)
      xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2)
!
      if(iflag.eq.3) then
!
!     computation of the global derivative of the local coordinates
!     (xsi) (inversion of xs)
!
c         xsi(1,1)=xs(2,2)/xsj(3)
c         xsi(2,1)=-xs(2,1)/xsj(3)
c         xsi(1,2)=-xs(1,2)/xsj(3)
c         xsi(2,2)=xs(1,1)/xsj(3)
c         xsi(1,3)=-xs(2,2)/xsj(1)
c         xsi(2,3)=xs(2,1)/xsj(1)
         if(dabs(xsj(3)).gt.1.d-10) then
            xsi(1,1)=xs(2,2)/xsj(3)
            xsi(2,2)=xs(1,1)/xsj(3)
            xsi(1,2)=-xs(1,2)/xsj(3)
            xsi(2,1)=-xs(2,1)/xsj(3)
            if(dabs(xsj(2)).gt.1.d-10) then
               xsi(2,3)=xs(1,1)/(-xsj(2))
               xsi(1,3)=-xs(1,2)/(-xsj(2))
            elseif(dabs(xsj(1)).gt.1.d-10) then
               xsi(2,3)=xs(2,1)/xsj(1)
               xsi(1,3)=-xs(2,2)/xsj(1)
            else
               xsi(2,3)=0.d0
               xsi(1,3)=0.d0
            endif
         elseif(dabs(xsj(2)).gt.1.d-10) then
            xsi(1,1)=xs(3,2)/(-xsj(2))
            xsi(2,3)=xs(1,1)/(-xsj(2))
            xsi(1,3)=-xs(1,2)/(-xsj(2))
            xsi(2,1)=-xs(3,1)/(-xsj(2))
            if(dabs(xsj(1)).gt.1.d-10) then
               xsi(1,2)=xs(3,2)/xsj(1)
               xsi(2,2)=-xs(3,1)/xsj(1)
            else
               xsi(1,2)=0.d0
               xsi(2,2)=0.d0
            endif
         else
            xsi(1,2)=xs(3,2)/xsj(1)
            xsi(2,3)=xs(2,1)/xsj(1)
            xsi(1,3)=-xs(2,2)/xsj(1)
            xsi(2,2)=-xs(3,1)/xsj(1)
            xsi(1,1)=0.d0
            xsi(2,1)=0.d0
         endif
!
!     computation of the global derivatives of the shape functions
!
         do k=1,6
            do j=1,3
               sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)
            enddo
            do j=1,3
               shp(j,k)=sh(j)
            enddo
         enddo
!
      elseif(iflag.eq.4) then
!
!     local 2nd order derivatives of the shape functions: xi,xi-derivative
!
         shp(5,1)=4.d0
         shp(5,2)=4.d0
         shp(5,3)=0.d0
         shp(5,4)=-8.d0
         shp(5,5)=0.d0
         shp(5,6)=0.d0
!
!     local 2nd order derivatives of the shape functions: xi,eta-derivative
!
         shp(6,1)=4.d0
         shp(6,2)=0.d0
         shp(6,3)=0.d0
         shp(6,4)=-4.d0
         shp(6,5)=4.d0
         shp(6,6)=-4.d0
!
!     local 2nd order derivatives of the shape functions: eta,eta-derivative
!
         shp(7,1)=4.d0
         shp(7,2)=0.d0
         shp(7,3)=4.d0
         shp(7,4)=0.d0
         shp(7,5)=0.d0
         shp(7,6)=-8.d0
!
!     computation of the local 2nd derivatives of the global coordinates
!     (xs)
!
         do i=1,3
            do j=5,7
               xs(i,j)=0.d0
               do k=1,6
                  xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k)
               enddo
            enddo
         enddo
      endif
!
      return
      end


      BLOCK DATA CMATHB
      IMPLICIT None
C
C 1.    CMABD
C
C 1.1   CMABD PROGRAM SPECIFICATION
C
C 1.1.1 CMABD is the block data which initializes the mathematical
C       constants.  Rather than obtaining the mathematical constants
C       from the database, they must be initialized here because of
C       the problems with differing representations of the constants
C       in ASCII and binary.
C
C 1.1.2 RESTRICTIONS - NONE
C
C 1.1.3 REFERENCES - CHEMICAL RUBBER COMPANY HANDBOOK
C
C 1.2   CMABD PROGRAM INTERFACE
C
C 1.2.1 CALLING SEQUENCE - NONE
C
C 1.2.2 COMMON BLOCK
C
      Real*8         PI, TWOPI, HALFPI, CONVD, CONVDS, CONVHS, SECDAY
      COMMON /CMATH/ PI, TWOPI, HALFPI, CONVD, CONVDS, CONVHS, SECDAY
C
C     VARIABLES "TO":
C
C     1. PI     - THE MATHEMATICAL CONSTANT PI (UNITLESS)
C     2. TWOPI  - PI * 2.0D0 (UNITLESS)
C     3. HALFPI - PI / 2.0D0 (UNITLESS)
C     4. CONVD  - THE CONVERSION FACTOR FROM DEGREES TO RADIANS (RAD/DEG)
C     5. CONVDS - THE CONVERSION FACTOR FROM ARCSECONDS TO RADIANS
C                 (RAD/ARCSECOND)
C     6. CONVHS - THE CONVERSION FACTOR FROM TIME SECONDS TO RADIANS
C                 (RADIANS / TIME SECOND)
C     7. SECDAY - THE NUMBER OF TIME SECONDS PER DAY (SECONDS / DAY)
C
C     VARIABLES "FROM": NONE
C
C 1.2.3 PROGRAM SPECIFICATIONS -
C
      DATA PI     /3.1415926535897932D0/,
     1     TWOPI  /6.2831853071795865D0/,
     2     HALFPI /1.5707963267948966D0/,
     3     CONVD  /1.7453292519943296D-02/,
     4     CONVDS /4.8481368110953599D-06/,
     5     CONVHS /7.2722052166430399D-05/,
     6     SECDAY /8.6400D04/
C
C 1.2.4 CONSTANTS USED - PI, TWOPI, HALFPI, CONVD, CONVDS, CONVHS, SECDAY
C
C 1.2.5 PROGRAMMER - BRUCE SCHUPLER 02/15/78
C                    SAVITA GOEL    06/04/87 (CDS FOR A900)
C                    David Gordon 94.04.14 Converted to Implicit None
C
C 1.3   PROGRAM STRUCTURE - NONE
C
      END


program energy

 != unit (m) :: height
 != unit (kg) :: mass
  real, parameter :: mass = 3.00, gravity = .81, height = 4.20

 != unit (kg m** (2) / s** (2)) :: potential_energy
  real :: potential_energy

  potential_energy = mass * gravity * height
end program energy


module global_module

  implicit none

  ! Time integration

  real(kind=8), parameter :: dt    = 1.0d-4 ! [s] time step for the simulation
  real(kind=8), parameter :: t_end = 0.5d-0  ! [s] total simulated time (from 0 to t_end)

  real(kind=8), parameter :: c = 299792458.0  ! [m/s] speed of light in vacuum

  ! Specify domain and discretization

  real(kind=8), parameter :: x_min = -c/10.0 ! [m]
  real(kind=8), parameter :: x_max = c   ! [m]
  real(kind=8), parameter :: y_min = -0.5*9.109d-31*c     ! [kg*m/s] THIS IS A MOMENTUM
  real(kind=8), parameter :: y_max = 4.0*9.109d-31*c      ! [kg*m/s] THIS IS A MOMENTUM

  ! Total number of cells (including 2 ghost cells for each side)
  ! (using 2 ghost cells makes it easy to reach second order accuracy)

  integer, parameter :: Nx = 256   ! Physical space
  integer, parameter :: Ny = 256*4 ! Momentum space

  ! Periodicity and second order
  logical, parameter :: x_periodic_bool   = .False.
  logical, parameter :: second_order_bool = .True.

  real(kind=8), parameter :: dx = (x_max-x_min)/(Nx-4) ! discretization in physical space
  real(kind=8), parameter :: dy = (y_max-y_min)/(Ny-4) ! discretization in velocity space

!   ! Initial 1D1V maxwellian
!   real(kind=8), parameter :: n0 = 1.0d16     ! [1/m3] number density
!   real(kind=8), parameter :: u0 = 0.0d0      ! [m/s]  average velocity
!   real(kind=8), parameter :: T0 = 116045.0d0  ! [K]    temperature

end module


program rzf

double precision pi, pi_squared_over_6, zeta_2, zeta
integer*8 N
pi = 3.1415926535897
pi_squared_over_6 = pi*pi / 6.0
N = 16000000000_8
zeta_2 = zeta(N,2_8)

print *,"    zeta(2) = ",zeta_2
print *,"pi^2 / 6.0  = ",pi_squared_over_6
print *,"      error = ",pi_squared_over_6 - zeta_2

end

double precision function zeta(N,a)
integer*8 N,a,k,upper,lower
integer unr
double precision xsum, ri
double precision, dimension(4) :: r,ik,dk = (/ 4.0d0,4.0d0,4.0d0,4.0d0/), qsum = 0.0d0

xsum = 0.0
upper = (N) - ((modulo(N,4)))
lower = 4

do k=N-1,upper+1,-1
        ri = 1.0d0/k
        xsum = xsum + ri**a
enddo

do unr=1,4
  ik(unr) = dble( upper - (unr-1) )
enddo

do k=upper,2*lower,-4
        r = 1.0d0 / ik
        ik = ik - dk
        qsum = qsum + r**a
enddo

do k=lower,1,-1
   ri = 1.0d0/k
   xsum = xsum + ri**a
enddo

zeta = xsum + sum(qsum)

end function


	SUBROUTINE OA_WFSR  ( deltan, search, weight, srad, iret )
C************************************************************************
C* OA_WFSR								*
C*									*
C* This subroutine computes the weighting factor and search radius to	*
C* be used in the Barnes analysis.  The weighting factor is computed	*
C* using the formula:							*
C*									*
C*        WEIGHT = [ 5.051457 * ( DELTAN * 2. / PI ) ** 2 ]		*
C*									*
C* The search radius, SRAD, is computed as SEARCH * WEIGHT.  This	*
C* limits the search area to stations whose weights will be larger	*
C* than  [ EXP ( -SEARCH ) ] .  If SEARCH is non-positive, a value	*
C* of 20 will be used.  Both the weighting factor and search radius	*
C* should be multiplied by GAMMA for the second pass analysis.		*
C*									*
C* OA_WFSR  ( DELTAN, SEARCH, WEIGHT, SRAD, IRET )			*
C*									*
C* Input parameters:							*
C*	DELTAN		REAL		Station spacing			*
C*	SEARCH		REAL		User input search condition	*
C*									*
C* Output parameters:							*
C*	WEIGHT		REAL		Weighting factor		*
C*	SRAD		REAL		Search radius			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 7/86						*
C* M. desJardins/GSFC	10/88	Documentation				*
C* K. Brill/GSC          4/90   Changed default SEARCH  to 7.		*
C* K. Brill/NMC          9/90   Changed default SEARCH  back to 20.	*
C* M. Linda/GSC		 9/97	Corrected right border of prologue	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C------------------------------------------------------------------------
	iret = 0
C
C*	Compute the weighting factor using S. Koch's formula (documented
C*	in his tech memo and paper).
C
	weight = 5.051457 * ( deltan * 2. / PI ) **2
C
C*	The search radius is set to 20. * weight if no value is entered.
C
	IF ( search .le. 0. ) THEN
	    srad = 20. * weight
	  ELSE
	    srad = search * weight
	END IF
C*
	RETURN
	END