submodule(euler_interface_m) euler_prob_0007_m
    implicit none

contains

    module character(len=20) function euler0007()
        write (euler0007, "(i20)") ans(10000)
    end function euler0007

    integer function ans(n)
        use euler_primes_m, only: is_prime
        implicit none
        integer, intent(in) :: n
        integer :: i, j

        i = 0; j = 0
        loop_1: do
            if (j == n + 1) exit loop_1
            i = i + 1
            if (mod(i, 2) == 2 .and. i /= 2) then
                cycle loop_1
            else if (is_prime(int(i))) then
                j = j + 1
            end if
        end do loop_1
        ans = i
    end function ans
end submodule euler_prob_0007_m


module simpson_mod
    use :: quad_mod
    implicit none

    private
    type, public, extends(quad_type) :: simpson_type
        private
        integer :: n
    contains
        procedure, public :: init
        procedure, public :: integrate
    end type simpson_type

contains

    subroutine init(self, n)
        implicit none
        class(simpson_type), intent(inout) :: self
        integer, intent(In) :: n
        self%n = n
    end subroutine init

    function integrate(self, f, a, b) result(r)
        use, intrinsic :: iso_fortran_env, only : dp => REAL64
        use :: quad_func_interface
        implicit none
        class(simpson_type), intent(in) :: self
        procedure(quad_func_type) :: f
        real(kind=dp), intent(in) :: a, b
        real(kind=dp) :: r
        real(kind=dp) :: x, delta
        integer :: i
        x = a
        r = f(x)
        delta = (b - a)/self%n
        do i = 1, self%n
            x = x + delta
            r = r + f(x)
        end do
        r = (b - a)*r/(self%n + 1)
    end function integrate

end module simpson_mod


MODULE ExperimentosNumericos

   ! Modulo que implementa os problemas com Solucao (ou benchmarks)

   IMPLICIT  NONE

   CONTAINS
   !-------------------- FUNCOES DO EXPERIMENTO 5 -----------------------
   DOUBLE PRECISION FUNCTION CC_U_W_experimento5(t, j) RESULT(valor)
      USE VariaveisGerais
      INTEGER, INTENT(IN) :: t, j

      valor = -DCOS(Xi)*DSIN( yu(j) )*DEXP(-2.0d0*(ht*(t-1) + Ti))

   END FUNCTION CC_U_W_experimento5

   DOUBLE PRECISION FUNCTION CC_U_E_experimento5(t, j) RESULT(valor)
      USE VariaveisGerais
      INTEGER, INTENT(IN) :: t, j

      valor = -DCOS(Xf)*DSIN( yu(j) )*DEXP(-2.0d0*(ht*(t-1) + Ti))

   END FUNCTION CC_U_E_experimento5

   DOUBLE PRECISION FUNCTION CC_U_S_experimento5(t, i) RESULT(valor)
      USE VariaveisGerais
      INTEGER, INTENT(IN) :: t, i

      valor = -DCOS( xu(i) )*DSIN( Yi )*DEXP(-2.0d0*(ht*(t-1)+Ti))

   END FUNCTION CC_U_S_experimento5

   DOUBLE PRECISION FUNCTION CC_U_N_experimento5(t, i) RESULT(valor)
      USE VariaveisGerais
      INTEGER, INTENT(IN) :: t, i

      valor = -DCOS( xu(i) )*DSIN( Yf )*DEXP(-2.0d0*(ht*(t-1)+Ti))

   END FUNCTION CC_U_N_experimento5

   DOUBLE PRECISION FUNCTION CC_V_W_experimento5(t, j) RESULT(valor)
      USE VariaveisGerais
      INTEGER, INTENT(IN) :: t, j

      valor = DSIN(Xi)*DCOS( yv(j) )*DEXP(-2.0d0*(ht*(t-1)+Ti))

   END FUNCTION CC_V_W_experimento5

   DOUBLE PRECISION FUNCTION CC_V_E_experimento5(t, j) RESULT(valor)
      USE VariaveisGerais
      INTEGER, INTENT(IN) :: t, j

      valor = DSIN(Xf)*DCOS( yv(j) )*DEXP(-2.0d0*(ht*(t-1)+Ti))

   END FUNCTION CC_V_E_experimento5

   DOUBLE PRECISION FUNCTION CC_V_S_experimento5(t, i) RESULT(valor)
      USE VariaveisGerais
      INTEGER, INTENT(IN) :: t, i

      valor = DSIN( xv(i) )*DCOS(Yi)*DEXP(-2.0d0*(ht*(t-1)+Ti))

   END FUNCTION CC_V_S_experimento5

   DOUBLE PRECISION FUNCTION CC_V_N_experimento5(t, i) RESULT(valor)
      USE VariaveisGerais
      INTEGER, INTENT(IN) :: t, i

      valor = DSIN( xv(i) )*DCOS(Yf)*DEXP(-2.0d0*(ht*(t-1)+Ti))

   END FUNCTION CC_V_N_experimento5

   DOUBLE PRECISION FUNCTION PressaoAnaliticaExperimento5(t, volume) RESULT(valor)
      USE VariaveisGerais
      INTEGER, INTENT(IN) :: t, volume
      INTEGER :: i, j

      j = FLOOR ( DBLE(volume-1)/Nx ) + 1
      i = volume - (j - 1)*Nx
      valor = -(1.0d0/(4.0d0*Re))*( DCOS(2.0d0*xv(i)) + DCOS(2.0d0*yu(j)) )*DEXP(-4.0d0 * (ht*(t-1.5d0) + Ti) )

   END FUNCTION PressaoAnaliticaExperimento5

   DOUBLE PRECISION FUNCTION PressaoInicialExperimento5(t, volume) RESULT(valor)
      USE VariaveisGerais
      INTEGER, INTENT(IN) :: t, volume
      INTEGER :: i, j

      j = FLOOR ( DBLE(volume-1)/Nx ) + 1
      i = volume - (j - 1)*Nx
      valor = -(1.0d0/(4.0d0*Re))*( DCOS(2.0d0*xv(i)) + DCOS(2.0d0*yu(j)) )

   END FUNCTION PressaoInicialExperimento5

   DOUBLE PRECISION FUNCTION VelocidadeU_InicialExperimento5(t, volume) RESULT(valor)
      USE VariaveisGerais
      INTEGER, INTENT(IN) :: t, volume
      INTEGER :: i, j

      j = FLOOR ( DBLE(volume-1)/(Nx-1) ) + 1
      i = volume - (j - 1)*(Nx-1)
      valor = -DCOS(xu(i))*DSIN(yu(j))

   END FUNCTION VelocidadeU_InicialExperimento5

   DOUBLE PRECISION FUNCTION VelocidadeV_InicialExperimento5(t, volume) RESULT(valor)
      USE VariaveisGerais
      INTEGER, INTENT(IN) :: t, volume
      INTEGER :: i, j

      j = FLOOR ( DBLE(volume-1)/Nx ) + 1
      i = volume - (j - 1)*Nx
      valor = DSIN(xv(i))*DCOS(yv(j))

   END FUNCTION VelocidadeV_InicialExperimento5

   DOUBLE PRECISION FUNCTION VelocidadeU_AnaliticaExperimento5(t, volume) RESULT(valor)
      USE VariaveisGerais
      INTEGER, INTENT(IN) :: t, volume
      INTEGER :: i, j

      j = FLOOR ( DBLE(volume-1)/(Nx-1) ) + 1
      i = volume - (j - 1)*(Nx-1)
      valor = -DCOS(xu(i))*DSIN(yu(j))*DEXP(-2.0d0*(ht*(t-1)+Ti))

   END FUNCTION VelocidadeU_AnaliticaExperimento5

   DOUBLE PRECISION FUNCTION VelocidadeV_AnaliticaExperimento5(t, volume) RESULT(valor)
      USE VariaveisGerais
      INTEGER, INTENT(IN) :: t, volume
      INTEGER :: i, j

      j = FLOOR ( DBLE(volume-1)/(Nx) ) + 1
      i = volume - (j - 1)*(Nx)
      valor = DSIN(xv(i))*DCOS(yv(j))*DEXP(-2.0d0*(ht*(t-1)+Ti))

   END FUNCTION VelocidadeV_AnaliticaExperimento5

   !-------------------- FUNCOES DO EXPERIMENTO 5 -----------------------

END MODULE ExperimentosNumericos


!    This module contains all constants and declarations
!    of variables read in by the function read_data. These
!    variables are used by many functions.

MODULE constants
  INTEGER,  PARAMETER :: dp = KIND(1.0D0)
  INTEGER, PARAMETER :: dpc = KIND((1.0D0,1.0D0))
END MODULE constants

!    F90 program library, adapted from Numerical Recipes
!    All functions have been translated to F90 from F77

MODULE F90library
  USE constants
CONTAINS

  !
  !            Routines to do mtx inversion, from Numerical
  !            Recipes, Teukolsky et al. Routines included
  !            below are MATINV, LUDCMP and LUBKSB. See chap 2
  !            of Numerical Recipes for further details
  !
  SUBROUTINE matinv(a,n,d)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n
    INTEGER :: i, j
    REAL(DP), DIMENSION(n,n), INTENT(INOUT)  :: a
    REAL(DP), ALLOCATABLE :: y(:,:)
    REAL(DP) :: d
    INTEGER, ALLOCATABLE :: indx(:)

    ALLOCATE (y( n, n))  ; ALLOCATE ( indx (n))
    y=0.
    !     setup identity matrix
    DO i=1,n
       y(i,i)=1.
    ENDDO
    !     LU decompose the matrix just once
    CALL  lu_decompose(a,n,indx,d)

    !     Find inverse by columns
    DO j=1,n
       CALL lu_linear_equation(a,n,indx,y(:,j))
    ENDDO
    !     The original matrix a was destroyed, now we equate it with the inverse y
    a=y

    DEALLOCATE ( y ); DEALLOCATE ( indx )

  END SUBROUTINE matinv

  !     Given an NxN matrix A(N,N), this routine replaces it by the LU
  !     decomposed one, where the matrix elements are stored in the same
  !     matrix A. The array indx is  an output vector which records the row
  !     permutation effected by the partial pivoting. d is the determinant
  !
  SUBROUTINE lu_decompose(a,n,indx,d)
    IMPLICIT NONE
    INTEGER :: n, i, j, k, imax
    REAL(DP) :: sum , tiny, aamax, dum, d
    REAL(DP), DIMENSION(n,n) :: a
    INTEGER, DIMENSION(n) :: indx
    REAL(DP), ALLOCATABLE :: vv(:)

    tiny=1.0e-20
    ALLOCATE ( vv(n) )
    D=1.
    DO i=1,n
       aamax=0.
       DO j=1,n
          IF (ABS(a(i,j)) > aamax) aamax=ABS(a(i,j))
       ENDDO
       !     Zero is the largest element
       IF (aamax == 0.) STOP 'Singular matrix.'
       !     No nonzero largest element
       vv(i)=1./aamax
    ENDDO
    !     loop over columns
    DO j=1,n
       !     solves equation 2.3.12 except for i=j of Numerical Recipes
       IF (j > 1) THEN
          DO i=1,j-1
             sum=a(i,j)
             IF (i > 1)THEN
                DO k=1,i-1
                   sum=sum-a(i,k)*a(k,j)
                ENDDO
                a(i,j)=sum
             ENDIF
          ENDDO
       ENDIF
       !    start searching for largest pivot element
       aamax=0.
       DO i=j,n
          sum=a(i,j)
          IF (j > 1)THEN
             DO k=1,j-1
                sum=sum-a(i,k)*a(k,j)
             ENDDO
             a(i,j)=sum
          ENDIF
          dum=vv(i)*ABS(sum)
          IF (dum >= aamax) THEN
             imax=i
             aamax=dum
          ENDIF
       ENDDO
       !    interchange of rows
       IF (j /= imax)THEN
          DO k=1,n
             dum=a(imax,k)
             a(imax,k)=a(j,k)
             a(j,k)=dum
          ENDDO
          !    change of parity for determinant
          d=-d
          vv(imax)=vv(j)
       ENDIF
       indx(j)=imax
       IF(j /= n) THEN
          IF(a(j,j) == 0.) a(j,j)=tiny
          dum=1./a(j,j)
          DO i=j+1,n
             a(i,j)=a(i,j)*dum
          ENDDO
       ENDIF
       !    set up determinant
       d=d*a(j,j)
    ENDDO
    IF(a(n,n) == 0.)  a(n,n)=tiny
    DEALLOCATE ( vv)

  END SUBROUTINE lu_decompose

  !     Solves set of linear equations Ax=b, A is input as an LU decompomsed
  !     matrix and indx keeps track of the permutations of the rows. b is input
  !     as the right-hand side vector b and returns the solution x. A, n and indx
  !     are not modified by this routine. This function takes into that b can contain
  !     many zeros and is therefore suitable for matrix inversion

  SUBROUTINE lu_linear_equation(a,n,indx,b)
    IMPLICIT NONE
    INTEGER :: n, ii, ll, i, j
    REAL(DP) :: sum
    REAL(DP), DIMENSION(n,n) :: a
    REAL(DP), DIMENSION(n) :: b
    INTEGER, DIMENSION(n) :: indx

    ii=0
    !     First we solve equation 2.3.6 of numerical recipes
    DO i=1,n
       ll=indx(i)
       sum=b(ll)
       b(ll)=b(i)
       IF (ii /= 0)THEN
          DO j=ii,i-1
             sum=sum-a(i,j)*b(j)
          ENDDO
       ELSEIF (sum /= 0.) THEN
          ii=i
       ENDIF
       b(i)=sum
    ENDDO
    !     then we solve equation 2.3.7
    DO i=n,1,-1
       sum=b(i)
       IF (i < n) THEN
          DO j=i+1,n
             sum=sum-a(i,j)*b(j)
          ENDDO
       ENDIF
       !     store a component of the solution x in the same place as b
       b(i)=sum/a(i,i)
    ENDDO

  END SUBROUTINE lu_linear_equation

  !     determine eigenvalues and eigenvectors of a real symmetric
  !     tri-diagonal matrix, or a real, symmetric matrix previously
  !     reduced by function tred2 to tri-diagonal form. On input,
  !     d[] contains the diagonal element and e[] the sub-diagonal
  !     of the tri-diagonal matrix. On output d[] contains the
  !     eigenvalues and  e[] is destroyed. If eigenvectors are
  !     desired z[][] on input contains the identity matrix. If
  !     eigenvectors of a matrix reduced by tred2() are required,
  !     then z[][] on input is the matrix output from tred2().
  !     On output, the k'th column returns the normalized eigenvector
  !     corresponding to d[k].
  !     The function is modified from the version in Numerical recipe.

  SUBROUTINE tqli(d,e,n,z)
    IMPLICIT NONE
    INTEGER :: n
    REAL(DP)  :: d(n),e(n),z(n,n)
    INTEGER :: i,iter,k,l,m
    REAL(DP)  :: b,c,dd,f,g,p,r,s,pythag,one

    DO i=2,n
       e(i-1)=e(i)
    ENDDO
    one=1.
    DO l=1,n
       iter=0
       ITERATE : DO
          DO m=l,n-1
             dd=ABS(d(m))+ABS(d(m+1))
             IF (ABS(e(m))+dd == dd) EXIT
          ENDDO
          IF(m == l) EXIT ITERATE
          IF(iter == 30) STOP 'too many iterations in tqli'
          iter=iter+1
          g=(d(l+1)-d(l))/(2.*e(l))
!          r=pythag(g,one)
          g=d(m)-d(l)+e(l)/(g+sign(r,g))
          s=1.
          c=1.
          p=0.
          DO i=m-1,l,-1
             f=s*e(i)
             b=c*e(i)
