module gmdpd_f

implicit none
contains

real(8) function randd()
    call random_number(randd)
end function

pure function wr(nr)
    real(8), intent(in) :: nr
    real(8) :: wr
    wr = 0.0
    if (nr <= 1.0) then
        wr = 1.0 - nr
    endif
end function

pure function wdd(nr, rd)
    real(8), intent(in) :: nr, rd
    real(8) :: wdd
    wdd = 0.0
    if (nr <= rd) then
        wdd = 1.0 - nr/rd
    endif
end function

function gaussnum() result (y)
    real(8) :: x1, x2, w, y
    w = 2.0
    do while (w >= 1.0)
        x1 = 2.0 * randd() - 1.0
        x2 = 2.0 * randd() - 1.0
        w = x1**2 + x2**2
    enddo

    w = sqrt((-2.0 * log(w)) / w)
    y = x1 * w
end function

function local_density(X, bl, nbt, ip_rd, n_rho, box) result (rho2)
    ! -----
    ! X: position matrix
    ! bl: vector of bead types
    ! nbt: number of bead types
    ! ip_rd: manybody cutoff, constant w.r.t. bead type
    ! -----
    integer, intent(in) :: bl(:), nbt
    real(8), intent(in) :: X(:, :), ip_rd(:, :), n_rho(:, :), box(3, 3)
    integer :: i, j, N
    real(8) :: rij(3), g(3), inv_box(3, 3), d_rho, pi, rd, nrm, nri
    real(8) :: rho2(size(X, 1), nbt)
    N = size(X, 1)
    g = 0.0
    inv_box = 0.0
    rho2 = 0.0
    pi = 4.0 * atan(1.0)
    rd = 0.0
    nrm = 0.0
    nri = 0.0

    forall (i = 1:3) inv_box(i, i) = 1.0 / box(i, i)

    do i = 1, N
        do j = 1, i-1
            rij = X(i, :) - X(j, :)
            g = matmul(inv_box, rij)
            g = g - nint(g)
            rij = matmul(box, g)

            rd = ip_rd(bl(i), bl(j))
            nri = n_rho(bl(i), bl(j))
            nrm = (nri+1.0)*(nri+2.0)*(nri+3.0) / (8.0*pi*rd*rd*rd)

            d_rho = nrm * wdd(norm2(rij), rd)**nri
            rho2(i, bl(j)) = rho2(i, bl(j)) + d_rho
            rho2(j, bl(i)) = rho2(j, bl(i)) + d_rho
        enddo
    enddo
end function

function compute_force_fun(X, V, rho2, bl, &
        ip_a, ip_b, ip_rd, n_wrap, n_rho, box, gama, kT, dt) result (F)
    integer, intent(in) :: bl(:)
    real(8), intent(in) :: X(:, :), V(:, :), rho2(:, :)
    real(8), intent(in) :: ip_a(:, :), ip_b, ip_rd(:, :), n_wrap(:), n_rho(:, :)
    real(8), intent(in) :: box(3, 3), gama, kT, dt
    real(8) :: g(3), rij(3), vij(3), inv_box(3, 3), fpair, a, nr
    real(8) :: rhoi, rhoj, rd, nrm, pi, nwi, nwj, nri
    integer :: i, j, N
    real(8) :: fcube(size(X, 1), size(X, 1), 3), F(size(X, 1), 3)
    N = size(X, 1)
    fcube = 0.0
    g = 0.0
    fpair = 0.0
    inv_box = 0.0
    rd = 0.0
    nrm = 0.0
    pi = 4.0 * atan(1.0)

    forall (i = 1:3) inv_box(i, i) = 1.0 / box(i, i)

    do i = 1, N
        do j = 1, i-1
            rij = X(i, :) - X(j, :)
            g = matmul(inv_box, rij)
            g = g - nint(g)
            rij = matmul(box, g)
            vij = V(i, :) - V(j, :)

            nr = norm2(rij)
            a = ip_a(bl(i), bl(j))
            rd = ip_rd(bl(i), bl(j))
            nwi = n_wrap(bl(i))
            nwj = n_wrap(bl(j))
            nri = n_rho(bl(i), bl(j))
            nrm = (nri+1.0)*(nri+2.0)*(nri+3.0) / (8.0*pi*rd*rd*rd)
            rhoi = rho2(i, bl(j))
            rhoj = rho2(j, bl(j))

            fpair = a * wr(nr) &
                + ip_b * (rhoi**(nwi-1.0) + rhoj**(nwj-1.0)) &
                    * nrm * wdd(nr, rd)**(nri-1.0) * nri / rd &
                - gama * wr(nr)**2 * dot_product(rij, vij) / nr &
                + sqrt(2*gama*kT) * wr(nr) * gaussnum() / sqrt(dt)
            fcube(i, j, :) = fpair / nr * rij(:)
            fcube(j, i, :) = -fcube(i, j, :)
        enddo
    enddo
    F = sum(fcube, 2)
end function

subroutine compute_force(F, vir, sigma, &
        X, V, rho2, bl, ip_a, ip_b, ip_rd, n_wrap, n_rho, &
        box, gama, kT, dt)
    real(8), intent(inout) :: F(:, :), vir, sigma(3)
    integer, intent(in) :: bl(:)
    real(8), intent(in) :: X(:, :), V(:, :), rho2(:, :)
    real(8), intent(in) :: ip_a(:, :), ip_b, ip_rd(:, :), n_wrap(:), n_rho(:, :)
    real(8), intent(in) :: box(3, 3), gama, kT, dt
    real(8) :: g(3), rij(3), vij(3), inv_box(3, 3), volume, fpair, a, nr
    real(8) :: rhoi, rhoj, rd, nrm, pi, nwi, nwj, nri
    integer :: i, j, N
    real(8) :: fcube(size(X, 1), size(X, 1), 3)
    N = size(X, 1)
    fcube = 0.0
    g = 0.0
    fpair = 0.0
    inv_box = 0.0
    rd = 0.0
    nwi = 0.0
    nwj = 0.0
    nri = 0.0
    nrm = 0.0
    volume = 1.0
    pi = 4.0 * atan(1.0)

    vir = 0.0
    sigma = 0.0
    F = 0.0

    forall (i = 1:3) inv_box(i, i) = 1.0 / box(i, i)
    do i = 1, 3
        volume = volume * box(i, i)
    enddo

    do i = 1, N
        do j = 1, i-1
            rij = X(i, :) - X(j, :)
            g = matmul(inv_box, rij)
            g = g - nint(g)
            rij = matmul(box, g)
            vij = V(i, :) - V(j, :)

            nr = norm2(rij)
            a = ip_a(bl(i), bl(j))
            rd = ip_rd(bl(i), bl(j))
            nwi = n_wrap(bl(i))
            nwj = n_wrap(bl(j))
            nri = n_rho(bl(i), bl(j))
            nrm = (nri+1.0)*(nri+2.0)*(nri+3.0) / (8.0*pi*rd*rd*rd)
            rhoi = rho2(i, bl(j))
            rhoj = rho2(j, bl(j))

            fpair = a * wr(nr) &
                + ip_b * (rhoi**(nwi-1.0) + rhoj**(nwj-1.0)) &
                    * nrm * wdd(nr, rd)**(nri-1.0) * nri / rd &
                - gama * wr(nr)**2 * dot_product(rij, vij) / nr &
                + sqrt(2*gama*kT) * wr(nr) * gaussnum() / sqrt(dt)
            fcube(i, j, :) = fpair / nr * rij(:)
            fcube(j, i, :) = -fcube(i, j, :)

            vir = vir + dot_product(fcube(i, j, :), rij(:))
            sigma(:) = sigma(:) + fcube(i, j, :) * rij(:)
        enddo
    enddo

    do i = 1, N  ! kinetic term of the stress tensor
        sigma(:) = sigma(:) + V(i, :) * V(i, :)
    enddo

    sigma = sigma / volume
    F = sum(fcube, 2)
end subroutine

function compute_force_cube(X, V, rho2, bl, &
        ip_a, ip_b, ip_rd, n_wrap, n_rho, &
        box, gama, kT, dt) result (fcube)
    integer, intent(in) :: bl(:)
    real(8), intent(in) :: X(:, :), V(:, :), rho2(:, :)
    real(8), intent(in) :: ip_a(:, :), ip_b, ip_rd(:, :), n_wrap(:), n_rho(:, :)
    real(8), intent(in) :: box(3, 3), gama, kT, dt
    real(8) :: g(3), rij(3), vij(3), inv_box(3, 3), fpair, a, nr
    real(8) :: rhoi, rhoj, rd, nrm, pi, nwi, nwj, nri
    integer :: i, j, N
    real(8) :: fcube(size(X, 1), size(X, 1), 3)
    N = size(X, 1)
    fcube = 0.0
    g = 0.0
    fpair = 0.0
    inv_box = 0.0
    rd = 0.0
    nwi = 0.0
    nwj = 0.0
    nri = 0.0
    nrm = 0.0
    nrm = 0.0
    pi = 4.0 * atan(1.0)

    forall (i = 1:3) inv_box(i, i) = 1.0 / box(i, i)

    do i = 1, N
        do j = 1, i-1
            rij = X(i, :) - X(j, :)
            g = matmul(inv_box, rij)
            g = g - nint(g)
            rij = matmul(box, g)
            vij = V(i, :) - V(j, :)

            nr = norm2(rij)
            a = ip_a(bl(i), bl(j))
            rd = ip_rd(bl(i), bl(j))
            nwi = n_wrap(bl(i))
            nwj = n_wrap(bl(j))
            nri = n_rho(bl(i), bl(j))
            nrm = (nri+1.0)*(nri+2.0)*(nri+3.0) / (8.0*pi*rd*rd*rd)
            rhoi = rho2(i, bl(j))
            rhoj = rho2(j, bl(j))

            fpair = a * wr(nr) &
                + ip_b * (rhoi**(nwi-1.0) + rhoj**(nwj-1.0)) &
                    * nrm * wdd(nr, rd)**(nri-1.0) * nri / rd &
                - gama * wr(nr)**2 * dot_product(rij, vij) / nr &
                + sqrt(2*gama*kT) * wr(nr) * gaussnum() / sqrt(dt)
            fcube(i, j, :) = fpair / nr * rij(:)
            fcube(j, i, :) = -fcube(i, j, :)
        enddo
    enddo
end function

function compute_pe(X, rho2, bl, ip_a, ip_b, n_wrap, box) result (pe)
    integer, intent(in) :: bl(:)
    real(8), intent(in) :: X(:, :), rho2(:, :)
    real(8), intent(in) :: ip_a(:, :), ip_b, n_wrap(:), box(3, 3)
    integer :: i, j, N
    real(8) :: pe, rij(3), g(3), inv_box(3, 3), pi, nwi
    pe = 0.0
    N = size(X, 1)
    inv_box = 0.0
    pi = 4.0 * atan(1.0)
    nwi = 0.0

    forall (i = 1:3) inv_box(i, i) = 1.0 / box(i, i)

    do i = 1, n
        do j = 1, i-1
            rij = X(i, :) - X(j, :)
            g = matmul(inv_box, rij)
            g = g - nint(g)
            rij = matmul(box, g)
            pe = pe + ip_a(bl(i), bl(j)) * wr(norm2(rij))**2 / 2.0
        enddo
    enddo

    do i = 1, n
        nwi = n_wrap(bl(i))
        pe = pe + ip_b * sum(rho2(i, :), 1)**nwi / nwi
    enddo
