module methods
    use   trisys, only: backcol, forwcol
    use cholesky, only: cholcol
    implicit none

contains
    subroutine grad(x, x0, f, g, ls, gamma, eps, iteration, armijo)
        ! Entrada
        double precision, intent(in) :: x0(:)   ! Ponto inicial
        double precision, intent(in) :: eps     ! Tolerância
        double precision, intent(in) :: gamma   ! γ > 0, Constante para condição de Armijo

        ! Função, gradiente e busca linear
        interface
            function f(x)
                double precision, intent(in) :: x(:)
                double precision             :: f
            end function f

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

            subroutine ls(alpha, x, d, f, gamma, gTd, xd, armijo)
                double precision, intent(inout) :: alpha
                double precision, intent(in)    :: x(:), d(:)
                double precision, intent(in)    :: gamma, gTd
                double precision, intent(inout) :: xd(:)

                interface
                    function f(x)
                        double precision, intent(in) :: x(:)
                        double precision             :: f
                    end function f

                    subroutine armijo()
                    end subroutine armijo
                end interface
            end subroutine ls

            subroutine iteration()
            end subroutine iteration

            subroutine armijo()
            end subroutine armijo
        end interface

        ! Saída
        double precision, intent(out) :: x(:)

        ! Variáveis locais
        integer                       :: n       ! Dimensão do problema
        double precision, allocatable :: d(:)    ! Direção
        double precision              :: alpha   ! Passo

        ! Variáveis para evitar chamadas de função desnecessárias
        double precision, allocatable :: gx(:)   ! g(x)
        double precision              :: gTd     ! gᵀ(x)d
        double precision, allocatable :: xd(:)

        ! Aloca
        n = size(x0)
        allocate( d(n))
        allocate(xd(n))
        allocate(gx(n))

        ! Valores iniciais
        x  = x0
        call g(gx, x)

        d     = -gx
        gTd   = dot_product(gx, d)
        alpha = 1.d0
        do while (norm2(gx) > eps)
            call iteration()
            ! Máxima descida
            d = -gx

            ! Aproxima chute inicial de α a partir do aceito anteriormente
            alpha = alpha*gTd
            gTd   = dot_product(gx, d)
            alpha = alpha/gTd

            ! Busca linear
            call ls(alpha, x, d, f, gamma, gTd, xd, armijo)

            ! Atualiza x com o novo valor
            x  = x + alpha*d
            call g(gx, x)

        end do

        ! Libera a memória
        deallocate(d)
        deallocate(xd)
        deallocate(gx)
    end subroutine grad

    subroutine newt(x, x0, f, g, h, ls, gamma, sigma, theta, eps, iteration, armijo, norm, angle)
        ! Entrada
        double precision, intent(in) :: x0(:)   ! Ponto inicial
        double precision, intent(in) :: eps     ! Tolerância
        double precision, intent(in) :: gamma   ! γ > 0, Constante para condição de Armijo
        double precision, intent(in) :: sigma   ! σ > 0, constante para condição da norma
        double precision, intent(in) :: theta   ! Θ > 0, constante para condição do ângulo

        ! Função, gradiente, hessiana e busca linear
        interface
            function f(x)
                double precision, intent(in) :: x(:)
                double precision             :: f
            end function f

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

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

            subroutine ls(alpha, x, d, f, gamma, gTd, xd, armijo)
                double precision, intent(inout) :: alpha
                double precision, intent(in)    :: x(:), d(:)
                double precision, intent(in)    :: gamma, gTd
                double precision, intent(inout) :: xd(:)

                interface
                    function f(x)
                        double precision, intent(in) :: x(:)
                        double precision             :: f
                    end function f

                    subroutine armijo()
                    end subroutine armijo
                end interface
            end subroutine ls

            subroutine iteration()
            end subroutine iteration

            subroutine armijo()
            end subroutine armijo

            subroutine norm()
            end subroutine norm

            subroutine angle()
            end subroutine angle
        end interface

        ! Saída
        double precision, intent(out) :: x(:)

        ! Variáveis locais
        integer                       :: n       ! Dimensão do problema
        double precision, allocatable :: d(:)    ! Direção
        integer,          allocatable :: p(:)    ! Vetor de permutação
        double precision              :: alpha   ! Passo
        double precision              :: rho     ! Constante para shift nos autovalores
                                                 ! da hessiana

        integer                       :: i, status, tmp

        ! Variáveis para evitar chamadas de função desnecessárias
        double precision, allocatable :: gx(:)   ! ∇f(x)
        double precision, allocatable :: xd(:)
        double precision, allocatable :: hx(:,:) ! ∇²f(x)
        double precision, allocatable :: hr(:,:) ! ∇²f(x) + ρI
        double precision              :: gTd     ! ∇ᵀf(x)d
        double precision              :: ng      ! ‖∇f(x)‖
        double precision              :: nd      ! ‖d‖

        ! Aloca
        n = size(x0)
        allocate( d(n))
        allocate( p(n))
        allocate(gx(n))
        allocate(xd(n))
        allocate(hx(n, n))
        allocate(hr(n, n))

        ! Valores iniciais
        x  = x0
        call g(gx, x)

        do while (norm2(gx) > eps)
            call iteration()
            ! Calcula fator de Cholesky de uma aproximação
            ! definida positiva da hessiana
            !     GGᵀ = ∇²f(x) + ρI
            call h(hx, x)

            ! Verifica se a própria hessiana não é definida positiva
            hr  = hx
            status = cholcol(n, hr)
            if (status == 0) then
                ! É definida positiva

                d = -gx
                ! Resolve Gᵀd solução da equação
                !    GGᵀd = -∇f(x)
                tmp = forwcol(n, hr, d, unit = .false.)

                ! Resolve d solução da equação
                !     Gᵀd = -G⁻¹∇f
                tmp = backcol(n, hr, d, trans = .true.)
            end if
            ng  = norm2(gx)
            nd  = norm2(d)
            gTd = dot_product(gx, d)
            rho = 1e-3

            ! Condição do ângulo
            do while (status == -1 .or. gTd > -theta*ng*nd)
                call angle()
                ! Faz shift nos autovalores e tenta novamente
                ! hr = ∇²f(x) + ρI
                hr = hx
                do i = 1, n
                    hr(i, i) = hr(i, i) + rho
                end do

                status = cholcol(n, hr)
                if (status == 0) then
                    ! É definida positiva

                    d = -gx
                    ! Resolve Gᵀd solução da equação
                    !    GGᵀd = -∇f(x)
                    tmp = forwcol(n, hr, d, unit = .false.)

                    ! Resolve d solução da equação
                    !     Gᵀd = -G⁻¹∇f
                    tmp = backcol(n, hr, d, trans = .true.)
                end if

                ng  = norm2(gx)
                nd  = norm2(d)
                gTd = dot_product(gx, d)
                rho = 10*rho
            end do

            ! Condição da norma
            if (nd < sigma*ng) then
                call norm()
                d = sigma*ng/nd*d
            end if

            gTd = dot_product(gx, d)

            ! Busca linear
            alpha = 1.d0
            call ls(alpha, x, d, f, gamma, gTd, xd, armijo)

            ! Atualiza x com o novo valor
            x  = x + alpha*d
            call g(gx, x)
        end do

        ! Libera a memória
        deallocate(d)
        deallocate(p)
        deallocate(xd)
        deallocate(gx)
        deallocate(hx)
        deallocate(hr)
    end subroutine newt

    subroutine bfgs(x, x0, f, g, ls, gamma, sigma, theta, eps, iteration, armijo, norm, angle)
        ! Entrada
        double precision, intent(in) :: x0(:)   ! Ponto inicial
        double precision, intent(in) :: eps     ! Tolerância
        double precision, intent(in) :: gamma   ! γ > 0, constante para condição de Armijo
        double precision, intent(in) :: sigma   ! σ > 0, constante para condição da norma
        double precision, intent(in) :: theta   ! Θ > 0, constante para condição do ângulo

        ! Função, gradiente e busca linear
        interface
            function f(x)
                double precision, intent(in) :: x(:)
                double precision             :: f
            end function f

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

            subroutine ls(alpha, x, d, f, gamma, gTd, xd, armijo)
                double precision, intent(inout) :: alpha
                double precision, intent(in)    :: x(:), d(:)
                double precision, intent(in)    :: gamma, gTd
                double precision, intent(inout) :: xd(:)

                interface
                    function f(x)
                        double precision, intent(in) :: x(:)
                        double precision             :: f
                    end function f

                    subroutine armijo()
                    end subroutine armijo
                end interface
            end subroutine ls

            subroutine iteration()
            end subroutine iteration

            subroutine armijo()
            end subroutine armijo

            subroutine norm()
            end subroutine norm

            subroutine angle()
            end subroutine angle
        end interface

        ! Saída
        double precision, intent(out) :: x(:)

        ! Variáveis locais
        integer                       :: n       ! Dimensão do problema
        double precision, allocatable :: d(:)    ! Direção
        double precision              :: alpha   ! Passo

        integer                       :: i, j, k

        ! Variáveis para evitar chamadas de função desnecessárias
        double precision, allocatable :: gx(:)    ! ∇f(x)
        double precision, allocatable :: xd(:)    ! x + αd
        double precision, allocatable :: h(:,:)   ! H(x)
        double precision, allocatable :: eye(:,:) ! I
        double precision, allocatable :: p(:)     !    x + αd  -    x
        double precision, allocatable :: q(:)     ! ∇f(x + αd) - ∇f(x)
        double precision              :: gTd      ! ∇ᵀf(x)d
        double precision              :: ng       ! ‖∇f(x)‖
        double precision              :: nd       ! ‖d‖
        ! Constantes para atualizar a matriz pelo BFGS
        double precision              :: a
        double precision              :: pTq     ! pᵀq
        double precision              :: qTHq    ! qᵀHq
        double precision              :: pqTHij  ! (pqᵀH)ᵢⱼ
        double precision              :: HqpTij  ! (Hqpᵀ)ᵢⱼ

        ! Aloca
        n = size(x0)
        allocate( d(n))
        allocate( p(n))
        allocate( q(n))
        allocate(gx(n))
        allocate(xd(n))
        allocate(eye(n, n))
        allocate(h(n, n))

        ! Valores iniciais
        x  = x0
        call g(gx, x)
        ng = norm2(gx)

        ! h começa sendo a identidade
        eye(:, :) = 0.d0
        do i = 1, n
            eye(i, i) = 1.d0
        end do

        h = eye
        do while (ng > eps)
            call iteration()
            ! Direção de Quasi-Newton
            ! d = -H∇f
            d(:) = 0.d0
            do j = 1, n
                do i = 1, n
                    d(i) = d(i) - h(i, j)*gx(j)
                end do
            end do
            nd = norm2(d)

            ! Condição da norma
            if (nd < sigma*ng) then
                call norm()
                d = sigma*ng/nd*d
                nd = norm2(d)
            end if

            gTd = dot_product(gx, d)

            ! Condição do ângulo
            if (gTd > -theta*ng*nd) then
                call angle()
                h = eye

                ! Vai pra próxima iteração
                cycle
            end if

            ! Busca linear
            alpha = 1.d0
            call ls(alpha, x, d, f, gamma, gTd, xd, armijo)

            q = gx

            ! Atualiza x
            x  = x + alpha*d
            call g(gx, x)
            ng = norm2(gx)

            p = alpha*d   ! p =    x + αd  -    x
            q = gx - q    ! q = ∇f(x + αd) - ∇f(x)
            pTq  = dot_product(p, q)

            ! Atualiza H
            qTHq = 0.d0
            do j = 1, n
                do i = 1, n
                    qTHq = qTHq + q(i)*h(i, j)*q(j)
                end do
            end do

            a = (pTq + qTHq)/pTq

            ! Atualiza a parte triangular inferior de H (sem a diagonal principal)
            do j = 1, n
                do i = j+1, n
                    ! Explora o fato que
                    !     H = Hᵀ
                    pqTHij = 0.d0
                    HqpTij = 0.d0

                    ! Só acessa a parte triangular superior de H (diagonal principal inclusa)
                    !     i <= j
                    do k = 1, j
                        pqTHij = pqTHij + p(i)*q(k)*h(k, j)
                    end do

                    do k = j+1, n
                        pqTHij = pqTHij + p(i)*q(k)*h(j, k)
                    end do

                    do k = 1, j
                        HqpTij = HqpTij + h(i, k)*q(k)*p(j)
                    end do

                    do k = j+1, n
                        HqpTij = HqpTij + h(k, i)*q(k)*p(j)
                    end do

                    ! i > j
                    h(i, j) = h(i, j) + (a*p(i)*p(j) - pqTHij - HqpTij)/pTq
                end do
            end do

            ! Atualiza a diagonal principal
            ! Aqui é importante o fato de que o termo Hᵢᵢ só é usado
            ! na iteração i e, portanto, pode ser alterado sem afetar as seguintes
            do i = 1, n
                pqTHij = 0.d0
                HqpTij = 0.d0

                ! Só acessa a parte triangular superior de H (diagonal principal inclusa)
                !     i <= j
                do k = 1, i
                    pqTHij = pqTHij + p(i)*q(k)*h(k, i)
                end do

                do k = i+1, n
                    pqTHij = pqTHij + p(i)*q(k)*h(i, k)
                end do

                do k = 1, i
                    HqpTij = HqpTij + h(i, k)*q(k)*p(i)
                end do

                do k = i+1, n
                    HqpTij = HqpTij + h(k, i)*q(k)*p(i)
                end do

                ! i = j
                h(i, i) = h(i, i) + (a*p(i)*p(i) - pqTHij - HqpTij)/pTq
            end do

            ! Atualiza a parte triangular superior de H
            do j = 1, n
                do i = 1, j-1
                    ! i < j
                    h(i, j) = h(j, i)
                end do
            end do
        end do

        ! Libera a memória
        deallocate(d)
        deallocate(p)
        deallocate(q)
        deallocate(xd)
        deallocate(h)
        deallocate(eye)
        deallocate(gx)
    end subroutine bfgs