!             r=pythag(f,g)
             e(i+1)=r
             IF(r == 0.) THEN
                d(i+1)=d(i+1)-p
                e(m)=0.
                CYCLE ITERATE
             ENDIF
             s=f/r
             c=g/r
             g=d(i+1)-p
             r=(d(i)-g)*s+2.*c*b
             p=s*r
             d(i+1)=g+p
             g=c*r-b
             !     Omit lines from here ...
             DO k=1,n
                f=z(k,i+1)
                z(k,i+1)=s*z(k,i)+c*f
                z(k,i)=c*z(k,i)-s*f
             ENDDO
             !     ... to here when finding only eigenvalues.
          ENDDO
          d(l)=d(l)-p
          e(l)=g
          e(m)=0.
       ENDDO ITERATE
    ENDDO

  END SUBROUTINE tqli

  REAL(DP) FUNCTION pythag(a,b)
    REAL(DP)  :: a,b
    REAL(DP)  :: absa,absb
    absa=ABS(a)
    absb=ABS(b)
    IF(absa > absb) THEN
       pythag=absa*sqrt(1.+(absb/absa)**2)
    ELSE
       IF(absb == 0.) THEN
          pythag=0.
       ELSE
          pythag=absb*sqrt(1.+(absa/absb)**2)
       ENDIF
    ENDIF

  END FUNCTION pythag

  !    perform a Housholder reduction of a real symmetric matrix
  !    a[][]. On output a[][] is replaced by the orthogonal matrix
  !    effecting the transformation. d[] returns the diagonal elements
  !    of the tri-diagonal matrix, and e[] the off-diagonal elements,
  !    with e[0] = 0.
  !    The function is modified from the version in Numerical recipes.

  SUBROUTINE tred2(a,n,d,e)
    IMPLICIT NONE
    INTEGER :: n
    REAL(DP) :: a(n,n),d(n),e(n)
    INTEGER :: i,j,k,l
    REAL(DP) ::  f,g,h,hh,scale

    DO i=n,2,-1
       l=i-1
       h=0.
       scale=0.
       IF (l > 1) THEN
          scale=SUM(abs(a(i,1:l)))
          IF (scale == 0.) THEN
             e(i)=a(i,l)
          ELSE
             a(i,1:l)=a(i,1:l)/scale
             h=sum(a(i,1:l)**2)
             f=a(i,l)
             g=-sign(sqrt(h),f)
             e(i)=scale*g
             h=h-f*g
             a(i,l)=f-g
             f=0.
             DO j=1,l
                !     Omit following line if finding only eigenvalues
                a(j,i)=a(i,j)/h
                g=0.
                DO k=1,j
                   g=g+a(j,k)*a(i,k)
                ENDDO
                DO  k=j+1,l
                   g=g+a(k,j)*a(i,k)
                ENDDO
                e(j)=g/h
                f=f+e(j)*a(i,j)
             ENDDO
             hh=f/(h+h)
             DO j=1,l
                f=a(i,j)
                g=e(j)-hh*f
                e(j)=g
                DO k=1,j
                   a(j,k)=a(j,k)-f*e(k)-g*a(i,k)
                ENDDO
             ENDDO
          ENDIF
       ELSE
          e(i)=a(i,l)
       ENDIF
       d(i)=h
    ENDDO
    !     Omit following line if finding only eigenvalues.
    d(1)=0.
    e(1)=0.
    DO i=1,n
       !     Delete lines from here ...
       l=i-1
       IF (d(i) /= 0.) THEN
          DO j=1,l
             g=0.
             DO k=1,l
                g=g+a(i,k)*a(k,j)
             ENDDO
             DO k=1,l
                a(k,j)=a(k,j)-g*a(k,i)
             ENDDO
          ENDDO
       endif
       !     ... to here when finding only eigenvalues.
       d(i)=a(i,i)
       !     Also delete lines from here ...
       a(i,i)=1.
       DO j=1,l
          a(i,j)=0.
          a(j,i)=0.
       ENDDO
       !     ... to here when finding only eigenvalues.
    ENDDO

  END SUBROUTINE tred2

  ! takes as input xa[1,..,n] and ya[1,..,n] together with
  ! a given value of x and returns a value y and an error
  ! estimate dy. If P(x) is a polynomial of degree N - 1 such
  ! that P(xa_i) = ya_i, i = 0,..,n-1, then the returned
  ! value is y = P(x).

  SUBROUTINE polint(xa,ya,n,x,y,dy)
    IMPLICIT NONE
    INTEGER :: i, ns, m, n
    REAL(DP), DIMENSION(n) :: xa,ya
    REAL(DP), DIMENSION(:), ALLOCATABLE :: c , d
    REAL(DP) :: den ,dif, dift, ho, hp, w, x, y, dy

    ALLOCATE ( c(n), d(n) )
    ns=1
    dif=ABS(x-xa(1))
    DO i=1,n
       dift=ABS(x-xa(i))
       IF (dift < dif) THEN
          ns=i
          dif=dift
       ENDIF
       c(i)=ya(i)
       d(i)=ya(i)
    ENDDO
    y=ya(ns)
    ns=ns-1
    DO m=1,n-1
       DO i=1,n-m
          ho=xa(i)-x
          hp=xa(i+m)-x
          w=c(i+1)-d(i)
          den=ho-hp
          IF(den == 0.) WRITE(6,*)  'Error in POLINT, den =0'
          den=w/den
          d(i)=hp*den
          c(i)=ho*den
       ENDDO
       IF (2*ns < n-m)THEN
          dy=c(ns+1)
       ELSE
          dy=d(ns)
          ns=ns-1
       ENDIF
       y=y+dy
    ENDDO
    DEALLOCATE ( c, d)

  END SUBROUTINE polint

  ! takes as input x[1,..,n] and y[1,..,n] containing a tabulation
  ! y_i = f(x_i) with x_0 < x_1 < .. < x_(n - 1)
  ! together with yp_1 and yp2 for first derivatives  f(x) at x_0
  ! and x_(n-1), respectively. Then the
  ! function returns y2[1,..,n] which contains the second
  ! derivatives of f(x_i)at each point x_i. If yp1 and/or yp2
  ! is larger than the constant INFINITY the function will
  ! put corresponding second derivatives to zero.

  SUBROUTINE spline(x,y,n,yp1,ypn,y2)
    IMPLICIT NONE
    INTEGER :: i, k, n
    REAL(DP), DIMENSION(n) :: x, y, y2
    REAL(DP), DIMENSION(:), ALLOCATABLE :: u
    REAL(DP) :: p, qn, sig, un, ypn, yp1

    ALLOCATE ( u (n) )
    IF (yp1 > .99E30) THEN
       y2(1)=0.
       u(1)=0.
    ELSE
       y2(1)=-0.5
       u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
    ENDIF
    DO i=2,n-1
       sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
       p=sig*y2(i-1)+2.
       y2(i)=(sig-1.)/p
       u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) &
            /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
    ENDDO
    IF (ypn > .99E30) THEN
       qn=0.
       un=0.
    ELSE
       qn=0.5
       un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
    ENDIF
    y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
    DO k=n-1,1,-1
       y2(k)=y2(k)*y2(k+1)+u(k)
    ENDDO
    DEALLOCATE ( u )

  END SUBROUTINE spline

  ! takes xa[1,..,n] and y[1,..,n] which tabulates a function
  ! (with the xa[i]'s in order) and given ya[0,..,n - 1],
  ! which is the output from function spline() and with
  ! given value of x returns a cubic--spline interpolation value y.

  SUBROUTINE splint(xa,ya,y2a,n,x,y)
    IMPLICIT NONE
    INTEGER :: k, n, klo, khi
    REAL(DP), DIMENSION(n) :: xa, ya, y2a
    REAL(DP) ::  x, y, h, b, a

    klo=1
    khi=n
    DO WHILE  (khi-klo > 1)
       k=(khi+klo)/2
       IF(xa(k)  > x)THEN
          khi=k
       ELSE
          klo=k
       ENDIF
    ENDDO
    h=xa(khi)-xa(klo)
    IF (h == 0.) WRITE (6,*) 'Bad XA input in SPLINT.F.'
    a=(xa(khi)-x)/h
    b=(x-xa(klo))/h
    y=a*ya(klo)+b*ya(khi)+ &
         ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.

  END SUBROUTINE splint

  !      This routine calculates gauss-legendre mesh points and weights
  !      input:
  !      x1   : lower limit of the integration interval
  !      x2   : upper limit ---------- "" -------------
  !      n    : the desired number of mesh points
  !      output :
  !      x     : gauss-legendre mesh points on the interval (x1,x2)
  !      w     : the corresponding weights

  SUBROUTINE gauleg(x1,x2,x,w,n)
    IMPLICIT NONE
    INTEGER :: i, j, m, n
    REAL(DP) :: eps, x1, x2, x, w
    DIMENSION :: x(n), w(n)
    PARAMETER (eps=3.D-14)
    REAL(DP) :: p1,p2,p3,pp,xl,xm,z,z1

    m=(n+1)/2
    xm=0.5d0*(x2+x1)
    xl=0.5d0*(x2-x1)
    DO i=1,m
       z1=0.
       z=COS(3.141592654d0*(i-.25d0)/(n+.5d0))
       DO WHILE ( ABS(z-z1) > EPS)
          p1=1.
          p2=0.
          DO j=1,n
             p3=p2
             p2=p1
             p1=((2.*j-1.)*z*p2-(j-1.)*p3)/j
          ENDDO
          pp=n*(z*p1-p2)/(z*z-1.)
          z1=z
          z=z-p1/pp
       ENDDO
       x(i)=xm-xl*z
       x(n+1-i)=xm+xl*z
       w(i)=2.*xl/((1.-z*z)*pp*pp)
       w(n+1-i)=w(i)
    ENDDO

  END SUBROUTINE gauleg

  !     Function to integrate a function func over the
  !     interval [a,b] with input a, b, and the number of steps
  !     n.  It returns the sum as the variable trapez_sum
  !     The trapezoidal rule is used

  SUBROUTINE trapezoidal_rule(a,b,trapez_sum,n,func)
    INTEGER, INTENT(IN) :: n
    REAL(DP), INTENT(IN) :: a,b
    REAL(DP), INTENT(INOUT) :: trapez_sum
    REAL(DP) fa, fb, x, step
    INTEGER :: j
    INTERFACE
       DOUBLE PRECISION FUNCTION  func(x)
         IMPLICIT NONE
         DOUBLE PRECISION, INTENT(IN) :: x

       END FUNCTION func
    END INTERFACE

    step=(b-a)/FLOAT(n)
    fa=func(a)/2. ; fb=func(b)/2. ; trapez_sum=0.
    DO j=1,n-1
       x=j*step+a
       trapez_sum=trapez_sum+func(x)
    ENDDO
    trapez_sum=(trapez_sum+fb+fa)*step

  END  SUBROUTINE trapezoidal_rule

  !     Function to integrate a function func over the
  !     interval [a,b] with input a, b, and the number of steps
  !     n.  It returns the sum as the variable simpson_sum
  !     Simpson's method is used

  SUBROUTINE simpson(a,b,simpson_sum,n,func)
    REAL(DP), INTENT(IN) :: a,b
    REAL(DP), INTENT(INOUT) :: simpson_sum
    REAL(DP) fa, fb, x, step, fac
    INTEGER, INTENT(IN) :: n
    INTEGER :: j

    INTERFACE
       DOUBLE PRECISION FUNCTION  func(x)
         IMPLICIT NONE
         DOUBLE PRECISION, INTENT(IN) :: x

       END FUNCTION func
    END INTERFACE

    step=(b-a)/FLOAT(n)
    fa=func(a) ; fb=func(b) ; simpson_sum=fa ; fac=2.
    DO j=1,n-1
       IF ( fac == 2.) THEN
          fac = 4.
       ELSE
          fac = 2.
       ENDIF
       x=j*step+a
       simpson_sum=simpson_sum+func(x)*fac
    ENDDO
    simpson_sum=(simpson_sum+fb)*step/3.

  END SUBROUTINE simpson

  !
  !  4th-Runge-Kutta solution of coupled equations
  !
  SUBROUTINE rk4(x,y,yout,dydx,step,n)
    IMPLICIT NONE
    INTEGER :: n
    REAL(DP), DIMENSION(n) :: yt, dyt, dym
    REAL(DP), DIMENSION(n), INTENT(IN) :: y, dydx
    REAL(DP), DIMENSION(n), INTENT(OUT) :: yout
    REAL(DP) :: hh, h6, xh, step
    REAL(DP), INTENT(IN) :: x

    hh=step*0.5; h6=step/6. ; xh=x+hh
    !     first rk-step
    yt=y+hh*dydx
    !      CALL derivs(xh,yt,dyt)
    !     second rk-step
    yt=y+hh*dyt
    !      CALL derivs(xh,yt,dym)
    !     third rk-step
    yt=y+step*dym;  dym=dyt+dym
    !      CALL derivs(x+step,yt,dyt)
    !     fourth rk-step
    yout=y+h6*(dydx+dyt+2.*dym)

  END SUBROUTINE rk4

  !  This function sets up the recursive relation
  !  for the associated Legendre polynomials

  REAL(DP) FUNCTION legendre_polynomials(l, m, x)
    IMPLICIT NONE
    REAL(DP) ::  fact,pll,pmm,pmmp1,somx2
    REAL(DP), INTENT(IN)  :: x
    INTEGER ::  i,ll
    INTEGER, INTENT(IN) :: l, m

    !  check whether m, l and x are ok

    IF((M < 0).OR.(M > L).OR.(ABS(X) > 1.)) THEN
       WRITE(6,*) 'bad arguments', m, l, x; RETURN
    ENDIF

    !  calculate now pmm as starting point for iterations

    pmm=1.0
    IF (m > 0) THEN
       somx2=SQRT((1.0-x)*(1.0+x))
       fact=1.0;
       DO i=1, m
          pmm = -fact*somx2*pmm
          fact = fact+2.0
       ENDDO
    ENDIF

    !  if l == m we do not need to use recursion relation

    IF (l == m) THEN
       legendre_polynomials=pmm

       !  recursive relation for associated Legendre polynomials

    ELSE
       pmmp1=x*(2*m+1)*pmm

       !  analytical formula for the case l == m+1

       IF (l == (m+1)) THEN
          legendre_polynomials=pmmp1
       ELSE
          DO ll=m+2, l
             pll=(x*(2*ll-1)*pmmp1-(ll+m-1)*pmm)/(ll-m)
             pmm=pmmp1
             pmmp1=pll
          ENDDO
          legendre_polynomials= pll
       ENDIF
    ENDIF

  END FUNCTION legendre_polynomials

  !
  !     This function uses Newton-Raphson's
  !     method to find the root of a function
  !     known to lie between x1 and x2. The root is returned as rtnewt
  !     and is refined till its accuracy is xacc. You need to provide
  !     this value when calling the function.
  !     You must also provide an external function called funcd which
  !     calculates both the function f and its derivative df.
  !
  REAL(DP) FUNCTION rtnewt(funcd,x1,x2,xacc)
    IMPLICIT NONE
    INTEGER :: jmax, j
    REAL(DP) :: x1,x2,xacc
    PARAMETER (jmax=20)
    REAL(DP) :: df,dx,f
    INTERFACE
       SUBROUTINE funcd(x,y,z)
         IMPLICIT NONE
         DOUBLE PRECISION :: x, y, z

       END SUBROUTINE  funcd
    END INTERFACE

    rtnewt=.5*(x1+x2)
    DO j=1,jmax
       CALL funcd(rtnewt,f,df)
       dx=f/df
       rtnewt=rtnewt-dx
       IF ((x1-rtnewt)*(rtnewt-x2) < 0.) THEN
          WRITE(6,*) 'Error in rtnewt, jumped out of brackets'
          STOP
       ENDIF
       IF (ABS (dx) < xacc) RETURN
    ENDDO

  END FUNCTION rtnewt

  !
  !     This function uses the bisection  method to find the
  !     root of a function
  !     known to lie between x1 and x2. The root is returned as rtbis
  !     and is refined till its accuracy is xacc.
  !     You must provide an external function called func.
  !
  REAL(DP) FUNCTION rtbis(func,x1,x2,xacc)
    IMPLICIT NONE
    INTEGER :: jmax, j
    REAL(DP) :: x1,x2,xacc
    PARAMETER (jmax=40)
    REAL(DP) :: dx,f,fmid,xmid

    INTERFACE
       DOUBLE PRECISION FUNCTION  func(x)
         IMPLICIT NONE
         DOUBLE PRECISION, INTENT(IN) :: x

       END FUNCTION func
    END INTERFACE

    fmid=func(x2)
    f=func(x1)
    IF(f*fmid >= 0.) STOP 'root must be bracketed in rtbis'
    IF (f < 0.) THEN
       rtbis=x1
       dx=x2-x1
    ELSE
       rtbis=x2
       dx=x1-x2
    ENDIF
    DO j=1,jmax
       dx=dx*.5
       xmid=rtbis+dx
       fmid=func(xmid)
       IF (fmid <= 0.) rtbis=xmid
       IF (ABS(dx) < xacc .or. fmid == 0.) RETURN
    ENDDO

  END FUNCTION rtbis
  !
  !     This function uses the secant method
  !     to find the root of a function
  !     known to lie between x1 and x2. The root is returned as rtsec
  !     and is refined till its accuracy is xacc
  !     You must provide an external function called func.
  !
  REAL(DP) FUNCTION rtsec(func,x1,x2,xacc)
    IMPLICIT NONE
    INTEGER :: maxit, j
    real(DP) :: x1,x2,xacc
    PARAMETER (maxit=30)
    REAL(DP) :: dx,f,fl,swap,xl
    INTERFACE
       DOUBLE PRECISION FUNCTION  func(x)
         IMPLICIT NONE
         DOUBLE PRECISION, INTENT(IN) :: x

       END FUNCTION func
    END INTERFACE

    fl=func(x1)
    f=func(x2)
    IF(ABS(fl) < ABS(f)) THEN
       rtsec=x1
       xl=x2
       swap=fl
       fl=f
       f=swap
    ELSE
       xl=x1
       rtsec=x2
    ENDIF
    DO j=1,maxit
       dx=(xl-rtsec)*f/(f-fl)
       xl=rtsec
       fl=f
       rtsec=rtsec+dx
       f=func(rtsec)
       IF((ABS(dx) < xacc).or.(f == 0.)) RETURN
    ENDDO

  END FUNCTION rtsec

  !
  !     This function uses Brent's method to find the root of a function
  !     known to lie between x1 and x2. The root is returned as zbrent
  !     and is refined till its accuracy is tol
  !     You must provide an external function called func.
  !
  REAL(DP) FUNCTION zbrent(func,x1,x2,tol)
    IMPLICIT NONE
    REAL(DP) :: tol, x1, x2
    REAL(DP), PARAMETER :: EPS= epsilon(x1)
    INTEGER, PARAMETER :: ITMAX=100
    INTEGER :: iter
    REAL(DP) :: a,b,c,d,e,fa,fb,fc,p,q,r,s,tol1,xm
    INTERFACE
       DOUBLE PRECISION FUNCTION  func(x)
         IMPLICIT NONE
         DOUBLE PRECISION, INTENT(IN) :: x

       END FUNCTION func
    END INTERFACE

    a=x1
    b=x2
    fa=func(a)
    fb=func(b)
    !      IF((fa > 0.0.AND.fb > 0.0).OR.(fa < 0.0.AND.fb < 0.0)) THEN
    !          WRITE(*,*) 'root must be bracketed for zbrent' ; STOP
    !      ENDIF
    c=b
    fc=fb
    DO iter=1,ITMAX
       IF ((fb > 0.0.AND.fc > 0.).OR.(fb < 0.0.AND.fc < 0.0))THEN
          c=a
          fc=fa
          d=b-a
          e=d
       ENDIF
       IF(ABS(fc) < ABS(fb)) THEN
          a=b
          b=c
          c=a
          fa=fb
          fb=fc
          fc=fa
       ENDIF
       tol1=2.*eps*ABS(b)+0.5*tol
       xm=.5*(c-b)
       IF((ABS(xm) <= tol1) .OR. (fb == 0.))THEN
          zbrent=b
          RETURN
       ENDIF
       IF((ABS(e) >= tol1) .AND.( ABS(fa) > ABS(fb)) ) THEN
          s=fb/fa
          IF(a == c) THEN
             p=2.*xm*s
             q=1.-s
          ELSE
             q=fa/fc
             r=fb/fc
             p=s*(2.*xm*q*(q-r)-(b-a)*(r-1.))
             q=(q-1.)*(r-1.)*(s-1.)
          ENDIF
          IF(p > 0.) q=-q
          p=ABS(p)
          IF(2.*p < MIN(3.*xm*q-ABS(tol1*q),ABS(e*q))) THEN
             e=d
             d=p/q
          ELSE
             d=xm
             e=d
          ENDIF
       ELSE
          d=xm
          e=d
       ENDIF
       a=b
       fa=fb
       b=b+MERGE(d,SIGN(tol1,xm), ABS(d) > tol1 )
       fb=func(b)
    ENDDO
    WRITE (*,*) 'zbrent exceeding maximum iterations'; STOP
    zbrent=b

  END FUNCTION zbrent

  !
  !     The function
  !           ran0()
  !     is an "Minimal" random number generator of Park and Miller
  !     (see Numerical recipe page 279). Set or reset the input value
  !     idum to any integer value (except the unlikely value MASK)
  !     to initialize the sequence; idum must not be altered between
  !     calls for sucessive deviates in a sequence.
  !     The function returns a uniform deviate between 0.0 and 1.0.
  !

  REAL(DP) FUNCTION ran0(idum)
    IMPLICIT NONE
    INTEGER :: idum,ia,im,iq,ir,mask,k
    REAL(DP) :: am
    PARAMETER (ia=16807,im=2147483647,am=1./im,iq=127773,ir=2836,mask=123459876)

    idum=ieor(idum,MASK)
    k=idum/IQ
    idum=IA*(idum-k*IQ)-IR*k
    IF  (idum < 0) idum=idum+IM
    ran0=am*idum
    idum=ieor(idum,MASK)

  END FUNCTION ran0

  !
  !      The function
  !           ran1()
  !      is an "Minimal" random number generator of Park and Miller
  !      (see Numerical recipe page 280) with Bays-Durham shuffle and
  !      added safeguards. Call with idum a negative integer to initialize;
  !      thereafter, do not alter idum between sucessive deviates in a
  !      sequence. RNMX should approximate the largest floating point value
  !      that is less than 1.
  !      The function returns a uniform deviate between 0.0 and 1.0
  !      (exclusive of end-point values).
  !

  REAL(DP) FUNCTION ran1(idum)
    IMPLICIT NONE
    INTEGER :: idum,ia,im,iq,ir,ntab,ndiv
    REAL(DP) :: am,eps,rnmx
    PARAMETER (ia=16807,im=2147483647,am=1./im,iq=127773,ir=2836, &
         ntab=32,ndiv=1+(im-1)/ntab,eps=1.2e-7,rnmx=1.-eps)
    INTEGER :: j,k,iv(ntab),iy
    SAVE iv,iy
    DATA iv /NTAB*0/, iy /0/

    IF ((idum == 0).OR.(iy==0)) THEN
       idum=MAX(-idum,1)
       DO j=ntab+8,1,-1
          k=idum/iq
          idum=ia*(idum-k*iq)-ir*k
          IF (idum < 0) idum=idum+im
          IF (j <= ntab) iv(j)=idum
       ENDDO
       iy=iv(1)
    ENDIF
    k=idum/IQ
    idum=ia*(idum-k*iq)-ir*k
    if (idum < 0) idum=idum+IM
    j=1+iy/ndiv
    iy=iv(j)
    iv(j)=idum
    ran1=MIN(am*iy,rnmx)

  END FUNCTION ran1

  REAL(DP) FUNCTION ran(idum)
    IMPLICIT NONE
    INTEGER, PARAMETER :: K4B=selected_int_kind(9)
    INTEGER(K4B), INTENT(INOUT) :: idum
    INTEGER :: ia,im,iq,ir
    REAL(DP), SAVE :: am
    PARAMETER (ia=16807,im=2147483647,iq=127773,ir=2836)
    INTEGER(K4B), SAVE :: ix=-1, iy=-1, k

    IF ((idum <= 0).OR.(iy < 0)) THEN
       am=NEAREST(1.,-1.)/im
       iy=IOR(IEOR(888889999,ABS(idum)),1)
       ix=IEOR(777755555,ABS(idum))
       idum=ABS(idum)+1
    ENDIF
    ix=IEOR(ix,ISHFT(ix,13))
    ix=IEOR(ix,ISHFT(ix,-17))
    ix=IEOR(ix,ISHFT(ix,5))
    k=iy/iq
    iy=ia*(iy-k*iq)-ir*k
    IF ( iy < 0 ) iy=iy+im
    ran=am*IOR(IAND(im,IEOR(ix,iy)),1)

  END FUNCTION ran

  !
  !     The function
  !         ran2
  !     is a long periode (> 2 x 10^18) random number generator of
  !     L'Ecuyer and Bays-Durham shuffle and added safeguards.
  !     Call with idum a negative integer to initialize; thereafter,
  !     do not alter idum between sucessive deviates in a
  !     sequence. RNMX should approximate the largest floating point value
  !     that is less than 1.
  !     The function returns a uniform deviate between 0.0 and 1.0
  !     (exclusive of end-point values).
  !

  REAL(DP)  FUNCTION ran2(idum)
    IMPLICIT NONE
    INTEGER :: idum,im1,im2,imm1,ia1,ia2,iq1,iq2,ir1,ir2,ntab,ndiv
    REAL(DP) :: am,eps,rnmx
    PARAMETER (im1=2147483563,im2=2147483399,am=1./im1,imm1=im1-1, &
         ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1=12211,ir2=3791, &
         ntab=32,ndiv=1+imm1/ntab,eps=1.2e-7,rnmx=1.-eps)
    INTEGER :: idum2,j,k,iv(NTAB),iy
    SAVE iv,iy,idum2
    DATA idum2/123456789/, iv/NTAB*0/, iy/0/
    IF  (idum <= 0) then
       idum=MAX(-idum,1)
       idum2=idum
       DO j=NTAB+8,1,-1
          k=idum/IQ1
          idum=ia1*(idum-k*iq1)-k*ir1
          IF  (idum < 0) idum=idum+IM1
          IF (J <= NTAB) IV(J)=IDUM
       ENDDO
       IY=IV(1)
    ENDIF
    k=idum/iq1
    idum=ia1*(idum-k*iq1)-k*ir1
    if (idum < 0) idum=idum+im1
    k=idum2/iq2
    idum2=ia2*(idum2-k*iq2)-k*ir2
    IF (idum2 < 0) idum2=idum2+im2
    j=1+iy/ndiv
    iy=iv(j)-idum2
    iv(j)=idum
    IF (iy < 1)iy=iy+imm1
    ran2=MIN(am*iy,rnmx)

  END FUNCTION ran2

  !
  !     The function
  !        ran3
  !     returns a uniform random number deviate between 0.0 and 1.0. Set
  !     the idum to any negative value to initialize or reinitialize the
  !     sequence. Any large MBIG, and any small (but still large) MSEED
  !     can be substituted for the present values.
  !

  REAL(DP) FUNCTION ran3(idum)
    IMPLICIT NONE
    INTEGER :: idum
    INTEGER :: mbig,mseed,mz
    REAL(DP) ::  fac
    PARAMETER (mbig=1000000000,mseed=161803398,mz=0,fac=1./mbig)
    INTEGER :: i,iff,ii,inext,inextp,k
    INTEGER :: mj,mk,ma(55)
    SAVE iff,inext,inextp,ma
    DATA iff /0/

    IF ( (idum < 0) .or. (iff == 0) ) THEN
       iff=1
       mj=mseed-IABS(idum)
       mj=MOD(mj,mbig)
       ma(55)=mj
       mk=1
       DO i=1,54
          ii=MOD(21*i,55)
          ma(ii)=mk
          mk=mj-mk
          IF(mk < mz)mk=mk+mbig
          mj=ma(ii)
       ENDDO
       DO k=1,4
          DO i=1,55
             ma(i)=ma(i)-ma(1+MOD(i+30,55))
             IF (ma(i) < mz)ma(i)=ma(i)+mbig
          ENDDO
       ENDDO
       inext=0
       inextp=31
       idum=1
    ENDIF
    inext=inext+1
    IF (inext == 56) inext=1
    inextp=inextp+1
    IF (inextp == 56) inextp=1
    mj=ma(inext)-ma(inextp)
    IF (mj < mz) mj=mj+mbig
    ma(inext)=mj
    ran3=mj*fac

  END FUNCTION ran3

END MODULE F90library


program normalize_performance
    use, intrinsic :: iso_fortran_env, only : error_unit, DP => REAL64
    implicit none
    integer :: matrix_size
    real(kind=DP), dimension(:, :), allocatable :: matrix
    real(kind=DP) :: row_norm
    integer :: row, col, istat
    real :: start_time, end_time

    call get_arguments(matrix_size)
    allocate (matrix(matrix_size, matrix_size), stat=istat)

    ! reinitialize the matrix to avoid cache effects
    call random_number(matrix)
    call cpu_time(start_time)
    do row = 1, size(matrix, 1)
        matrix(row, :) = matrix(row, :)/sum(matrix(row, :))
    end do
    call cpu_time(end_time)
    print '(A, F10.6)', 'row-wise norm: ', end_time - start_time
    if (.not. is_normed(matrix, abs_tol=1e-4_DP)) then
        write (unit=error_unit, fmt='(A)') 'error: array is not normalized (row-wise)'
    end if

    ! reinitialize the matrix to avoid cache effects
    call random_number(matrix)
    call cpu_time(start_time)
    do concurrent (row = 1:size(matrix, 1))
        row_norm = 1.0_DP/sum(matrix(row, :))
        do concurrent (col = 1:size(matrix, 2))
            matrix(row, col) = matrix(row, col)*row_norm
        end do
    end do
    call cpu_time(end_time)
    print '(A, F10.6)', 'do concurrent row-wise norm: ', end_time - start_time
    if (.not. is_normed(matrix, abs_tol=1e-4_DP)) then
        write (unit=error_unit, fmt='(A)') 'error: array is not normalized (row-wise)'
    end if

    ! initialize the matrix
    call random_number(matrix)
    call cpu_time(start_time)
    matrix = matrix/spread(sum(matrix, dim=2), 2, size(matrix, 2))
    call cpu_time(end_time)
    print '(A, F10.6)', 'norm using spread: ', end_time - start_time
    if (.not. is_normed(matrix, abs_tol=1e-4_DP)) then
        write (unit=error_unit, fmt='(A)') 'error: array is not normalized (spread)'
    end if

    deallocate (matrix)

contains

    subroutine get_arguments(matrix_size)
        implicit none
        integer, intent(out) :: matrix_size
        character(len=1024) :: buffer, msg
        integer :: istat

        if (command_argument_count() /= 1) then
            write (unit=error_unit, fmt='(A)') 'error: expect matrix size as argument'
            stop 1
        end if
        call get_command_argument(1, buffer)
        read (buffer, fmt=*, iostat=istat, iomsg=msg) matrix_size
        if (istat /= 0) then
            write (unit=error_unit, fmt='(2A)') 'error: ', trim(msg)
            stop 2
        end if
    end subroutine get_arguments

    function is_normed(matrix, abs_tol) result(is_okay)
        implicit none
        real(kind=DP), dimension(:, :), intent(in) :: matrix
        real(kind=DP), value :: abs_tol
        logical :: is_okay

        is_okay = all(sum(matrix, dim=2) - 1.0_DP < abs_tol)
    end function is_normed

end program normalize_performance


submodule(forlab_linalg) forlab_linalg_chol

    implicit none

contains

    module procedure chol_sp

    integer :: i, j, k, n
    real(sp) :: sum1, sum2
    real(sp), dimension(:), allocatable :: d
    real(sp), dimension(:, :), allocatable :: V
    real(sp), parameter::zero = 0.0_sp, one = 1.0_sp
    call eig(A, V, d)
    deallocate (V)
    if (all(d >= zero)) then
        n = size(A, 1)
        L = zeros(n, n)
        L(1, 1) = sqrt(A(1, 1))
        do i = 2, n
            L(i, 1) = A(i, 1)/L(1, 1)
        end do
        do i = 2, n
            do k = 1, i
                sum1 = zero
                sum2 = zero
                do j = 1, k - 1
                    if (i == k) then
                        sum1 = sum1 + (L(k, j)*L(k, j))
                        L(k, k) = sqrt(A(k, k) - sum1)
                    elseif (i .gt. k) then
                        sum2 = sum2 + (L(i, j)*L(k, j))
                        L(i, k) = (one/L(k, k))*(A(i, k) - sum2)
                    else
                        L(i, k) = zero
                    end if
                end do
            end do
        end do
    else
        error stop "Error: in chol(A), A should be positive definite."
    end if
    deallocate (d)
    end procedure chol_sp
    module procedure chol_dp

    integer :: i, j, k, n
    real(dp) :: sum1, sum2
    real(dp), dimension(:), allocatable :: d
    real(dp), dimension(:, :), allocatable :: V
    real(dp), parameter::zero = 0.0_dp, one = 1.0_dp
    call eig(A, V, d)
    deallocate (V)
    if (all(d >= zero)) then
        n = size(A, 1)
        L = zeros(n, n)
        L(1, 1) = sqrt(A(1, 1))
        do i = 2, n
            L(i, 1) = A(i, 1)/L(1, 1)
        end do
        do i = 2, n
            do k = 1, i
                sum1 = zero
                sum2 = zero
                do j = 1, k - 1
                    if (i == k) then
                        sum1 = sum1 + (L(k, j)*L(k, j))
                        L(k, k) = sqrt(A(k, k) - sum1)
                    elseif (i .gt. k) then
                        sum2 = sum2 + (L(i, j)*L(k, j))
                        L(i, k) = (one/L(k, k))*(A(i, k) - sum2)
                    else
                        L(i, k) = zero
                    end if
                end do
            end do
        end do
    else
        error stop "Error: in chol(A), A should be positive definite."
    end if
    deallocate (d)
    end procedure chol_dp

end submodule forlab_linalg_chol


program test_gamma

   use gamma_module

   implicit none
   integer, parameter :: n_a = 5
   integer, parameter :: n_x = 9
   integer :: i, j, k
   real(dp) :: a(n_a), x(n_x), gamma_mathematica(n_a*n_x)

   a = (/ 1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp /)
   x = (/ 0.0_dp, 1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp, 6.0_dp, 7.0_dp, 8.0_dp /)
   gamma_mathematica = (/ &
   1.00000000000000e0_dp, &
   3.67879441171442e-1_dp, &
   1.35335283236613e-1_dp, &
   4.9787068367864e-2_dp, &
   1.83156388887342e-2_dp, &
   6.73794699908547e-3_dp, &
   2.47875217666636e-3_dp, &
   9.11881965554516e-4_dp, &
   3.35462627902512e-4_dp, &
   1.00000000000000e0_dp, &
   7.35758882342885e-1_dp, &
   4.06005849709838e-1_dp, &
   1.99148273471456e-1_dp, &
   9.15781944436709e-2_dp, &
   4.04276819945128e-2_dp, &
   1.73512652366645e-2_dp, &
   7.29505572443613e-3_dp, &
   3.01916365112261e-3_dp, &
   2.00000000000000e0_dp, &
   1.83939720585721e0_dp, &
   1.35335283236613e0_dp, &
   8.46380162253687e-1_dp, &
   4.76206611107089e-1_dp, &
   2.49304038966162e-1_dp, &
   1.23937608833318e-1_dp, &
   5.92723277610436e-2_dp, &
   2.7507935488006e-2_dp, &
   6.0000000000000e0_dp, &
   5.88607105874308e0_dp, &
   5.14274076299128e0_dp, &
   3.88339133269339e0_dp, &
   2.60082072220025e0_dp, &
   1.59015549178417e0_dp, &
   9.07223296659887e-1_dp, &
   4.9059249746833e-1_dp, &
   2.54280671950104e-1_dp, &
   2.40000000000000e1_dp, &
   2.39121636761438e1_dp, &
   2.27363275837509e1_dp, &
   1.95663178685705e1_dp, &
   1.5092086444317e1_dp, &
   1.05718388415651e1_dp, &
   6.84135600759915e0_dp, &
   4.15179858916971e0_dp, &
   2.39117761168911e0_dp/)

   !print*,'TESTING GAMMA FUNCTION - GFORTRAN ONLY'
   !do i = 1, n_a
   !   print*, a(i), exp(ln_gamma(a(i))), gamma(a(i)), abs(exp(ln_gamma(a(i)))-gamma(a(i)))
   !enddo

   print*,'TESTING INCOMPLETE GAMMA FUNCTION - Mathematica results'
   print'(2a10,2a25,a14)','a','x','Gamma(a,x) Mathematica','Gamma(a,x) Current','Delta'
   k = 0
   do i = 1, n_a
      do j = 1, n_x
         k = k + 1
         print'(2f10.6,2e25.15,e14.5)',a(i),x(j),gamma_mathematica(k),gamma_incomplete_upper(a(i),x(j)), &
            abs(gamma_mathematica(k)-gamma_incomplete_upper(a(i),x(j)))
      enddo
   enddo

endprogram test_gamma


program prl2
  use forSVG
  use GaussElimination
  use Utilities
  implicit none

  real(8) :: AR,b,S
  real(8),allocatable :: spanY(:), chordY(:), twistY(:)
  real(8),allocatable :: spanTh(:), chordTh(:), twistTh(:)
  real(8),allocatable :: Gamm(:), dGamm(:), Cl(:), yPlot(:)
  integer :: N, Nplot, Nsol
  integer :: i,j
  real(8) :: v
  real(8),allocatable  :: a(:,:), r(:), An(:)

  real(8) :: CanvasLowerLeft(2),CanvasUpperRight(2)
  integer :: Resolution

  real(8),parameter :: Cla = 2.0d0*3.141592
  real(8) :: theta, yloc, chord, twist
  real(8) :: alfa
  character(len=80) :: text,filename

  write(*,*) "Prandtl Lifting Line v3 11/11/16"
  b = 2.0d0 ! span from -1 to 1

  ! SVG
  CanvasLowerLeft = [-2,-2]
  CanvasUpperRight = [2,2]
  Resolution = 1000
  call svgOpen("Geo", CanvasLowerLeft,CanvasUpperRight, Resolution)
  call svgHeader()

  Nplot = 400
  allocate(Gamm(Nplot))
  allocate(dGamm(Nplot))
  allocate(Cl(Nplot))
  allocate(yPlot(Nplot))

  ! geometery
  write(*,*) "Geometry Filename"
  read*, filename
  open(unit=101,file=trim(filename),status="old")

  read(101,*) ! Header Line
  read(101,*) ! Comment Line
  read(101,*) N

  allocate(spanY(N))
  allocate(chordY(N))
  allocate(twistY(N))

  read(101,*) ! Comment Line
  do i=1,N
    read(101,*) spanY(i), chordY(i), twistY(i)
    twistY(i) = twistY(i)*3.1415926/180.0d0
  enddo

  do i=1,N-1
    call svgQuadColor([spanY(i),0.25*chordY(i)],&
                      [spanY(i+1),0.25*chordY(i+1)],&
                      [spanY(i+1),-0.75*chordY(i+1)],&
                      [spanY(i),-0.75*chordY(i)],[150,150,150],1.0d0)
    call svgLine([spanY(i),-twistY(i)],[spanY(i+1),-twistY(i+1)],[0,0,0])
  enddo
  do i=-10,10,2
    call svgLine([1.0d0,i/57.30d0],[1.1d0,i/57.3d0],[0,0,0])
    call svgText([1.2d0,i/57.3d0],0.03d0,-i*1.0d0)
  enddo
  do i=1,N
        call svgLine([spanY(i),0.25*chordY(i)],[spanY(i),-0.75*chordY(i)],[255,255,255])
  enddo

  ! COmpute geometry
  S = 0
  do i=1,N-1
    S = S + 0.5*(chordY(i)+chordY(i+1))*(spanY(i+1)-spanY(i))
  enddo
  AR = b*b/S
  write(*,*) "Area = ", S, "AR =", AR

  ! Solution
  Nsol = 50
  allocate( a(Nsol,Nsol))
  allocate( r(Nsol))
  allocate( An(Nsol))

  ! Polar FIle
  open(unit=109,file="polar.txt",status='unknown')
  write(109,*) "Area = ", S, "AR =", AR
  write(109,*) "CL                 CD"

  do while(.true.)
  write(*,*) "Alpha [deg]"
  read*, alfa
  if(alfa.eq.-999) exit
  alfa = alfa/57.3

  do i=1,Nsol
    theta = gettheta(i,Nsol)
    yloc = Th2Y(b/2.0d0,theta)
    chord = interpolate(spanY,chordY,yloc)
    twist = interpolate(spanY,twistY,yloc)
    do j=1,Nsol
      a(i,j) = aic(b,theta,chord,Cla,j)
    enddo
    r(i)=raic(alfa,b,theta,chord,twist,Cla,Nsol)
  enddo

  write(*,*) "Solving...."
  call GaussElim(a,r,An,Nsol)

  open(unit=301,file="Coeffs.txt",status='unknown')
  write(301,'(f15.5)') An
  close(301)

  write(*,*) "Values...."
  write(*,*) "CL = ", getCL(AR,An)
  write(*,*) "CDi = ", getCD(AR,An)
  write(*,*) "Delta = ", getDelta(AR,An)
  write(109,*) getCL(AR,An), getCD(AR,An)

  write(*,*) "Plotting...."

  do i=1,Nplot
    yloc = -1 + b*(i-1.0d0)/(Nplot-1.0d0)
    chord = interpolate(spanY,chordY,yloc)
    yPlot(i) = yloc
    Gamm(i) = GammaCirc(An,b,Nsol,yloc)
    dGamm(i) = dGammaCirc(An,b,Nsol,yloc)
    Cl(i) = 2*Gamm(i)/chord
  enddo

  write(*,*) "SVG...."

  ! Gamma
  do i=1,Nplot-1
    call svgQuadColor([yPlot(i),-0.0d0],&
                      [yPlot(i+1),0.0d0],&
                      [yPlot(i+1),Gamm(i+1)/maxval(Gamm)],&
                      [yPlot(i),Gamm(i)/maxval(Gamm)],[0,255,0],0.1d0)
    call svgLine([yPlot(i),Gamm(i)/maxval(Gamm)],[yPlot(i+1),Gamm(i+1)/maxval(Gamm)],[0,255,0])
  enddo

  ! Cl Plotting
  do i=1,Nplot-1
    call svgLine([yPlot(i),Cl(i)],[yPlot(i+1),Cl(i+1)],[0,0,255])
  enddo
  text = "Cl"
  call svgTextT([-1.3d0,0.0d0],0.05d0,text)
  write(text,'( "AOA=", f5.1, " CL=", f6.3, " CD= ", f6.3)') alfa*57.3, getCL(AR,An), getCD(AR,An)
  call svgTextT([0.0d0,Cl(Nplot/2)+0.02],0.05d0,text)
  do i=-10,20
    call svgLine([-1.0d0,i/10.0d0],[-1.1d0,i/10.0d0],[0,0,0])
    call svgText([-1.2d0,i/10.0d0],0.05d0,i/10.0d0)
  enddo

  open(unit=200,file="output.txt",status='unknown')
  write(200,*) "#### ", filename, alfa, "CL ", getCL(AR,An), "CD ", getCD(AR,An)
  do i=1,Nplot-1
    write(200,*) yPlot(i), Gamm(i), Cl(i)
  enddo

  ! ! Trailing Vortex Sheet
  ! do i=2,Nplot-2
  !   call svgLine([yPlot(i),(dGamm(i))/maxval(dGamm)],&
  !               [yPlot(i+1),(dGamm(i+1))/maxval(dGamm)],[255,0,0])
  !   !call svgQuadColor([yPlot(i),-0.2d0],&
  !   !                  [yPlot(i+1),-0.2d0],&
  !   !                  [yPlot(i+1),-2.0d0],&
  !   !                  [yPlot(i),-2.0d0],[255,0,0],abs(dGamm(i))/maxval(dGamm))
  ! enddo
enddo
  call svgFooter()
contains

  function getCL(AR,An)
    real(8) :: getCL, AR
    real(8),allocatable :: An(:)
    getCL = 3.14159*AR*An(1)
  end function

  function getCD(AR,An)
    real(8) :: getCD, AR
    real(8),allocatable :: An(:)
    integer :: n
    n = size(An)
    getCD = 0.0
    do i=1,n
      getCD= getCD + 3.14159*AR*i*An(i)**2
    enddo
  end function

  function getDelta(AR,An)
    real(8) :: getDelta, AR
    real(8),allocatable :: An(:)
    integer :: n
    n = size(An)
    getDelta = 0.0
    do i=2,n
      getDelta= getDelta + i*(An(i)/An(1))**2
    enddo
  end function

  function GammaCirc(An,b,n,y)
    implicit none
    real(8) :: b,y
    real(8),allocatable :: An(:)
    integer :: n, i
    real(8) :: GammaCirc
    GammaCirc = 0
    do i=1,n
      GammaCirc = GammaCirc + 2*b*An(i)*sin(i*acos(2*y/b))
    enddo
  end function

  function dGammaCirc(An,b,n,y)
    implicit none
    real(8) :: b,y
    real(8),allocatable :: An(:)
    integer :: n, i
    real(8) :: dGammaCirc
    real(8),parameter :: deltay = 0.0001
    dGammaCirc =  -(GammaCirc(An,b,n,y+deltay)- GammaCirc(An,b,n,y-deltay))/deltay/2.0d0

  end function

  function gettheta(m,N)
    real(8) :: gettheta
    integer :: m,N
    gettheta = 3.1415926*m/(N+1.0d0)
  end function

  function aic(b,theta,chord,Cla,n)
    real(8) :: theta,chord,CLa,b
    integer :: n
    real(8) :: aic
    aic = sin(n*theta)+chord/4.0/b*Cla*n*sin(n*theta)/sin(theta)
  end function

  function raic(alfa,b,theta,chord,twist,Cla,n)
    real(8) :: theta,chord,CLa,twist,alfa,b
    integer :: n
    real(8) :: raic
    raic = chord/4.0/b*Cla*(alfa+twist)
  end function

  function Th2Y(halfspan,theta)
    real(8) :: Th2Y,theta,halfspan
    Th2Y = halfspan*cos(theta)
  end function

  function interpolate(x,y,x0)
    real(8) :: interpolate
    real(8) :: x(:)
    real(8) :: y(:)
    real(8) :: x0,deltax, deltay
    integer :: i,n
    ! Sizes
    n = size(x)

    if(x0 .LT. x(1))then
      stop "Interpolation Failed. Too small"
    elseif(x0 .GT. x(n))then
      stop "Interpolation Failed. Too LARGE"
    endif
    do i=1,n
      if( x0 < x(i+1) ) exit
    enddo

    ! interpolate
    deltax = x(i+1)-x(i)
    deltay = y(i+1)-y(i)

    interpolate = y(i)+deltay/deltax*(x0-x(i))
  end function

end program


      program prog
      parameter(n1=2)
      parameter(n2=n1*4)
      parameter(n3=(n2+n1)*5)
      parameter(n4=(n3-n2)**3)
      parameter(n5f=n2*(n4+1)/1.99)
      write(6, *) n5f
      end


      SUBROUTINE CARTFRAC(RX11,RY11,RZ11,RA,RB,RC)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!  converts cartesian to fractional cooridates
!!!!  K.Travis 06/05/12 Univ. of Sheffield
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      USE header_file
      IMPLICIT NONE

      REAL(kind = double) :: RA,RB,RC,RX11,RY11,RZ11

      RA = RX11*ECF(1,1) + RY11*ECF(1,2) + RZ11*ECF(1,3)
      RB = RX11*ECF(2,1) + RY11*ECF(2,2) + RZ11*ECF(2,3)
      RC = RX11*ECF(3,1) + RY11*ECF(3,2) + RZ11*ECF(3,3)
      RA = RA + 0.5D0
      RB = RB + 0.5D0
      RC = RC + 0.5D0

      END SUBROUTINE


module mt19937
    ! This module is the submodule of "random_number" module
    use,intrinsic :: iso_fortran_env
    implicit none
    private
    public:: set_seed, random_mt
    integer(int32),parameter:: N = 624
    integer(int32),parameter:: N1 = 625
    integer(int32),parameter:: M = 397
    integer(int32),parameter:: MATA = -1727483681
    integer(int32),parameter:: UMASK = -2147483648_int64
    integer(int32),parameter:: LMASK = 2147483647
    integer(int32),parameter:: TMASKB = -1658038656
    integer(int32),parameter:: TMASKC = -272236544
    real(real64),parameter:: b32 = 2.0d0 ** 32
    integer(int32) :: mti = N1, mt(0:N-1), mag01(0:1) = [0, MATA]
contains
    subroutine set_seed(seed)
        integer(int32),intent(in) :: seed
        mt(0) = iand(seed, -1)
        do mti = 1, N-1
            mt(mti) = iand(69069 * mt(mti-1), -1)
        end do
    end subroutine set_seed

    function random_mt()
        integer(int32) :: y, kk
        real(real64):: random_mt

        if(mti >= N) then
            if(mti == N+1) call set_seed(4357)
            do kk=0, N-M-1
                y = ior(iand(mt(kk), UMASK), iand(mt(kk+1), LMASK))
                mt(kk) = ieor(ieor(mt(kk+M), ishft(y, -1)), mag01(iand(y, 1)))
            end do

            do kk = N-M, N-2
                y = ior(iand(mt(kk), UMASK), iand(mt(kk+1), LMASK))
                mt(kk) = ieor(ieor(mt(kk+(M-N)), ishft(y, -1)), mag01(iand(y, 1)))
            end do

            y = ior(iand(mt(N-1), UMASK), iand(mt(0), LMASK))
            mt(N-1) = ieor(ieor(mt(M-1), ishft(y, -1)), mag01(iand(y, 1)))
            mti = 0
        endif

        y = mt(mti)
        mti = mti+1
        y = ieor(y, ishft(y, -11))
        y = ieor(y, iand(ishft(y, 7), TMASKB))
        y = ieor(y, iand(ishft(y, 15), TMASKC))
        y = ieor(y, ishft(y, -18))

        if(y < 0) then
            random_mt = (dble(y)+b32) / b32
        else
            random_mt = dble(y) / b32
        endif
    end function random_mt
end module mt19937

module multiple_congruential_method
    ! This module is the submodule of "random_number" module
    ! These are the random numbers used by Ootoriken.
    use,intrinsic :: iso_fortran_env
    implicit none
    private
    public:: random_mcm, init_mcm
    real(real64),parameter:: b0=5d0**9,tm=2d0**25
    real(real64):: dran=3d0**11
contains
    subroutine init_mcm()
        implicit none

        dran=3d0**11
    end subroutine

    function random_mcm() result(ret)
        real(real64):: ret

        dran=mod(b0*dran,tm)
        ret=dran/tm
    end function
end module

module random_number
    ! This module include
    ! random_mt random_mcm
    ! random_gaussian

    ! 1. random_mt
    ! This is a function that uses the
    ! Mersenne Twister to return a uniform random number.
    ! ex.) rnum = random_mt()

    ! 2. random_mcm
    ! This is a function that uses the
    ! multiplicative congruence method
    ! to return a uniform random number.
    ! ex.) rnum = random_mcm()

    ! 3. random_gaussian
    ! This is a function that uses the
    ! Box-Muller method to return
    ! a normal random number.
    ! ex.) rnum = random_gaussian(random_mt) <- use Mersenne Twister
    ! ex.) rnum = random_gaussian(random_mcm) <- use multiplicative congruence method
    use,intrinsic :: iso_fortran_env
    use multiple_congruential_method
    use mt19937
    implicit none
    abstract interface
        function random_func()
            use,intrinsic :: iso_fortran_env
            real(real64):: random_func
        end function
    end interface
    private
    public:: random_gaussian, random_mt, random_mcm
    public:: init_mcm
    real(real64),parameter:: pi2 = acos(-1d0)*2d0