end function

function compute_ke(V) result (ke)
    real(8), intent(in) :: V(:, :)
    real(8) :: ke
    integer :: i, j, N
    ke = 0.0
    N = size(V, 1)

    do i = 1, N
        do j = 1, 3
            ke = ke + V(i, j) * V(i, j) / 2.0
        enddo
    enddo
end function

function init_pos(N, box) result(X)
    integer, intent(in) :: N
    real(8), intent(in) :: box(3, 3)
    real(8) :: X(N, 3)
    integer :: i, j

    do i = 1, N
        do j = 1, 3
            X(i, j) = randd() * box(j, j)
        enddo
    enddo
end function

function init_vel(N, kT) result(V)
    integer, intent(in) :: N
    real(8), intent(in) :: kT
    real(8) :: V(N, 3), Vcom(3)
    integer :: i, j

    do i = 1, N
        do j = 1, 3
            V(i, j) = gaussnum() * kT
        enddo
    enddo
    Vcom = sum(V, 1) / N
    do i = 1, N
        V(i, :) = V(i, :) - Vcom(:)
    enddo
end function

subroutine euler_step(X, V, rho2, bl, nbt, ip_a, ip_b, ip_rd, n_wrap, n_rho, &
    box, gama, kT, dt)
    real(8), intent(inout) :: X(:, :), V(:, :), rho2(:, :)
    real(8), intent(in) :: ip_a(:, :), ip_b, ip_rd(:, :), n_wrap(:), n_rho(:, :)
    integer, intent(in) :: bl(:), nbt
    real(8), intent(in) :: box(3, 3), gama, kT, dt
    real(8) :: F(size(X, 1), 3)
    F = 0.0

    rho2 = local_density(X, bl, nbt, ip_rd, n_rho, box)
    F = compute_force_fun(X, V, rho2, bl, ip_a, ip_b, ip_rd, n_wrap, n_rho, &
        box, gama, kT, dt)
    V(:, :) = V(:, :) + F(:, :) * dt
    X(:, :) = X(:, :) + V(:, :) * dt
end subroutine

subroutine verlet_step(X, V, F, rho2, bl, nbt, ip_a, ip_b, ip_rd, &
    n_wrap, n_rho, box, gama, kT, dt)
    real(8), intent(inout) :: X(:, :), V(:, :), F(:, :), rho2(:, :)
    real(8), intent(in) :: ip_a(:, :), ip_b, ip_rd(:, :), n_wrap(:), n_rho(:, :)
    integer, intent(in) :: bl(:), nbt
    real(8), intent(in) :: box(3, 3), gama, kT, dt
    real(8) :: V2(size(X, 1), 3)
    V2 = 0.0

    V2(:, :) = V(:, :) + 0.5 * F(:, :) * dt
    X(:, :) = X(:, :) + V2(:, :) * dt
    rho2 = local_density(X, bl, nbt, ip_rd, n_rho, box)
    F = compute_force_fun(X, V2, rho2, bl, ip_a, ip_b, ip_rd, n_wrap, n_rho, &
        box, gama, kT, dt)
    V(:, :) = V2(:, :) + 0.5 * F(:, :) * dt
end subroutine

subroutine print_mat(A)
    real(8), intent(in) :: A(:, :)
    integer :: M, N, i
    M = size(A, 1)
    N = size(A, 2)
    do i = 1, M
        print '(f5.3, " ", f5.3, " ", f5.3)', A(i, 1), A(i, 2), A(i, 3)
    enddo
end subroutine

end module


! Fast Fourier/Cosine/Sine Transform
!     dimension   :two
!     data length :power of 2
!     decimation  :frequency
!     radix       :split-radix, row-column
!     data        :inplace
!     table       :use
! subroutines
!     cdft2d: Complex Discrete Fourier Transform
!     rdft2d: Real Discrete Fourier Transform
!     ddct2d: Discrete Cosine Transform
!     ddst2d: Discrete Sine Transform
! necessary package
!     fftsg.f  : 1D-FFT package
!
!
! -------- Complex DFT (Discrete Fourier Transform) --------
!     [definition]
!         <case1>
!             X(k1,k2) = sum_j1=0^n1-1 sum_j2=0^n2-1 x(j1,j2) *
!                            exp(2*pi*i*j1*k1/n1) *
!                            exp(2*pi*i*j2*k2/n2),
!                            0<=k1<n1, 0<=k2<n2
!         <case2>
!             X(k1,k2) = sum_j1=0^n1-1 sum_j2=0^n2-1 x(j1,j2) *
!                            exp(-2*pi*i*j1*k1/n1) *
!                            exp(-2*pi*i*j2*k2/n2),
!                            0<=k1<n1, 0<=k2<n2
!         (notes: sum_j=0^n-1 is a summation from j=0 to n-1)
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call cdft2d(n1max, 2*n1, n2, 1, a, t, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call cdft2d(n1max, 2*n1, n2, -1, a, t, ip, w)
!     [parameters]
!         n1max  :row size of the 2D array (integer)
!         2*n1   :data length (integer)
!                 n1 >= 1, n1 = power of 2
!         n2     :data length (integer)
!                 n2 >= 1, n2 = power of 2
!         a(0:2*n1-1,0:n2-1)
!                :input/output data (real*8)
!                 input data
!                     a(2*j1,j2) = Re(x(j1,j2)),
!                     a(2*j1+1,j2) = Im(x(j1,j2)),
!                     0<=j1<n1, 0<=j2<n2
!                 output data
!                     a(2*k1,k2) = Re(X(k1,k2)),
!                     a(2*k1+1,k2) = Im(X(k1,k2)),
!                     0<=k1<n1, 0<=k2<n2
!         t(0:8*n2-1)
!                :work area (real*8)
!                 length of t >= 8*n2
!         ip(0:*):work area for bit reversal (integer)
!                 length of ip >= 2+sqrt(n)
!                 (n = max(n1, n2))
!                 ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:*) :cos/sin table (real*8)
!                 length of w >= max(n1/2, n2/2)
!                 w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call cdft2d(n1max, 2*n1, n2, -1, a, t, ip, w)
!         is
!             call cdft2d(n1max, 2*n1, n2, 1, a, t, ip, w)
!             do j2 = 0, n2 - 1
!                 do j1 = 0, 2 * n1 - 1
!                     a(j1, j2) = a(j1, j2) * (1.0d0 / n1 / n2)
!                 end do
!             end do
!         .
!
!
! -------- Real DFT / Inverse of Real DFT --------
!     [definition]
!         <case1> RDFT
!             R(k1,k2) = sum_j1=0^n1-1 sum_j2=0^n2-1 a(j1,j2) *
!                            cos(2*pi*j1*k1/n1 + 2*pi*j2*k2/n2),
!                            0<=k1<n1, 0<=k2<n2
!             I(k1,k2) = sum_j1=0^n1-1 sum_j2=0^n2-1 a(j1,j2) *
!                            sin(2*pi*j1*k1/n1 + 2*pi*j2*k2/n2),
!                            0<=k1<n1, 0<=k2<n2
!         <case2> IRDFT (excluding scale)
!             a(k1,k2) = (1/2) * sum_j1=0^n1-1 sum_j2=0^n2-1
!                            (R(j1,j2) *
!                            cos(2*pi*j1*k1/n1 + 2*pi*j2*k2/n2) +
!                            I(j1,j2) *
!                            sin(2*pi*j1*k1/n1 + 2*pi*j2*k2/n2)),
!                            0<=k1<n1, 0<=k2<n2
!         (notes: R(n1-k1,n2-k2) = R(k1,k2),
!                 I(n1-k1,n2-k2) = -I(k1,k2),
!                 R(n1-k1,0) = R(k1,0),
!                 I(n1-k1,0) = -I(k1,0),
!                 R(0,n2-k2) = R(0,k2),
!                 I(0,n2-k2) = -I(0,k2),
!                 0<k1<n1, 0<k2<n2)
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call rdft2d(n1max, n1, n2, 1, a, t, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call rdft2d(n1max, n1, n2, -1, a, t, ip, w)
!     [parameters]
!         n1max  :row size of the 2D array (integer)
!         n1     :data length (integer)
!                 n1 >= 2, n1 = power of 2
!         n2     :data length (integer)
!                 n2 >= 2, n2 = power of 2
!         a(0:n1-1,0:n2-1)
!                :input/output data (real*8)
!                 <case1>
!                     output data
!                         a(2*k1,k2) = R(k1,k2) = R(n1-k1,n2-k2),
!                         a(2*k1+1,k2) = I(k1,k2) = -I(n1-k1,n2-k2),
!                             0<k1<n1/2, 0<k2<n2,
!                         a(2*k1,0) = R(k1,0) = R(n1-k1,0),
!                         a(2*k1+1,0) = I(k1,0) = -I(n1-k1,0),
!                             0<k1<n1/2,
!                         a(0,k2) = R(0,k2) = R(0,n2-k2),
!                         a(1,k2) = I(0,k2) = -I(0,n2-k2),
!                         a(1,n2-k2) = R(n1/2,k2) = R(n1/2,n2-k2),
!                         a(0,n2-k2) = -I(n1/2,k2) = I(n1/2,n2-k2),
!                             0<k2<n2/2,
!                         a(0,0) = R(0,0),
!                         a(1,0) = R(n1/2,0),
!                         a(0,n2/2) = R(0,n2/2),
!                         a(1,n2/2) = R(n1/2,n2/2)
!                 <case2>
!                     input data
!                         a(2*j1,j2) = R(j1,j2) = R(n1-j1,n2-j2),
!                         a(2*j1+1,j2) = I(j1,j2) = -I(n1-j1,n2-j2),
!                             0<j1<n1/2, 0<j2<n2,
!                         a(2*j1,0) = R(j1,0) = R(n1-j1,0),
!                         a(2*j1+1,0) = I(j1,0) = -I(n1-j1,0),
!                             0<j1<n1/2,
!                         a(0,j2) = R(0,j2) = R(0,n2-j2),
!                         a(1,j2) = I(0,j2) = -I(0,n2-j2),
!                         a(1,n2-j2) = R(n1/2,j2) = R(n1/2,n2-j2),
!                         a(0,n2-j2) = -I(n1/2,j2) = I(n1/2,n2-j2),
!                             0<j2<n2/2,
!                         a(0,0) = R(0,0),
!                         a(1,0) = R(n1/2,0),
!                         a(0,n2/2) = R(0,n2/2),
!                         a(1,n2/2) = R(n1/2,n2/2)
!                 ---- output ordering ----
!                     call rdft2d(n1max, n1, n2, 1, a, t, ip, w)
!                     call rdft2dsort(n1max, n1, n2, 1, a)
!                     ! stored data is a(0:n1-1,0:n2+1):
!                     ! a(2*k1,k2) = R(k1,k2),
!                     ! a(2*k1+1,k2) = I(k1,k2),
!                     ! 0<=k1<=n1/2, 0<=k2<n2.
!                     ! the stored data is larger than the input data!
!                 ---- input ordering ----
!                     call rdft2dsort(n1max, n1, n2, -1, a)
!                     call rdft2d(n1max, n1, n2, -1, a, t, ip, w)
!         t(0:8*n2-1)
!                :work area (real*8)
!                 length of t >= 8*n2
!         ip(0:*):work area for bit reversal (integer)
!                 length of ip >= 2+sqrt(n)
!                 (n = max(n1/2, n2))
!                 ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:*) :cos/sin table (real*8)
!                 length of w >= max(n1/4, n2/2) + n1/4
!                 w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call rdft2d(n1max, n1, n2, 1, a, t, ip, w)
!         is
!             call rdft2d(n1max, n1, n2, -1, a, t, ip, w)
!             do j2 = 0, n2 - 1
!                 do j1 = 0, n1 - 1
!                     a(j1, j2) = a(j1, j2) * (2.0d0 / n1 / n2)
!                 end do
!             end do
!         .
!
!
! -------- DCT (Discrete Cosine Transform) / Inverse of DCT --------
!     [definition]
!         <case1> IDCT (excluding scale)
!             C(k1,k2) = sum_j1=0^n1-1 sum_j2=0^n2-1 a(j1,j2) *
!                            cos(pi*j1*(k1+1/2)/n1) *
!                            cos(pi*j2*(k2+1/2)/n2),
!                            0<=k1<n1, 0<=k2<n2
!         <case2> DCT
!             C(k1,k2) = sum_j1=0^n1-1 sum_j2=0^n2-1 a(j1,j2) *
!                            cos(pi*(j1+1/2)*k1/n1) *
!                            cos(pi*(j2+1/2)*k2/n2),
!                            0<=k1<n1, 0<=k2<n2
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call ddct2d(n1max, n1, n2, 1, a, t, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call ddct2d(n1max, n1, n2, -1, a, t, ip, w)
!     [parameters]
!         n1max  :row size of the 2D array (integer)
!         n1     :data length (integer)
!                 n1 >= 2, n1 = power of 2
!         n2     :data length (integer)
!                 n2 >= 2, n2 = power of 2
!         a(0:n1-1,0:n2-1)
!                :input/output data (real*8)
!                 output data
!                     a(k1,k2) = C(k1,k2), 0<=k1<n1, 0<=k2<n2
!         t(0:4*n2-1)
!                :work area (real*8)
!                 length of t >= 4*n2
!         ip(0:*):work area for bit reversal (integer)
!                 length of ip >= 2+sqrt(n)
!                 (n = max(n1/2, n2/2))
!                 ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:*) :cos/sin table (real*8)
!                 length of w >= max(n1*3/2, n2*3/2)
!                 w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call ddct2d(n1max, n1, n2, -1, a, t, ip, w)
!         is
!             do j1 = 0, n1 - 1
!                 a(j1, 0) = a(j1, 0) * 0.5d0
!             end do
!             do j2 = 0, n2 - 1
!                 a(0, j2) = a(0, j2) * 0.5d0
!             end do
!             call ddct2d(n1max, n1, n2, 1, a, t, ip, w)
!             do j2 = 0, n2 - 1
!                 do j1 = 0, n1 - 1
!                     a(j1, j2) = a(j1, j2) * (4.0d0 / n1 / n2)
!                 end do
!             end do
!         .
!
!
! -------- DST (Discrete Sine Transform) / Inverse of DST --------
!     [definition]
!         <case1> IDST (excluding scale)
!             S(k1,k2) = sum_j1=1^n1 sum_j2=1^n2 A(j1,j2) *
!                            sin(pi*j1*(k1+1/2)/n1) *
!                            sin(pi*j2*(k2+1/2)/n2),
!                            0<=k1<n1, 0<=k2<n2
!         <case2> DST
!             S(k1,k2) = sum_j1=0^n1-1 sum_j2=0^n2-1 a(j1,j2) *
!                            sin(pi*(j1+1/2)*k1/n1) *
!                            sin(pi*(j2+1/2)*k2/n2),
!                            0<k1<=n1, 0<k2<=n2
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call ddst2d(n1max, n1, n2, 1, a, t, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call ddst2d(n1max, n1, n2, -1, a, t, ip, w)
!     [parameters]
!         n1max  :row size of the 2D array (integer)
!         n1     :data length (integer)
!                 n1 >= 2, n1 = power of 2
!         n2     :data length (integer)
!                 n2 >= 2, n2 = power of 2
!         a(0:n1-1,0:n2-1)
!                :input/output data (real*8)
!                 <case1>
!                     input data
!                         a(j1,j2) = A(j1,j2), 0<j1<n1, 0<j2<n2,
!                         a(j1,0) = A(j1,n2), 0<j1<n1,
!                         a(0,j2) = A(n1,j2), 0<j2<n2,
!                         a(0,0) = A(n1,n2)
!                         (i.e. A(j1,j2) = a(mod(j1,n1),mod(j2,n2)))
!                     output data
!                         a(k1,k2) = S(k1,k2), 0<=k1<n1, 0<=k2<n2
!                 <case2>
!                     output data
!                         a(k1,k2) = S(k1,k2), 0<k1<n1, 0<k2<n2,
!                         a(k1,0) = S(k1,n2), 0<k1<n1,
!                         a(0,k2) = S(n1,k2), 0<k2<n2,
!                         a(0,0) = S(n1,n2)
!                         (i.e. S(k1,k2) = a(mod(k1,n1),mod(k2,n2)))
!         t(0:4*n2-1)
!                :work area (real*8)
!                 length of t >= 4*n2
!         ip(0:*):work area for bit reversal (integer)
!                 length of ip >= 2+sqrt(n)
!                 (n = max(n1/2, n2/2))
!                 ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:*) :cos/sin table (real*8)
!                 length of w >= max(n1*3/2, n2*3/2)
!                 w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call ddst2d(n1max, n1, n2, -1, a, t, ip, w)
!         is
!             do j1 = 0, n1 - 1
!                 a(j1, 0) = a(j1, 0) * 0.5d0
!             end do
!             do j2 = 0, n2 - 1
!                 a(0, j2) = a(0, j2) * 0.5d0
!             end do
!             call ddst2d(n1max, n1, n2, 1, a, t, ip, w)
!             do j2 = 0, n2 - 1
!                 do j1 = 0, n1 - 1
!                     a(j1, j2) = a(j1, j2) * (4.0d0 / n1 / n2)
!                 end do
!             end do
!         .
!
!
      subroutine cdft2d(n1max, n1, n2, isgn, a, t, ip, w)
      integer n1max, n1, n2, isgn, ip(0 : *), n, j
      real*8 a(0 : n1max - 1, 0 : n2 - 1), t(0 : 8 * n2 - 1),
     &    w(0 : *)
      n = max(n1, 2 * n2)
      if (n .gt. 4 * ip(0)) then
          call makewt(n / 4, ip, w)
      end if
      do j = 0, n2 - 1
          call cdft(n1, isgn, a(0, j), ip, w)
      end do
      call cdft2d_sub(n1max, n1, n2, isgn, a, t, ip, w)
      end