end module methods


      subroutine foo(f1,f2,f3,f4,f5,f6,f7,f8,f9,f0,g1,g2,g3)
      implicit none
      integer f4,f3,f2,f1
      integer g4,g5,g6,g7,g8,g9
      integer i1,i2,i3,i4,i5

      real*8 g1(5,f3,f2,f1),g2(5,5,f3,f2,f1),g3(5,f3,f2,f1)
      real*8 f0(5,5,f3,f2,f1),f9(5,5,f3,f2,f1),f8(5,5,f3,f2,f1)
      real*8 f7(5,5,f3,f2,f1),f6(5,5,f3,f2,f1),f5(5,5,f3,f2,f1)

      do i3=1,f1
         g8=mod(i3+f1-2,f1)+1
         g9=mod(i3,f1)+1
         do i4=1,f2
            g6=mod(i4+f2-2,f2)+1
            g7=mod(i4,f2)+1
            do i5=1,f3
               g4=mod(i5+f3-2,f3)+1
               g5=mod(i5,f3)+1
               do i1=1,5
                  g3(i1,i5,i4,i3)=0.0d0
                  do i2=1,5
                     g3(i1,i5,i4,i3)=g3(i1,i5,i4,i3)+
     1                    g2(i1,i2,i5,i4,i3)*g1(i2,i5,i4,i3)+
     2                    f0(i1,i2,i5,i4,i3)*g1(i2,g5,i4,i3)+
     3                    f9(i1,i2,i5,i4,i3)*g1(i2,i5,g7,i3)+
     4                    f8(i1,i2,i5,i4,i3)*g1(i2,i5,i4,g9)+
     5                    f7(i1,i2,i5,i4,i3)*g1(i2,g4,i4,i3)+
     6                    f6(i1,i2,i5,i4,i3)*g1(i2,i5,g6,i3)+
     7                    f5(i1,i2,i5,i4,i3)*g1(i2,i5,i4,g8)
                  enddo
               enddo
            enddo
         enddo
      enddo
      return
      end

! We should be able to interchange this as the number of iterations is
! known to be 4 in the inner two loops.  See interchange-2.f for the
! kernel from bwaves.

! { dg-final { scan-tree-dump-times "will be interchanged" 1 "graphite" { xfail *-*-* } } }


      REAL FUNCTION SASUM(N,SX,INCX)
*     .. Scalar Arguments ..
      INTEGER INCX,N
*     ..
*     .. Array Arguments ..
      REAL SX(*)
*     ..
*
*  Purpose
*  =======
*
*     takes the sum of the absolute values.
*     uses unrolled loops for increment equal to one.
*     jack dongarra, linpack, 3/11/78.
*     modified 3/93 to return if incx .le. 0.
*     modified 12/3/93, array(1) declarations changed to array(*)
*
*

*     .. Local Scalars ..
      REAL STEMP
      INTEGER I,M,MP1,NINCX
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC ABS,MOD
*     ..
      SASUM = 0.0e0
      STEMP = 0.0e0
      IF (N.LE.0 .OR. INCX.LE.0) RETURN
      IF (INCX.EQ.1) GO TO 20
*
*        code for increment not equal to 1
*
      NINCX = N*INCX
      DO 10 I = 1,NINCX,INCX
          STEMP = STEMP + ABS(SX(I))
   10 CONTINUE
      SASUM = STEMP
      RETURN
*
*        code for increment equal to 1
*
*
*        clean-up loop
*
   20 M = MOD(N,6)
      IF (M.EQ.0) GO TO 40
      DO 30 I = 1,M
          STEMP = STEMP + ABS(SX(I))
   30 CONTINUE
      IF (N.LT.6) GO TO 60
   40 MP1 = M + 1
      DO 50 I = MP1,N,6
          STEMP = STEMP + ABS(SX(I)) + ABS(SX(I+1)) + ABS(SX(I+2)) +
     +            ABS(SX(I+3)) + ABS(SX(I+4)) + ABS(SX(I+5))
   50 CONTINUE
   60 SASUM = STEMP
      RETURN
      END


! { dg-do run }
! { dg-additional-options "-fno-range-check -w" }
!
! Check that we can print large constants
!
! "-fno-range-check -w" is used so the testcase compiles even with targets
! that don't support large integer kinds.

program test
  use iso_fortran_env, only : ikinds => integer_kinds
  implicit none

  ! Largest integer kind
  integer, parameter :: k = ikinds(size(ikinds))
  integer, parameter :: hk = k / 2

  if (k <= 8) stop

  call check(9000000000000000000_k, "9000000000000000000")
  call check(90000000000000000000_k, "90000000000000000000")
  call check(int(huge(1_hk), kind=k), "9223372036854775807")
  call check(2_k**63, "9223372036854775808")
  call check(10000000000000000000_k, "10000000000000000000")
  call check(18446744065119617024_k, "18446744065119617024")
  call check(2_k**64 - 1, "18446744073709551615")
  call check(2_k**64, "18446744073709551616")
  call check(20000000000000000000_k, "20000000000000000000")
  call check(huge(0_k), "170141183460469231731687303715884105727")
  call check(huge(0_k)-1, "170141183460469231731687303715884105726")

  call check(-9000000000000000000_k, "-9000000000000000000")
  call check(-90000000000000000000_k, "-90000000000000000000")
  call check(-int(huge(1_hk), kind=k), "-9223372036854775807")
  call check(-2_k**63, "-9223372036854775808")
  call check(-10000000000000000000_k, "-10000000000000000000")
  call check(-18446744065119617024_k, "-18446744065119617024")
  call check(-(2_k**64 - 1), "-18446744073709551615")
  call check(-2_k**64, "-18446744073709551616")
  call check(-20000000000000000000_k, "-20000000000000000000")
  call check(-huge(0_k), "-170141183460469231731687303715884105727")
  call check(-(huge(0_k)-1), "-170141183460469231731687303715884105726")
  call check(-huge(0_k)-1, "-170141183460469231731687303715884105728")

  call check(2_k * huge(1_hk), "18446744073709551614")
  call check((-2_k) * huge(1_hk), "-18446744073709551614")

contains

  subroutine check (i, str)
    implicit none
    integer(kind=k), intent(in), value :: i
    character(len=*), intent(in) :: str

    character(len=100) :: buffer
    write(buffer,*) i
    if (adjustl(buffer) /= adjustl(str)) call abort
  end subroutine

end


program foo
  integer, dimension(3, 2) :: a

  a = reshape ((/1, 2, 3, 4, 5, 6/), (/3, 2/))
  a = a(3:1:-1, 2:1:-1);

  if (any (a .ne. reshape ((/6, 5, 4, 3, 2, 1/), (/3, 2/)))) call abort
end program


C> \brief \b SCEIL
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       REAL FUNCTION SCEIL( A )
*
*       .. Scalar Arguments ..
*       REAL A
*       ..
*
*    =====================================================================
*
*       .. Intrinsic Functions ..
* 	      INTRINSIC          INT
*       ..
*       .. Executable Statements ..*
*
*       IF (A-INT(A).EQ.0) THEN
*           SCEIL = A
*       ELSE IF (A.GT.0) THEN
*           SCEIL = INT(A)+1;
*       ELSE
*           SCEIL = INT(A)
*       END IF
*
*       RETURN
*
*       END
*  Purpose
*  =======
*
C>\details \b Purpose:
C>\verbatim
C>\endverbatim
*
*  Arguments:
*  ==========
*
*
*  Authors:
*  ========
*
C> \author Univ. of Tennessee
C> \author Univ. of California Berkeley
C> \author Univ. of Colorado Denver
C> \author NAG Ltd.
*
C> \date November 2011
*
C> \ingroup variantsOTHERcomputational
*
*  =====================================================================
      REAL FUNCTION SCEIL( A )
*
*  -- LAPACK computational routine (version 3.1) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..*
      REAL A
*     ..
*
*  =====================================================================
*
*     .. Intrinsic Functions ..
	      INTRINSIC          INT
*     ..
*     .. Executable Statements ..*
*
      IF (A-INT(A).EQ.0) THEN
          SCEIL = A
      ELSE IF (A.GT.0) THEN
          SCEIL = INT(A)+1;
      ELSE
          SCEIL = INT(A)
      END IF

      RETURN
*
      END


SUBROUTINE formlump(diag,emm,g)
!
! This subroutine forms the lumped global mass matrix as a vector diag.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::emm(:,:)
 REAL(iwp),INTENT(OUT)::diag(0:)
 INTEGER,INTENT(IN)::g(:)
 INTEGER::i,ndof
 ndof=UBOUND(emm,1)
 DO i=1,ndof
   diag(g(i))=diag(g(i))+emm(i,i)
 END DO
RETURN
END SUBROUTINE formlump


subroutine take_forward_euler_step(t, dt, q)

! Take a time step using Forward Euler.
!
! Args:
!   t: Time before the step.
!   dt: Length of time step.
!   q: PDE solution at time t.

    !$ use omp_lib
    implicit none

    integer :: mx, my, mbc, meqn
    double precision :: x_lower, y_lower, dx, dy
    common /claw_config/ mx, my, mbc, x_lower, y_lower, dx, dy, meqn

    double precision, intent(in) :: t, dt
    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn),  &
        intent(inout) :: q

    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn) :: op_output
    integer :: ix, iy, ieqn

    call apply_bcs(t, q)
    call apply_pde_operator(t, q, op_output)

    do ieqn = 1, meqn
        !$omp parallel do private(ix)
        do iy = 1, my
            do ix = 1, mx
                q(ix, iy, ieqn) = q(ix, iy, ieqn) + dt * op_output(ix, iy, ieqn)
            end do
        end do
    end do

end subroutine take_forward_euler_step


        function transform1new(m1,m2,r,v,element)
*
*       Calculates 6 orbital elements given vectors r and v and mass ratio q.
*       --------------------------------------------------------------------
*       updated for arbitrary m1 3-1-05
*       28/red/7
*       2/12/97     Santa Cruz
*
        implicit real*8 (a-h,m,o-z)
        real*8 r(3),v(3),element(6)
        real*8 h(3),e(3),n(3),hn(3),rh(3),he(3)
        real*8 ii(3),jj(3),kk(3),nn,dot
        data ii/1.d0,0.d0,0.d0/
        data jj/0.d0,1.d0,0.d0/
        data kk/0.d0,0.d0,1.d0/
        INTEGER transform1new

c       write(*,*) "Transform:", m1,m2,r,v
        call cross(r,v,h)
        call cross(v,h,e)

        rr=sqrt(dot(r,r))
        hh=sqrt(dot(h,h))

        do i=1,3
           e(i)=e(i)/(m1+m2)-r(i)/rr
           h(i)=h(i)/hh
           rh(i)=r(i)/rr
        enddo

        call cross(kk,h,n)

        nn=sqrt(dot(n,n))
        ecc=sqrt(dot(e,e))
        a=hh**2/(m1+m2)/(1.d0-ecc**2)

        do i=1,3
           if(nn.eq.0)then
              n(i)=ii(i)
           else
              n(i)=n(i)/nn
           endif
           e(i)=e(i)/ecc
        enddo

        call cross(h,n,hn)
        call cross(h,e,he)

        cosOm=dot(ii,n)
        sinOm=dot(jj,n)
        cosi=dot(kk,h)
        sini=nn
        cosw=dot(n,e)
        sinw=dot(e,hn)
        cosphi=dot(rh,e)
        sinphi=dot(rh,he)

        element(1)=a
        element(2)=ecc
        element(3)=atan2(sini,cosi)
        element(4)=atan2(sinw,cosw)
        element(5)=atan2(sinOm,cosOm)
        element(6)=atan2(sinphi,cosphi)