contains
    function random_gaussian(rand) result(ret)
        procedure(random_func):: rand
        real(real64):: ret
        ret=sqrt(-2d0*log(rand()))*cos(pi2*rand())
    end function
end module


c
c-----------------------------------------------------------------------
c main program: time-efficient radix-4 fast fourier transform
c author:       l. robert morris
c               department of systems engineering and computing science
c               carleton university, ottawa, canada k1s 5b6
c
c input:        the array "a" contains the data to be transformed
c-----------------------------------------------------------------------
c
c       test program for autogen radix-4 fft
c
        dimension a(2048),b(2048)
        common /aa/a
c
        ioutd=i1mach(2)
c
c       compute dft and idft for n = 64, 256, and 1024 complex points
c
        do 1 mm=3,5
        n=4**mm
        do 2 j=1,n
        a(2*j-1)=uni(0)
        a(2*j  )=uni(0)
        b(2*j-1)=a(2*j-1)
2       b(2*j  )=a(2*j)
c
c       forward dft
c
        call radix4(mm,1,-1)
c
        if(mm.ne.3) go to 5
c
c       list dft input, output for n = 64 only
c
        write(ioutd,98)
        write(ioutd,100)
        do 3 j=1,n
        write(ioutd,96) b(2*j-1),b(2*j),a(2*j-1),a(2*j)