!
      subroutine rdft2d(n1max, n1, n2, isgn, a, t, ip, w)
      integer n1max, n1, n2, isgn, ip(0 : *), n, nw, nc, j
      real*8 a(0 : n1max - 1, 0 : n2 - 1), t(0 : 8 * n2 - 1),
     &    w(0 : *)
      n = max(n1, 2 * n2)
      nw = ip(0)
      if (n .gt. 4 * nw) then
          nw = n / 4
          call makewt(nw, ip, w)
      end if
      nc = ip(1)
      if (n1 .gt. 4 * nc) then
          nc = n1 / 4
          call makect(nc, ip, w(nw))
      end if
      if (isgn .lt. 0) then
          call rdft2d_sub(n1max, n1, n2, isgn, a)
          call cdft2d_sub(n1max, n1, n2, isgn, a, t, ip, w)
      end if
      do j = 0, n2 - 1
          call rdft(n1, isgn, a(0, j), ip, w)
      end do
      if (isgn .ge. 0) then
          call cdft2d_sub(n1max, n1, n2, isgn, a, t, ip, w)
          call rdft2d_sub(n1max, n1, n2, isgn, a)
      end if
      end
!
      subroutine rdft2dsort(n1max, n1, n2, isgn, a)
      integer n1max, n1, n2, isgn, n2h, j
      real*8 a(0 : n1max - 1, 0 : n2 - 1), x, y
      n2h = n2 / 2
      if (isgn .lt. 0) then
          do j = n2h + 1, n2 - 1
              a(0, j) = a(n1 + 1, j)
              a(1, j) = a(n1, j)
          end do
          a(1, 0) = a(n1, 0)
          a(1, n2h) = a(n1, n2h)
      else
          do j = n2h + 1, n2 - 1
              y = a(0, j)
              x = a(1, j)
              a(n1, j) = x
              a(n1 + 1, j) = y
              a(n1, n2 - j) = x
              a(n1 + 1, n2 - j) = -y
              a(0, j) = a(0, n2 - j)
              a(1, j) = -a(1, n2 - j)
          end do
          a(n1, 0) = a(1, 0)
          a(n1 + 1, 0) = 0
          a(1, 0) = 0
          a(n1, n2h) = a(1, n2h)
          a(n1 + 1, n2h) = 0
          a(1, n2h) = 0
      end if
      end
!
      subroutine ddct2d(n1max, n1, n2, isgn, a, t, ip, w)
      integer n1max, n1, n2, isgn, ip(0 : *), n, nw, nc, j
      real*8 a(0 : n1max - 1, 0 : n2 - 1), t(0 : 4 * n2 - 1),
     &    w(0 : *)
      n = max(n1, n2)
      nw = ip(0)
      if (n .gt. 4 * nw) then
          nw = n / 4
          call makewt(nw, ip, w)
      end if
      nc = ip(1)
      if (n .gt. nc) then
          nc = n
          call makect(nc, ip, w(nw))
      end if
      do j = 0, n2 - 1
          call ddct(n1, isgn, a(0, j), ip, w)
      end do
      call ddxt2d_sub(n1max, n1, n2, 0, isgn, a, t, ip, w)
      end
!
      subroutine ddst2d(n1max, n1, n2, isgn, a, t, ip, w)
      integer n1max, n1, n2, isgn, ip(0 : *), n, nw, nc, j
      real*8 a(0 : n1max - 1, 0 : n2 - 1), t(0 : 4 * n2 - 1),
     &    w(0 : *)
      n = max(n1, n2)
      nw = ip(0)
      if (n .gt. 4 * nw) then
          nw = n / 4
          call makewt(nw, ip, w)
      end if
      nc = ip(1)
      if (n .gt. nc) then
          nc = n
          call makect(nc, ip, w(nw))
      end if
      do j = 0, n2 - 1
          call ddst(n1, isgn, a(0, j), ip, w)
      end do
      call ddxt2d_sub(n1max, n1, n2, 1, isgn, a, t, ip, w)
      end