c       write(*,*) "Transform2:", element
        transform1new = 0
        end

        subroutine transform1(q,r,v,element)
*
*       Calculates 6 orbital elements given vectors r and v and mass ratio q.
*       --------------------------------------------------------------------
*       28/red/7
*       2/12/97     Santa Cruz
*
        implicit real*8 (a-h,m,o-z)
        real*8 r(3),v(3),element(6)
        real*8 h(3),e(3),n(3),hn(3),rh(3),he(3)
        real*8 ii(3),jj(3),kk(3),nn,dot
        data ii/1.d0,0.d0,0.d0/
        data jj/0.d0,1.d0,0.d0/
        data kk/0.d0,0.d0,1.d0/

        call cross(r,v,h)
        call cross(v,h,e)

        rr=sqrt(dot(r,r))
        hh=sqrt(dot(h,h))

        do i=1,3
           e(i)=e(i)/(1.d0+q)-r(i)/rr
           h(i)=h(i)/hh
           rh(i)=r(i)/rr
        enddo

        call cross(kk,h,n)

        nn=sqrt(dot(n,n))
        ecc=sqrt(dot(e,e))
        a=hh**2/(1.d0+q)/(1.d0-ecc**2)

        do i=1,3
           if(nn.eq.0)then
              n(i)=ii(i)
           else
              n(i)=n(i)/nn
           endif
           e(i)=e(i)/ecc
        enddo

        call cross(h,n,hn)
        call cross(h,e,he)

        cosOm=dot(ii,n)
        sinOm=dot(jj,n)
        cosi=dot(kk,h)
        sini=nn
        cosw=dot(n,e)
        sinw=dot(e,hn)
        cosphi=dot(rh,e)
        sinphi=dot(rh,he)

        element(1)=a
        element(2)=ecc
        element(3)=atan2(sini,cosi)
        element(4)=atan2(sinw,cosw)
        element(5)=atan2(sinOm,cosOm)
        element(6)=atan2(sinphi,cosphi)

        end

        function transform2(mtot,element,r,v)
*
*       Calculates vectors r and v given 6 orbital elements.
*
        implicit real*8 (a-h,m,o-z)

        real*8 r(3),v(3),element(6)
        real*8 tempr(3),tempv(3)
        real*8 inc,B(3,3),mtot
        INTEGER transform2

        a=element(1)
        e=element(2)
        inc=element(3)
        w=element(4)
        Om=element(5)
        phi=element(6)

        cosp=cos(phi)
        sinp=sin(phi)
        cosi=cos(inc)
        sini=sin(inc)
        cosw=cos(w)
        sinw=sin(w)
        cosOm=cos(Om)
        sinOm=sin(Om)

        B(1,1) = cosw*cosOm - sinw*cosi*sinOm
        B(1,2) = cosw*sinOm + sinw*cosi*cosOm
        B(1,3) = sinw*sini
        B(2,1) = -sinw*cosOm - cosw*cosi*sinOm
        B(2,2) = -sinw*sinOm + cosw*cosi*cosOm
        B(2,3) = cosw*sini
        B(3,1) = sini*sinOm
        B(3,2) = -sini*cosOm
        B(3,3) = cosi

        h=sqrt(mtot*a*(1-e**2))
        rr=a*(1-e**2)/(1+e*cosp)
        rd=e*h*sinp/(a*(1-e**2))
        phid=h/rr**2

        r(1)=rr*cosp
        r(2)=rr*sinp
        r(3)=0

        v(1)=rd*cosp-rr*phid*sinp
        v(2)=rd*sinp+rr*phid*cosp
        v(3)=0

        do i=1,3
           sum1=0
           sum2=0
           do j=1,3
              sum1=sum1 + B(j,i)*r(j)
              sum2=sum2 + B(j,i)*v(j)
           enddo
           tempr(i)=sum1
           tempv(i)=sum2
        enddo
        do i=1,3
           r(i)=tempr(i)
           v(i)=tempv(i)
        enddo

        transform2 = 0
        end

        subroutine cross(u,v,w)
        real*8 u(3),v(3),w(3)
        w(1) = u(2)*v(3) - u(3)*v(2)
        w(2) = u(3)*v(1) - u(1)*v(3)
        w(3) = u(1)*v(2) - u(2)*v(1)
        end

        real*8 function dot(u,v)
        real*8 u(3),v(3)
        dot=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
        end

        subroutine transform3(q,eQD,r,v,element)
*
*       Calculates 6 orbital elements given vectors r and v and mass ratio q.
*       --------------------------------------------------------------------
*       28/red/7
*       2/12/97
*
        implicit real*8 (a-h,m,o-z)

        real*8 r(3),v(3),element(6)
        real*8 h(3),e(3),n(3),hn(3),rh(3),he(3)
        real*8 ii(3),jj(3),kk(3),nn,dot
        data ii/1.d0,0.d0,0.d0/
        data jj/0.d0,1.d0,0.d0/
        data kk/0.d0,0.d0,1.d0/

        call cross(r,v,h)
        call cross(v,h,e)

        rr=sqrt(dot(r,r))
        hh=sqrt(dot(h,h))

        do i=1,3
           e(i)=e(i)/((1+q)*(1+eQD))-r(i)/rr
           h(i)=h(i)/hh
           rh(i)=r(i)/rr
        enddo

        call cross(kk,h,n)

        nn=sqrt(dot(n,n))
        ecc=sqrt(dot(e,e))
        a=hh**2/(1+q)/(1-ecc**2)

        do i=1,3
           n(i)=n(i)/nn
           e(i)=e(i)/ecc
        enddo

        call cross(h,n,hn)
        call cross(h,e,he)

        cosOm=dot(ii,n)
        sinOm=dot(jj,n)
        cosi=dot(kk,h)
        sini=nn
        cosw=dot(n,e)
        sinw=dot(e,hn)
        cosphi=dot(rh,e)
        sinphi=dot(rh,he)

        element(1)=a
        element(2)=ecc
        element(3)=atan2(sini,cosi)
        element(4)=atan2(sinw,cosw)
        element(5)=atan2(sinOm,cosOm)
        element(6)=atan2(sinphi,cosphi)

        end

        subroutine transform4(e,h,q,element)
*
*       Calculates 5 orbital elements given vectors evec and h and mass ratio q.
*       -----------------------------------------------------------------------
*
        implicit real*8 (a-h,m,o-z)

        real*8 element(5)
        real*8 h(3),e(3),n(3),hn(3),he(3)
        real*8 eh(3),hhat(3),dot
        real*8 ii(3),jj(3),kk(3),nn,nnn
        data ii/1.d0,0.d0,0.d0/
        data jj/0.d0,1.d0,0.d0/
        data kk/0.d0,0.d0,1.d0/

        hh=sqrt(dot(h,h))

        call cross(kk,h,n)

        nn=sqrt(dot(n,n))
        if(nn.eq.0)then
           do i=1,3
              n(i)=ii(i)
           enddo
           nnn=1
        else
           nnn=nn
        endif
        ecc=sqrt(dot(e,e))
        a=hh**2/(1+q)/(1-ecc**2)

        do i=1,3
           n(i)=n(i)/nnn
           hhat(i)=h(i)/hh
           eh(i)=e(i)/ecc
        enddo

        call cross(hhat,n,hn)
        call cross(hhat,eh,he)

        cosOm=dot(ii,n)
        sinOm=dot(jj,n)
        cosi=dot(kk,hhat)
        sini=nn
        cosw=dot(n,eh)
        sinw=dot(eh,hn)

        element(1)=a
        element(2)=ecc
c       element(3)=datan2(sini,cosi)            1/3/00
        element(3)=dacos(cosi)
        element(4)=datan2(sinw,cosw)
        element(5)=datan2(sinOm,cosOm)

        end

        subroutine transform5(q,r,v,e,h)
*
*       Calculates vectors e and h given r,v and q.
*       -------------------------------------------
*
        implicit real*8 (a-h,m,o-z)

        real*8 r(3),v(3)
        real*8 h(3),e(3),dot

        call cross(r,v,h)
        call cross(v,h,e)

        rr=sqrt(dot(r,r))

        do i=1,3
           e(i)=e(i)/(1+q)-r(i)/rr
        enddo

        end

        subroutine transform6(e,h,kk,q,element)
*
*       Calculates 5 orbital elements given vectors evec and h and mass ratio q.
*       Uses Hout for kk
*       Precession Om not corrected
*       -----------------------------------------------------------------------
*
        implicit real*8 (a-h,m,o-z)

        real*8 element(5)
        real*8 h(3),e(3),n(3),hn(3),he(3)
        real*8 eh(3),dot
        real*8 ii(3),jj(3),kk(3),nn,nnn
        data ii/1.d0,0.d0,0.d0/
        data jj/0.d0,1.d0,0.d0/

        hh=sqrt(dot(h,h))

        call cross(kk,h,n)

        nn=sqrt(dot(n,n))
        if(nn.eq.0)then
           nnn=1
        else
           nnn=nn
        endif
        ecc=sqrt(dot(e,e))
        a=hh**2/(1+q)/(1-ecc**2)

        do i=1,3
           n(i)=n(i)/nnn
           eh(i)=e(i)/ecc
        enddo

        call cross(h,n,hn)
        call cross(h,eh,he)

        cosOm=dot(ii,n)
        sinOm=dot(jj,n)
        cosi=dot(kk,h)
        sini=nn
        cosw=dot(n,eh)
        sinw=dot(eh,hn)

        element(1)=a
        element(2)=ecc
c       element(3)=atan2(sini,cosi)
        element(3)=acos(cosi)
        element(4)=atan2(sinw,cosw)
        element(5)=atan2(sinOm,cosOm)

        end

        subroutine transform7(q,r,v,ehat,qhat,hhat)
*
*       Calculates basis vectors ehat, qhat and hhat given r,v and q.
*       ------------------------------------------------------------
*
        implicit real*8 (a-h,m,o-z)

        real*8 r(3),v(3)
        real*8 h(3),e(3),dot
        real*8 ehat(3),qhat(3),hhat(3)

        call cross(r,v,h)
        call cross(v,h,e)

        rr=sqrt(dot(r,r))

        ee=0
        hh=0

        do i=1,3
           e(i)=e(i)/(1+q)-r(i)/rr
           ee=ee+e(i)**2
           hh=hh+h(i)**2
        enddo

        do i=1,3
           ehat(i)=e(i)/sqrt(ee)
           hhat(i)=h(i)/sqrt(hh)
        enddo

        call cross(hhat,ehat,qhat)

        end


subroutine tara2dHydSer(arg)

use cfgio_mod, only: cfg_t, parse_cfg

implicit none

type(cfg_t):: cfg

real (kind=8), parameter :: pi = 3.14159265358979323846d0

include "fftw3.f"

integer (kind=4) Np,Nx,Ny,Nh

integer (kind=4) i,j,m,n,t
real (kind = 8) Lx, Ly, dx, dy, h, kx, ky, nu, W0, m0, d, y_Energy
real (kind = 8) time, time_min, time_max, dt

real (kind = 8), dimension (:), allocatable :: xp, yp, vxp, vyp
real (kind = 8), dimension (:), allocatable :: x, y

real (kind=8), dimension(:, :), allocatable :: omega, psi, ux, uy
complex (kind=8), dimension(:, :), allocatable :: omegak, omegak_new, psik, ukx, uky
complex (kind=8), dimension(:, :), allocatable :: omegak_dum,psik_dum,ukx_dum,uky_dum
complex (kind=8), dimension(:, :), allocatable :: dt_omegak_new,  dt_omegak_old

integer (kind=8) plan_forward, plan_backward

character (len=90) :: filename
character (len=32) :: arg

cfg = parse_cfg(arg)

call cfg%get("particle","Np",Np)
call cfg%get("grid","Nx",Nx)
call cfg%get("grid","Ny",Ny)

Nh = (Nx/2) + 1

allocate(xp(Np))
allocate(yp(Np))
allocate(vxp(Np))
allocate(vyp(Np))

allocate(x(Nx))
allocate(y(Ny))