3       continue
c
c       inverse dft
c
5       call radix4(mm,0, 1)
c
c       list dft input, idft output for n = 64 only
c
        if(mm.ne.3) go to 7
c
        write(ioutd,99)
        write(ioutd,100)
        do 6 j=1,n
        write(ioutd,96) b(2*j-1),b(2*j),a(2*j-1),a(2*j)
6       continue
c
c       calculate rms error
c
7       err=0.0
        do 8 j=1,n
8       err=err+(a(2*j-1)-b(2*j-1))**2+(a(2*j)-b(2*j))**2
        err=sqrt(err/float(n))
        write(ioutd,97) mm,err
1       continue
c
96      format(1x,4(f10.6,2x))
97      format(1x,20h   rms error for m =,i2,4h is ,e14.6/)
98      format(1x,43h       dft input                dft  output/)
99      format(1x,43h       dft input                idft output/)
100     format(1x,44h   real        imag       real          imag/)
        stop
        end


MODULE Complex_Number
!Ahora definiremos tambien las funciones de lo Complejos

USE Complex_Data

IMPLICIT NONE

CONTAINS    ! Esta declaracion es necesaria para agregar procedimientos (funciones y subrutinas)

FUNCTION C_Add(Z1, Z2)

USE Complex_Data
!IMPLICIT NONE