!
! -------- child routines --------
!
      subroutine cdft2d_sub(n1max, n1, n2, isgn, a, t, ip, w)
      integer n1max, n1, n2, isgn, ip(0 : *), i, j
      real*8 a(0 : n1max - 1, 0 : n2 - 1), t(0 : 8 * n2 - 1),
     &    w(0 : *)
      if (n1 .gt. 4) then
          do i = 0, n1 - 8, 8
              do j = 0, n2 - 1
                  t(2 * j) = a(i, j)
                  t(2 * j + 1) = a(i + 1, j)
                  t(2 * n2 + 2 * j) = a(i + 2, j)
                  t(2 * n2 + 2 * j + 1) = a(i + 3, j)
                  t(4 * n2 + 2 * j) = a(i + 4, j)
                  t(4 * n2 + 2 * j + 1) = a(i + 5, j)
                  t(6 * n2 + 2 * j) = a(i + 6, j)
                  t(6 * n2 + 2 * j + 1) = a(i + 7, j)
              end do
              call cdft(2 * n2, isgn, t, ip, w)
              call cdft(2 * n2, isgn, t(2 * n2), ip, w)
              call cdft(2 * n2, isgn, t(4 * n2), ip, w)
              call cdft(2 * n2, isgn, t(6 * n2), ip, w)
              do j = 0, n2 - 1
                  a(i, j) = t(2 * j)
                  a(i + 1, j) = t(2 * j + 1)
                  a(i + 2, j) = t(2 * n2 + 2 * j)
                  a(i + 3, j) = t(2 * n2 + 2 * j + 1)
                  a(i + 4, j) = t(4 * n2 + 2 * j)
                  a(i + 5, j) = t(4 * n2 + 2 * j + 1)
                  a(i + 6, j) = t(6 * n2 + 2 * j)
                  a(i + 7, j) = t(6 * n2 + 2 * j + 1)
              end do
          end do
      else if (n1 .eq. 4) then
          do j = 0, n2 - 1
              t(2 * j) = a(0, j)
              t(2 * j + 1) = a(1, j)
              t(2 * n2 + 2 * j) = a(2, j)
              t(2 * n2 + 2 * j + 1) = a(3, j)
          end do
          call cdft(2 * n2, isgn, t, ip, w)
          call cdft(2 * n2, isgn, t(2 * n2), ip, w)
          do j = 0, n2 - 1
              a(0, j) = t(2 * j)
              a(1, j) = t(2 * j + 1)
              a(2, j) = t(2 * n2 + 2 * j)
              a(3, j) = t(2 * n2 + 2 * j + 1)
          end do
      else if (n1 .eq. 2) then
          do j = 0, n2 - 1
              t(2 * j) = a(0, j)
              t(2 * j + 1) = a(1, j)
          end do
          call cdft(2 * n2, isgn, t, ip, w)
          do j = 0, n2 - 1
              a(0, j) = t(2 * j)
              a(1, j) = t(2 * j + 1)
          end do
      end if
      end
!
      subroutine rdft2d_sub(n1max, n1, n2, isgn, a)
      integer n1max, n1, n2, isgn, n2h, i, j
      real*8 a(0 : n1max - 1, 0 : n2 - 1), xi
      n2h = n2 / 2
      if (isgn .lt. 0) then
          do i = 1, n2h - 1
              j = n2 - i
              xi = a(0, i) - a(0, j)
              a(0, i) = a(0, i) + a(0, j)
              a(0, j) = xi
              xi = a(1, j) - a(1, i)
              a(1, i) = a(1, i) + a(1, j)
              a(1, j) = xi
          end do
      else
          do i = 1, n2h - 1
              j = n2 - i
              a(0, j) = 0.5d0 * (a(0, i) - a(0, j))
              a(0, i) = a(0, i) - a(0, j)
              a(1, j) = 0.5d0 * (a(1, i) + a(1, j))
              a(1, i) = a(1, i) - a(1, j)
          end do
      end if
      end
!
      subroutine ddxt2d_sub(n1max, n1, n2, ics, isgn, a, t,
     &    ip, w)
      integer n1max, n1, n2, ics, isgn, ip(0 : *), i, j
      real*8 a(0 : n1max - 1, 0 : n2 - 1), t(0 : 4 * n2 - 1),
     &    w(0 : *)
      if (n1 .gt. 2) then
          do i = 0, n1 - 4, 4
              do j = 0, n2 - 1
                  t(j) = a(i, j)
                  t(n2 + j) = a(i + 1, j)
                  t(2 * n2 + j) = a(i + 2, j)
                  t(3 * n2 + j) = a(i + 3, j)
              end do
              if (ics .eq. 0) then
                  call ddct(n2, isgn, t, ip, w)
                  call ddct(n2, isgn, t(n2), ip, w)
                  call ddct(n2, isgn, t(2 * n2), ip, w)
                  call ddct(n2, isgn, t(3 * n2), ip, w)
              else
                  call ddst(n2, isgn, t, ip, w)
                  call ddst(n2, isgn, t(n2), ip, w)
                  call ddst(n2, isgn, t(2 * n2), ip, w)
                  call ddst(n2, isgn, t(3 * n2), ip, w)
              end if
              do j = 0, n2 - 1
                  a(i, j) = t(j)
                  a(i + 1, j) = t(n2 + j)
                  a(i + 2, j) = t(2 * n2 + j)
                  a(i + 3, j) = t(3 * n2 + j)
              end do
          end do
      else if (n1 .eq. 2) then
          do j = 0, n2 - 1
              t(j) = a(0, j)
              t(n2 + j) = a(1, j)
          end do
          if (ics .eq. 0) then
              call ddct(n2, isgn, t, ip, w)
              call ddct(n2, isgn, t(n2), ip, w)
          else
              call ddst(n2, isgn, t, ip, w)
              call ddst(n2, isgn, t(n2), ip, w)
          end if
          do j = 0, n2 - 1
              a(0, j) = t(j)
              a(1, j) = t(n2 + j)
          end do
      end if
      end
!


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

      USE header_file
      IMPLICIT NONE

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

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

      END SUBROUTINE


      subroutine phi1_2m(m2,x3,xth,xphi,s3min,p1,p2,p3,wt,*)
c     massive particle p1 decaying into p2 mass m2 and p3 mass-squared s3.
c     with invariant mass of particle three s3 integrated over.
c     s3min is the minimum value of s3.
c     Vectors returned p2 and p3 are in the same frame as p1 is supplied.
c     Expression evaluated is
c     ds3 d^4 p2 d^4 p3 (2 pi)^4 delta(p1-p2-p3)/(2 pi)^6
c     delta(p2^2-m2) delta(p3^2-s3)
      implicit none
      include 'constants.f'
      include 'debug.f'
      include 'zerowidth.f'
      include 'breit.f'
      double precision p1(4),p2(4),p3(4),p3cm(4)
      double precision x3,xth,xphi,costh,sinth,phi,cphi,sphi
      double precision wt,wt0,w3
      double precision s3max,s3min,xx
      double precision m1,m2,m3,s1,s2,s3,lambda
      integer j
      parameter(wt0=one/8d0/pi)

      wt=0d0
      s1=p1(4)**2-p1(1)**2-p1(2)**2-p1(3)**2
      if (s1 .lt. 0d0) return 1
      m1=dsqrt(s1)
      s2=m2**2
      s3max=(m2-m1)**2
      if (s3min .gt. s3max) return 1
      if (n3 .eq. 0) then
         w3=s3max-s3min
         s3=s3max*x3+s3min*(1d0-x3)
         xx=0d0
      elseif (n3 .eq. 1) then
        if ((zerowidth) .and. (s3max .lt. mass3)) return 1
        xx=1d0
        call breitw(x3,s3min,s3max,mass3,width3,s3,w3)
      endif

      m3=dsqrt(s3)
      if (m1-m2-m3.lt. 0d0) return 1

      costh=two*xth-one
      phi=twopi*xphi
      sinth=dsqrt(one-costh**2)
      cphi=dcos(phi)
      sphi=dsin(phi)
      lambda=((s1-s2-s3)**2-4d0*s2*s3)

      if ((m1-m2-m3.lt. 0d0) .or. debug) then
      write(6,*) 'lambda in phi1_2m',lambda
      write(6,*) 's1 in phi1_2m',s1
      write(6,*) 's2 in phi1_2m',s2
      write(6,*) 's3 in phi1_2m',s3
      write(6,*) 'm1 in phi1_2m',m1
      write(6,*) 'm2 in phi1_2m',m2
      write(6,*) 'm3 in phi1_2m',m3
      write(6,*) 'm1-m2-m3 in phi1_2m',m1-m2-m3
      write(6,*) 'xx in phi1_2m',xx
      write(6,*) 'x3 in phi1_2m',x3
      write(6,*) 'n3 in phi1_2m',n3
      write(6,*) 'mass3 in phi1_2m',mass3
      return 1
      endif
      lambda=dsqrt(lambda)

      wt=wt0*w3*lambda/s1

      if(debug) write(6,*) 'wt in phi1_2m',wt

      p3cm(4)=m1/two*(s1+s3-s2)/s1
      p3cm(1)=m1/two*lambda/s1*sinth*sphi
      p3cm(2)=m1/two*lambda/s1*sinth*cphi
      p3cm(3)=m1/two*lambda/s1*costh
      call boost(m1,p1,p3cm,p3)
      do j=1,4
      p2(j)=p1(j)-p3(j)
      enddo

      if (  (p1(4) .lt. 0d0)
     & .or. (p2(4) .lt. 0d0)
     & .or. (p3(4) .lt. 0d0)) then
      return 1
      endif
      return
      end


C
C $Id: nggcog.f,v 1.4 2008-07-27 00:17:17 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE NGGCOG (CLAT,CLON,CRAD,ALAT,ALON,NPTS)
C
C This routine returns, in the arrays ALAT and ALON, the latitudes and
C longitudes of NPTS points on the surface of the globe, all of them at
C the great-circle distance CRAD from the point (CLAT,CLON), defining a
C circle.  The last point returned is a copy of the first.
C
        DIMENSION ALAT(*),ALON(*)
C
C Define multiplicative constants to convert from degrees to radians
C and from radians to degrees.
C
        DATA DTOR / .017453292519943 /
        DATA RTOD / 57.2957795130823 /
C
C Points on a circle around the North Pole are rotated to lie around
C the point at latitude CLAT and longitude CLON.
C
        RLAT=DTOR*(90.-CRAD)
C
        DO 101 IPNT=1,NPTS
          RLON=DTOR*360.*(REAL(IPNT-1)/REAL(NPTS-1))
          UCRD=COS(RLAT)*COS(RLON)
          VCRD=COS(RLAT)*SIN(RLON)
          WCRD=SIN(RLAT)
          CALL NGRITD (2,90.-CLAT,UCRD,VCRD,WCRD)
          CALL NGRITD (3,    CLON,UCRD,VCRD,WCRD)
          ALAT(IPNT)=RTOD*ASIN(WCRD)
          ALON(IPNT)=RTOD*ATAN2(VCRD,UCRD)
  101   CONTINUE
C
C Done.
C
        RETURN
C
      END


!
! SPDX-License-Identifier: MIT
!
module mod_gradls
  !
  use mod_types, only: rp
#if defined(_OPENACC)
  use cudafor