allocate(omega(Nx,Ny))
allocate(psi(Nx,Ny))
allocate(ux(Nx,Ny))
allocate(uy(Nx,Ny))

allocate(omegak(Nh,Ny))
allocate(omegak_new(Nh,Ny))
allocate(psik(Nh,Ny))
allocate(ukx(Nh,Ny))
allocate(uky(Nh,Ny))

allocate(omegak_dum(Nh,Ny))
allocate(psik_dum(Nh,Ny))
allocate(ukx_dum(Nh,Ny))
allocate(uky_dum(Nh,Ny))

allocate(dt_omegak_new(Nh,Ny))
allocate(dt_omegak_old(Nh,Ny))

open(unit = 20, file = 'output/Energy.dat', status = 'unknown')

!====================== USER INPUTS ====================================

call cfg%get("length","Lx",Lx)
call cfg%get("length","Ly",Ly)

call cfg%get("resistivity","nu",nu)

call cfg%get("time","time_min",time_min)
call cfg%get("time","time_max",time_max)
call cfg%get("time","dt",dt)

call cfg%get("initialProfile","W0",W0)
call cfg%get("initialProfile","m0",m0)
call cfg%get("initialProfile","d",d)

Lx = Lx*pi
Ly = Ly*pi

dx = Lx/dfloat(Nx)
dy = Ly/dfloat(Ny)
h = 1.0d0/(dx*dy)

d = d*pi

do i = 1,Np
  xp(i) = rand()*Lx
  yp(i) = rand()*Ly
enddo

do i = 1,Nx
  x(i) = (i-1)*dx
  do j = 1,Ny
    y(j) = (j-1)*dy
    omega(i,j) = W0/dcosh((y(j)+0.5d0*pi)/d)**2.0 - W0/dcosh((y(j)-0.5d0*pi)/d)**2.0
    omega(i,j) = omega(i,j) - W0/dcosh((y(j)+1.50d0*pi)/d)**2.0+W0/dcosh((y(j)-1.50d0*pi)/d)**2.0
    omega(i,j) = omega(i,j) + 0.10d0*dcos(m0*x(i))
  enddo
enddo

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, omega, omegak, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)
  call dfftw_destroy_plan_ (plan_forward)

!==================== MAIN PROGRAM ========================================

do time = time_min, time_max, dt

t = nint(time/dt) - int(time_min/dt)

  call derive2csh (Nx, Ny, Nh, nu, time, omegak, omegak_new, dt_omegak_old, dt_omegak_new)
  call ab2csh (Nx, Ny, Nh, nu, time, dt, omegak, omegak_new, dt_omegak_old, dt_omegak_new)

do i = 1, Nh
  do j = 1, Ny
    dt_omegak_old(i,j) = dt_omegak_new(i,j)
    omegak(i,j) = omegak_new(i,j)
  enddo
enddo

do i = 1,Nh
  kx = 2.0d0*pi*dfloat(i-1)/Lx
  do j = 1,Ny/2
    ky = 2.0d0*pi*dfloat(j-1)/Ly
      if (i == 1 .and. j == 1) then
      psik(i,j) = (0.0d0,0.0d0)
      ukx(i,j) = (0.0d0,0.0d0)
      uky(i,j) = (0.0d0,0.0d0)
      else
      psik(i,j) = omegak(i,j)/(kx*kx+ky*ky)
      ukx(i,j) = + (0.0d0,1.0d0) * ky * psik(i,j)
      uky(i,j) = - (0.0d0,1.0d0) * kx * psik(i,j)
      endif
    psik_dum(i,j) = psik(i,j)
    omegak_dum(i,j) = omegak(i,j)
    ukx_dum(i,j) = ukx(i,j)
    uky_dum(i,j) = uky(i,j)
  enddo
  do j = Ny/2+1,Ny
    ky = 2.0d0*pi*(dfloat(j-1)-Ny)/Ly
    psik(i,j) = omegak(i,j)/(kx*kx+ky*ky)
    ukx(i,j) = + (0.0d0,1.0d0) * ky * psik(i,j)
    uky(i,j) = - (0.0d0,1.0d0) * kx * psik(i,j)
    psik_dum(i,j) = psik(i,j)
    omegak_dum(i,j) = omegak(i,j)
    ukx_dum(i,j) = ukx(i,j)
    uky_dum(i,j) = uky(i,j)
  enddo
enddo

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, omegak_dum, omega, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)
  call dfftw_destroy_plan_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, ukx_dum, ux, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)
  call dfftw_destroy_plan_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, uky_dum, uy, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)
  call dfftw_destroy_plan_ (plan_backward)

do i = 1,Nx
  do j = 1,Ny
  omega(i,j) = omega(i,j)/dfloat(Nx*Ny)
  ux(i,j) = ux(i,j)/dfloat(Nx*Ny)
  uy(i,j) = uy(i,j)/dfloat(Nx*Ny)
  if (mod(dfloat(t),1000.0d0) == 0.0d0) then
  write(filename, '("output/fort.",I8.8)') t+100
  open(unit=t+100,file=filename,status='unknown')
  write(t+100,*) x(i), y(j), omega(i,j), ux(i,j), uy(i,j)
  endif
  enddo
enddo

if (mod(dfloat(t),1000.0d0) == 0.0d0) then
  close(t+100)
endif

  do i = 1,Np

  m = aint(xp(i)/dx) + 1

  n = aint(yp(i)/dy) + 1

  if (m /= Nx .and. n /= Ny) then

  vxp(i) = ux(m,n) * (x(m+1) - xp(i)) * (y(n+1) - yp(i)) * h &
         + ux(m+1,n) * (xp(i) - x(m)) * (y(n+1) - yp(i)) * h &
         + ux(m,n+1) * (x(m+1) - xp(i)) * (yp(i) - y(n)) * h &
         + ux(m+1,n+1) * (xp(i) - x(m)) * (yp(i) - y(n)) * h

  vyp(i) = uy(m,n) * (x(m+1) - xp(i)) * (y(n+1) - yp(i)) * h &
         + uy(m+1,n) * (xp(i) - x(m)) * (y(n+1) - yp(i)) * h &
         + uy(m,n+1) * (x(m+1) - xp(i)) * (yp(i) - y(n)) * h &
         + uy(m+1,n+1) * (xp(i) - x(m)) * (yp(i) - y(n)) * h

  endif

  if (m == Nx .and. n == Ny) then

  vxp(i) = ux(m,n) * (Lx - xp(i)) * (Ly - yp(i)) * h &
         + ux(m+1,n) * (xp(i) - x(m)) * (Ly - yp(i)) * h &
         + ux(m,n+1) * (Lx - xp(i)) * (yp(i) - y(n)) * h &
         + ux(m+1,n+1) * (xp(i) - x(m)) * (yp(i) - y(n)) * h

  vyp(i) = uy(m,n) * (Lx - xp(i)) * (Ly - yp(i)) * h &
         + uy(m+1,n) * (xp(i) - x(m)) * (Ly - yp(i)) * h &
         + uy(m,n+1) * (Lx - xp(i)) * (yp(i) - y(n)) * h &
         + uy(m+1,n+1) * (xp(i) - x(m)) * (yp(i) - y(n)) * h

  endif

  if (m == Nx .and. n /= Ny) then

  vxp(i) = ux(m,n) * (Lx - xp(i)) * (y(n+1) - yp(i)) * h &
         + ux(m+1,n) * (xp(i) - x(m)) * (y(n+1) - yp(i)) * h &
         + ux(m,n+1) * (Lx - xp(i)) * (yp(i) - y(n)) * h &
         + ux(m+1,n+1) * (xp(i) - x(m)) * (yp(i) - y(n)) * h

  vyp(i) = uy(m,n) * (Lx - xp(i)) * (y(n+1) - yp(i)) * h &
         + uy(m+1,n) * (xp(i) - x(m)) * (y(n+1) - yp(i)) * h &
         + uy(m,n+1) * (Lx - xp(i)) * (yp(i) - y(n)) * h &
         + uy(m+1,n+1) * (xp(i) - x(m)) * (yp(i) - y(n)) * h

  endif

  if (m /= Nx .and. n == Ny) then

  vxp(i) = ux(m,n) * (x(m+1) - xp(i)) * (Ly - yp(i)) * h &
         + ux(m+1,n) * (xp(i) - x(m)) * (Ly - yp(i)) * h &
         + ux(m,n+1) * (x(m+1) - xp(i)) * (yp(i) - y(n)) * h &
         + ux(m+1,n+1) * (xp(i) - x(m)) * (yp(i) - y(n)) * h

  vyp(i) = uy(m,n) * (x(m+1) - xp(i)) * (Ly - yp(i)) * h &
         + uy(m+1,n) * (xp(i) - x(m)) * (Ly - yp(i)) * h &
         + uy(m,n+1) * (x(m+1) - xp(i)) * (yp(i) - y(n)) * h &
         + uy(m+1,n+1) * (xp(i) - x(m)) * (yp(i) - y(n)) * h

  endif

  enddo

  do i = 1,Np
  xp(i) = xp(i) + vxp(i) * dt
  yp(i) = yp(i) + vyp(i) * dt

  xp(i) = xp(i) - (int(xp(i)/Lx)) * Lx
    if (xp(i) .le. 0.0d0) then
      xp(i) = xp(i) + Lx
    endif

  yp(i) = yp(i) - (int(yp(i)/Ly)) * Ly
    if (yp(i) .le. 0.0d0) then
      yp(i) = yp(i) + Ly
    endif

  enddo

  if (mod(dfloat(t),1000.0d0) == 0.0d0) then
  do i = 1,Np
  write(filename, '("output/fort.",I8.8)') t+105
  open(unit=t+105,file=filename,status='unknown')
  write(t+105,*) xp(i),yp(i)
  enddo
  endif

enddo !time

end subroutine tara2dHydSer


! { dg-do run }
!
! PR 63733: [4.8/4.9/5 Regression] [OOP] wrong resolution for OPERATOR generics
!
! Original test case from Alberto F. Martín Huertas <amartin@cimne.upc.edu>
! Slightly modified by Salvatore Filippone <sfilippone@uniroma2.it>
! Further modified by Janus Weil <janus@gcc.gnu.org>

module overwrite
  type parent
   contains
     procedure :: sum => sum_parent
     generic   :: operator(+) => sum
  end type

  type, extends(parent) ::  child
  contains
    procedure :: sum => sum_child
  end type

contains

  integer function sum_parent(op1,op2)
    implicit none
    class(parent), intent(in) :: op1, op2
    sum_parent = 0
  end function

  integer function sum_child(op1,op2)
    implicit none
    class(child) , intent(in) :: op1
    class(parent), intent(in) :: op2
    sum_child = 1
  end function

end module

program drive
  use overwrite
  implicit none

  type(parent) :: m1, m2
  class(parent), pointer :: mres
  type(child)  :: h1, h2
  class(parent), pointer :: hres

  if (m1 + m2 /= 0) STOP 1
  if (h1 + m2 /= 1) STOP 2
  if (h1%sum(h2) /= 1) STOP 3

end


C$Procedure  INTSTR  ( Integer to character string )

      SUBROUTINE INTSTR ( NUMBER, STRING )

C$ Abstract
C
C     Convert an integer to an equivalent character string.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     ALPHANUMERIC
C     CONVERSION
C
C$ Declarations

      INTEGER               NUMBER
      CHARACTER*(*)         STRING

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     NUMBER     I   Integer to be converted.
C     STRING     O   Equivalent character string, left justified.
C
C$ Detailed_Input
C
C     NUMBER   The integer to be converted into a character string.
C
C$ Detailed_Output
C
C     STRING   The character string representing the integer NUMBER.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1)   If the output character string is not large enough to
C          contain the entire character string produced, the output
C          character string will be truncated on the right.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine will convert a signed integer into an equivalent
C     decimal character string representation. The decimal digits of
C     the integer NUMBER are found by repeated applications of
C     "modulus" and division operations.
C
C$ Examples
C
C     The following argument values illustrate the use of INTSTR.
C
C         NUMBER        STRING
C         ------------  ---------------------
C          1            '-1'
C         -1            '-1'
C          223          '223'
C         -32           '-32'
C          0            '0'
C          2147483647   '2147483647'   ( Maximum 32 bit integer )
C         -2147483647   '-2147483647'  ( Minimum 32 bit integer + 1 )
C         -2147483647   '-2147483648'  ( Minimum 32 bit integer )
C
C$ Restrictions
C
C     This routine assumes that all signed integers will fit into a
C     character string with LINLEN or fewer digits. See the parameter
C     LINLEN below for the current value.
C
C$ Author_and_Institution
C
C     K.R. Gehringer   (JPL)
C     W.L. Taber       (JPL)
C     I.M. Underwood   (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SPICELIB Version 2.1.0, 11-MAY-1993 (HAN) (MJS)
C
C        DATA statement came before the SAVE statement. This is
C        a violation of the ANSI Standard. It is now the other way
C        around.
C
C-    SPICELIB Version 2.0.0, 14-OCT-1992 (KRG)
C
C        The routine was rewritten to fix a bug concerning the minimum
C        representable integer.
C
C        This routine used to negate a negative number before it began
C        generating its digits. This was a bad thing to do, because on
C        many machines the minimum representable integer and the
C        maximum representable integer have the following relationship:
C
C           ABS( minimum integer ) = 1 + ABS( maximum integer ).
C
C        Changing the sign of a negative number before converting it
C        to a character string would cause a program to crash if it
C        were attempting to convert the minimum representable integer
C        into a character string.
C
C-    SPICELIB Version 1.0.2, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.1   7-DEC-1990 (WLT)
C
C        References to the old name INT2CH were removed and
C        an exception added to that section.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) (WLT)
C
C-&