!Definici�n de Datos
TYPE (C_Number) :: C_Add
TYPE (C_Number), INTENT(IN):: Z1, Z2

!Definici�n de la Suma
C_Add%ReZ = Z1%ReZ + Z2%ReZ
C_Add%ImZ = Z1%ImZ + Z2%ImZ

END FUNCTION C_Add

FUNCTION C_Mul(Z1, Z2)

USE Complex_Data

TYPE (C_Number) :: C_Mul
TYPE (C_Number), INTENT(IN):: Z1, Z2

!Definici�n de la Suma
C_Mul%ReZ = (Z1%ReZ * Z2%ReZ)-(Z1%ImZ * Z2%ImZ)
C_Mul%ImZ = (Z1%ReZ * Z2%ImZ)+(Z1%ImZ * Z2%ReZ)

END FUNCTION C_Mul

END MODULE Complex_Number


! Purpose :
!    Multidimensional minimization of the function funk(x) where !x(1:ndim)
!    is a vector in ndim dimensions, by the downhill simplex method of
!    Nelder and Mead. The  matrix p(1:ndim+1,1:ndim) is input. Its ndim+1 rows
!    are ndim-dimensional vectors which are the vertices of the starting
!    simplex. Also input is the vector y(1:ndim+1), whose components must be
!    pre-initialized to the values of funk evaluated at the ndim+1 vertices
!    (rows) of p; and ftol the fractional convergence tolerance to be
!    achieved in the  function value (n.b.!). On output, p and y will
!    have been reset to ndim+1 new points all within ftol of a minimum
!    function value, and iter gives the number of function evaluations taken.
! Ref :
!    Nelder, J.A., and Mead, R. 1965, Computer Journal, vol. 7, pp. 308–313. [1]
!    Yarbro, L.A., and Deming, S.N. 1974, Analytica Chimica Acta, vol. 73, pp.
!    391–398.
!    Jacoby, S.L.S, Kowalik, J.S., and Pizzo, J.T. 1972, Iterative Methods for
!    Nonlinear Optimization
!    Problems (Englewood Cliffs, NJ: Prentice-Hall).
!
!

   subroutine amoeba(ndim, p,y,ftol,func,iter)
      implicit none

      ! precision control
      integer, parameter :: dp= kind(1d0)
      integer, parameter :: i4b= 4

      !>> inout variables
      ! dimension of our variable space
      integer(i4b), intent(in) :: ndim
      integer(i4b), intent(out) :: iter

      ! the fractional convergence tolerance to be achieved in the function
      ! value
      real(dp), intent(in) :: ftol

      real(dp), intent(inout) :: y(ndim+1)
      real(dp), intent(inout) :: p(ndim+1, ndim)

      interface
         function func(n, x)
         implicit none
         integer, parameter :: dp= kind(1d0)
         integer, intent(in) :: n
         real(dp), dimension(n), intent(in) :: x
         real(dp) :: func
         end function func
      end interface

      !>> local variables
      integer(i4b), parameter :: itmax=5000
      real(dp), parameter :: tiny=1.0e-10
      integer(i4b) :: ihi
      real(dp), dimension(size(p,2)) :: psum

      call amoeba_private
      contains

      subroutine amoeba_private
      implicit none
      integer(i4b) :: i,ilo,inhi
      real(dp) :: rtol,ysave,ytry,ytmp
      iter=0

      ! Enter here when starting or have just overall contracted.
      ! Recompute psum.
      psum(:)=sum(p(:,:),dim=1)

      do while (.true.)

         ! Enter here when have just changed a single point.
         ! Determine which point is the highest (worst) ihi, next-highest inhi,
         ! and lowest (best)  ilo
         ilo=iminloc(y(:))
         ihi=imaxloc(y(:))
         ytmp=y(ihi)
         y(ihi)=y(ilo)
         inhi=imaxloc(y(:))
         y(ihi)=ytmp

         ! Compute the fractional range from highest to lowest and return if
         ! satisfactory.
         ! If returning, put best point and value in slot 1.
         rtol=2.0_dp*abs(y(ihi)-y(ilo))/(abs(y(ihi))+abs(y(ilo))+tiny)
         if (rtol < ftol) then
            call swap1(y(1),y(ilo))
            call swap2(p(1,:),p(ilo,:))
            call printpy(p, y)
            return
         end if
         if (iter >= itmax) then
            print*, 'itmax exceeded in amoeba'
            return
         endif

         ! begin a new iteration. first extrapolate by a factor ?1 through the
         ! face of the simplex
         ! across from the high point, i.e., reflect the simplex from the high
         ! point.
         ytry=amotry(-1.0_dp)
         iter=iter+1
         call printpy(p, y)
         if (ytry <= y(ilo)) then
            ! gives a result better than the best point, so
            ! try an additional extrapolation by a factor of 2
            ytry=amotry(2.0_dp)
            iter=iter+1
            call printpy(p, y)
         else if (ytry >= y(inhi)) then
            ! the reflected point is worse than the second
            ! highest, so look for an intermediate lower point, i.e., do a
            ! one-dimensional contraction.
            ysave=y(ihi)
            ytry=amotry(0.5_dp)
            iter=iter+1
            call printpy(p, y)
            if (ytry >= ysave) then
               ! can't seem to get rid of that high point. better contract
               ! around the lowest (best) point.
               p(:,:)=0.5_dp*(p(:,:)+spread(p(ilo,:),1,size(p,1)))
               do i=1,ndim+1
                 !if (i /= ilo) call func(ndim, p(i,:), y(i))
                  if (i /= ilo) y(i)=func(ndim, p(i,:))
               end do
               !keep track of function evaluations.
               iter=iter+ndim
               psum(:)=sum(p(:,:),dim=1)
            end if
         end if

      end do !go back for the test of doneness and the next
   end subroutine amoeba_private
!bl

   !>>> Extrapolates by a factor fac through the face of the simplex across from
   ! the high point,
   ! tries it, and replaces the high point if the new point is better.
   function amotry(fac)
      implicit none
      real(dp), intent(in) :: fac
      real(dp) :: amotry
      real(dp) :: fac1,fac2,ytry
      real(dp), dimension(size(p,2)) :: ptry
      fac1=(1.0_dp-fac)/ndim
      fac2=fac1-fac
      ptry(:)=psum(:)*fac1-p(ihi,:)*fac2
      ytry=func(ndim, ptry)
     !call func(ndim, ptry, ytry)
      if (ytry < y(ihi)) then
         y(ihi)=ytry
         psum(:)=psum(:)-p(ihi,:)+ptry(:)
         p(ihi,:)=ptry(:)
      end if
      amotry=ytry
   end function amotry

   !>>> function that find the location of the minimum value of y
   function iminloc(y)
      implicit none
      real(dp), intent(in) :: y(ndim+1)
      integer(i4b) :: iminloc

      integer(i4b) :: i

      iminloc=1
      do i=1, ndim+1
         if (y(i)<y(iminloc)) iminloc=i
      enddo
   end function iminloc

   !>>> function that find the location of the maximum value of y
   function imaxloc(y)
      implicit none
      real(dp), intent(in) :: y(ndim+1)
      integer(i4b) :: imaxloc

      integer(i4b) :: i

      imaxloc=1
      do i=1, ndim+1
         if (y(i)>y(imaxloc)) imaxloc=i
      enddo
   end function imaxloc

   ! swap two values
   subroutine swap1(x, y)
      implicit none
      real(dp), intent(inout) :: x
      real(dp), intent(inout) :: y
      real(dp) :: z
      z= x
      x= y
      y= z
      return
   end subroutine swap1

   ! swap two vectors
   subroutine swap2(x, y)
      implicit none
      real(dp), intent(inout) :: x(ndim)
      real(dp), intent(inout) :: y(ndim)
      real(dp) :: z(ndim)
      z= x
      x= y
      y= z

      return
   end subroutine swap2

   subroutine printpy(p, y)

      implicit none

      real(dp), intent(in) :: p(ndim+1, ndim)
      real(dp), intent(in) :: y(ndim+1      )

      integer :: i

      ! output some informations
      write(6, '(a, i8)') 'Amoeba iter= ', iter
      write(6, '("x", 4f16.6)') (p(1, i), i=1, ndim)
      write(6, '("y", 4f16.6)') (y(   i), i=1, ndim+1)

      return
   end subroutine printpy
   end subroutine amoeba