#endif
  !
  implicit none
  !
  private
  public  :: weno5,weno5_old
  !
  contains
  !
  subroutine weno5_old(n,dli,qmin,is_f,phi,ux,uy,uz,dphidt)
    !
    implicit none
    !
    real(rp), parameter, dimension(3,3) :: c = 1._rp/6._rp*reshape((/ 2._rp,-7._rp,11._rp, &
                                                                     -1._rp, 5._rp, 2._rp, &
                                                                      2._rp, 5._rp,-1._rp/),shape(c))
    real(rp), parameter, dimension(3)   :: sigma = (/0.1_rp,0.6_rp,0.3_rp/)
    real(rp), parameter :: eps = 10._rp**(-6)
    !
    integer , intent(in ), dimension(3)                    :: n
    real(rp), intent(in ), dimension(3)                    :: dli
    integer , intent(in )                                  :: qmin
    logical , intent(in )                                  :: is_f
    real(rp), intent(in ), dimension(   -2:,   -2:,   -2:) :: phi
    real(rp), intent(in ), dimension(-qmin:,-qmin:,-qmin:) :: ux,uy,uz
    real(rp), intent(out), dimension(    1:,    1:,    1:) :: dphidt
    !
    real(rp), dimension(-2:2) :: f
    real(rp), dimension(3) :: beta,we,dfdlh
    real(rp) :: dphidx,dphidy,dphidz
    real(rp) :: uxc,uyc,uzc
    integer  :: a,i,j,k,p,q
    !
    if(is_f) then
      q = 1
    else
      q = 0
    endif
    !
    do k=1,n(3)
      do j=1,n(2)
        do i=1,n(1)
          !
          uxc = 0.5_rp*(ux(i-q,j,k)+ux(i,j,k))
#if defined(_TWOD)
          dphidx = 0._rp
#else
          a = nint(sign(1._rp,uxc))
          f(-2) = a*(phi(i-2*a,j,k) - phi(i-3*a,j,k))*dli(1)
          f(-1) = a*(phi(i-1*a,j,k) - phi(i-2*a,j,k))*dli(1)
          f( 0) = a*(phi(i+0*a,j,k) - phi(i-1*a,j,k))*dli(1)
          f( 1) = a*(phi(i+1*a,j,k) - phi(i+0*a,j,k))*dli(1)
          f( 2) = a*(phi(i+2*a,j,k) - phi(i+1*a,j,k))*dli(1)
          beta(1) = (13._rp/12._rp)*(      f(-2) -2._rp*f(-1) +       f( 0))**2 + &
                    ( 1._rp/4._rp )*(      f(-2) -4._rp*f(-1) + 3._rp*f( 0))**2
          beta(2) = (13._rp/12._rp)*(      f(-1) -2._rp*f( 0) +       f( 1))**2 + &
                    ( 1._rp/4._rp )*(      f(-1)              -       f( 1))**2
          beta(3) = (13._rp/12._rp)*(      f( 0) -2._rp*f( 1) +       f( 2))**2 + &
                    ( 1._rp/4._rp )*(3._rp*f( 0) -4._rp*f( 1) +       f( 2))**2
          !we(:) = sigma(:)/(beta(:)+eps)**2
          we(:) = sigma(:)*(1._rp+(abs(beta(1)-beta(3))/(eps+beta(:))))
          we(:) = we(:)/sum(we(:))
          dfdlh(1) = sum(c(:,1)*f(-2:0))
          dfdlh(2) = sum(c(:,2)*f(-1:1))
          dfdlh(3) = sum(c(:,3)*f( 0:2))
          dphidx   = sum(we(:)*dfdlh(:))
#endif
          !
          uyc = 0.5_rp*(uy(i,j-q,k)+uy(i,j,k))
          a = nint(sign(1._rp,uyc))
          f(-2) = a*(phi(i,j-2*a,k) - phi(i,j-3*a,k))*dli(2)
          f(-1) = a*(phi(i,j-1*a,k) - phi(i,j-2*a,k))*dli(2)
          f( 0) = a*(phi(i,j+0*a,k) - phi(i,j-1*a,k))*dli(2)
          f( 1) = a*(phi(i,j+1*a,k) - phi(i,j+0*a,k))*dli(2)
          f( 2) = a*(phi(i,j+2*a,k) - phi(i,j+1*a,k))*dli(2)
          beta(1) = (13._rp/12._rp)*(      f(-2) - 2._rp*f(-1) +       f( 0))**2 + &
                    ( 1._rp/4._rp )*(      f(-2) - 4._rp*f(-1) + 3._rp*f( 0))**2
          beta(2) = (13._rp/12._rp)*(      f(-1) - 2._rp*f( 0) +       f( 1))**2 + &
                    ( 1._rp/4._rp )*(      f(-1)               -       f( 1))**2
          beta(3) = (13._rp/12._rp)*(      f( 0) - 2._rp*f( 1) +       f( 2))**2 + &
                    ( 1._rp/4._rp )*(3._rp*f( 0) - 4._rp*f( 1) +       f( 2))**2
          !we(:) = sigma(:)/(beta(:)+eps)**2
          we(:) = sigma(:)*(1._rp+(abs(beta(1)-beta(3))/(eps+beta(:))))
          we(:) = we(:)/sum(we(:))
          dfdlh(1) = sum(c(:,1)*f(-2:0))
          dfdlh(2) = sum(c(:,2)*f(-1:1))
          dfdlh(3) = sum(c(:,3)*f( 0:2))
          dphidy   = sum(we(:)*dfdlh(:))
          !
          uzc = 0.5_rp*(uz(i,j,k-q)+uz(i,j,k))
          a = nint(sign(1._rp,uzc))
          f(-2) = a*(phi(i,j,k-2*a) - phi(i,j,k-3*a))*dli(3)
          f(-1) = a*(phi(i,j,k-1*a) - phi(i,j,k-2*a))*dli(3)
          f( 0) = a*(phi(i,j,k+0*a) - phi(i,j,k-1*a))*dli(3)
          f( 1) = a*(phi(i,j,k+1*a) - phi(i,j,k+0*a))*dli(3)
          f( 2) = a*(phi(i,j,k+2*a) - phi(i,j,k+1*a))*dli(3)
          beta(1) = (13._rp/12._rp)*(      f(-2) - 2._rp*f(-1) +       f( 0))**2 + &
                    ( 1._rp/4._rp )*(      f(-2) - 4._rp*f(-1) + 3._rp*f( 0))**2
          beta(2) = (13._rp/12._rp)*(      f(-1) - 2._rp*f( 0) +       f( 1))**2 + &
                    ( 1._rp/4._rp )*(      f(-1)               -       f( 1))**2
          beta(3) = (13._rp/12._rp)*(      f( 0) - 2._rp*f( 1) +       f( 2))**2 + &
                    ( 1._rp/4._rp )*(3._rp*f( 0) - 4._rp*f( 1) +       f( 2))**2
          !we(:) = sigma(:)/(beta(:)+eps)**2
          we(:) = sigma(:)*(1._rp+(abs(beta(1)-beta(3))/(eps+beta(:))))
          we(:) = we(:)/sum(we(:))
          dfdlh(1) = sum(c(:,1)*f(-2:0))
          dfdlh(2) = sum(c(:,2)*f(-1:1))
          dfdlh(3) = sum(c(:,3)*f( 0:2))
          dphidz   = sum(we(:)*dfdlh(:))
          !
          dphidt(i,j,k) = - (uxc*dphidx + uyc*dphidy + uzc*dphidz)
          !
        enddo
      enddo
    enddo
    return
  end subroutine weno5_old
  !
  subroutine weno5(nx,ny,nz,dxi,dyi,dzi,nh_u,is_f,phi,ux,uy,uz,dphidt)
    !
    implicit none
    !
    real(rp), parameter :: c11    =  2._rp/6._rp, &
                           c21    = -7._rp/6._rp, &
                           c31    = 11._rp/6._rp, &
                           c12    = -1._rp/6._rp, &
                           c22    =  5._rp/6._rp, &
                           c32    =  2._rp/6._rp, &
                           c13    =  2._rp/6._rp, &
                           c23    =  5._rp/6._rp, &
                           c33    = -1._rp/6._rp
    real(rp), parameter :: sigma1 = 0.1_rp, &
                           sigma2 = 0.6_rp, &
                           sigma3 = 0.3_rp
    real(rp), parameter :: eps    = 10._rp**(-6)
    !
    integer , intent(in )                                     :: nx,ny,nz
    real(rp), intent(in )                                     :: dxi,dyi,dzi
    integer , intent(in )                                     :: nh_u
    logical , intent(in )                                     :: is_f
    real(rp), intent(in ), dimension(    -2:,    -2:,    -2:) :: phi
    real(rp), intent(in ), dimension(1-nh_u:,1-nh_u:,1-nh_u:) :: ux,uy,uz
    real(rp), intent(out), dimension(      :,      :,      :) :: dphidt
    !
    real(rp) :: fm2,fm1,f0,fp1,fp2
    real(rp) :: beta1,beta2,beta3
    real(rp) :: we1,we2,we3,sum_we
    real(rp) :: dfdlh1,dfdlh2,dfdlh3
    real(rp) :: dphidx,dphidy,dphidz
    integer  :: a,i,j,k,p
    real(rp) :: uxc,uyc,uzc
    integer  :: q
#if defined(_OPENACC)
    integer :: istat
    attributes(managed) :: ux,uy,uz
    attributes(managed) :: phi,dphidt
#endif
    !
    if(is_f) then
      q = 1
    else
      q = 0
    endif
    !
#if defined(_OPENACC)
    !
    !$acc kernels
#else
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP PRIVATE(uxc,uyc,uzc,a) &
    !$OMP PRIVATE(fm2,fm1,f0,fp1,fp2) &
    !$OMP PRIVATE(beta1,beta2,beta3,we1,we2,we3,eps) &
    !$OMP PRIVATE(c11,c21,c31,c12,c22,c32,c13,c23,c33) &
    !$OMP PRIVATE(dfdlh1,dfdlh2,dfdlh3,dphidx,dphidy,dphidz) &
    !$OMP SHARED(nx,ny,nz,dxi,dyi,dzi,ux,uy,uz,phi,dphidt)
#endif
    do k=1,nz
      do j=1,ny
        do i=1,nx
          !
#if defined(_OPENACC) && defined(_ACC_OPT)
          !$acc cache(ux(i-q:i,j:j,k:k))
          !$acc cache(uy(i:i,j-q:j,k:k))
          !$acc cache(uz(i:i,j:j,k-q:k))
          !$acc cache(phi(i-3:i+3,j-3:j+3,k-3:k+3))
#endif
          uxc = 0.5_rp*(ux(i-q,j,k)+ux(i,j,k))
#if defined(_TWOD)
          dphidx = 0._rp
#else
          a   = nint(sign(1._rp,uxc))
          fm2 = a*(phi(i-2*a,j,k) - phi(i-3*a,j,k))*dxi
          fm1 = a*(phi(i-1*a,j,k) - phi(i-2*a,j,k))*dxi
          f0  = a*(phi(i+0*a,j,k) - phi(i-1*a,j,k))*dxi
          fp1 = a*(phi(i+1*a,j,k) - phi(i+0*a,j,k))*dxi
          fp2 = a*(phi(i+2*a,j,k) - phi(i+1*a,j,k))*dxi
          beta1 = (13._rp/12._rp)*(      fm2 - 2._rp*fm1 +       f0 )**2 + &
                  ( 1._rp/4._rp )*(      fm2 - 4._rp*fm1 + 3._rp*f0 )**2
          beta2 = (13._rp/12._rp)*(      fm1 - 2._rp*f0  +       fp1)**2 + &
                  ( 1._rp/4._rp )*(      fm1             -       fp1)**2
          beta3 = (13._rp/12._rp)*(      f0  - 2._rp*fp1 +       fp2)**2 + &
                  ( 1._rp/4._rp )*(3._rp*f0  - 4._rp*fp1 +       fp2)**2
          we1 = sigma1*(1._rp+(abs(beta1-beta3)/(eps+beta1)))
          we2 = sigma2*(1._rp+(abs(beta1-beta3)/(eps+beta2)))
          we3 = sigma3*(1._rp+(abs(beta1-beta3)/(eps+beta3)))
          sum_we = we1+we2+we3
          we1 = we1/sum_we
          we2 = we2/sum_we
          we3 = we3/sum_we
          dfdlh1 = c11*fm2+c21*fm1+c31*f0
          dfdlh2 = c12*fm1+c22*f0 +c32*fp1
          dfdlh3 = c13*f0 +c23*fp1+c33*fp2
          dphidx = we1*dfdlh1+we2*dfdlh2+we3*dfdlh3