C$ Index_Entries
C
C     convert integer to character string
C
C-&

C
C     Local Parameters
C
      INTEGER               BASE
      PARAMETER           ( BASE = 10 )

      INTEGER               STRLEN
      PARAMETER           ( STRLEN = 80 )
C
C     Local variables
C
      CHARACTER*(STRLEN)    TMPSTR

      CHARACTER*(1)         DIGITS(0:9)

      INTEGER               TMPNUM
      INTEGER               RESULT
      INTEGER               REMNDR

      INTEGER               I

C
C    Saved values
C
      SAVE DIGITS

      DATA                  DIGITS /
     .                               '0', '1', '2', '3',
     .                               '4', '5', '6', '7',
     .                               '8', '9'
     .                             /

C
C     The digits are generated in reverse order, so we fill the
C     character string in reverse order, from `right' to `left',
C     so that the digits are in the correct order when we are
C     done converting the integer. This is to avoid reversing the
C     character string before returning. The output character
C     string is then left justified upon exit.
C
C     Make a copy of the input so that it will not be modified.
C
      TMPNUM = NUMBER
C
C     Initialize the temporary character buffer used to store the
C     character string as it is generated to blanks.
C
      TMPSTR = ' '
C
C     We need to do different things for the cases where the number to
C     be converted is positive, negative, or zero. ( Actually, the
C     positive case and the zero case are the same, but since we can
C     test for integer zero exactly it will save a few arithmetic
C     operations if we treat it as a special case. ) The case for a
C     negative number is the only one which truly might cause problems,
C     because ABS(minimum integer) may equal ABS(maximum integer) + 1.
C     For 32 bit numbers, INTMIN = -214748368 and INTMAX = 214748367.
C     You should be able to see the repercussions of this.
C
      I = LEN( TMPSTR ) + 1
      IF ( TMPNUM .LT. 0 ) THEN
C
C        Collect all of the digits in the string.
C
         DO WHILE ( TMPNUM .NE. 0 )

            I      = I - 1
            RESULT = TMPNUM / BASE
            REMNDR = RESULT * BASE - TMPNUM
            TMPNUM = RESULT

            TMPSTR (I:I) = DIGITS(REMNDR)

         END DO
C
C        Put the minus sign in place.
C
         I           = I - 1
         TMPSTR(I:I) = '-'

      ELSE IF ( TMPNUM .GT. 0 ) THEN
C
C        Collect all of the digits in the string.
C
         DO WHILE ( TMPNUM .NE. 0 )

            I      = I - 1
            RESULT = TMPNUM / BASE
            REMNDR = TMPNUM - RESULT * BASE
            TMPNUM = RESULT

            TMPSTR (I:I) = DIGITS(REMNDR)

         END DO

      ELSE
C
C        Treat zero as a special case, because it's easier.
C
         I           = I - 1
         TMPSTR(I:I) = DIGITS(0)

      END IF
C
C     Set the value of the output string before returning. Let the
C     Fortran string equals deal with the left justification, and the
C     truncation on the right if the string STRING is not long enough
C     to contain all of the characters necessary.
C
      STRING = TMPSTR(I:LEN(TMPSTR))

      RETURN
      END


            program demo_string_to_values
             use M_strings, only : string_to_values
             implicit none
             character(len=80)  :: s=' 10 20e3;3.45 -400.3e-2;1234; 5678 '
             integer,parameter  :: isz=10
             real               :: array(isz)
             integer            :: inums, ierr, ii

             call string_to_values(s,10,array,inums,' ;',ierr)
             call reportit()

             call string_to_values('10;2.3;3.1416',isz,array,inums,' ;',ierr)
             call reportit()

             contains
                subroutine reportit()
                   write(*,*)'string_to_values:'
                   write(*,*)'input string.............',trim(s)
                   write(*,*)'number of values found...',inums
                   write(*,*)'values...................',(array(ii),ii=1,inums)
                end subroutine reportit
            end program demo_string_to_values


    program demo_btest
    implicit none
    integer :: i, j, pos, a(2,2)
    logical :: bool
    character(len=*),parameter :: g='(*(g0))'

         i = 32768 + 1024 + 64
        write(*,'(a,i0,"=>",b32.32,/)')'Looking at the integer: ',i

        ! looking one bit at a time from LOW BIT TO HIGH BIT
        write(*,g)'from bit 0 to bit ',bit_size(i),'==>'
        do pos=0,bit_size(i)-1
            bool = btest(i, pos)
            write(*,'(l1)',advance='no')bool
        enddo
        write(*,*)

        ! a binary format the hard way.
        ! Note going from bit_size(i) to zero.
        write(*,*)
        write(*,g)'so for ',i,' with a bit size of ',bit_size(i)
        write(*,'(b32.32)')i
        write(*,g)merge('^','_',[(btest(i,j),j=bit_size(i)-1,0,-1)])
        write(*,*)
        write(*,g)'and for ',-i,' with a bit size of ',bit_size(i)
        write(*,'(b32.32)')-i
        write(*,g)merge('^','_',[(btest(-i,j),j=bit_size(i)-1,0,-1)])

        ! elemental:
        !
        a(1,:)=[ 1, 2 ]
        a(2,:)=[ 3, 4 ]
        write(*,*)
        write(*,'(a,/,*(i2,1x,i2,/))')'given the array a ...',a
        ! the second bit of all the values in a
        write(*,'(a,/,*(l2,1x,l2,/))')'the value of btest (a, 2)',btest(a,2)
        ! bits 1,2,3,4 of the value 2
        write(*,'(a,/,*(l2,1x,l2,/))')'the value of btest (2, a)',btest(2,a)
    end program demo_btest


      subroutine shllindx(n,arr,iarr,iopt)
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C SHELL sorts an index array IARR of an ARR of length N to indicate
C either ascending or descending numerical order
C by the Shell - Mezgar algorithm . (Numerical Recipes p 229)
c
c Inputs:
c   arr  - The array to be indexed
c   n    - length of sort
c   iopt - >0 sort into ascending order
c          <0 "      "  descending order
c
c Outputs:
c   iarr - The index array
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c
      real     arr(n)
      integer iarr(n)
c
      parameter ( ALN2I = 1./0.69314718, TINY = 1.E-5)
C
      lognb2 = INT( ALOG( FLOAT(n) ) * ALN2I + TINY)
C
      do 1 i = 1,n
   1  iarr(i) = i
C
      if (iopt.lt.0) GO TO 100
      m = n
      do 12 nn = 1, lognb2
        m = m/2
        k = n - m
        do 11 j = 1, k
          i = j
   3      CONTINUE
          l = i + m
          if ( arr( iarr(l) ).lt.arr( iarr(i) ) ) THEN
                 it = iarr(i)
            iarr(i) = iarr(l)
            iarr(l) = it
            i = i - m
            if (i.ge.1) GO TO 3
          endif
   11   continue
   12 continue
      RETURN
C
  100 CONTINUE
      m = n
      do 112 nn = 1, lognb2
        m = m/2
        k = n - m
        do 111 j = 1, k
          i = j
 103      CONTINUE
          l = i + m
          if ( arr( iarr(l) ).gt.arr( iarr(i) ) ) then
                 it = iarr(i)
            iarr(i) = iarr(l)
            iarr(l) = it
            i = i - m
            if (i.ge.1) GO TO 103
          endif
  111   continue
  112 continue
      RETURN
      end


module physics
    ! always keep module named 'physics'
    !   even if the file name changes.
    !   - this lets you create different physics for different runs,
    !       and have things like simply by compiling the right physics file
    !       !!! NOTE !!!
    !           - this means you MUST make sure you have a recent,
    !             compiled version of the right physics.

    implicit none
    public calc_energy
    public calc_force, accuracy_check
    integer, parameter           :: precision=8 ! double precision

    type, public :: accuracy_state
            real(kind=precision) :: energy
        contains
            procedure, pass :: initialize => accuracy_state_initialize
    end type accuracy_state

    logical, parameter                  :: allow_z_motion = .False. ! for bulirsch_stoer

    real(kind=precision), parameter     :: energy_tol      = 1d-4

    real(kind=precision), parameter     :: epsilon         = .1
    real(kind=precision), parameter     :: R_c             = 0.5
    real(kind=precision), parameter     :: V_0             = 1
    real(kind=precision), parameter     :: Omega_b         = 1.25
    integer,              parameter     :: m               = 2

    ! ! ! DERIVED CONSTANTS
    ! location of resonances (inner Lindblad does not exist)
    real(kind=precision), parameter     :: R_corot         = 0.6245
    real(kind=precision), parameter     :: R_outer         = 1.308363879053123
    real(kind=precision), parameter     :: R_general       = 1

    ! unperturbed tangential velocities at resonances, in rotating frame
    real(kind=precision), parameter     :: v_corot_tang    =  0
    real(kind=precision), parameter     :: v_outer_tang    = -0.70134187239444
    real(kind=precision), parameter     :: v_general_tang  = -0.35557280900008

    contains

    subroutine calc_force(n_bodies, x, v, mass, force)
        ! Calculate gravitational forces given current positions

        ! inputs:
        !   n_bodies    - integer - number of interacting bodies
        !   x           - (n_bodies x 3) float array - positions

        ! outputs:
        !   f           - (n_bodies x 3) float array - forces

        ! side effects:
        !   none (this is enforced)

        ! assumes:

        ! features for later:

        implicit none
        integer,                                      intent(in)  :: n_bodies
        real(kind=precision), dimension(n_bodies, 3), intent(in)  :: x
        real(kind=precision), dimension(n_bodies, 3), intent(in)  :: v
        real(kind=precision), dimension(n_bodies   ), intent(in)  :: mass
        real(kind=precision), dimension(n_bodies, 3), intent(out) :: force
        real(kind=precision)                                      :: dLog_term
        real(kind=precision)                                      :: dcos_term
        real(kind=precision)                                      :: x1, x2 ! x,y coords
        real(kind=precision)                                      :: R_squared
        integer                                                   :: i ! loop variables

        do concurrent (i=1:n_bodies)
            x1 = x(i,1)  ! x coord
            x2 = x(i,2)  ! y coord
            R_squared = x1**2 + x2**2   ! radial coordinate, SQUARED

            dLog_term = V_0**2 * (1 + (epsilon**2 * ((x1**2 - x2**2) / R_squared)) ) &
                / (R_c**2 + R_squared)

            dcos_term = 2 * V_0**2 * log(R_c**2 + R_squared) &
                * (epsilon**2 * x1 * x2) / (R_squared**2)

            force(i,1) = mass(i) * ( -x1*dLog_term - x2*dcos_term )
            force(i,2) = mass(i) * ( -x2*dLog_term + x1*dcos_term )
            force(i,3) = 0.

            ! Add centrifugal:
            force(i,1) = force(i,1) + mass(i) * Omega_b**2 * x(i,1)
            force(i,2) = force(i,2) + mass(i) * Omega_b**2 * x(i,2)
            force(i,3) = force(i,3) + 0.