c     Calculate determinant of square matrix
c     Author: Pearu Peterson, March 2002
c
c     prefixes: d,z,s,c   (double,complex double,float,complex float)
c     suffixes: _c,_r     (column major order,row major order)

      subroutine ddet_c(det,a,n,piv,info)
      integer n,piv(n),i
      double precision det,a(n,n)
cf2py intent(in,copy) :: a
cf2py intent(out) :: det,info
cf2py integer intent(hide,cache),depend(n),dimension(n) :: piv
cf2py integer intent(hide),depend(a) :: n = shape(a,0)
cf2py check(shape(a,0)==shape(a,1)) :: a
cf2py callprotoargument double*,double*,int*,int*,int*
      external dgetrf
      call dgetrf(n,n,a,n,piv,info)
      det = 0d0
      if (info.ne.0) then
         return
      endif
      det = 1d0
      do 10,i=1,n
         if (piv(i).ne.i) then
            det = -det * a(i,i)
         else
            det = det * a(i,i)
         endif
 10   continue
      end

      subroutine ddet_r(det,a,n,piv,info)
      integer n,piv(n)
      double precision det,a(n,n)
cf2py intent(c,in,copy) :: a
cf2py intent(out) :: det,info
cf2py integer intent(hide,cache),depend(n),dimension(n) :: piv
cf2py integer intent(hide),depend(a) :: n = shape(a,0)
cf2py check(shape(a,0)==shape(a,1)) :: a
cf2py callprotoargument double*,double*,int*,int*,int*
      external ddet_c
      call ddet_c(det,a,n,piv,info)
      end

      subroutine sdet_c(det,a,n,piv,info)
      integer n,piv(n),i
      real det,a(n,n)
cf2py intent(in,copy) :: a
cf2py intent(out) :: det,info
cf2py integer intent(hide,cache),depend(n),dimension(n) :: piv
cf2py integer intent(hide),depend(a) :: n = shape(a,0)
cf2py check(shape(a,0)==shape(a,1)) :: a
cf2py callprotoargument float*,float*,int*,int*,int*
      external sgetrf
      call sgetrf(n,n,a,n,piv,info)
      det = 0e0
      if (info.ne.0) then
         return
      endif
      det = 1e0
      do 10,i=1,n
         if (piv(i).ne.i) then
            det = -det * a(i,i)
         else
            det = det * a(i,i)
         endif
 10   continue
      end

      subroutine sdet_r(det,a,n,piv,info)
      integer n,piv(n)
      real det,a(n,n)
cf2py intent(c,in,copy) :: a
cf2py intent(out) :: det,info
cf2py integer intent(hide,cache),depend(n),dimension(n) :: piv
cf2py integer intent(hide),depend(a) :: n = shape(a,0)
cf2py check(shape(a,0)==shape(a,1)) :: a
cf2py callprotoargument float*,float*,int*,int*,int*
      external sdet_c
      call sdet_c(det,a,n,piv,info)
      end

      subroutine zdet_c(det,a,n,piv,info)
      integer n,piv(n),i
      complex*16 det,a(n,n)
cf2py intent(in,copy) :: a
cf2py intent(out) :: det,info
cf2py integer intent(hide,cache),depend(n),dimension(n) :: piv
cf2py integer intent(hide),depend(a) :: n = shape(a,0)
cf2py check(shape(a,0)==shape(a,1)) :: a
cf2py callprotoargument complex_double*,complex_double*,int*,int*,int*
      external zgetrf
      call zgetrf(n,n,a,n,piv,info)
      det = (0d0,0d0)
      if (info.ne.0) then
         return
      endif
      det = (1d0,0d0)
      do 10,i=1,n
         if (piv(i).ne.i) then
            det = -det * a(i,i)
         else
            det = det * a(i,i)
         endif
 10   continue
      end

      subroutine zdet_r(det,a,n,piv,info)
      integer n,piv(n)
      complex*16 det,a(n,n)
cf2py intent(c,in,copy) :: a
cf2py intent(out) :: det,info
cf2py integer intent(hide,cache),depend(n),dimension(n) :: piv
cf2py integer intent(hide),depend(a) :: n = shape(a,0)
cf2py check(shape(a,0)==shape(a,1)) :: a
cf2py callprotoargument complex_double*,complex_double*,int*,int*,int*
      external zdet_c
      call zdet_c(det,a,n,piv,info)
      end

      subroutine cdet_c(det,a,n,piv,info)
      integer n,piv(n),i
      complex det,a(n,n)
cf2py intent(in,copy) :: a
cf2py intent(out) :: det,info
cf2py integer intent(hide,cache),depend(n),dimension(n) :: piv
cf2py integer intent(hide),depend(a) :: n = shape(a,0)
cf2py check(shape(a,0)==shape(a,1)) :: a
cf2py callprotoargument complex_float*,complex_float*,int*,int*,int*
      external cgetrf
      call cgetrf(n,n,a,n,piv,info)
      det = (0e0,0e0)
      if (info.ne.0) then
         return
      endif
      det = (1e0,0e0)
      do 10,i=1,n
         if (piv(i).ne.i) then
            det = -det * a(i,i)
         else
            det = det * a(i,i)
         endif
 10   continue
      end

      subroutine cdet_r(det,a,n,piv,info)
      integer n,piv(n)
      complex det,a(n,n)
cf2py intent(c,in,copy) :: a
cf2py intent(out) :: det,info
cf2py integer intent(hide,cache),depend(n),dimension(n) :: piv
cf2py integer intent(hide),depend(a) :: n = shape(a,0)
cf2py check(shape(a,0)==shape(a,1)) :: a
cf2py callprotoargument complex_float*,complex_float*,int*,int*,int*
      external cdet_c
      call cdet_c(det,a,n,piv,info)
      end


module AB_matrix_fct

contains

!z=matmul(aij,s)  z=multiply(AB,s(:,:))  matmul for AB matrix

function multiply(AB,s) result (z)
 implicit none
 INTEGER, PARAMETER :: wp = KIND(0.0D0) ! working precision
 REAL (wp) :: AB(:,:),s(:,:)
 REAL(wp) :: z(size(s,1),size(s,2))
 INTEGER :: i,j,k
 INTEGER :: n, KU
   KU=(size(AB,1)-1)/2
   n=size(AB,2)
   z=0
    do j=1,n
      do i=1,2*KU+1
       z(j,:)=z(j,:)+AB(i,j)*s(1+mod(N+i+j-2-KU,N),:)
      end do
   end do
 end function

! CD=ColumnConvert(AB)  makes a LAPACK band matrix compatible with dgbsv and KU=KL out of periodic AB matrix

 function ColumnConvert(AB) result (CD)
 implicit none
 INTEGER, PARAMETER :: wp = KIND(0.0D0) ! working precision
 REAL (wp) :: AB(:,:)
 REAL(wp) :: CD((3*size(AB,1)-1)/2,size(AB,2))
 INTEGER :: i,j,m
 INTEGER :: n, KU
   m=size(AB,1)
   KU=(m-1)/2
   n=size(AB,2)
   CD=0
    do j=1,n
      do i=1,2*KU+1
       CD(i+KU,j)=AB(m-i+1,1+mod(N+i+j+KU-m-1,n))
      end do
   end do
 end function

 ! AB=RowConvert(CD)  makes a periodic AB matrix out of a LAPACK band matrix compatible with dgbsv and KU=KL

 function RowConvert(CD) result (AB)
 implicit none
 INTEGER, PARAMETER :: wp = KIND(0.0D0) ! working precision
 REAL (wp) :: CD(:,:)
 REAL(wp) :: AB((2*size(CD,1)+1)/3,size(CD,2))
 INTEGER :: i,j,m
 INTEGER :: n, KU
   m=(2*size(CD,1)+1)/3
   KU=(m-1)/2
   n=size(CD,2)
   AB=0
    do j=1,n
      do i=1,2*KU+1
       AB(m-i+1,1+mod(N+i+j+KU-m-1,n))=CD(i+KU,j)
      end do
   end do
 end function

end module


module svd_lib
 use nan_lib
 implicit none
 interface svd
  module procedure d_svd, z_svd
 end interface

contains
 subroutine d_svd(a,u,v,s,tol,rmax,err,info)
  implicit none
  real(8),intent(in) :: a(:,:)
  real(8),pointer :: u(:,:),v(:,:),s(:)
  real(8),intent(in),optional :: tol
  integer,intent(in),optional :: rmax
  real(8),intent(out),optional :: err
  integer,intent(out),optional :: info
  character(len=*),parameter :: subnam='d_svd'
  real(8),allocatable :: b(:,:),work(:),ss(:),uu(:,:),vv(:,:)
  integer :: m,n,mn,lwork,ierr,r,i,j
  real(8),external :: dnrm2
  m=size(a,1); n=size(a,2); mn=min(m,n); lwork=256*max(m,n)
  allocate(uu(m,mn),vv(mn,n),ss(mn),b(m,n),work(lwork),stat=ierr)
  if(ierr.ne.0)then;write(*,*)subnam,': cannot allocate';stop;endif
  call dcopy(m*n,a,1,b,1)
  call dgesvd('s','s',m,n,b,m,ss,uu,m,vv,mn,work,lwork,ierr)
  if(present(info))info=ierr
  if(ierr.ne.0)then
   write(*,*)subnam,': dgesvd info: ',ierr
   if(ierr.lt.0)stop
   if(nan(a))then
    write(*,*) subnam,': NaNs detected in the input array'
    stop
   else
    write(*,*) subnam,': min/max element of input: ',minval(a),maxval(a)
   end if
   u=>null(); v=>null(); s=>null()
  else
   r=chop(ss,tol,rmax,err)
   if(present(err))err=err/dnrm2(mn,ss,1)
   allocate(u(m,r),v(n,r),s(r))
   call dcopy(m*r,uu,1,u,1)
   call dcopy(r,ss,1,s,1)
   forall(i=1:n,j=1:r)v(i,j)=vv(j,i)
  end if
  deallocate(uu,vv,ss,b,work)
 end subroutine
 subroutine z_svd(a,u,v,s,tol,rmax,err,info)
  implicit none
  double complex,intent(in) :: a(:,:)
  double complex,pointer :: u(:,:),v(:,:)
  real(8),pointer :: s(:)
  real(8),intent(in),optional :: tol
  integer,intent(in),optional :: rmax
  real(8),intent(out),optional :: err
  integer,intent(out),optional :: info
  character(len=*),parameter :: subnam='z_svd'
  double complex,allocatable :: b(:,:),work(:),uu(:,:),vv(:,:)
  real(8),allocatable :: ss(:),rwork(:)
  integer :: m,n,mn,lwork,ierr,r,i,j
  real(8),external :: dnrm2
  m=size(a,1); n=size(a,2); mn=min(m,n); lwork=256*max(m,n)
  allocate(uu(m,mn),vv(mn,n),ss(mn),b(m,n),work(lwork),rwork(lwork),stat=ierr)
  if(ierr.ne.0)then;write(*,*)subnam,': cannot allocate';stop;endif
  call zcopy(m*n,a,1,b,1)
  call zgesvd('s','s',m,n,b,m,ss,uu,m,vv,mn,work,lwork,rwork,ierr)
  if(present(info))info=ierr
  if(ierr.ne.0)then
   write(*,*)subnam,': zgesvd info: ',ierr
   if(ierr.lt.0)stop
   if (nan(a)) then
    write(*,*) subnam,': NaNs detected in the input array'
    stop
   end if
   u=>null(); v=>null(); s=>null()
  else
   r=chop(ss,tol,rmax,err)
   if(present(err))err=err/dnrm2(mn,ss,1)
   allocate(u(m,r),v(n,r),s(r))
   call zcopy(m*r,uu,1,u,1)
   call dcopy(r,ss,1,s,1)
   forall(i=1:n,j=1:r)v(i,j)=vv(j,i)
  end if
  deallocate(uu,vv,ss,b,work)
 end subroutine

 integer function chop(s,tol,rmax,err) result (r)
  implicit none
  real(8),intent(in) :: s(:)
  real(8),intent(in),optional :: tol
  integer,intent(in),optional :: rmax
  real(8),intent(out),optional :: err
  real(8) :: nrm,er,er2,bound
  real(8),external :: dnrm2
  r=size(s); er2=0.d0
  if(present(rmax))then
   if(rmax.lt.r)then
    er2=dot_product(s(rmax+1:r),s(rmax+1:r))
    r=rmax
   end if
  end if
  if(present(tol))then
   nrm=dnrm2(size(s),s,1)
   bound=tol*tol*nrm*nrm
   er=er2+s(r)*s(r)
   do while(er.lt.bound)
    er2=er; r=r-1; er=er+s(r)*s(r)
   end do
  end if
  if(present(err))err=dsqrt(er2)
  return
 end function

end module