#endif
          !
          uyc = 0.5_rp*(uy(i,j-q,k)+uy(i,j,k))
          a   = nint(sign(1._rp,uyc))
          fm2 = a*(phi(i,j-2*a,k) - phi(i,j-3*a,k))*dyi
          fm1 = a*(phi(i,j-1*a,k) - phi(i,j-2*a,k))*dyi
          f0  = a*(phi(i,j+0*a,k) - phi(i,j-1*a,k))*dyi
          fp1 = a*(phi(i,j+1*a,k) - phi(i,j+0*a,k))*dyi
          fp2 = a*(phi(i,j+2*a,k) - phi(i,j+1*a,k))*dyi
          beta1 = (13._rp/12._rp)*(      fm2 - 2._rp*fm1 +       f0 )**2 + &
                  ( 1._rp/4._rp )*(      fm2 - 4._rp*fm1 + 3._rp*f0 )**2
          beta2 = (13._rp/12._rp)*(      fm1 - 2._rp*f0  +       fp1)**2 + &
                  ( 1._rp/4._rp )*(      fm1             -       fp1)**2
          beta3 = (13._rp/12._rp)*(      f0  - 2._rp*fp1 +       fp2)**2 + &
                  ( 1._rp/4._rp )*(3._rp*f0  - 4._rp*fp1 +       fp2)**2
          we1 = sigma1*(1._rp+(abs(beta1-beta3)/(eps+beta1)))
          we2 = sigma2*(1._rp+(abs(beta1-beta3)/(eps+beta2)))
          we3 = sigma3*(1._rp+(abs(beta1-beta3)/(eps+beta3)))
          sum_we = we1+we2+we3
          we1 = we1/sum_we
          we2 = we2/sum_we
          we3 = we3/sum_we
          dfdlh1 = c11*fm2+c21*fm1+c31*f0
          dfdlh2 = c12*fm1+c22*f0 +c32*fp1
          dfdlh3 = c13*f0 +c23*fp1+c33*fp2
          dphidy = we1*dfdlh1+we2*dfdlh2+we3*dfdlh3
          !
          uzc = 0.5_rp*(uz(i,j,k-q)+uz(i,j,k))
          a   = nint(sign(1._rp,uzc))
          fm2 = a*(phi(i,j,k-2*a) - phi(i,j,k-3*a))*dzi
          fm1 = a*(phi(i,j,k-1*a) - phi(i,j,k-2*a))*dzi
          f0  = a*(phi(i,j,k+0*a) - phi(i,j,k-1*a))*dzi
          fp1 = a*(phi(i,j,k+1*a) - phi(i,j,k+0*a))*dzi
          fp2 = a*(phi(i,j,k+2*a) - phi(i,j,k+1*a))*dzi
          beta1 = (13._rp/12._rp)*(      fm2 - 2._rp*fm1 +       f0 )**2 + &
                  ( 1._rp/4._rp )*(      fm2 - 4._rp*fm1 + 3._rp*f0 )**2
          beta2 = (13._rp/12._rp)*(      fm1 - 2._rp*f0  +       fp1)**2 + &
                  ( 1._rp/4._rp )*(      fm1             -       fp1)**2
          beta3 = (13._rp/12._rp)*(      f0  - 2._rp*fp1 +       fp2)**2 + &
                  ( 1._rp/4._rp )*(3._rp*f0  - 4._rp*fp1 +       fp2)**2
          we1 = sigma1*(1._rp+(abs(beta1-beta3)/(eps+beta1)))
          we2 = sigma2*(1._rp+(abs(beta1-beta3)/(eps+beta2)))
          we3 = sigma3*(1._rp+(abs(beta1-beta3)/(eps+beta3)))
          sum_we = we1+we2+we3
          we1 = we1/sum_we
          we2 = we2/sum_we
          we3 = we3/sum_we
          dfdlh1 = c11*fm2+c21*fm1+c31*f0
          dfdlh2 = c12*fm1+c22*f0 +c32*fp1
          dfdlh3 = c13*f0 +c23*fp1+c33*fp2
          dphidz = we1*dfdlh1+we2*dfdlh2+we3*dfdlh3
          !
          dphidt(i,j,k) = - (uxc*dphidx + uyc*dphidy + uzc*dphidz)
          !
        enddo
      enddo
    enddo
#if defined(_OPENACC)
    !$acc end kernels
    !@cuf istat=cudaDeviceSynchronize()
#else
    !$OMP END PARALLEL DO
#endif
    return
  end subroutine weno5
end module mod_gradls


          program windstress

          implicit none
          real wvel, wind, cd
          integer i

          do i=0,1000

          wvel=i*0.1

C Large and Pond (1981)
          if(wvel.lt.10.) then
            cd=1.14
          else if( wvel.lt.26. ) then
            cd=0.49+0.065*wvel
          else
            cd=0.49+0.065*26.
          end if

C Garrat (1977)
          cd=0.75+0.067*wvel
          if( wvel.gt.26. ) then
            cd=0.75+0.067*26.
          end if

C Mellor and Blumberg (2004)
          if( wvel.lt.3.7313 ) then
            cd=1.5-wvel*0.134002
          else
            cd=0.75+0.067*wvel
            cd=min(2.492,cd)
          end if

          write(6,*) wvel, cd

          end do

          end


!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
!* See https://llvm.org/LICENSE.txt for license information.
!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

!	OpenMP verison of matmul

      integer result(1), expect(1), itest
      result(1) = itest()
      data expect/200/
      call check(result, expect, 1)
      end
      integer function itest
c
      integer i, j, k
      integer size, m, n, p
      parameter (size=200)
      parameter (m=size,n=size,p=size)
      real*8 a, b, c, arow
      dimension a(m,n), b(n,p), c(n,p), arow(n)
      integer omp_get_thread_num
      integer omp_get_num_threads
c
      integer l
c
      do i = 1, m
      do j = 1, n
         a(i,j) = 1.0
      enddo
      enddo
      do i = 1, n
      do j = 1, p
         b(i,j) = 1.0
      enddo
      enddo
c
!$omp parallel
!!      print *, '#t ', omp_get_thread_num()
!!      print *, '#h ', omp_get_num_threads()
!$omp do
         do j = 1, p
            do i = 1, m
               c(i,j) = 0.0
            enddo
         enddo
         do i = 1, m
!$omp do
            do ii = 1, n
               arow(ii) = a(i,ii)
            enddo
!$omp do
            do j = 1, p
               do k = 1, n
                  c(i,j) = c(i,j) + arow(k) * b(k,j)
               enddo
            enddo
         enddo
!$omp end parallel
c
!!      print *, "c(1,1) = ", c(1,1)
c
      itest = c(1,1) + 0.005
      end


!------------------------------------------------------------------------------
module module_my_struct  ! make a type definition available everywhere

  type my_struct
     real(8) :: x
     integer :: i
  end type my_struct

  external :: my_fun   ! will become MPI reduction operator
end

!------------------------------------------------------------------------------
program main  ! hints for user defined datatype and operator

  use module_my_struct
  implicit none
  type(my_struct) :: a, b, s

  a%x = 1
  a%i = 2

  b%x = 10
  b%i = 20

  call sum(my_fun, a, b, s)  ! call my_fun from another routine (substitute for MPI)

  write(6,*) s%x, s%i
end

!------------------------------------------------------------------------------
subroutine sum(fun, x, y, z)

  use module_my_struct
  implicit none
  external :: fun
  type(my_struct), intent(in) :: x, y
  type(my_struct), intent(inout) :: z

  z%x = x%x
  z%i = x%i
  call fun(y, z, 1, 0)
end

!------------------------------------------------------------------------------
subroutine my_fun(in, inout, len, type)  ! very similar to MPI_User_function

  use module_my_struct, exclude => my_fun
  implicit none
  type(my_struct), intent(in) :: in(*)
  type(my_struct), intent(inout) :: inout(*)
  integer, intent(in) :: len, type
  integer :: i

  do i = 1, len
     inout(i)%x = inout(i)%x + in(i)%x
     inout(i)%i = inout(i)%i + in(i)%i
  enddo
end


SUBROUTINE stream_func_set_up(grav,depth,period,i_wavel_or_per,wave_l,    &
     wavenum,wave_h,i_euler_or_stokes,e_or_s_vel,i_deep_or_finite,        &
     n_h_steps,n_four_modes,nwrk,yy,zz)

! From HBB: utilities.f90

  USE Precision

  IMPLICIT NONE

  INTEGER i_wavel_or_per, i_euler_or_stokes, i_deep_or_finite, n_h_steps, &
       n_four_modes, nwrk
  REAL(KIND=long) :: grav, depth, period, wave_l, wavenum, e_or_s_vel,      &
       wave_h, yy(*), zz(*)

! Workspace for the stream function coefficient calculation
  CHARACTER(len=10) :: deep_or_finite, wavel_or_per, Euler_or_Stokes
  INTEGER :: iwrk(nwrk)
  REAL(KIND=long) :: hoverd, height, zero=0._long
  REAL(KIND=long) :: wrk1(0:nwrk), wrk2(0:nwrk), wrk3(nwrk), wrk4(nwrk,2), &
       wrk5(nwrk), wrk6(nwrk), wrk7(nwrk,nwrk), wrk8(nwrk)

  IF((WAVENUM*DEPTH).GT.9.0D0) THEN
     I_DEEP_OR_FINITE=0
     deep_or_finite='deep'
     hoverd=zero
  ELSE
     I_DEEP_OR_FINITE=1
     deep_or_finite='finite'
     hoverd=wave_H/depth
  ENDIF
  IF(i_Euler_or_Stokes==0)THEN
     Euler_or_Stokes='Euler'
  ELSE
     Euler_or_Stokes='Stokes'
  END IF
  IF(i_wavel_or_per==0)THEN
     wavel_or_per='wavelength'
     height=wave_H/wave_l
  ELSE
     wavel_or_per='period'
     height=wave_H/(grav*period**2)
  END IF
  E_or_S_vel = E_or_S_vel/(grav*wave_H)**0.5
! Compute the Stream Function coefficients.
! This subroutine is basically Fenton's
! original code, with output turned off, turned into a subroutine.
! On return the zz's and the yy's hold the solution.
  call stream_func_coeffs(deep_or_finite,hoverd,wavel_or_per,     &
       height,Euler_or_Stokes,E_or_S_vel,n_four_modes,n_H_steps,  &
       nwrk,wrk1,wrk2,wrk3,wrk4,wrk5,wrk6,wrk7,wrk8,iwrk,zz,yy)
  If(i_wavel_or_per==0)THEN
     period=zz(3)/sqrt(grav*wavenum)
  ELSE IF(i_wavel_or_per==1)THEN
     wavenum=zz(1)/depth
  END If

  RETURN