!             ! Add coriolis:
            force(i,1) = force(i,1) + 2 * mass(i) * Omega_b * v(i,2)
            force(i,2) = force(i,2) - 2 * mass(i) * Omega_b * v(i,1)
            force(i,3) = force(i,3) + 0.
        end do

    end subroutine calc_force

    pure function calc_energy(n_bodies, x, v, mass) result(energy)
        implicit none
        integer,                                      intent(in)  :: n_bodies
        real(kind=precision), dimension(n_bodies, 3), intent(in)  :: x, v
        real(kind=precision), dimension(n_bodies   ), intent(in)  :: mass
        real(kind=precision)                                      :: energy
        integer                                                   :: i,j ! loop variables

        energy = 0.

        do concurrent (i=1:n_bodies, j=1:3)
            energy = energy + 1./2 * mass(i) * v(i,j)**2
        end do

        do concurrent (i=1:n_bodies)
            energy  = energy + mass(i) * (1./2) * V_0**2 &
                * log(R_c**2 + x(i,1)**2 + x(i,2)**2) &
                * (1 + epsilon**2  &
                    * ((x(i,1)**2 - x(i,2)**2) / (x(i,1)**2 + x(i,2)**2)) )
            energy = energy - ( mass(i)*Omega_b**2 * (x(i,1)**2 + x(i,2)**2)/2 )  ! centrifugal barrier
        end do

    end function calc_energy

    function accuracy_check(state_initial, state_current) result (check)
        implicit none
        class(accuracy_state), intent(in) :: state_initial, state_current
        logical :: check
        real(kind=precision) :: energy_err

        energy_err = abs( (state_current%energy - state_initial%energy) &
            / (state_initial%energy) )

        check = .False.
        if (energy_err.lt.energy_tol) then
            check = .True.
        end if

    end function

    subroutine accuracy_state_initialize(state, n_bodies, x, v, mass)
        implicit none
        class(accuracy_state),                        intent(out) :: state
        integer,                                      intent(in)  :: n_bodies
        real(kind=precision), dimension(n_bodies, 3), intent(in)  :: x, v
        real(kind=precision), dimension(n_bodies   ), intent(in)  :: mass
        real(kind=precision) :: energy

        energy = calc_energy(n_bodies, x, v, mass)

        state%energy = energy

    end subroutine

end module


c=======================================================================
c
c     subroutine ALLOCIT
c
c     Index Tracking allocation srtategy
c
c     Min[ Tracking Error ]
c      s.t.
c     rho*w - index perf. >= delta      (relative target return)
c     C*w <= b                          (linear constraints)
c     Cinf <= w <= Csup                 (lower/upper bounds)
c
c        w   : portfolio weights
c        Q   : covariance matrix
c        rho : assets performance
c
c----------------------------------------------------------------------
      SUBROUTINE allocit ( n, cov, rho, covb, rhob,
     &                     neq, nin, ccst, bcst, cinf, csup, delta,
     &                     iwork, dwork, wopt, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : number of asset                                 integer
c       cov    : covariance matrix (n*n)                          double
c       rho    : expected returns (n)                             double
c       covb   : covariance assets-index (n)                      double
c       rhob   : index expected return                            double
c       neq    : number of equality constraints                  integer
c       nin    : number of inequality constraints                integer
c       ccst   : matrix of constraints (n*(neq+nin))              double
c       bcst   : vector of constraints (neq+nin)                  double
c       cinf   : lower bound (n)                                  double
c       csup   : upper bound (n)                                  double
c       delta  : relative target return                           double
c
c     WORKSPACE
c       iwork  : 3*n+2*nin+neq+6                                 integer
c       dwork  : n*(2*n+2*nin+2*neq+18)+4*neq+6*nin+15            double
c
c     OUTPUT
c       wopt   : optimal portfolio (n)                            double
c       info   : diagnostic argument                             integer
c
c     CALL
c       OPIT    : computing optimization for ALLOCIT (cf. OPIT.F)
c       TESTSDP : test if covariance matrix is SDP
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, neq, nin
      DOUBLE PRECISION rhob, delta
      DOUBLE PRECISION cov(*), rho(*), covb(*), cinf(*), csup(*),
     &                 wopt(*), ccst(n,*), bcst(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER pisdp, piwo, pdsdp, pdwo
c
c     external subroutines
      EXTERNAL testsdp, opit
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      pisdp = 1
c     pisdp : pointer for workspace of TESTSDP (n)
      piwo  = 1
c     piwo  : pointer for OPIT (3*n+2*nin+neq+6)
c
c     Total size of iwork array = 3*n + 2*nin + neq + 6
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdsdp = 1
c     pdsdp : pointer for TESTSDP (n*(2*n + 7))
      pdwo  = 1
c     pdwo : pointer for OPIT
c            n*(2*n + 2*nin + 2*neq + 18) + 4*neq + 6*nin + 15
c
c     Total size of dwork array = n*(2*n+2*nin+2*neq+18)+4*neq+6*nin+15
c
c--------------------------------------------------------------------
c
c     covariance matrix SDP ?
      CALL testsdp (n, cov, iwork(pisdp), dwork(pdsdp), info)
      IF (info .NE. 0) THEN
         info = -108
         RETURN
      ENDIF
c
c     optimization - traking error minimazion
      CALL opit ( n, cov, covb, rho, rhob, delta,
     &            neq, nin, ccst, bcst, cinf, csup,
     &            iwork(piwo), dwork(pdwo), wopt, info)
      IF (info .ge. 0) THEN
        CALL checkfeasit (n, wopt, rho, rhob, neq, nin, ccst, bcst,
     &                    cinf, csup, delta, dwork(pdwo), info)
      ENDIF
      RETURN
      END


!
! Geroch-Held-Penrose (GHP) operators
!
! edth:        rescaled by R
! edth_prime:  rescaled by R
! thorn:       rescaled by R
! thorn_prime: not rescaled (is already nonzero at future null infinity)
!
module mod_ghp
!=============================================================================
   use mod_prec
   use mod_cheb,   only: R=>Rarr, compute_DR
   use mod_swal,   only: cy=>cyarr, sy=>syarr, swal_lower, swal_raise
   use mod_field,  only: field, set_level, set_DT

   use mod_bkgrd_np, only: ep_0
   use mod_params,   only: &
      ZI, &
      dt, nx, ny, min_m, max_m, max_l, &
      cl=>compactification_length, &
      bhm=>black_hole_mass, &
      bhs=>black_hole_spin
!=============================================================================
   implicit none
   private

   public :: ghp_init, set_edth, set_edth_prime, set_thorn, set_thorn_prime

   complex(rp), allocatable :: &
      pre_edth_DT(:,:), &
      pre_edth_raised(:,:), &
      pre_edth_level(:,:), &
      pre_edth_prime_DT(:,:), &
      pre_edth_prime_lowered(:,:), &
      pre_edth_prime_level(:,:), &
      pre_thorn_DT(:,:), &
      pre_thorn_DR(:,:), &
      pre_thorn_level(:,:), &
      pre_thorn_prime_DT(:,:), &
      pre_thorn_prime_DR(:,:)
!=============================================================================
   interface set_edth
      module procedure set_edth_field, set_edth_arr
   end interface

   interface set_edth_prime
      module procedure set_edth_prime_field, set_edth_prime_arr
   end interface

   interface set_thorn
      module procedure set_thorn_field, set_thorn_arr
   end interface

   interface set_thorn_prime
      module procedure set_thorn_prime_field, set_thorn_prime_arr
   end interface
!=============================================================================
   contains
!=============================================================================
! precompute some of the prefactors for ghp operators
!=============================================================================
   subroutine ghp_init()
      allocate(pre_edth_DT(nx,ny))
      allocate(pre_edth_raised(nx,ny))
      allocate(pre_edth_level(nx,ny))
      allocate(pre_edth_prime_DT(nx,ny))
      allocate(pre_edth_prime_lowered(nx,ny))
      allocate(pre_edth_prime_level(nx,ny))
      allocate(pre_thorn_DT(nx,ny))
      allocate(pre_thorn_DR(nx,ny))
      allocate(pre_thorn_level(nx,ny))
      allocate(pre_thorn_prime_DT(nx,ny))
      allocate(pre_thorn_prime_DR(nx,ny))
   !--------------------------------------------------------------------------
   ! divided by R
   !--------------------------------------------------------------------------
      pre_edth_DT = &
         (1.0_rp/sqrt(2.0_rp))*(1.0_rp/((cl**2) - ZI*bhs*R*cy))*(-ZI*bhs*sy)

      pre_edth_raised = &
         (1.0_rp/sqrt(2.0_rp))*(1.0_rp/((cl**2) - ZI*bhs*R*cy))

      pre_edth_level = &
         ( &
            (ZI*bhs*R*sy/sqrt(2.0_rp)) &
         /  ((ZI*(cl**2) + bhs*R*cy)**2) &
         )
   !--------------------------------------------------------------------------
   ! divided by R
   !--------------------------------------------------------------------------
      pre_edth_prime_DT = &
         (1.0_rp/sqrt(2.0_rp))*(1.0_rp/((cl**2) + ZI*bhs*R*cy)) * ZI*bhs*sy

      pre_edth_prime_lowered = &
         (1.0_rp/sqrt(2.0_rp))*(1.0_rp/((cl**2) + ZI*bhs*R*cy))

      pre_edth_prime_level = &
         ( &
            (ZI*bhs*R*sy/sqrt(2.0_rp)) &
         /  ((cl**2 + ZI*bhs*R*cy)**2) &
         )
   !--------------------------------------------------------------------------
   ! divided by R
   !--------------------------------------------------------------------------
      pre_thorn_DT = &
         (1.0_rp/((cl**4)+((bhs*R*cy)**2))) &
         *R*2.0_rp*bhm*(2.0_rp*bhm-((bhs/cl)**2)*R)

      !--------------
      ! divided by R
      !--------------
      pre_thorn_DR = &
         (1.0_rp/((cl**4)+((bhs*R*cy)**2)))*( &
         -  0.5_rp*((cl**2)-(2.0_rp*bhm*R) + ((bhs*R/cl)**2)) &
         )

      pre_thorn_level = &
         (1.0_rp/((cl**4)+((bhs*R*cy)**2)))*R*(ZI*bhs)
   !--------------------------------------------------------------------------
   ! NOT divided by R
   !--------------------------------------------------------------------------
      pre_thorn_prime_DT = &
         (2.0_rp + (4.0_rp*bhm*R/(cl**2)))

      !--------------
      ! divided by R
      !--------------
      pre_thorn_prime_DR = &
         ((1.0_rp/cl)**2)*R
   !--------------------------------------------------------------------------
   end subroutine ghp_init
!=============================================================================
   subroutine set_edth_arr(m_ang, spin, boost, level, DT, raised, edth_arr)
      integer(ip), intent(in) :: m_ang, spin, boost
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in)  :: level
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in)  :: DT
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in)  :: raised
      complex(rp), dimension(nx,ny,min_m:max_m), intent(out) :: edth_arr

      real(rp) :: p

      p = (spin+boost)

      edth_arr(:,:,m_ang) = &
         pre_edth_DT     *DT(:,:,m_ang) &
      +  pre_edth_raised *raised(:,:,m_ang) &
      +  p*pre_edth_level*level(:,:,m_ang)

   end subroutine set_edth_arr
!=============================================================================
   subroutine set_edth_field(step, m_ang, f)
      integer(ip), intent(in)    :: step, m_ang
      type(field), intent(inout) :: f

      call set_level(step, m_ang, f)
      call set_DT(   step, m_ang, f)

      call swal_raise(f%spin, m_ang, f%level, f%raised)

      call set_edth_arr(m_ang, f%spin, f%boost, f%level, f%DT, f%raised, f%edth)

   end subroutine set_edth_field
!=============================================================================
   subroutine set_edth_prime_arr(m_ang, spin, boost, level, DT, lowered, edth_prime_arr)
      integer(ip), intent(in) :: m_ang, spin, boost
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in)  :: level
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in)  :: DT
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in)  :: lowered
      complex(rp), dimension(nx,ny,min_m:max_m), intent(out) :: edth_prime_arr

      real(rp) :: q

      q = (-spin+boost)

      edth_prime_arr(:,:,m_ang) = &
         pre_edth_prime_DT     *DT(:,:,m_ang) &
      +  pre_edth_prime_lowered*lowered(:,:,m_ang) &
      +  q*pre_edth_prime_level*level(:,:,m_ang)

   end subroutine set_edth_prime_arr
!=============================================================================
   subroutine set_edth_prime_field(step, m_ang, f)
      integer(ip), intent(in)    :: step, m_ang
      type(field), intent(inout) :: f

      call set_level(step, m_ang, f)
      call set_DT(   step, m_ang, f)

      call swal_lower(f%spin, m_ang, f%level, f%lowered)

      call set_edth_prime_arr(m_ang, f%spin, f%boost, f%level, f%DT, f%lowered, f%edth_prime)

   end subroutine set_edth_prime_field