program perfect_numbers

  use module_rational
  implicit none
  integer, parameter :: n_min = 2
  integer, parameter :: n_max = 2 ** 19 - 1
  integer :: n
  integer :: factor
  type (rational) :: sum

  do n = n_min, n_max
    sum = 1 // n
    factor = 2
    do
      if (factor * factor >= n) then
        exit
      end if
      if (modulo (n, factor) == 0) then
        sum = rational_simplify (sum + (1 // factor) + (factor // n))
      end if
      factor = factor + 1
    end do
    if (sum % numerator == 1 .and. sum % denominator == 1) then
      write (*, '(i0)') n
    end if
  end do

end program perfect_numbers


SUBROUTINE fmkdke(km,kp,c,ke,kd,theta)
!
! This subroutine builds up the 'coupled' stiffnesses ke and kd from
! the 'elastic' stiffness km, fluid stiffness kp and coupling matrix c.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::km(:,:),kp(:,:),c(:,:),theta
 REAL(iwp),INTENT(OUT)::ke(:,:),kd(:,:)
 INTEGER::ndof
 REAL::one=1.0_iwp
 ndof=SIZE(km,1)
 ke(:ndof,:ndof)=theta*km
 ke(:ndof,ndof+1:)=theta*c
 ke(ndof+1:,:ndof)=theta*TRANSPOSE(c)
 ke(ndof+1:,ndof+1:)=-theta**2*kp
 kd(:ndof,:ndof)=(theta-one)*km
 kd(:ndof,ndof+1:)=(theta-one)*c
 kd(ndof+1:,:ndof)=ke(ndof+1:,:ndof)
 kd(ndof+1:,ndof+1:)=theta*(one-theta)*kp
RETURN
END SUBROUTINE fmkdke


C  ***************************  HERON  *************************
C  function that computes the area of faces of each element
C   by applying  Heron's formula:
C   given a,b,c the length of the edge of a triangle,
C   set s=(a+b+c)/2 the formula is:
C    area = dsqrt(s*(s-a)*(s-b)*(s-c))
C
C **************************************************************
       real*8 function heron(xfac,yfac,zfac)
       implicit none
       integer j
       real*8 xfac(3), yfac(3), zfac(3), length(3)
       real*8 s

       do j=1,3
         length(j) =dsqrt( (xfac(j)- xfac(mod(j,3)+1) )**2 +
     1              (yfac(j) - yfac(mod(j,3)+1) )**2 +
     2              (zfac(j) - zfac(mod(j,3)+1) )**2  )
       end do
       s= ( length(1) + length(2) +length(3) )*0.5d0
       heron = s
       do j=1,3
         heron =heron*(s-length(j))
       end do
       heron = dsqrt(heron)
       return
       end


module comoving_nd_module

  use amrex_error_module
  use amrex_fort_module, only : rt => amrex_real

  contains

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_integrate_comoving_a(old_a,new_a,dt) &
         bind(C, name="fort_integrate_comoving_a")

        use fundamental_constants_module, only: Hubble_const
        use comoving_module             , only: comoving_h, comoving_OmM, &
                                                comoving_OmR, comoving_type

        implicit none

        real(rt), intent(in   ) :: old_a, dt
        real(rt), intent(  out) :: new_a

        real(rt), parameter :: xacc = 1.0d-8
        real(rt) :: H_0, OmL
        real(rt) :: Delta_t, prev_soln
        real(rt) :: start_a, end_a, start_slope, end_slope
        integer  :: iter, j, nsteps

        if (comoving_h .eq. 0.0d0) then
          new_a = old_a
          return
        endif

        H_0 = comoving_h * Hubble_const
        OmL = 1.d0 - comoving_OmM - comoving_OmR

        prev_soln = 2.0d0 ! 0<a<1 so a=2 will do as "wrong" solution
        do iter = 1, 11  ! max allowed iterations
          nsteps = 2**(iter-1)
          Delta_t = dt/nsteps
          end_a = old_a

          do j = 1, nsteps
            ! This uses RK2 to integrate the ODE:
            !   da / dt = H_0 * sqrt(OmM/a + OmR/a^2 + OmL*a^2)
            start_a = end_a

            ! Compute the slope at the old time
            if (comoving_type > 0) then
                start_slope = H_0*dsqrt(comoving_OmM/start_a + comoving_OmR/(start_a*start_a) + OmL*start_a**2)
            else
                start_slope = comoving_h
            end if

            ! Compute a provisional value of ln(a) at the new time
            end_a = start_a + start_slope * Delta_t

            ! Compute the slope at the new time
            if (comoving_type > 0) then
                end_slope = H_0*dsqrt(comoving_OmM/end_a + comoving_OmR/(end_a*end_a) + OmL*end_a**2)
            else
                end_slope = comoving_h
            end if

            ! Now recompute a at the new time using the average of the two slopes
            end_a = start_a + 0.5d0 * (start_slope + end_slope) * Delta_t
          enddo

          new_a  = end_a
          if (abs(1.0d0-new_a/prev_soln) .le. xacc) return
          prev_soln = new_a

        enddo

      end subroutine fort_integrate_comoving_a

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_integrate_comoving_a_to_z(old_a,z_value,dt) &
         bind(C, name="fort_integrate_comoving_a_to_z")

        use fundamental_constants_module, only: Hubble_const
        use comoving_module             , only: comoving_h, comoving_OmM, &
                                                comoving_OmR, comoving_type

        implicit none

        real(rt), intent(in   ) :: old_a, z_value
        real(rt), intent(inout) :: dt

        real(rt), parameter :: xacc = 1.0d-8
        real(rt) :: H_0, OmL
        real(rt) :: Delta_t
        real(rt) :: start_a, end_a, start_slope, end_slope
        real(rt) :: a_value
        integer  :: j, nsteps

        if (comoving_h .eq. 0.0d0) &
          call amrex_error("fort_integrate_comoving_a_to_z: Shouldn't be setting plot_z_values if not evolving a")

        H_0 = comoving_h * Hubble_const
        OmL = 1.d0 - comoving_OmM - comoving_OmR

        ! Translate the target "z" into a target "a"
        a_value = 1.d0 / (1.d0 + z_value)

        ! Use lots of steps if we want to nail the z_value
        nsteps = 1024

        ! We integrate a, but stop when a = a_value (or close enough)
        Delta_t = dt/nsteps
        end_a = old_a
        do j = 1, nsteps
            ! This uses RK2 to integrate the ODE:
            !   da / dt = H_0 * sqrt(OmM/a + OmR/a^2 + OmL*a^2)
            start_a = end_a

            ! Compute the slope at the old time
            if (comoving_type > 0) then
                start_slope = H_0*dsqrt(comoving_OmM/start_a + comoving_OmR/(start_a*start_a) + OmL*start_a**2)
            else
                start_slope = comoving_h
            end if

            ! Compute a provisional value of ln(a) at the new time
            end_a = start_a + start_slope * Delta_t

            ! Compute the slope at the new time
            if (comoving_type > 0) then
                end_slope = H_0*dsqrt(comoving_OmM/end_a + comoving_OmR/(end_a*end_a) + OmL*end_a**2)
            else
                end_slope = comoving_h
            end if

            ! Now recompute a at the new time using the average of the two slopes
            end_a = start_a + 0.5d0 * (start_slope + end_slope) * Delta_t

            ! We have crossed from a too small to a too big in this step
            if ( (end_a - a_value) * (start_a - a_value) < 0) then
                dt = ( (  end_a - a_value) * dble(j  ) + &
                       (a_value - start_a) * dble(j+1) ) / (end_a - start_a) * Delta_t
                exit
            end if
        end do

      end subroutine fort_integrate_comoving_a_to_z

! ! :::
! ! ::: ----------------------------------------------------------------
! ! :::

!       subroutine fort_get_omb(frac) &
!          bind(C, name="fort_get_omb")

!         use comoving_module, only: comoving_OmB, comoving_OmM

!         real(rt) :: frac

!         frac = comoving_OmB / comoving_OmM

!       end subroutine fort_get_omb

! ! :::
! ! ::: ----------------------------------------------------------------
! ! :::

!       subroutine fort_get_omm(omm) &
!          bind(C, name="fort_get_omm")

!         use comoving_module, only: comoving_OmM

!         real(rt) :: omm

!         omm = comoving_OmM

!       end subroutine fort_get_omm

! ! :::
! ! ::: ----------------------------------------------------------------
! ! :::

        subroutine fort_get_hubble(hubble) &
           bind(C, name="fort_get_hubble")

          use comoving_module, only: comoving_h

          real(rt) :: hubble

          hubble = comoving_h

        end subroutine fort_get_hubble

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_set_omb(omb) &
         bind(C, name="fort_set_omb")

        use comoving_module, only: comoving_OmB

        real(rt), intent(in) :: omb

        comoving_OmB = omb

      end subroutine fort_set_omb

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_set_omm(omm) &
         bind(C, name="fort_set_omm")

        use comoving_module, only: comoving_OmM

        real(rt), intent(in) :: omm

        comoving_OmM = omm

      end subroutine fort_set_omm

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_set_omr(omr) &
         bind(C, name="fort_set_omr")

        use comoving_module, only: comoving_OmR

        real(rt), intent(in) :: omr

        comoving_OmR = omr

      end subroutine fort_set_omr

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_set_hubble(hubble) &
         bind(C, name="fort_set_hubble")

        use comoving_module, only: comoving_h

        real(rt), intent(in) :: hubble

        comoving_h = hubble

      end subroutine fort_set_hubble

end module comoving_nd_module


program compute_pi
    use omp_lib
    implicit none
    integer, parameter :: num_iters = 1000
    integer :: i
    real :: x, pi_sum, dx, pi

    pi_sum = 0.0
    dx = 1.0/num_iters
    !$omp parallel private(x), shared(dx, pi_sum), default(none)
    !$omp do reduction(+:pi_sum) schedule(runtime)
    do i = 1, num_iters
        x = i*dx
        pi_sum = pi_sum + 1.0/(1.0 + x**2)
    end do
    !$end omp do
    !$omp end parallel
    pi = 4.0*pi_sum*dx
    print *, pi
end program compute_pi


C++--------------------------------------------------------------------
C Subroutine POLYFIT
C	Fits a polynomial to real*8 arrays XX and YY
C	Degree : KK (less than 9)
C YY = poly(XX)
C
C Contains:
C TEST_POLYFIT, POLYFIT, PREPPW, INVMAT, INTERCH, CALPOLY
C
C From now on, it is better (?) to use "polyfit.c" (JLP, Feb. 2007)
C
C JLP
C Version 07-09-90
C--------------------------------------------------------------------
	SUBROUTINE TEST_POLYFIT
C	PROGRAM TEST_POLYFIT
	PARAMETER(IDIM=50,NNMAX=50)
	REAL*8 XX(IDIM),YY(IDIM)
	REAL*8 A(NNMAX,NNMAX),B(NNMAX),C(NNMAX)
	REAL*8 XC(20),SDEV(20),ERR
	INTEGER*4 NPTS

	PRINT *,' First test:'
	PRINT *,' x1 + x2 + x3 = 1'
	PRINT *,' x1 + x2 + 2x3 = 2'
	PRINT *,' x1 + 2x2 + 2x3 = 1'
	A(1,1)=1.
	A(2,1)=1.
	A(3,1)=1.
	A(1,2)=1.
	A(2,2)=1.
	A(3,2)=2.
	A(1,3)=1.
	A(2,3)=2.
	A(3,3)=2.

	C(1)=1.
	C(2)=2.
	C(3)=1.

	NN=3
	IFAIL=-1
	CALL JLP_INVMAT(A,B,C,NN,NNMAX,IFAIL)

	PRINT *,' IFAIL=',IFAIL,' Solution should be: 1 -1 1'
	PRINT *,' B:',B(1),B(2),B(3)

	PRINT *,' Second test:'
	PRINT *,' x1 + x2 + x3 = 1'
	PRINT *,' 0.0001x2 + x3 = 1'
	PRINT *,'         9999.x3 = 10000.'
	A(1,1)=1.
	A(2,1)=1.
	A(3,1)=1.
	A(1,2)=0.
	A(2,2)=0.0001
	A(3,2)=1.
	A(1,3)=0.
	A(2,3)=0.
	A(3,3)=9999.

	C(1)=1.
	C(2)=1.
	C(3)=10000.

	NN=3
	IFAIL=-1
	CALL JLP_INVMAT(A,B,C,NN,NNMAX,IFAIL)

	PRINT *,' IFAIL=',IFAIL,' Solution should be: 1 -1 1'
	PRINT *,' B:',B(1),B(2),B(3)

	PRINT *,' Test of msq:   C0 + C1 X          (0.5+X) '
	XX(1)=1.
	YY(1)=1.5
	XX(2)=3.
	YY(2)=3.5
	XX(3)=4.
	YY(3)=4.5
	XX(4)=6.
	YY(4)=6.5
	XX(5)=7.
	YY(5)=7.5

	NPTS=5
	KK=1
	CALL POLYFIT(XX,YY,NPTS,KK,XC,SDEV,ERR)
	PRINT *,' IFAIL=',IFAIL,' Solution should be: 0.5 1.00'
	PRINT *,' XC: ',XC(1),XC(2)

	NPTS=5
	KK=2
	CALL POLYFIT(XX,YY,NPTS,KK,XC,SDEV,ERR)
	PRINT *,' IFAIL=',IFAIL,' Solution should be: 0.5 1.00 0.00'
	PRINT *,' XC: ',XC(1),XC(2),XC(3)

	PRINT *,' Test of msq:   C0 + C1 X + C2 X**2    0+X-X**2'
	XX(1)=0.
	YY(1)=0.
	XX(2)=1.
	YY(2)=0.
	XX(3)=2.
	YY(3)=-2.
	XX(4)=3.
	YY(4)=-6.
	XX(5)=4.
	YY(5)=-12.

	NPTS=5
	KK=2
	CALL POLYFIT(XX,YY,NPTS,KK,XC,SDEV,ERR)
	PRINT *,' IFAIL=',IFAIL,' Solution should be: 0. 1. -1.'
	PRINT *,' XC: ',XC(1),XC(2),XC(3)

	RETURN
	END

C***************************************************************************
C Subroutine POLYFIT(XX,YY,NPTS,KK,XC,SDEV,ERR)
C YY = poly(XX)
C
C KK: Order of the polynomial
C M : This integer variable contains the number of residuals.
C N : This integer variable contains the number of variables. With M >= N.
C XX and YY : arrays to be fitted by a polynomial
C
C XC : Array containing the parameters which we are minimizing with respect to.
C XC(I) is the coeff. of X**(I-1) (REAL*8)
C SDEV : standard deviation for the coeff XC(I) (REAL*8).
C ERR : mean deviation of the fit (REAL*8)
C
C FSUMSQ : sum of the squares of the final point.
C***************************************************************************
	SUBROUTINE POLYFIT(XX,YY,NPTS,KK,XC,SDEV,ERR)
	PARAMETER(IDIM=500,NNMAX=50)
	REAL*8 XX(*),YY(*),XC(20),SDEV(20)
	REAL*8 XX1(IDIM,20),FSUMSQ,YVAL,ERR
	REAL*8 A(NNMAX,NNMAX),B(NNMAX),C(NNMAX),SCALE
	INTEGER*4 PNTR1
	CHARACTER ANS*1

10	FORMAT(A)

	IF(NPTS.LE.KK)THEN
	  WRITE(6,32) NPTS,KK
32        FORMAT(' Fatal error in polyfit : too few points for the fit',
     1           /,' npoints = ',I5,' whereas polynomial order = ',I3)
	  STOP
	ENDIF

	IF(NPTS.GT.IDIM)THEN
	  WRITE(6,33) NPTS,IDIM
33        FORMAT(' Fatal error in polyfit : too many points for the fit',
     1           /,' npoints = ',I8,' whereas idim = ',I8)
	  STOP
	ENDIF

C Normalization of XX to avoid integer overflow:
	SCALE=1.
	DO I=1,NPTS
	  SCALE=MAX(ABS(XX(I)),SCALE)
	END DO
C
	DO I=1,NPTS
	  XX(I)=XX(I)/SCALE
	END DO
	PRINT *,' POLYFIT/ Internal X scale:',SCALE

C Preparing the array of the powers:
	NN=KK+1
	CALL JLP_PREPPW(XX,NPTS,XX1,IDIM,KK,ISTATUS)
	IF(ISTATUS.NE.0)THEN
	  PRINT *,' Fatal error in polyfit : order is too big'
	  STOP
	ENDIF

C Computing the coefficients of the normal equations:
	DO J=1,NN
C C vector:
	 C(J)=0.
	 DO L=1,NPTS
	   C(J)=C(J)+YY(L)*XX1(L,J)
	 END DO
C A matrix (symmetrical)
	  DO I=1,J
	   A(I,J)=0.
	    DO L=1,NPTS
	      A(I,J)=A(I,J)+XX1(L,J)*XX1(L,I)
	    END DO
	  END DO
	END DO

C A matrix (symmetrical)
	DO J=1,NN
	  DO I=J+1,NN
	   A(I,J)=A(J,I)
	  END DO
	END DO

C Inversion of a matrix with pivotal elements:
	IFAIL=0
	CALL JLP_INVMAT(A,B,C,NN,NNMAX,IFAIL)

C Transfer, taking SCALE into account:
	XC(1)=B(1)
	DO K=2,KK+1
	  XC(K)=B(K)/(SCALE**(K-1))
	END DO

C Errors:
	FSUMSQ=0.
	DO L=1,NPTS
C Going back to the initial value of XX:
	 XX(L)=XX(L)*SCALE
	 CALL CALPOLY(XX(L),YVAL,XC,KK)
	 FSUMSQ=FSUMSQ+(YVAL-YY(L))*(YVAL-YY(L))
	END DO
	FSUMSQ=FSUMSQ/FLOAT(NPTS)
	ERR=SQRT(FSUMSQ)/FLOAT(KK+1)

	RETURN
	END
C***********************************************************************
C Preparing the array of the powers:
C***********************************************************************
	SUBROUTINE JLP_PREPPW(XX,NPTS,XX1,IDIM,KK,ISTATUS)
	REAL*8 XX(NPTS),XX1(IDIM,*)
	INTEGER*4 ISTATUS

C To start the process:
	 DO I=1,NPTS
	  XX1(I,1)=1.
	 END DO

	DO K=2,KK+1
	 DO I=1,NPTS
	  XX1(I,K)=XX1(I,K-1)*XX(I)
C Check if there is a risk of overflow:
C (Will be squared in A matrix):
	  IF(ABS(XX1(I,K)).GT.1.E+18)THEN
	   WRITE(6,*)' POLYFIT/Error: overflow'
	   ISTATUS=1
	   RETURN
	  ENDIF
	 END DO
	END DO

	ISTATUS=0
	RETURN
	END
C***********************************************************************
C JLP_INVMAT
C Inversion of a matrix with pivotal elements:
C AB=C
C
C***********************************************************************
	SUBROUTINE JLP_INVMAT(A,B,C,NN,NNMAX,IFAIL)
	REAL*8 A(NNMAX,NNMAX),B(NNMAX),C(NNMAX),AA,APIVOT,EPSILON

	EPSILON=1.E-12

C------------------
C FIRST STEP
C Loop on the rows, to obtain a triangular matrix:
	DO J=1,NN

C Partial pivoting: look for the biggest coefficient:
	  JPIVOT=J
	  DO JJ=J+1,NN
	    IF(ABS(A(J,JJ)).GT.ABS(A(J,JPIVOT)))THEN
	     JPIVOT=JJ
	    ENDIF
	  END DO

C When found, interchange rows JPIVOT and J:
	IF(JPIVOT.NE.J) CALL INTERCH(A,C,NN,NNMAX,JPIVOT,J)

C After this, test if pivotal element is too small:
	IF(ABS(A(J,J)).LT.EPSILON)THEN
	   WRITE(6,23)
23	   FORMAT(' JLP_INVMAT/Pivotal element too small')
	   IF(IFAIL.NE.-1)THEN
	     WRITE(6,24)
24	     FORMAT(' JLP_INVMAT/Fatal error')
	     STOP
	   ELSE
	     IFAIL=2
	     RETURN
	   ENDIF
	ENDIF

C When OK, divide all the coefficients of this row by the pivot:
	APIVOT=A(J,J)
	DO I=J,NN
	  A(I,J)=A(I,J)/APIVOT
	END DO
	C(J)=C(J)/APIVOT

C Then subtract this row to all the following rows (to obtain a triangular
C matrix in the end...)
	DO JJ=J+1,NN
	  AA=A(J,JJ)
	  IF(ABS(AA).GT.EPSILON)THEN
	    DO I=J,NN
	      A(I,JJ)=A(I,JJ)/AA-A(I,J)
	    END DO
	    C(JJ)=C(JJ)/AA-C(J)
	  ENDIF
	END DO

	END DO

C------------------
C SECOND STEP
C Inverse triangular matrix with all pivotal elements equal to 1. :
	DO J=NN,1,-1
	  B(J)=C(J)
	  DO I=NN,J+1,-1
	   B(J)=B(J)-A(I,J)*B(I)
	  END DO
	END DO

	IFAIL=0
	RETURN
	END
C*************************************************************
	SUBROUTINE INTERCH(A,C,NN,NNMAX,JNEW,JOLD)
	REAL*8 A(NNMAX,NNMAX),AA
	REAL*8 C(NNMAX),CC

	DO I=1,NN
	  AA=A(I,JNEW)
	  A(I,JNEW)=A(I,JOLD)
	  A(I,JOLD)=AA
	END DO

	CC=C(JNEW)
	C(JNEW)=C(JOLD)
	C(JOLD)=CC

	RETURN
	END
C*************************************************************
C Y = poly(X)
C*************************************************************
	SUBROUTINE CALPOLY(X,Y,XC,KDEGREE)
C For real*8
	REAL*8 X,Y
	REAL*8 XC(KDEGREE+1)
	Y=XC(1)
	WORK=1.

	DO I=2,KDEGREE+1
	WORK=WORK*X
	Y=Y+WORK*XC(I)
	END DO

	RETURN
	END


c     program DRCGEFSC
c>> 2001-05-22 DRCGEFSC Krogh Minor change for making .f90 version.
c>> 1992-03-18 CLL Declaring all integers.
c>> 1988-05-11 DRCGEFSC Lawson  Initial Code.
c        Demo driver for CGEFSC.  Solution of square nonsingular system
c     of linear equations having complex elements.
c     S. Y. Chiu, JPL, 1987.  C. L. Lawson, JPL, May 1988.
c     ------------------------------------------------------------------
      integer I, J, NMAX
      parameter (NMAX=3)
      complex   A(3,3), B(3,1), Z(NMAX)
      real      RCOND
      integer   IPVT(NMAX)
      data (A(1,J),J=1,3) / (0.579E0,0.735E0), (0.394E0,0.537E0),
     *                      (0.915E0,0.143E0) /
      data (A(2,J),J=1,3) / (0.795E0,0.430E0), (0.226E0,0.384E0),
     *                      (0.868E0,0.494E0) /
      data (A(3,J),J=1,3) / (0.141E0,0.207E0), (0.329E0,0.635E0),
     *                      (0.286E0,0.971E0) /
      data (B(I,1),I=1,3) / (-2.405E0,-4.735E0), (3.87E0,-3.08E0),
     *                      (4.231E0,-0.213E0) /
c     ------------------------------------------------------------------
      call CGEFSC(A,NMAX,NMAX,B,NMAX,1,IPVT,RCOND,Z)
      print*,'DRCGEFSC..  Demo driver for CGEFSC.'
      print*,'True solution is (2,4), (-5,5), (3,-9)'
      print*,'Computed solution:'
      do 40 I = 1,3
        print 100, I, B(I,1)
  40  continue
      print '(1x/1x,a,f7.4)','RCOND = ', RCOND
  100 format(1x,'X(',I1,') =',' (',g15.8,',',g15.8,')')
      end


!!----------------------------
!!	returns the root of the function func
!!	taken from Numerical Recipes
!!----------------------------
	MODULE DM_num

	contains

	FUNCTION zbrent(func,x1,x2,tol)
	USE nrtype; USE nrutil, ONLY : nrerror
	IMPLICIT NONE
	REAL(DP), INTENT(IN) :: x1,x2,tol
	REAL(DP), DIMENSION(4) :: zbrent !  = [ Tx1, emom1, Tx2, emom2 ], Tx1 is the best root
	INTERFACE
		FUNCTION func(x)
		USE nrtype
		IMPLICIT NONE
		REAL(DP), INTENT(IN) :: x
		REAL(DP) :: func
		END FUNCTION func
	END INTERFACE
	INTEGER(I4B), PARAMETER :: ITMAX=100
	REAL(DP), PARAMETER :: EPS=epsilon(x1)
	INTEGER(I4B) :: iter
	REAL(DP) :: a,b,c,d,e,fa,fb,fc,p,q,r,s,tol1,xm
	a=x1
	b=x2
	fa=func(a)
	fb=func(b)
	if ((fa > 0.0 .and. fb > 0.0) .or. (fa < 0.0 .and. fb < 0.0)) THEN
!		call nrerror('root must be bracketed for zbrent')
!		instead of exiting run, increase lower limit and try again
		zbrent = [-1.0D0, 0.0D0, 0.0D0, 0.0D0]
		RETURN
	ENDIF
	c=b
	fc=fb
	do iter=1,ITMAX
		if ((fb > 0.0 .and. fc > 0.0) .or. (fb < 0.0 .and. fc < 0.0)) then
			c=a
			fc=fa
			d=b-a
			e=d
		end if
		if (abs(fc) < abs(fb)) then
			a=b
			b=c
			c=a
			fa=fb
			fb=fc
			fc=fa
		end if
		tol1=2.0_dp*EPS*abs(b)+0.5_dp*tol
		xm=0.5_dp*(c-b)
		if (abs(xm) <= tol1 .or. fb == 0.0) then
			! Root (b) has been found.
			! Return this root plus the root from the other interval
			! (and both function evaluations).
			! This will be a or c depending on the signs of fa, fb, and fc.
			! The second root will be used to approximate the emoment
			! equation with a straight line so that a more accurate
			! root can be found when the extra energy is "too high".
			IF ( SIGN(1.0D0,fb) .EQ. -SIGN(1.0D0,fa) ) THEN
				zbrent = [b, fb, a, fa]
			ELSE IF ( SIGN(1.0D0,fb) .EQ. -SIGN(1.0D0,fc) ) THEN
				zbrent = [b, fb, c, fc]
			ELSE
				WRITE(*,*) "---***--- ALL ZBRENT ROOTS HAVE THE SAME SIGN ---***---"
				IF ( ABS(fa) .LT. ABS(fc) ) THEN
					zbrent = [b, fb, a, fa]
				ELSE
					zbrent = [b, fb, c, fc]
				END IF
			END IF
			! zbrent=b
			RETURN
		end if
		if (abs(e) >= tol1 .and. abs(fa) > abs(fb)) then
			s=fb/fa
			if (a == c) then
				p=2.0_dp*xm*s
				q=1.0_dp-s
			else
				q=fa/fc
				r=fb/fc
				p=s*(2.0_dp*xm*q*(q-r)-(b-a)*(r-1.0_dp))
				q=(q-1.0_dp)*(r-1.0_dp)*(s-1.0_dp)
			end if
			if (p > 0.0) q=-q
			p=abs(p)
			if (2.0_dp*p  <  min(3.0_dp*xm*q-abs(tol1*q),abs(e*q))) then
				e=d
				d=p/q
			else
				d=xm
				e=d
			end if
		else
			d=xm
			e=d
		end if
		a=b
		fa=fb
		b=b+merge(d,sign(tol1,xm), abs(d) > tol1 )
		fb=func(b)
	end do
	call nrerror('zbrent: exceeded maximum iterations')
	zbrent=[b, 0.0D0, 0.0D0, 0.0D0]
	END FUNCTION zbrent

	END MODULE DM_num


program ch1302
    ! Date Calculation
    implicit none

    integer :: year, month, day
    integer :: n, t

    print *, 'year, followed by day within year'
    read *, year, n
    if (mod(year,4)/=0) then
        t = 0
    elseif (mod(year,100)/=0) then
        t = 1
    elseif (mod(year,400)/=0) then
        t = 0
    else
        t = 1
    end if
    if (n>59+t) then
        day = n+2-t
    else
        day = n
    end if
    month = (day+91)*100/3055
    day = (day+91)-(month*3055)/100
    month = month-2
    print *, 'calendar date is ', day, month, year
end program


! Copyright 2015 Andrew Dawson, Peter Dueben
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

PROGRAM lorenz63
! A reference double-precision Lorenz '63 model.
!

    IMPLICIT NONE

    INTEGER, PARAMETER :: REAL_KIND = kind(1.0d0)

    ! Time-stepping parameters.
    REAL(KIND=REAL_KIND) :: t
    REAL(KIND=REAL_KIND) :: time_start = 0
    REAL(KIND=REAL_KIND) :: time_stop = 5
    REAL(KIND=REAL_KIND) :: dt = 0.01

    ! Lorenz 63 system parameters.
    REAL(KIND=REAL_KIND) :: sigma
    REAL(KIND=REAL_KIND) :: rho
    REAL(KIND=REAL_KIND) :: beta

    ! Array to store the 3d coordinate of the current system state.
    REAL(KIND=REAL_KIND), DIMENSION(3) :: x

    ! Runge-Kutta parameters.
    REAL(KIND=REAL_KIND), DIMENSION(3) :: k1, k2, k3, k4

    ! Set the model parameters.
    sigma = 10
    rho = 28
    beta = 8.0_REAL_KIND / 3.0_REAL_KIND

    ! Set the initial state.
    t = time_start
    x = (/ 1.508870_REAL_KIND, -1.531271_REAL_KIND, 25.46091_REAL_KIND /)

    ! Loop over time evaluating the model state (x).
    WRITE (*, '(F19.15, "    ", F19.15, "    ", F19.15)') x
    DO WHILE (t <= time_stop)
        k1 = f(x, sigma, rho, beta)
        k2 = f(x + 0.5_REAL_KIND * dt * k1, sigma, rho, beta)
        k3 = f(x + 0.5_REAL_KIND * dt * k2, sigma, rho, beta)
        k4 = f(x + dt * k3, sigma, rho, beta)
        x = x + dt * (k1 + 2 * (k2 + k3) + k4) / 6.0_REAL_KIND
        t = t + dt
        WRITE (*, '(F19.15, "    ", F19.15, "    ", F19.15)') x
    END DO

CONTAINS

    FUNCTION f (x, sigma, rho, beta)
    ! Update the Runge-Kutta parameters.
    !
        IMPLICIT NONE
        REAL(KIND=REAL_KIND), DIMENSION(3), INTENT(IN) :: x
        REAL(KIND=REAL_KIND),               INTENT(IN) :: sigma
        REAL(KIND=REAL_KIND),               INTENT(IN) :: rho
        REAL(KIND=REAL_KIND),               INTENT(IN) :: beta
        REAL(KIND=REAL_KIND), DIMENSION(3) :: f
        f = (/ sigma * (x(2) - x(1)), &
               x(1) * (rho - x(3)) - x(2), &
               x(1) * x(2) - beta * x(3) /)
    END FUNCTION f

END PROGRAM


subroutine getnorm(v1,v2,mn,norm)
  implicit none

  integer :: i,mn
  real(8) :: v1(mn),v2(mn),norm

  norm = 0.0
  do i=1,mn
     norm =  norm + v1(i)*v2(i)
  enddo

  return
end


subroutine phasefield_init(meqn,mbc,mx,my, &
        xlower,ylower,dx,dy,q)
    implicit none

    integer meqn,mbc,mx,my
    double precision xlower, ylower,dx,dy

    double precision q(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn)

    integer i,j
    double precision xlow, ylow, w

    do j = 1-mbc,my+mbc
        do i = 1-mbc,mx+mbc
            xlow = xlower + (i-1)*dx
            ylow = ylower + (j-1)*dy

            call cellave(xlow,ylow,dx,dy,w)
            q(i,j,1) = w-1.d0
            q(i,j,2) = 1-w
        enddo
    enddo

    return
end   subroutine phasefield_init

double precision function fdisc(x,y)
    implicit none

    double precision x,y

    DOUBLE PRECISION S, alpha, m, xi, k, gamma
    COMMON /comm_parms/ S, alpha, m, xi, k, gamma

    DOUBLE PRECISION r0, x0, y0
    COMMON /comm_init/ r0, x0, y0

    double precision r, rp, theta

    r = sqrt((x-x0)**2 + (y-y0)**2)
    theta = atan2(y - y0,x - x0)
    rp = r0*(1.d0 + gamma*cos(k*theta))
    fdisc = r - rp

end function fdisc