END SUBROUTINE stream_func_set_up


      program statblock2
c
c**********************************************************************
c
c     blocking method for estimating standard error of mean
c
c     (reference - tildesley and allen, p191  (1987)
c
c     copyright daresbury laboratory 1996
c     author - t. forester sept 1996
c
c**********************************************************************
c
      parameter (ndeg=25,mxrows=10000,mxcols=20)
      implicit real*8 (a-h,o-z)
      dimension list(mxcols),record(mxcols),d(mxrows,mxcols)
      dimension aver(mxcols),var(ndeg,mxcols)
      dimension x(ndeg),y(ndeg)
      dimension err(mxcols),seff(mxcols)
      character*40 statfile

      write(*,*)'error estimation using blocking method'
      write(*,*)'maximum number of time points allowed =',mxrows
      write(*,*)'name of statistical data file (40 chars max)?'
      read(*,'(a40)')statfile
      write(*,*)'enter number of columns in data file (max 20)'
      read(*,*)mcols
      mcols=min(mcols,mxcols)
      write(*,*)'enter number of columns to be processed (max 20)'
      read(*,*)ncols
      ncols=min(ncols,mxcols)
      write(*,*)'identify columns to be processed'
      read(*,*)(list(j),j=1,ncols)
c
c     open the statistical data file

      open(7,file=statfile)

c
c     read in statistical data
      do i=1,mxrows
        read(7,*,end=100)(record(j),j=1,mcols)
        do k=1,ncols
          d(i,k)=record(list(k))
        enddo
      enddo
  100 m=min(i-1,mxrows)
      write(*,*)'number of data points read',m
      if(m.le.2) then
        write(*,*) 'too few data points to process'
        call exit()
      endif

c
c     calculate errors using blocking method

      niter = min(m,ndeg)
      write(*,*) 'number of blocks used ',niter

c
c     calculate averages
      write(*,*)'calculated averages'
      do l=1,ncols
        aver(l)=0.d0
        do i=1,m
          aver(l)=aver(l)+d(i,l)
        enddo
        aver(l)=aver(l)/dble(m)
      enddo
      write(*,'(3x,1p,20e12.4)')(aver(l),l=1,ncols)

      do l=1,ncols

        var(1,l) =0.d0

        do  i=1,m
          var(1,l) = var(1,l) + (d(i,l)- aver(l))**2
        enddo

        var(1,l)= var(1,l)/dble(m)

      enddo

      do iter = 2,niter
c
c     block length

        tb = dble(m)/dble(iter)

        do l=1,ncols

          var(iter,l)=0.d0

          do  j=1,iter

            dd = 0.d0
            j1 = 1 + nint(dble(j-1)*tb)
            j2 = nint(dble(j)*tb)
            nb = j2 -j1 + 1

            do i = j1,j2

              dd = dd + d(i,l)

            enddo
c
c     dd is mean of block value

            dd = dd/dble(nb)
            var(iter,l)=var(iter,l)+((dd-aver(l))**2)

          enddo
          var(iter,l)=var(iter,l)/dble(iter)

        enddo

      enddo
c
c     linear regression of s = nb* var()^2/ var(1)^2
c     to find statistical uncertainty

      n0 = 2
      n1 = n0 -1

      do l = 1,ncols

        do j = n0,niter

          x(j-n1) = dble(j)/dble(m)
          if(var(1,l).gt.1d-8) then
            y(j-n1) = (var(j,l)/var(1,l))/x(j-n1)
          else
            y(j-n1) = 0.d0
          endif
        enddo
        nn = niter-n1
        call bestfit(nn,x,y,a1)
        a1 = max(a1,1.d0)
        err(l) = sqrt(var(1,l)*a1/dble(m))
        seff(l)= a1
      enddo
c$$$      write(*,'(/,a)')'# of blocks      r.m.s. fluctuations'
c$$$      do j = 1,niter
c$$$        write(*,'(i3,1p,20e12.4)')j,(sqrt(var(j,l)),l=1,ncols)
c$$$      enddo

      write(*,'(/,a)')' calculated uncertainty in averages'
      write(*,'(3x,1p,20e12.4)')(err(j),j=1,ncols)

      write(*,'(/,a)')' calculated statistical inefficiencies'
      write(*,'(3x,1p,20e12.4)')(seff(j),j=1,ncols)

      end

      subroutine bestfit(n,x,y,a1)

c***********************************************************************
c
c     least squares fitting of arbitary functions to data
c     uses gram-schmidt orthogonalisation procedure.
c
c     copyright daresbury laboratory 1993
c     author t. forester may 1993.
c
c     $author: wl $
c     $date: 1996/02/15 14:33:28 $
c     $revision: 1.1.1.1 $
c     $state: exp $
c
c***********************************************************************

      implicit real*8(a-h,o-z)

c     maximum number of functions to fit

      parameter (m1 = 5)

c     maximum number of data points (> m)

      parameter (n1 = 25)

      dimension a(m1,n1), b(m1,m1),c(m1,n1),x(n1),y(n1),d(m1)

c
c     linear fit

      m = 2
      if(n.lt.m) call error(4)
c
c     create a matrix - change function definitions here - only the first m
c     functions are used.

      do i = 1,n
c
c     define functions as power series
c     but in general may be any function you like

         if(m.ge.1) a(1,i) = 1
         if(m.ge.2) a(2,i) = x(i)
         if(m.ge.3) a(3,i) = x(i)*a(2,i)
         if(m.ge.4) a(4,i) = x(i)*a(3,i)
         if(m.ge.5) a(5,i) = x(i)*a(4,i)

      enddo

c
c     construct b = a.(a transpose)  (m x m)

      do i = 1,m

         do j = i,m

            b(i,j) = 0.d0

            do k = 1,n

               b(i,j) = b(i,j) + a(i,k)*a(j,k)

            enddo

            b(j,i) = b(i,j)

         enddo

      enddo

c
c     find inverse of b

      call invert(m,m1,b,b)

c
c     construct (b^-1)a  (m x n)

      do i = 1,m

         do j = 1,n

            c(i,j) = 0.0d0

            do k = 1,m

               c(i,j) = c(i,j) + b(i,k)*a(k,j)

            enddo

         enddo

      enddo

c
c     find coefficients

      do i = 1,m

         d(i) = 0.d0

         do j = 1,n

            d(i) = d(i) + c(i,j)*y(j)

         enddo

c     write(*,198) i,d(i)
  198    format (' coefficient',i5,4x,1p,e16.8)

      enddo
      a1 = d(1)

c
c     calculate best fit of data points
c      write(*,*)
c      write(*,'(3(5x,a5,5x))') 'x','y','fit'
      do i = 1,n

         ax = 0.d0

         do j = 1,m

            ax = ax + a(j,i)*d(j)

         enddo

c         write(*,95) x(i), y(i), ax

   95    format(1p,3e16.8)

      enddo

      end
      subroutine error(i)

    1 format(/,' error - too many functions specified')
    2 format(/,' error - too many data points specified')
    3 format(/,' error - matrix too big for "invert"')
    4 format(/,' error - too few data points specified')

      if(i.eq.1) write(*,1)
      if(i.eq.2) write(*,2)
      if(i.eq.3) write(*,3)
      if(i.eq.4) write(*,4)

      call exit()
      return
      end

      subroutine invert(nnn,nmax,aaa,bbb)
c
c***********************************************************************
c
c     routine to invert a real symmetric matrix (reference:
c     computing methods v.ii, i.s. berezin and n.p.zhidkov,
c     pergamon press 1965). note that the matrices are
c     packed in the minimum storage mode, (i.e. a(k)=a(i,j),
c     where i>j and k=(i*(i-1))/2+j ).
c     the matrices aaa and bbb may be equivalenced though
c     this will destroy the contents of the original
c     array.
c
c     general version for all real symmetric matrices
c
c     copyright daresbury laboratory 1993
c     author w.smith (added to dl_poly july 1993)
c
c***********************************************************************
c
      implicit real*8(a-h,o-z)
c
c     maximum matrix (mbig*mbig) to invert

      parameter (mbig =100, bmax = mbig*(mbig+1)/2)
      dimension aaa(nmax*nmax),bbb(nmax*nmax),bbi(bmax)

      ind(i,j)=(max0(i,j)*(max0(i,j)-1))/2+min0(i,j)

      if(nnn.gt.mbig) call error(3)
c
c     pack matrix aaa into a triangular form

      do i = 1,nnn
         do j = 1,i
            k = ind(i,j)
            k1 = (i-1)*nmax + j
            bbi(k) = aaa(k1)
         enddo
      enddo
      do i = 1,nnn
         do j = 1,i
            k = ind(i,j)
            aaa(k) = bbi(k)
         enddo
      enddo

c
c     factorize matrix aaa into upper and lower forms
      do l=1,nnn
         do m=1,l
            k=ind(l,m)
            bbi(k)=0.d0
            bbb(k)=aaa(k)
            if(m.ne.1)then
               lm=m-1
               do n=1,lm
                  ln=ind(l,n)
                  mn=ind(m,n)
                  temv  =bbb(k)-bbb(ln)*bbb(mn)+bbi(ln)*bbi(mn)
                  bbi(k)=bbi(k)-bbi(ln)*bbb(mn)-bbb(ln)*bbi(mn)
                  bbb(k)=temv
               enddo
            endif
            if(l.eq.m)then
               if(bbb(k).lt.0.d0)then
                  bbi(k)=sqrt(abs(bbb(k)))
                  bbb(k)=0.d0
               else
                  bbb(k)=sqrt(abs(bbb(k)))
                  bbi(k)=0.d0
               endif
            else
               mm=ind(m,m)
               den=1.d0/(bbb(mm)**2+bbi(mm)**2)
               temv  =den*(bbb(k)*bbb(mm)+bbi(k)*bbi(mm))
               bbi(k)=den*(bbi(k)*bbb(mm)-bbb(k)*bbi(mm))
               bbb(k)=temv
            endif
         enddo
      enddo
c
c     invert lower triangular matrix
      do l=1,nnn
         n=ind(l,l)
         den=1.d0/(bbb(n)*bbb(n)+bbi(n)*bbi(n))
         do m=1,l
            k=ind(l,m)
            if(l.eq.m)then
               bbb(k)= den*bbb(k)
               bbi(k)=-den*bbi(k)
            else
               lm=l-1
               suma=0.d0
               sumb=0.d0
               do j=m,lm
                  lj=ind(l,j)
                  mj=ind(m,j)
                  suma=suma-bbb(lj)*bbb(mj)+bbi(lj)*bbi(mj)
                  sumb=sumb-bbb(lj)*bbi(mj)-bbi(lj)*bbb(mj)
               enddo
               temv  =den*(suma*bbb(n)+sumb*bbi(n))
               bbi(k)=den*(sumb*bbb(n)-suma*bbi(n))
               bbb(k)=temv
            endif
         enddo
      enddo
c
c     form product of upper and lower inverse triangular matrices
      do l=1,nnn
         do m=1,l
            sum=0.d0
            k=ind(l,m)
            do j=l,nnn
               lj=ind(l,j)
               mj=ind(m,j)
               sum=sum+bbb(lj)*bbb(mj)-bbi(lj)*bbi(mj)
            enddo
            bbb(k)=sum
         enddo
      enddo

c
c     unpack inverse matrix bbb

      do i = 1,nnn
         do j = 1,i
            k=ind(i,j)
            bbi(k) = bbb(k)
         enddo
      enddo

      do i = 1,nnn
         do j = 1,nnn
            k1 = (i-1)*nmax + j
            k = ind(i,j)
            bbb(k1) = bbi(k)
         enddo
      enddo

      return
      end


PROGRAM FIBBER
  INTEGER :: A = 1;
  INTEGER :: B = 0;
  INTEGER :: C = 0;
  DO WHILE (A + B > -1)
    B = C;
    C = A + B;
    A = B;
    PRINT *, C;
  END DO
END PROGRAM FIBBER


integer :: my_seed
        becomes
  integer, optional :: my_seed
module ran_mod
! ran1 returns a uniform random number between 0-1
! the seed is optional and used to reset the generator
contains
   function ran1(my_seed)
      use numz
      implicit none
      real(b8) ran1,r
      integer, optional ,intent(in) :: my_seed  ! optional argument not changed in the routine
      integer,allocatable :: seed(:)
      integer the_size,j
      if(present(my_seed))then            ! use the seed if present
          call random_seed(size=the_size) ! how big is the intrisic seed?
          allocate(seed(the_size))        ! allocate space for seed
          do j=1,the_size                 ! create the seed
             seed(j)=abs(my_seed)+(j-1)   ! abs is generic
          enddo
          call random_seed(put=seed)      ! assign the seed
          deallocate(seed)                ! deallocate space
      endif
      call random_number(r)
      ran1=r
  end function ran1
end module

program darwin
    use numz


      REAL             FUNCTION SBESJ1 (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 SBESJ1 Krogh  Added external statement.
C>> 1995-11-13 SBESJ1 Krogh  Changed data statment for C converstion.
C>> 1995-11-03 SBESJ1 Krogh  Removed blanks in numbers for C conversion.
C>> 1994-11-11 SBESJ1 Krogh   Declared all vars.
C>> 1994-10-20 SBESJ1 Krogh  Changes to use M77CON
C>> 1992-02-07 SBESJ1 WV Snyder Correct sign for X < 0.
C>> 1990-11-29 SBESJ1 CLL
C>> 1985-08-02 SBESJ1 Lawson  Initial code.
C JUNE 1978 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C C.L.LAWSON & S.CHAN, JPL, 1984 FEB ADAPTED TO JPL MATH77 LIBRARY.
c     ------------------------------------------------------------------
c--S replaces "?": ?BESJ1, ?BMP1, ?INITS, ?CSEVL
c     ------------------------------------------------------------------
      EXTERNAL R1MACH, SCSEVL
      INTEGER NTJ1
      REAL             X, BJ1CS(19), AMPL, THETA, XSML, XMIN, Y,
     1  R1MACH, SCSEVL
C
C SERIES FOR BJ1        ON THE INTERVAL  0.          TO  1.60000E+01
C                                        WITH WEIGHTED ERROR   1.16E-33
C                                         LOG WEIGHTED ERROR  32.93
C                               SIGNIFICANT FIGURES REQUIRED  32.36
C                                    DECIMAL PLACES REQUIRED  33.57
C
      SAVE NTJ1, XSML, XMIN
C
      DATA BJ1CS / -.117261415133327865606240574524003E+0,
     *  -.253615218307906395623030884554698E+0,
     *  +.501270809844695685053656363203743E-1,
     *  -.463151480962508191842619728789772E-2,
     *  +.247996229415914024539124064592364E-3,
     *  -.867894868627882584521246435176416E-5,
     *  +.214293917143793691502766250991292E-6,
     *  -.393609307918317979229322764073061E-8,
     *  +.559118231794688004018248059864032E-10,
     *  -.632761640466139302477695274014880E-12,
     *  +.584099161085724700326945563268266E-14,
     *  -.448253381870125819039135059199999E-16,
     *  +.290538449262502466306018688000000E-18,
     *  -.161173219784144165412118186666666E-20,
     *  +.773947881939274637298346666666666E-23,
     *  -.324869378211199841143466666666666E-25,
     *  +.120223767722741022720000000000000E-27,
     *  -.395201221265134933333333333333333E-30,
     *  +.116167808226645333333333333333333E-32 /
C
      DATA NTJ1, XSML, XMIN / 0, 2*0.E0 /
C     ------------------------------------------------------------------
      IF (NTJ1 .eq. 0) then
         call SINITS (BJ1CS, 19, 0.1E0*R1MACH(3), NTJ1)
         XSML = SQRT (4.0E0*R1MACH(3))
         XMIN = 2.0E0*R1MACH(1)
      endif
C
      Y = ABS(X)
C
      IF (Y .LE. XMIN) THEN
        SBESJ1 = 0.E0
      ELSE IF (Y .LE. XSML) THEN
        SBESJ1 = .5E0 * X
      ELSE IF (Y .LE. 4.E0) THEN
        SBESJ1 = X * ( .25E0 + SCSEVL (.125E0*Y*Y-1.E0,BJ1CS, NTJ1) )
      ELSE
        CALL SBMP1 (Y, AMPL, THETA)
        SBESJ1 = AMPL * COS(THETA)
        IF (X .LT. 0.0e0) SBESJ1 = -SBESJ1
      END IF
C
      RETURN
      END


program CaidaLibre
implicit none

real :: t, tf, dt, y, dy, f
integer :: n, i
real, dimension(:), allocatable :: Posicion, Velocidad, tiempo

t = 0 ; tf = 5 ; dt = 0.01

n = (tf - t)/dt

ALLOCATE(Posicion(n), Velocidad(n), tiempo(n))

Posicion(1) = 100
Velocidad(1) = 0
tiempo(1) = 0

 open(10, file ="Solucion_Fortran.dat")

	i = 1

	write(10,*) tiempo(i), Posicion(i), Velocidad(i)

	do while(t.le.tf)

		Velocidad(i+1) = Velocidad(i) + (f(Posicion(i), Velocidad(i)))*dt

		Posicion(i+1) = Posicion(i) + Velocidad(i+1)*dt;

		tiempo(i+1) = tiempo(i) + dt;

		write(10,*) tiempo(i), Posicion(i), Velocidad(i)

		t = t + dt;
		i = i + 1

	enddo

 close(10)

call system("gnuplot -p Grafica_Fortran.gp")

end program

real function f(y,dy)

	real :: y,dy

	f =  -9.81

end function

Programas en Fortran/Caida Libre/Caida_libre.f90


      FUNCTION pythag(a,b)
      DOUBLE PRECISION a,b,pythag
      DOUBLE PRECISION absa,absb
      absa=abs(a)
      absb=abs(b)
      if(absa.gt.absb)then
        pythag=absa*sqrt(1.d0+(absb/absa)**2)
      else
        if(absb.eq.0.d0)then
          pythag=0.d0
        else
          pythag=absb*sqrt(1.d0+(absa/absb)**2)
        endif
      endif
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software 0!5,.


SUBROUTINE colinear_pred (mjd, r_sat, v_sat, r_sun, epsilon_t0, delta_t)

! ----------------------------------------------------------------------
! SUBROUTINE: colinear_pred.f03
! ----------------------------------------------------------------------
! Purpose:
!  Computation of the time of the colinearity angle (Sun elevation angle w.r.t. orbtial plane) at a previous epoch
!  based on the Keplerian elements for the satellite orbit propagation and the DE Ephemeris for the Sun position
! ----------------------------------------------------------------------
! Input arguments:
! - mjd:		Modified Julian Day number in GPS Time (including the fraction of the day)
! - r_sat: 		Satellite position vector (m) in ITRF
! - v_sat: 		Satellite velocity vector (m/sec) in ITRF
! - r_sun:			Sun position vector (m)
! - epsilon_t0:	colinearity angle (epsilon) at the current epoch
!
! Output arguments:
! - delta_t:		Sun elevation angle with respect to the orbital plane at the epoch t0 (degrees)
! ----------------------------------------------------------------------
! Note 1:
! - kepler:		Kepler elements array (6)
!   a:       	semi-major axis  (m)
!   e:      	eccentricity
!   i:      	inclination (degrees)
!   Omega:  	right ascension of the ascending node (degrees)
!   omega:  	argument of perigee (degrees)
!   E:      	eccentric anomaly (degrees)
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou at Geoscience Australia
! Created:	24 April 2020
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE mdl_planets
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: mjd, r_sat(3), v_sat(3), r_sun(3)
      REAL (KIND = prec_q), INTENT(IN) :: epsilon_t0
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: delta_t
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: epsilon_ti, epsilon_dot, ti

! ----------------------------------------------------------------------
! Current epoch in seconds since start of the day (0h)
ti = (mjd - INT(mjd)) * 86400.D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Colinearity angle at input epoch ti
CALL colinearity_angle (r_sat, v_sat, r_sun, epsilon_ti, epsilon_dot)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Time span
delta_t = (epsilon_ti - epsilon_t0)  / epsilon_dot
! ----------------------------------------------------------------------

END


!-----------------------------------------------------------------------
      program test

      include 'ceedf.h'

      integer ceed,err
      real*8 m(16), k(16), x(16), lambda(4), xxt(16)

      character arg*32

      m = (/ 0.2, 0.0745355993, -0.0745355993, 0.0333333333,&
     &       0.0745355993, 1., 0.1666666667, -0.0745355993,&
     &      -0.0745355993, 0.1666666667, 1., 0.0745355993,&
     &      0.0333333333, -0.0745355993, 0.0745355993, 0.2 /)
      k = (/ 3.0333333333, -3.4148928136, 0.4982261470, -0.1166666667,&
     &      -3.4148928136, 5.8333333333, -2.9166666667, 0.4982261470,&
     &       0.4982261470, -2.9166666667, 5.8333333333, -3.4148928136,&
     &      -0.1166666667, 0.4982261470, -3.4148928136, 3.0333333333 /)

      call getarg(1,arg)

      call ceedinit(trim(arg)//char(0),ceed,err)
      call ceedsimultaneousdiagonalization(ceed,k,m,x,lambda,4,err);

      do i=0,3
        do j=0,3
          xxt(j+i*4+1) = 0
          do kk=0,3
            xxt(j+i*4+1) = xxt(j+i*4+1)+x(kk+i*4+1)*x(kk+j*4+1)
          enddo
        enddo
      enddo

      write (*,*) 'x x^T:'
      do i=0,3
        do j=1,4
          if (abs(x(i*4+j))<1.0D-14) then
! LCOV_EXCL_START
            x(i*4+j) = 0
! LCOV_EXCL_STOP
          endif
        enddo
        write(*,'(A,F12.8,F12.8,F12.8,F12.8)') '',&
     &   xxt(i*4+1),xxt(i*4+2),xxt(i*4+3),xxt(i*4+4)
      enddo
      write (*,*) 'lambda:'
      do i=1,4
        if (abs(lambda(i))<1.0D-14) then
! LCOV_EXCL_START
          lambda(i) = 0
! LCOV_EXCL_STOP
        endif
        write(*,'(A,F12.8)') '',lambda(i)
      enddo

      call ceeddestroy(ceed,err)

      end
!-----------------------------------------------------------------------