!=============================================================================
   subroutine set_thorn_arr(m_ang, spin, boost, falloff, level, DT, DR, thorn_arr)
      integer(ip), intent(in)    :: m_ang, spin, boost, falloff
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in) :: level
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in) :: DT
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in) :: DR
      complex(rp), dimension(nx,ny,min_m:max_m), intent(out) :: thorn_arr

      real(rp) :: p, q

      p = ( spin+boost)
      q = (-spin+boost)

      thorn_arr(:,:,m_ang) = &
         pre_thorn_DT*DT(:,:,m_ang) &
      +  pre_thorn_DR*(R*DR(:,:,m_ang) + falloff*level(:,:,m_ang)) &
      +  pre_thorn_level*m_ang     *level(:,:,m_ang) &
      -  R*(p*ep_0 + q*conjg(ep_0))*level(:,:,m_ang)

   end subroutine set_thorn_arr
!=============================================================================
   subroutine set_thorn_field(step, m_ang, f)
      integer(ip), intent(in)    :: step, m_ang
      type(field), intent(inout) :: f

      call set_level( step, m_ang, f)
      call set_DT(    step, m_ang, f)
      call compute_DR(step, m_ang, f)

      call set_thorn_arr(m_ang, f%spin, f%boost, f%falloff, f%level, f%DT, f%DR, f%thorn)

   end subroutine set_thorn_field
!=============================================================================
! no rescaling in R for thorn prime
!=============================================================================
   subroutine set_thorn_prime_arr(m_ang, falloff, level, DT, DR, thorn_prime_arr)
      integer(ip), intent(in) :: m_ang, falloff
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in) :: level
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in) :: DT
      complex(rp), dimension(nx,ny,min_m:max_m), intent(in) :: DR
      complex(rp), dimension(nx,ny,min_m:max_m), intent(out) :: thorn_prime_arr

      thorn_prime_arr(:,:,m_ang) = &
         pre_thorn_prime_DT*DT(:,:,m_ang) &
      +  pre_thorn_prime_DR*(R*DR(:,:,m_ang) + falloff*level(:,:,m_ang))

   end subroutine set_thorn_prime_arr
!=============================================================================
   subroutine set_thorn_prime_field(step, m_ang, f)
      integer(ip), intent(in)    :: step, m_ang
      type(field), intent(inout) :: f

      call set_level( step, m_ang, f)
      call set_DT(    step, m_ang, f)
      call compute_DR(step, m_ang, f)

      call set_thorn_prime_arr(m_ang, f%falloff, f%level, f%DT, f%DR, f%thorn_prime)

   end subroutine set_thorn_prime_field
!=============================================================================
end module mod_ghp


    program demo_besj0
    use, intrinsic :: iso_fortran_env, only : real_kinds, &
    & real32, real64, real128
       implicit none
       real(kind=real64) :: x = 0.0_real64
       x = bessel_j0(x)
       write(*,*)x
    end program demo_besj0


!*******************************************************************
!                                                                  *
      INTEGER FUNCTION JTHN(K,N,I)
!                                                                  *
!   Written by G. Gaigalas,                                        *
!   Vanderbilt University,  Nashville               October  1996  *
!   Transform to fortran 90/95 by G. Gaigalas       December 2012  *
!   The last modification made by G. Gaigalas       October  2017  *
!                                                                  *
!*******************************************************************
!
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: I, N, K
!-----------------------------------------------
      IF(N == 1) THEN
        JTHN=MOD(K,I)
      ELSEIF(N == 2) THEN
        JTHN=MOD(K/I,I)
      ELSEIF(N == 3) THEN
        JTHN=MOD(K/(I*I),I)
      ELSEIF(N == 4) THEN
        JTHN=MOD(K/(I*I*I),I)
      ELSEIF(N == 5) THEN
        JTHN=MOD(K/(I*I*I*I),I)
      ELSE
        WRITE(6,'(A)') ' ERROR IN JTHN '
        STOP
      ENDIF
      RETURN
      END FUNCTION JTHN


!##############################################################################
!# Tutorial 006i: Create a mass and Laplace matrix
!##############################################################################

module tutorial006i

  ! Include basic Feat-2 modules
  use fsystem
  use storage
  use genoutput

  use triangulation
  use meshgeneration

  use element
  use derivatives
  use spatialdiscretisation
  use linearsystemscalar
  use bilinearformevaluation
  use stdoperators

  implicit none
  private

  public :: start_tutorial006i

contains

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

  subroutine start_tutorial006i

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialdiscretisation) :: rdiscretisation

    type(t_matrixScalar) :: rmatrixTemplate
    type(t_matrixScalar) :: rmatrixMass, rmatrixLaplace

    logical :: bhasstruc1, bhasstruc2, bhasstruc3
    logical :: bhascont1, bhascont2, bhascont3
    logical :: bsharedstruc1, bsharedstruc2, bsharedstruc3
    logical :: bsharedcont

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 006i")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 5x5-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 4, 4)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Discretise with Q1.
    !
    ! Create a structure rdiscretisation
    ! which describes the discretisation.
    ! =================================

    call spdiscr_initDiscr_simple (rdiscretisation,EL_Q1_2D,rtriangulation)

    ! =================================
    ! Create a CSR-matrix for the above
    ! discretisation.
    ! =================================

    ! Create the matrix structure
    call bilf_createMatrixStructure (rdiscretisation,LSYSSC_MATRIX9,rmatrixTemplate)

    ! =================================
    ! Derive a mass and a Laplace
    ! matrix which share the same
    ! structure but have their own
    ! content.
    ! =================================

    ! ------------------------------------
    ! ----- Mass matrix ------------------

    ! NOTE: "lsyssc_duplicateMatrix" allows to "derive" a matrix from another one
    ! in various ways. In the following, we use the routine to derive a mass
    ! matrix rmatrixMass from the template matrix rmatrixTemplate. The mass
    ! matrix "shares" the (CSR-) structure of the template matrix (->LSYSSC_DUP_SHARE),
    ! so no additional memory is allocated. For the "content" (the entries),
    ! a new and empty memory block is allocated (->LSYSSC_DUP_EMPTY) which we later
    ! fill with data.

    ! Share structure, allocate memory for new content
    call lsyssc_duplicateMatrix (rmatrixTemplate,rmatrixMass,&
        LSYSSC_DUP_SHARE, LSYSSC_DUP_EMPTY)

    ! Clear the matrix
    call lsyssc_clearMatrix (rmatrixMass)

    ! Create the matrix
    call stdop_assembleSimpleMatrix (rmatrixMass,DER_FUNC2D,DER_FUNC2D)

    ! ------------------------------------
    ! ----- Laplace matrix ---------------
    call lsyssc_duplicateMatrix (rmatrixTemplate,rmatrixLaplace,&
        LSYSSC_DUP_SHARE, LSYSSC_DUP_EMPTY)

    call lsyssc_clearMatrix (rmatrixLaplace)

    call stdop_assembleLaplaceMatrix (rmatrixLaplace)

    ! =================================
    ! Prove that the structure is shared.
    ! =================================

    ! Check which matrices have data and what is shared
    bhasstruc1    = lsyssc_hasMatrixStructure(rmatrixTemplate)
    bhasstruc2    = lsyssc_hasMatrixStructure(rmatrixMass)
    bhasstruc3    = lsyssc_hasMatrixStructure(rmatrixLaplace)

    bhascont1     = lsyssc_hasMatrixContent(rmatrixTemplate)
    bhascont2     = lsyssc_hasMatrixContent(rmatrixMass)
    bhascont3     = lsyssc_hasMatrixContent(rmatrixLaplace)

    bsharedstruc1 = lsyssc_isMatrixStructureShared(rmatrixTemplate,rmatrixMass)
    bsharedstruc2 = lsyssc_isMatrixStructureShared(rmatrixTemplate,rmatrixLaplace)
    bsharedstruc3 = lsyssc_isMatrixStructureShared(rmatrixMass,rmatrixLaplace)

    bsharedcont   = lsyssc_isMatrixContentShared(rmatrixMass,rmatrixLaplace)

    ! Print the results
    call output_line ("rmatrixTemplate has structure    = " // &
        trim(sys_sl(bhasstruc1)))

    call output_line ("rmatrixMass has structure        = " // &
        trim(sys_sl(bhasstruc2)))

    call output_line ("rmatrixLaplace has structure     = " // &
        trim(sys_sl(bhasstruc3)))

    call output_line ("rmatrixTemplate has content      = " // &
        trim(sys_sl(bhascont1)))

    call output_line ("rmatrixMass has content          = " // &
        trim(sys_sl(bhascont2)))

    call output_line ("rmatrixLaplace has content       = " // &
        trim(sys_sl(bhascont3)))

    call output_line ("Structure shared(rmatrixTemplate,rmatrixMass)    = " // &
        trim(sys_sl(bsharedstruc1)))

    call output_line ("Structure shared(rmatrixTemplate,rmatrixLaplace) = " // &
        trim(sys_sl(bsharedstruc2)))

    call output_line ("Structure shared(rmatrixMass,rmatrixLaplace)     = " // &
        trim(sys_sl(bsharedstruc3)))

    call output_line ("Content shared(rmatrixMass,rmatrixLaplace)       = " // &
        trim(sys_sl(bsharedcont)))

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the matrices
    call lsyssc_releaseMatrix (rmatrixMass)
    call lsyssc_releaseMatrix (rmatrixLaplace)

    ! Release template matrix
    call lsyssc_releaseMatrix (rmatrixTemplate)

    ! Release the Q1-discretisation
    call spdiscr_releaseDiscr (rdiscretisation)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


program main

    use auto_diff
    implicit none

    integer, parameter :: n = 1000
    type(tree_t) :: x1(n, n), x2(n, n)
    type(tree_t) :: y(n, n)
    real(rk) :: r1(n, n), r2(n, n)
    real(rk) :: z(n, n)

    real(rk) :: t1, t2

    x1 = randu(n, n)
    x2 = randu(n, n)

    r1 = randu(n, n)
    r2 = randu(n, n)

    print *, "Forward"
    call cpu_time(t1)
    y = (x1 + sigmoid(x2))/(sigmoid(x1) + (x1 + x2)**2)
    call cpu_time(t2)
    print *, "Elapsed time (seconds):", t2 - t1

    print *, "Ordinary arithmetic"
    call cpu_time(t1)
    z = (r1 + sigmoid_local(r2))/(sigmoid_local(r1) + (r1 + r2)**2)
    call cpu_time(t2)
    print *, "Elapsed time (seconds):", t2 - t1

    print *, "Backward"
    call cpu_time(t1)
    call y%backward()
    call cpu_time(t2)
    print *, "Elapsed time (seconds):", t2 - t1

contains

    function randu(m, n) result(out)
        integer, intent(in) :: m, n
        real(rk) :: out(m, n)

        call random_number(out)

    end function randu

    elemental function sigmoid_local(x) result(y)
        real(rk), intent(in) :: x
        real(rk) :: y
        y = 1.0_rk/(1.0_rk + exp(-x))
    end function sigmoid_local

end program main

! fpm run --example bench1 --profile debug:
! Forward
! Elapsed time (seconds):   1.9218750000000000
! Ordinary arithmetic
! Elapsed time (seconds):  0.15625000000000000
! Backward
! Elapsed time (seconds):  0.29687500000000000

! fpm run --example bench1 --profile release:
! Forward
! Elapsed time (seconds):   1.6093750000000000
! Ordinary arithmetic
! Elapsed time (seconds):   0.0000000000000000
! Backward
! Elapsed time (seconds):  0.21875000000000000


      subroutine SBESJN(X,ALPHA,NUM,BJ)
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 SBESJN Krogh  Removed INT from type statement.
C>> 1995-11-13 SBESJN Krogh  Converted SFTRAN to Fortran
C>> 1995-10-24 SBESJN Krogh  Removed blanks in numbers for C conversion.
C>> 1994-10-19 SBESJN Krogh  Changes to use M77CON
C>> 1994-04-19 SBESJN CLL  Edited to make DP & SP files similar.
C>> 1992-03-13 SBESJN FTK  Removed implicit statements.
C>> 1989-08-09 SBESJN CLL  More accurate HALFPI for Cray
C>> 1986-03-18 SBESJN Lawson  Initial code.
c--S replaces "?": ?BESJN, ?GAMMA, ?BESPQ, ?ERV1
C
C     COMPUTE THE J-BESSEL FUNCTIONS OF X FOR ORDER ALPHA THROUGH
C     ALPHA + NUM - 1 in steps of one.
C     STORE THE RESULT INTO BJ(I),I=1,...,NUM.
C     Require X .ge. 0, ALPHA .ge. 0, NUM .ge. 1
C
c     Original code due to E. W. Ng and W. V. Snyder, JPL, 1973.
c     Modified by Ng and S. Singletary, 1974.
C     C.Lawson & S.Chan, JPL, 1984 Apr 05:
c        Changed calling sequence.
c        Adapted to SFTRAN3 and Fortran 77.
c        Added code to avoid overflow during the recurrsion.
c        Added code to use Taylor series for small x.
c        March 23. Improved accuracy of backward recursion.
c        Changed to use P and Q instead of R and THETA
c                in the region of large X.
C     ------------------------------------------------------------------
C
      save EPS, SMALL, XPQ, BIG, HICUT
c     ----------
      external           SGAMMA, SBESPQ, R1MACH, ERMSG, SERV1, IERV1
c     ----------
      integer I,I1,II,J,K,M,MU,NMAX,NMIN,NUM
      real             R1MACH, SGAMMA
      real             ALPHA,BESV,BESVM1,BESVP1,BIG,BJ(NUM),BJNU,BOT
      real             C11293,C16,C1P5,C59,CHI,CP6
      real             DR,EM,EMU,EPS,ETA,FAC,FAC2,FK,FKM1,FKP1,FV,FVM1
      real             FVP1,G,GNU,HALF,HALFPI,HALFX,HICUT
      real             ONE,P,Q,SCALE,SMALL,SUM,T1,T2,TENTH,TERM
      real             TERM1,TEST,TOP,TWO,TWODX,V,VPMU,X,XPQ,ZERO
      parameter(ZERO=0.E0, ONE=1.E0, TWO=2.E0, C16=16.E0)
      parameter( TENTH = 0.1E0, HALF = 0.5E0)
      parameter(HALFPI = 1.57079632679489661923132169163975144E0)
      parameter(C11293 = 1.1293E0, CP6 = 0.60206E0, C59 = 0.59E0)
      parameter(C1P5 = 1.5E0)
      data EPS / ZERO /
C     ------------------------------------------------------------------
C
c     Set environment parameters.  This should happen only
c     the first time this subroutine is called.
c
      if( EPS .EQ. ZERO ) then
         EPS = R1MACH(3)
         HICUT = ONE /(EPS*C16)
         XPQ = C11293 * (CP6 - log10(EPS)) - C59
         SMALL = C16 * R1MACH(1) / EPS
         BIG = R1MACH(2)/TWO
      end if
C
c     Test validity of input values.
c
      if (X .lt. ZERO .or. ALPHA .lt. ZERO .or. NUM .lt. 1) then
c
c                                                           Error 1.
        call ERMSG('SBESJN',1,0,
     *             'REQUIRE X.GE.0, ALPHA.GE.0, NUM.GE.1',',')
      else
c                            Begin computation.
         NMIN = int(ALPHA)
         V = ALPHA - real(NMIN)
         NMAX = NMIN + NUM - 1
C
         if( X .le. TENTH ) then
c
c ********************* Code for the small X case. *********************
c
            if( X .eq. ZERO ) then
c                                        Special for X .eq. 0.
               do 80 I = 1, NUM
                  BJ(I) =  ZERO
   80          continue
               if (ALPHA .eq. 0) BJ(1) = ONE
            else
c                    Here use Taylor series for small x.
C
               GNU = ALPHA
               HALFX = HALF*X
               FAC2 = -HALFX*HALFX
               TERM1 = (HALFX**GNU) / SGAMMA(GNU + ONE)
               do 150 I = 1, NUM
c           Sum the series for the Bessel fcn J sub GNU of X given
c           in Eq 9.1.10, page 360, of AMS 55.
c           1984 March 9, JPL, C. L. Lawson.
c
                  if(TERM1 .eq. ZERO) then
                     BJNU = ZERO
                  else
c
                     SUM = ZERO
                     TOP = FAC2
                     BOT = GNU + ONE
                     T1 = ONE
                     T2 = BOT
                     TERM = TOP/BOT
c
  100                if ( abs(TERM) .GT. EPS ) then
                        SUM = SUM + TERM
                        TOP = TOP * FAC2
                        T1 = T1 + ONE
                        T2 = T2 + ONE
                        BOT = BOT * T1 * T2
                        TERM = TOP/BOT
                        go to 100
                     end if
                     BJNU = TERM1 + TERM1 * SUM
                  end if
c
                  BJ(I) = BJNU
                  if( BJNU .eq. ZERO ) then
C
c     Here current result has underflowed to zero, so we will
c     set the rest of the results to zero also.
c
                     do 120 J = I+1, NUM
                        BJ(J) = ZERO
  120                continue
                     return
                  end if
                  GNU = GNU + ONE
                  TERM1 = TERM1 * (HALFX / GNU)
  150          continue
            end if
            return
         else if( X .lt. MAX(real(NMAX+1), XPQ) ) then
c
c ********************* Code for the middle X case. ********************
c
C
C     J-TYPE BESSEL FUNCTIONS FOLLOW THE RECURRENCE RELATION
C     F(V-1,X)=(2*V/X)*F(V,X)-F(V+1,X).
C
            TWODX = TWO / X
            MU = MAX( int(X)+1, NMAX)
            DR = TWODX * (V+real(MU))
            FKP1 = ONE
            FK =  ZERO
C
C     RECUR FORWARD UNTIL FKP1 IS GREATER THAN PRECISION OF ARITHMETIC.
C
  200       if ( EPS * abs(FKP1) .le. ONE ) then
               MU = MU + 1
               DR = DR + TWODX
               FKM1 = FK
               FK = FKP1
               FKP1 = DR * FK - FKM1
               go to 200
            end if
C
C     WE ARE NOW ASSURED THAT BACKWARD RECURRENCE FROM MU WILL YIELD
C     ACCURATE RESULTS.
C
C                                        GUARANTEE EVEN MU
            if (MOD(MU,2) .ne. 0)  MU = MU + 1
            FVM1 = SMALL
            FV = ZERO
            ETA = ONE
            SUM = FVM1
            M = MU / 2
            EM = real(M)
            EMU = real(MU)
            FAC = (V + EMU) * TWODX
C
c     Set TEST = largest value that can be multiplied by
c     FAC without risking overflow.  The present value of
c     FAC is the largest that will occur during the recursion.
c     TEST will be used to protect against overflow during
c     the recursion.
c
            TEST = BIG / MAX(ONE, FAC)
C
C                            Loop while MU .GT. ZERO
  220       continue
               FVP1 = FV
               FV = FVM1
               if( abs(FV) .GT. TEST )then
                  FV = FV / SUM
                  FVP1 = FVP1 / SUM
                  I1 = MAX( 1, MU - NMIN + 1 )
                  do 230 II = I1, NUM
                     BJ(II) = BJ(II) / SUM
  230             continue
                  SUM = ONE
               end if
               FVM1 = FAC * FV - FVP1
               MU = MU -1
               EMU = EMU - ONE
               FAC = (V + EMU) * TWODX
               if (MU .ge. NMIN .AND. MU .le. NMAX) BJ(MU-NMIN+1) = FVM1
               if (MOD(MU,2) .eq. 0) then
                  if (V .eq. ZERO)  then
                     SUM = SUM + FVM1
                     if (MU .eq. 0) then
                        SCALE = ONE / SUM
                        go to 250
                     end if
                     SUM = SUM + FVM1
                  else
                     if (MU .ne. 0) then
                        VPMU = V + EMU
                        ETA = ETA * (EM/(V+(EM-ONE)))*(VPMU/(VPMU+TWO))
                        SUM = SUM + FVM1 * ETA
                        EM = EM - ONE
                     else
c
c           Here MU = 0 and EM = 0NE.  Thus the expression for
c           updating ETA reduces to the following simpler
c           expression.
c
                        ETA = ETA / (V + TWO)
                        SUM = SUM + FVM1 * ETA
                        SCALE = SGAMMA(V+ONE) / ETA * SUM * TWODX ** V
                        SCALE = ONE / SCALE
                        go to 250
                     end if
                  end if
               end if
            go to 220
  250       continue
C
C     NORMALIZE BJ() TO GET VALUES OF J-BESSEL FUNCTION.
C
            do 260 I = 1, NUM
               BJ(I) = BJ(I) * SCALE
  260       continue
            return
         else if( X .lt. HICUT ) then
c
c ********************* Code for the large X case. *********************
c
c  Here we have X .ge. XPQ, and V in [0.,1.).
c     The asymptotic series for  the auxiliary functions P and Q can be
c     used.  From these we will compute J(V,X) and J(V+1,X) and
c     then recur forward.  Reference: NBS AMS 55 Eqs 9.2.5 & 9.2.6
c
            call SBESPQ (X,V,  P,Q)
            CHI = X - (V + HALF) * HALFPI
            BESV = sqrt(ONE / (HALFPI*X)) * (P*COS(CHI) - Q*SIN(CHI))
C
            if( NMAX .GT. 0 ) then
               call SBESPQ (X,V+ONE,   P,Q)
               CHI = X - (V + C1P5) * HALFPI
               BESVP1 = sqrt(ONE / (HALFPI*X))*(P*COS(CHI)-Q*SIN(CHI))
            end if
c
            TWODX = TWO / X
c
c           Given BESV = J(V,X), BESVP1 = J(V+1,X), TWODX = 2/X,
c           NMIN, NUM, NMAX = NMIN + NUM -1, X, ALPHA, and BIG.
c           Recur forward and store J(NMIN+V) thru J(NMAX+V) in
c           BJ(1) thru BJ(NUM).
c           There should be no overflow posibility in this forward
c           recursion since NMAX .le. X - 1, and in this region the
c           magnitude of the J function is less than one.
c
            if( NMIN .eq. 0 ) then
               BJ(1) = BESV
               if( NMAX .GT. 0 ) then
                  BJ(2) = BESVP1
               end if
            else if( NMIN .eq. 1 ) then
               BJ(1) = BESVP1
            end if
c
            if( NMAX .GT. 1 ) then
               G = V * TWODX
c
c        Note:  In the following statement, 3-NMIN can be nonpositive.
c
               do 300 K = 3-NMIN, NUM
                  BESVM1 = BESV
                  BESV   = BESVP1
                  G = G + TWODX
                  BESVP1 = G * BESV - BESVM1
                  if( K .ge. 1)  BJ(K) = BESVP1
  300          continue
            end if
            return
         else
c                                                  Error 2.
            call ERMSG('SBESJN', 2, 0,
     *         'Cannot obtain any accuracy when X exceeds HICUT.', ',')
            call SERV1('HICUT', HICUT, ',')
         end if
      end if
      call SERV1('X',X,',')
      call SERV1('ALPHA',ALPHA,',')
      call IERV1('NUM',NUM,'.')
      return
      end


	subroutine func(ndim,y,icp,args,ijac,y_delta,dfdu,dfdp)
	implicit none
	integer, intent(in) :: ndim, icp(*), ijac
	double precision, intent(in) :: y(ndim), args(*)
	double precision, intent(out) :: y_delta(ndim)
	double precision, intent(inout) :: dfdu(ndim,ndim),
     & dfdp(ndim,*)
	double precision R_e,V_e,delta_e,tau_e,eta_e,J_ee,u

	! declare constants
	delta_e = args(1)
	tau_e = args(2)
	eta_e = args(3)
	J_ee = args(4)
	u = args(5)

	! extract state variables from input vector
	R_e = y(1)
	V_e = y(2)

	! calculate right-hand side update of equation system
	y_delta(1) = delta_e / (3.141592653589793 * tau_e ** 2)
     & + (2.0 * R_e * V_e) / tau_e
	y_delta(2) = (V_e ** 2 + eta_e + u) / tau_e + J_ee * R_e
     & - tau_e * (3.141592653589793 * R_e) ** 2

	end subroutine func

	subroutine stpnt(ndim, y, args, t)
	implicit None
	integer, intent(in) :: ndim
	double precision, intent(inout) :: y(ndim), args(*)
	double precision, intent(in) :: T
	double precision R_e,V_e,delta_e,tau_e,eta_e,J_ee,u

	delta_e = 1.0499999523162842
	tau_e = 6.0
	eta_e = -3.0
	J_ee = 1.0
	u = 0.0

	args(1) = delta_e
	args(2) = tau_e
	args(3) = eta_e
	args(4) = J_ee
	args(5) = u

	y(1) = 0.016092609614133835
	y(2) = -1.7307393550872803

	end subroutine stpnt

	subroutine bcnd
	end subroutine bcnd

	subroutine icnd
	end subroutine icnd

	subroutine fopt
	end subroutine fopt

	subroutine pvls
	end subroutine pvls