!***********************************************************************
!
! routines for spline interpolation
!              drivers
!
! Author:  Bernhard Seiwald
! Date:    16.12.2000
!          05.11.2001
!
!***********************************************************************

!***********************************************************************
!
! routines for third order spline
!
!***********************************************************************

SUBROUTINE splint_horner3_a(xa,a,b,c,d,swd,m,x_in,f,fp,fpp,fppp,&
                          y,yp,ypp,yppp)
!
! Computes value y(x) dy/dx(x) from cubic spline
!
! Attention - fastest routine; no check at all
!
! Input:
!         xa(n)         x-values
!         a(n),b(n),c(n),d(n)  coefs from spline
!         swd           Switch for derivatives (0: no / 1: yes)
!         m             powers of leading term
!         x_in          x-value for y(x_in) and yp(x_in)
!         f             'leading function' for spline
!         fp            'leading function' for spline, 1. derivative
!         fpp           'leading function' for spline, 2. derivative
!         fppp          'leading function' for spline, 3. derivative
! Output:
!         y             y-value at x_in
!         yp            dy/dx-value at x_in
!         ypp           d2y/dx2-value at x_in
!         yppp          d3y/dx3-value at x_in
!
!-----------------------------------------------------------------------
! Modules
!-----------------------------------------------------------------------

  USE inter_precision, ONLY: I4B, DP

!-----------------------------------------------------------------------

  IMPLICIT NONE

  INTEGER(I4B),               INTENT(IN)  :: swd
  REAL(DP),                   INTENT(IN)  :: m
  REAL(DP),     DIMENSION(:), INTENT(IN)  :: xa, a, b, c, d
  REAL(DP),                   INTENT(IN)  :: x_in
  REAL(DP),                   INTENT(OUT) :: y, yp, ypp, yppp
  INTERFACE
     FUNCTION f(x,m)
       USE inter_precision, ONLY: DP
       IMPLICIT NONE
       REAL(DP), INTENT(IN) :: x
       REAL(DP), INTENT(IN) :: m
       REAL(DP)             :: f
     END FUNCTION f
  END INTERFACE
  INTERFACE
     FUNCTION fp(x,m)
       USE inter_precision, ONLY: DP
       IMPLICIT NONE
       REAL(DP), INTENT(IN) :: x
       REAL(DP), INTENT(IN) :: m
       REAL(DP)             :: fp
     END FUNCTION fp
  END INTERFACE
  INTERFACE
     FUNCTION fpp(x,m)
       USE inter_precision, ONLY: DP
       IMPLICIT NONE
       REAL(DP), INTENT(IN) :: x
       REAL(DP), INTENT(IN) :: m
       REAL(DP)             :: fpp
     END FUNCTION fpp
  END INTERFACE
  INTERFACE
     FUNCTION fppp(x,m)
       USE inter_precision, ONLY: DP
       IMPLICIT NONE
       REAL(DP), INTENT(IN) :: x
       REAL(DP), INTENT(IN) :: m
       REAL(DP)             :: fppp
     END FUNCTION fppp
  END INTERFACE

  INTEGER(I4B) :: klo, khi, n
  INTEGER(I4B) :: k
  REAL(DP)     :: h, p, p1, p2, p3
  REAL(DP)     :: x
!-----------------------------------------------------------------------
  REAL(DP)     :: delta
!-----------------------------------------------------------------------

  n = SIZE(a)

  IF (.NOT. ( n == SIZE(b) .AND. n == SIZE(c) &
       .AND. n == SIZE(d) .AND. n == SIZE(xa) ) ) THEN
     WRITE (*,*) 'splint_horner3: assertion 1 failed'
     PRINT *, SIZE(a), SIZE(b), SIZE(c), SIZE(d), SIZE(xa)
     STOP 'program terminated'
  END IF

  x  = x_in

  klo=1
  khi=n

  DO WHILE ( (khi-klo) .GT. 1 )
     k=(khi+klo)/2
     IF(xa(k).GT.x)THEN
        khi=k
     ELSE
        klo=k
     ENDIF
  END DO

  IF ((klo < 0) .OR. (klo > n)) THEN
     PRINT *, 'splint_horner3: n, klo: ', n, klo
     STOP
  END IF
  IF ((khi < 0) .OR. (khi > n)) THEN
     PRINT *, 'splint_horner3: n, khi: ', n, khi
     STOP
  END IF

  h = x - xa(klo)

!! for equidistant points only!
! h = xa(2) - xa(1)
! klo = int((x - xa(1))/h) + 1
! if (klo .le. 0) klo = 1
! if (klo .ge. n) klo = n - 1
! khi = klo + 1

  !! Modifications by Andreas F. Martitsch (08.05.2015)
  !->
  !-> In previous versions of NEO-2 linear interpolation
  !-> and cubic splines have been mixed up due to a
  !-> misleading comment (error discovered by Gernot K.).
  !-> This is the old part of the code:
  !->
!!$!  Attention linear interpolation
!!$!  p = a(klo) + h * (b(klo) + h * (c(klo) + h * d(klo)))
!!$  delta = xa(khi) - xa(klo)
!!$  p = a(klo) + h * (b(klo) + delta * (c(klo) + delta * d(klo)))
!!$  !PRINT *,a(klo),b(klo),c(klo),d(klo)
  !->
  !-> This is the corrected part of the code:
  !->
  ! Cubic Spline
  p = a(klo) + h * (b(klo) + h * (c(klo) + h * d(klo)))
  ! Attention linear interpolation
  !delta = xa(khi) - xa(klo)
  !p = a(klo) + h * (b(klo) + delta * (c(klo) + delta * d(klo)))
  !PRINT *,a(klo),b(klo),c(klo),d(klo)
  !! End Modifications by Andreas F. Martitsch (08.05.2015)

  y = f(x,m) * p
  !PRINT *,y,f(x,m),p

  IF ( swd .NE. 0 ) THEN
     p1   = b(klo) + h * (2.0D0 * c(klo) + 3.0D0 * d(klo) * h)
     p2   = 2.0D0 * c(klo) + 6.0D0 * d(klo) * h
     p3   = 6.0D0 * d(klo)
     yp   = fp(x_in,m) * p + f(x_in,m) * p1
     ypp  = fpp(x_in,m) * p + 2.0D0 * fp(x_in,m) * p1 + f(x_in,m) * p2
     yppp = fppp(x_in,m) * p + 3.0D0 * fpp(x_in,m) * p1 &
          + 3.0D0 * fp(x_in,m) * p2 + f(x_in,m) * p3
  ELSE
     yp   = 0.0D0
     ypp  = 0.0D0
     yppp = 0.0D0
  ENDIF

END SUBROUTINE splint_horner3_a

SUBROUTINE splint_horner3_driv_s_a(svec,a,b,c,d,swd,ixm,ixn,s,theta,phi,&
                                   f,fp,fpp,fppp,y,ys,yt,yp)
!
! driver routine for splint_horner3
! y  =  y_mn  *   sin(m*theta - n*phi)
! ys =  y_mn' *   sin(m*theta - n*phi)
! yt =  y_mn  * m*cos(m*theta - n*phi)
! yp = -y_mn  * n*cos(m*theta - n*phi)
!
! Input:
!         svec()        s-values, dimension (ns)
!         a(),b(),c(),d()  coefs from spline, dimension (ns,no_cur)
!         swd           Switch for derivatives (0: no / 1: yes)
!         ixm           powers of leading term, mode  sin(m*theta-n*phi)
!         ixn           mode  sin(m*theta-n*phi)
!         s             s-value for y(s) and ys(s) and...
!         theta         angle
!         phi           angle
!         f             'leading function' for spline
!         fp            'leading function' for spline, 1. derivative
!         fpp           'leading function' for spline, 2. derivative
!         fppp          'leading function' for spline, 3. derivative
! Output:
!         y             y
!         ys            dy/ds
!         yt            d2y/dteta
!         yp            d3y/dphi
!
!-----------------------------------------------------------------------
! Modules
!-----------------------------------------------------------------------

  USE inter_precision,  ONLY: I4B, DP
  USE inter_interfaces, ONLY: splint_horner3

!-----------------------------------------------------------------------

  IMPLICIT NONE

  REAL(DP),     DIMENSION(:),   INTENT(IN)  :: svec
  REAL(DP),     DIMENSION(:,:), INTENT(IN)  :: a, b, c, d
  INTEGER(I4B),                 INTENT(IN)  :: swd
  REAL(DP),     DIMENSION(:),   INTENT(IN)  :: ixm
  INTEGER(I4B), DIMENSION(:),   INTENT(IN)  :: ixn
  REAL(DP),                     INTENT(IN)  :: s, theta, phi
  REAL(DP),                     INTENT(OUT) :: y, ys, yt, yp
  INTERFACE
     FUNCTION f(x,m)
       USE inter_precision, ONLY: DP
       IMPLICIT NONE
       REAL(DP), INTENT(IN) :: x
       REAL(DP), INTENT(IN) :: m
       REAL(DP)             :: f
     END FUNCTION f
  END INTERFACE
  INTERFACE
     FUNCTION fp(x,m)
       USE inter_precision, ONLY: DP
       IMPLICIT NONE
       REAL(DP), INTENT(IN) :: x
       REAL(DP), INTENT(IN) :: m
       REAL(DP)             :: fp
     END FUNCTION fp
  END INTERFACE
  INTERFACE
     FUNCTION fpp(x,m)
       USE inter_precision, ONLY: DP
       IMPLICIT NONE
       REAL(DP), INTENT(IN) :: x
       REAL(DP), INTENT(IN) :: m
       REAL(DP)             :: fpp
     END FUNCTION fpp
  END INTERFACE
  INTERFACE
     FUNCTION fppp(x,m)
       USE inter_precision, ONLY: DP
       IMPLICIT NONE
       REAL(DP), INTENT(IN) :: x
       REAL(DP), INTENT(IN) :: m
       REAL(DP)             :: fppp
     END FUNCTION fppp
  END INTERFACE

  INTEGER(I4B) :: no_cur, i
  REAL(DP)     :: arg, si, co
  REAL(DP)     :: ay, ays, ayss, aysss

!-----------------------------------------------------------------------

  no_cur = SIZE(a,2)

  y  = 0.0D0
  ys = 0.0D0
  yt = 0.0D0
  yp = 0.0D0

  DO i = 1, no_cur
     CALL splint_horner3(svec, a(:,i), b(:,i), c(:,i), d(:,i), swd, &
          ixm(i), s, f, fp, fpp, fppp, ay, ays, ayss, aysss)

     arg = ixm(i) * theta  -  ixn(i) * phi
     si  = SIN(arg)
     co  = COS(arg)
     y  =  y   +           ay  * si
     ys =  ys  +           ays * si
     yt =  yt  +  ixm(i) * ay  * co
     yp =  yp  -  ixn(i) * ay  * co
  END DO

END SUBROUTINE splint_horner3_driv_s_a

SUBROUTINE splint_horner3_driv_c_a(svec,a,b,c,d,swd,ixm,ixn,s,theta,phi,&
                                   f,fp,fpp,fppp,y,ys,yt,yp)
!
! driver routine for splint_horner3
! y  =  y_mn  *   cos(m*theta - n*phi)
! ys =  y_mn' *   cos(m*theta - n*phi)
! yt = -y_mn  * m*sin(m*theta - n*phi)
! yp =  y_mn  * n*sin(m*theta - n*phi)
!
! Input:
!         svec()        s-values, dimension (ns)
!         a(),b(),c(),d()  coefs from spline, dimension (ns,no_cur)
!         swd           Switch for derivatives (0: no / 1: yes)
!         ixm           powers of leading term, mode  sin(m*theta-n*phi)
!         ixn           mode  sin(m*theta-n*phi)
!         s             s-value for y(s) and ys(s) and...
!         theta         angle
!         phi           angle
!         f             'leading function' for spline
!         fp            'leading function' for spline, 1. derivative
!         fpp           'leading function' for spline, 2. derivative
!         fppp          'leading function' for spline, 3. derivative
! Output:
!         y             y
!         ys            dy/ds
!         yt            d2y/dteta
!         yp            d3y/dphi
!
!-----------------------------------------------------------------------
! Modules
!-----------------------------------------------------------------------

  USE inter_precision,  ONLY: I4B, DP
  USE inter_interfaces, ONLY: splint_horner3

!-----------------------------------------------------------------------

  IMPLICIT NONE

  REAL(DP),     DIMENSION(:),   INTENT(IN)  :: svec
  REAL(DP),     DIMENSION(:,:), INTENT(IN)  :: a, b, c, d
  INTEGER(I4B),                 INTENT(IN)  :: swd
  REAL(DP),     DIMENSION(:),   INTENT(IN)  :: ixm
  INTEGER(I4B), DIMENSION(:),   INTENT(IN)  :: ixn
  REAL(DP),                     INTENT(IN)  :: s, theta, phi
  REAL(DP),                     INTENT(OUT) :: y, ys, yt, yp
  INTERFACE
     FUNCTION f(x,m)
       USE inter_precision, ONLY: DP
       IMPLICIT NONE
       REAL(DP), INTENT(IN) :: x
       REAL(DP), INTENT(IN) :: m
       REAL(DP)             :: f
     END FUNCTION f
  END INTERFACE
  INTERFACE
     FUNCTION fp(x,m)
       USE inter_precision, ONLY: DP
       IMPLICIT NONE
       REAL(DP), INTENT(IN) :: x
       REAL(DP), INTENT(IN) :: m
       REAL(DP)             :: fp
     END FUNCTION fp
  END INTERFACE
  INTERFACE
     FUNCTION fpp(x,m)
       USE inter_precision, ONLY: DP
       IMPLICIT NONE
       REAL(DP), INTENT(IN) :: x
       REAL(DP), INTENT(IN) :: m
       REAL(DP)             :: fpp
     END FUNCTION fpp
  END INTERFACE
  INTERFACE
     FUNCTION fppp(x,m)
       USE inter_precision, ONLY: DP
       IMPLICIT NONE
       REAL(DP), INTENT(IN) :: x
       REAL(DP), INTENT(IN) :: m
       REAL(DP)             :: fppp
     END FUNCTION fppp
  END INTERFACE

  INTEGER(I4B) :: no_cur, i
  REAL(DP)     :: arg, si, co
  REAL(DP)     :: ay, ays, ayss, aysss

!-----------------------------------------------------------------------

  no_cur = SIZE(a,2)

  y  = 0.0D0
  ys = 0.0D0
  yt = 0.0D0
  yp = 0.0D0

  DO i = 1, no_cur
     CALL splint_horner3(svec, a(:,i), b(:,i), c(:,i), d(:,i), swd, &
          ixm(i), s, f, fp, fpp, fppp, ay, ays, ayss, aysss)

     arg = ixm(i) * theta  -  ixn(i) * phi
     si  = SIN(arg)
     co  = COS(arg)
     y  =  y   +           ay  * co
     ys =  ys  +           ays * co
     yt =  yt  -  ixm(i) * ay  * si
     yp =  yp  +  ixn(i) * ay  * si
  END DO

END SUBROUTINE splint_horner3_driv_c_a


module henondim
!  HENONDIM - Implement Algorithm D to determine the dimension of the basin of
!  infinity of the Henon map. Uses MPI.
!
!  SYNOPSIS
!    use henondim
!
!  DESCRIPTION
!    This module contains the necessary subroutines to calculate the number of
!    epsilon-uncertain grid points of the basin calculated for the Henon map.
!    It is parallelized using MPI by assigning columns to each processing element.
!    The code calling this module must get the results and add them together
!    using mpi_reduce.
!
!  PUBLIC ROUTINES DEFINED
!   - henon_map
!   - basin_alg
!   - basin_compare
!
!  REQUIRED DEPENDENCIES
!    precision - to define KINDs for single and double floating-point.
!          lsq - to do the power fitting needed at the end of th Algorithm D.
!
!  REVISION HISTORY
!   10/19/18 - Code works using constructed Matlab functions linspace and
!              meshgrid. Also the subroutine reshape since 2D arrays basins
!              are used.
!   10/24/18 - Removed all Matlab functions and reshaping. Adapted code to work
!              with 1D array basins of dimension NGRID^2. Included subroutine
!              basin_compare in order to use OpenMP. The subroutine will make
!              sure each thread has individual copies of the basins to work with
!              them.
!   11/13/18 - Adapted code to use MPI parallelism. However, each processing
!              element creates the whole domain and selects only a part to work
!              with. It would be better to only create the corresponding section
!              of the domain.
!   11/17/18 - Only the corresponding section of the domain is created and
!              worked with by each processing element, depending on its rank.
!
!  PROGRAMMER
!   Francisco Castillo-Carrasco, fjcasti1@asu.edu
!
  use precision
  implicit none
  contains
!-------------------------------------------------------------------------------
  subroutine henon_map(basin,basindim,xextent,me,npes,params,K,LOCKOUT,eps)
!  Iterate the Henon map for one or more initial conditions up to
!  MAXITER times or until the orbit of one of the points is further than
!  LOCKOUT units away from the origin.  (It suffices to check whether the
!  |X_n| > LOCKOUT on the nth iteration.)
!
! ARGUMENTS - basin   : logical array which dimension depends of the rank of the
!                       processor of dimension (the number of colums times NGRIDy),
!                       it is the original unshifted basin, used to compare with
!                       the shifted ones and obtain the number of epsilon-uncertain
!                       grid points. True will mean that the grid point tends
!                       to infinity.
!           - basindim: integer, dimension of the basin being worked with by the
!                       processing unit
!           - xextent : real, array with the following parameters:
!                                         Xmin, Xmax, Ymin, Ymax, NGRIDx, NGRIDy
!           - me      : integer, the MPI rank
!           - npes    : integer, the Number of Processing Elements (> 0)
!           - params  : real, parameters for the henon map.
!           - K       : integer, maxmimum number of iterations for the henon map
!           - LOCKOUT : real, limit where we separate infinity points from the rest
!           - eps     : real, the magnitude of the shifting of the initial grid.
!
! PROCEDURE : We define the initial grid using array constructors and do loops
!             and store it in the 2D array X0. This array will evolve according
!             to the equations giveni in the Henon map. The grid points will
!             be filtered out using the commands where and all.

    use, intrinsic::iso_fortran_env
    implicit none
    integer,  intent(in)  :: me, npes, K, basindim
    real(DP), intent(in)  :: xextent(6), params(2), eps, LOCKOUT
    logical,  intent(out) :: basin(basindim)

    integer  :: j, N, M, NGRIDx, NGRIDy
    real(DP) :: xMin, xMax, yMin, yMax, hx, hy
    real(DP), dimension(:)  , allocatable :: x, y, auxme
    real(DP), dimension(:,:), allocatable :: X0me

    xMin   = xextent(1)
    xMax   = xextent(2)
    yMin   = xextent(3)
    yMax   = xextent(4)
    NGRIDx = xextent(5)
    NGRIDy = xextent(6)

    hx = (xMax-xMin)/(NGRIDx-1)
    hy = (yMax-yMin)/(NGRIDy-1)
    N  = NGRIDx/npes
    M  = MOD(int(NGRIDx),npes)

    allocate(y(NGRIDy))
    y  = [(hy*(j-1)+yMin, j=1,NGRIDy)]

    if (me.lt.M) then
      allocate(x(N+1))
      allocate(X0me((N+1)*NGRIDy,2))
      allocate(auxme((N+1)*NGRIDy))
      x  = [(hx*(j-1)+xMin+eps, j=1+(N+1)*me,(N+1)*(me+1))]
      do j=1,N+1
        X0me(1+(j-1)*NGRIDy:j*NGRIDy,1) = x(j)
        X0me(1+(j-1)*NGRIDy:j*NGRIDy,2) = y(:)
      end do
    else
      allocate(x(N))
      allocate(X0me(N*NGRIDy,2))
      allocate(auxme(N*NGRIDy))
      x  = [(hx*(j-1)+xMin+eps, j=1+N*me+M,N*(me+1)+M)]
      do j=1,N
        X0me(1+(j-1)*NGRIDy:j*NGRIDy,1) = x(j)
        X0me(1+(j-1)*NGRIDy:j*NGRIDy,2) = y(:)
      end do
    endif

    basin=all(abs(X0me)>LOCKOUT,2)

    do j=1,K
      where(basin.eq..False.)
        auxme     = X0me(:,1)
        X0me(:,1) = params(1)-X0me(:,1)**2d0+params(2)*X0me(:,2)
        X0me(:,2) = auxme(:)
        basin = all(abs(X0me)>LOCKOUT,2)
      end where
    end do

  end subroutine henon_map
!-------------------------------------------------------------------------------
  subroutine basin_compare(basin0,basindim,xextent,me,npes,params,K,LOCKOUT,eps,Nuncert)
! BASIN_COMPARE - counts the number of epsilon uncertain grid points.
!
! ARGUMENTS - basin0  : logical array which dimension depends of the rank of the
!                       processor of dimension (the number of colums times NGRIDy),
!                       it is the original unshifted basin, used to compare with
!                       the shifted ones and obtain the number of epsilon-uncertain
!                       grid points.
!           - basindim: integer, dimension of the basin being worked with by the
!                       processing unit
!           - xextent : real, array with the following parameters:
!                                         Xmin, Xmax, Ymin, Ymax, NGRIDx, NGRIDy
!           - me      : integer, the MPI rank
!           - npes    : integer, the Number of Processing Elements (> 0)
!           - params  : real, parameters for the henon map.
!           - K       : integer, maxmimum number of iterations for the henon map
!           - LOCKOUT : real, limit where we separate infinity points from the rest
!           - eps     : real, the magnitude of the shifting of the initial grid.
!           - Nuncert : integer, the number of uncertain points
! ARGUMENTS - N     : real, N represents the number of epsilon-uncertain points
!                     for the given value of epsilon, eps.
!           - eps   : real, eps represents the magnitude of the shifting of the
!                     initial grid.
!
! PROCEDURE : We simply use the henon_map subroutine to calculate the shifted
!             basins and the function count to obtain the total number of grid
!             points whose basins don't match. This is, the number of
!             epsilon-uncertain grid points for the section that the given
!             processor is working with.
    implicit none
    integer,  intent(in)  :: me, npes, K, basindim
    integer,  intent(out) :: Nuncert
    real(DP), intent(in)  :: xextent(6), params(2), eps, LOCKOUT
    logical,  intent(in)  :: basin0(basindim)

    logical, dimension(:), allocatable :: basinP, basinM

    allocate(basinP(basindim))
    allocate(basinM(basindim))
! Obtain the basin for the shifted grid an amount eps to the right
    call henon_map(basinP,basindim,xextent,me,npes,params,K,LOCKOUT,eps)
! Obtain the basin for the shifted grid an amount eps to the left
    call henon_map(basinM,basindim,xextent,me,npes,params,K,LOCKOUT,-eps)
! Compare the basins and obtain the number of uncertain grid points.
    Nuncert = count(basin0.ne.basinP.or.basin0.ne.basinM)
  end subroutine basin_compare
!-------------------------------------------------------------------------------
  subroutine basin_alg(xextent,me,npes,params,K,LOCKOUT,eps,epsdim,uncert)

! BASIN_ALG - implements Algorithm D, using MPI.
!
! ARGUMENTS - xextent : real, array with the following parameters:
!                                         Xmin, Xmax, Ymin, Ymax, NGRIDx, NGRIDy
!           - me      : integer, the MPI rank
!           - npes    : integer, the Number of Processing Elements (> 0)
!           - params  : real, parameters for the henon map.
!           - K       : integer, maxmimum number of iterations for the henon map
!           - LOCKOUT : real, limit where we separate infinity points from the rest
!           - eps     : real, 1D array eps which represents the magnitude of the
!                        shifting of the initial grid.
!           - epsdim  : integer, dimension of the array of epsilons.
!           - uncert  : integer, 1D array which represents the number of uncertain points

! PROCEDURE : We obtain the basin of attraction for the Henon map for the
!             unshifted grid, basin. Then, for multiple epsilons, we compare
!             the basins obtained out of shifted grids by a magnitued epsilon.
!             This is done in the subroutine basin_compare. Such subroutine
!             returns then the number of epsilon uncertain grid points uncert.
!             MPI is implemented by calculating the number of columns each
!             processor has to deal with.
    implicit none
    integer, intent(in)  :: me, npes, K, epsdim
    integer, intent(inout) :: uncert(epsdim)
    real(DP), intent(in) :: xextent(6), params(2), eps(epsdim), LOCKOUT

    integer  :: j, ierr, basindim, N, M, NGRIDx, NGRIDy
    real(DP) :: d
    logical,  dimension(:)  , allocatable :: basin

    NGRIDx = xextent(5)
    NGRIDy = xextent(6)
! The following section assigns the number of columns that each processor has to
! work with
    N  = NGRIDx/npes
    M  = MOD(int(NGRIDx),npes)
    if (me.lt.M) then
      allocate(basin((N+1)*NGRIDy))
    else
      allocate(basin(N*NGRIDy))
    endif
! Calculate the unshifted basin
    call henon_map(basin,size(basin),xextent,me,npes,params,K,LOCKOUT,0d0)

    do j=1,epsdim
      call basin_compare(basin,size(basin),xextent,me,npes,params,K,LOCKOUT,eps(j),uncert(j))
    enddo

    return
  end subroutine basin_alg
!-------------------------------------------------------------------------------
end module henondim


      SUBROUTINE QPARMR
C
C     MODULE PARAMR PERFORMS THE FOLLOW OP ON PARAMETERS IN SINGLE
C     PRECISION
C     (COMPANION MODULE PARAMD AND SUBROUTINE QPARMD)
C
C     DMAP
C     PARAMR  / /C,N,OP/ V,N,OUTR/V,N,IN1R/V,N,IN2R/
C                        V,N,OUTC/V,N,IN1C/V,N,IN2C/V,N,FLAG $
C
C         OP        COMPUTE
C         --        -------------------------------------------
C      BY DEFAULT   FLAG = 0
C      1  ADD       OUTR = IN1R + IN2R
C      2  SUB       OUTR = IN1R - IN2R
C      3  MPY       OUTR = IN1R * IN2R
C      4  DIV       OUTR = IN1R / IN2R (IF IN2R = 0, FLAG IS SET TO +1)
C      5  NOP       RETURN
C      6  SQRT      OUTR = SQRT(IN1R)
C      7  SIN       OUTR = SIN(IN1R) WHERE IN1R IS IN RADIANS
C      8  COS       OUTR = COS(IN1R) WHERE IN1R IS IN RADIANS
C      9  ABS       OUTR = ABS(IN1R)
C     10  EXP       OUTR = EXP(IN1R)
C     11  TAN       OUTR = TAN(IN1R) WHERE IN1R IS IN RADIANS
C     12  ADDC      OUTC = IN1C + IN2C
C     13  SUBC      OUTC = IN1C - IN2C
C     14  MPYC      OUTC = IN1C * IN2C
C     15  DIVC      OUTC = IN1C / IN2C (IF IN2C = 0, FLAG IS SET TO +1)
C     16  COMPLEX   OUTC = (IN1R,IN2R)
C     17  CSQRT     OUTC = CSQRT(IN1C)
C     18  NORM      OUTR = SQRT(OUTC(1)**2 + OUTC(2)**2)
C     19  REAL      IN1R = OUTC(1),   IN2R = OUTC(2)
C     20  POWER     OUTR = IN1R**IN2R
C     21  CONJ      OUTC = CONJG(IN1C)
C     22  EQ        FLAG =-1 IF IN1R COMPARES WITH IN2R
C     23  GT        FLAG =-1 IF IN1R IS GT IN2R
C     24  GE        FLAG =-1 IF IN1R IS GE IN2R
C     25  LT        FLAG =-1 IF IN1R IS LT IN2R
C     26  LE        FLAG =-1 IF IN1R IS LE IN2R
C     27  NE        FLAG =-1 IF IN1R IS NE IN2R
C     28  LOG       OUTR = ALOG10(IN1R)
C     29  LN        OUTR = ALOG(IN1R)
C     30  FIX       FLAG = OUTR
C     31  FLOAT     OUTR = FLOAT(FLAG)
C
C     NEW OP CODE ADDED IN THIS NEW VERSION, 12/1988 -
C
C     32  ERR       IF FLAG IS 0, SYSTEM NOGO FLAG IS SET TO ZERO
C                   IF FLAG IS NON-ZERO, JOB TERMINATED IF ANY PREVIOUS
C                      PARAMR (OR PARAMD) CONTAINS NON-FATAL ERROR(S)
C
      LOGICAL          PRT
      INTEGER          OP,OPCODE(50),FLAG,IVPS(1),NAME(2),IL(8),ILX(8),
     1                 NAM(2),BLNK
      REAL             IN1R,IN2R,IN1C,IN2C
      CHARACTER        UFM*23,UWM*25,UIM*29
      COMMON /XMSSG /  UFM,UWM,UIM
      COMMON /BLANK /  OP(2),OUTR,IN1R,IN2R,OUTC(2),IN1C(2),IN2C(2),FLAG
      COMMON /XVPS  /  VPS(1)
      COMMON /ILXXR /  IL1,IL2,IL3,IL4,IL5,IL6,IL7,IL8
      COMMON /SYSTEM/  IBUF,NOUT,NOGO,DUMMY(33),KSYS37
      EQUIVALENCE      (VPS(1),IVPS(1)), (IL,IL1)
      DATA NAME     /  4HQPAR,4HMR  /      ,IFIRST / 15  /
      DATA OPCODE   /  4HADD ,4HSUB ,4HMPY ,4HDIV ,4HNOP ,
     1                 4HSQRT,4HSIN ,4HCOS ,4HABS ,4HEXP ,
     2                 4HTAN ,4HADDC,4HSUBC,4HMPYC,4HDIVC,
     3                 4HCOMP,4HCSQR,4HNORM,4HREAL,4HPOWE,
     4                 4HCONJ,4HEQ  ,4HGT  ,4HGE  ,4HLT  ,
     5                 4HLE  ,4HNE  ,4HLOG ,4HLN  ,4HFIX ,
     6                 4HFLOA,4HERR ,4H    ,4H    ,4H    ,
     7                 4H    ,4H    ,4H    ,4H    ,4H    ,
     8                 4H    ,4H    ,4H    ,4H    ,4H    ,
     9                 4H    ,4H    ,4H    ,4H    ,4H    /
      DATA ILX      /  4H1ST ,4H2ND ,4H3RD ,4H4TH ,4H5TH ,
     1                 4H6TH ,4H7TH ,4H8TH               /
      DATA PARM,NAM /  4HPARM,4H/PAR,3HAMR/,BLNK  /4H    /
C
C     SUPPRESSED ALL INPUT/OUTPUT CHECK MESSAGES IF DIAG 37 IS ON
C
      CALL SSWTCH (37,I)
      PRT = I .EQ. 0
      IF (PRT) NAM(1) = BLNK
      IF (PRT) NAM(2) = BLNK
C
C     COMPUTE VPS INDEXES AND PARAMETER NAMES
C
      DO 2 I = 2,8
      CALL FNDPAR (-I,IL(I))
    2 CONTINUE
      IF (.NOT.PRT) GO TO 4
      CALL PAGE2 (IFIRST)
      IFIRST = 6
      WRITE  (NOUT,3) UIM,OP
    3 FORMAT (A29,' FROM PARAMR MODULE - OP CODE = ',2A4, /5X,
     1        '(ALL PARAMR MESSAGES CAN BE SUPPRESED BY DIAG 37)')
C
C     BRANCH ON OPERATION CODE
C
    4 IFLAG = FLAG
      FLAG  = 0
      IERR  = 0
C
      DO 5 IOP = 1,32
      IF (OP(1) .EQ. OPCODE(IOP)) GO TO
     1   (  10,  20,  30,  40,  50,  60,  70,  80,  90, 100,
     2     110, 120, 130, 140, 150, 160, 170, 180, 190, 200,
     3     210, 220, 230, 240, 250, 260, 270, 280, 290, 300,
     4     310, 320    ), IOP
    5 CONTINUE
      WRITE  (NOUT,6) OP(1),NAM
    6 FORMAT (22X,'UNRECOGNIZABLE OP CODE = ',A4,'  (INPUT ERROR) ',2A4)
      CALL MESAGE (-7,0,NAME)
C
C *******
C     REAL NUMBER FUNCTIONS
C *******
C
C     ADD
C
   10 OUTR = IN1R + IN2R
      GO TO 600
C
C     SUBTRACT
C
   20 OUTR = IN1R - IN2R
      GO TO 600
C
C     MULTIPLY
C
   30 OUTR = IN1R*IN2R
      GO TO 600
C
C     DIVIDE
C
   40 OUTR = 0.0
      IF (IN2R .EQ. 0.D0) GO TO 45
      OUTR = IN1R/IN2R
      GO TO 600
   45 WRITE  (NOUT,47) NAM
   47 FORMAT (5X,'ERROR - DIVIDED BY ZERO  ',2A4)
      IERR = 1
      FLAG =+1
      IF (IL8 .LE. 0) GO TO 730
      IVPS(IL8) = FLAG
      I = IL8 - 3
      WRITE  (NOUT,48) IVPS(I),IVPS(I+1),FLAG,NAM
   48 FORMAT (22X,2A4,2H =,I10,'   (OUTPUT)  ',2A4)
      GO TO 730
C
C     NOP
C
   50 RETURN
C
C     SQUARE ROOT
C
   60 IF (IN1R .LT. 0.0) GO TO 65
      OUTR = SQRT(IN1R)
      GO TO 650
   65 WRITE  (NOUT,67) NAM
   67 FORMAT (5X,'ERROR - OPERATING ON A NEGATIVE NUMBER  ',2A4)
      OUTR = 0.0
      IERR = 1
      GO TO 650
C
C     SINE
C
   70 OUTR = SIN(IN1R)
      GO TO 650
C
C     COSINE
C
   80 OUTR = COS(IN1R)
      GO TO 650
C
C     ABSOLUTE VALUE
C
   90 OUTR = ABS(IN1R)
      GO TO 650
C
C     EXPONENTIAL
C
  100 OUTR = EXP(IN1R)
      GO TO 650
C
C     TANGENT
C
  110 OUTR = TAN(IN1R)
      GO TO 650
C
C     NORM
C
  180 OUTR = SQRT(OUTC(1)**2 + OUTC(2)**2)
      GO TO 690
C
C     POWER
C
  200 OUTR  = IN1R**IN2R
      GO TO 600
C
C     LOG
C
  280 IF (IN1R .LT. 0.0) GO TO 65
      OUTR = ALOG10(IN1R)
      GO TO 650
C
C     NATURAL LOG
C
  290 IF (IN1R .LT. 0.0) GO TO 65
      OUTR = ALOG(IN1R)
      GO TO 650
C
C     FLOAT
C
  310 OUTR = IFLAG
      GO TO 670
C
C     ERR
C
  320 IF (IFLAG.NE.0 .AND. KSYS37.NE.0) GO TO 970
      KSYS37 = 0
      NOGO   = 0
      IF (PRT) WRITE (NOUT,325)
  325 FORMAT (5X,'SYSTEM NOGO FLAG IS RESET TO INTEGER ZERO',/)
      GO TO 990
C
C *******
C     COMPLEX FUNCTIONS
C *******
C
C     ADD COMPLEX
C
  120 OUTC(1) = IN1C(1) + IN2C(1)
      OUTC(2) = IN1C(2) + IN2C(2)
      GO TO 730
C
C     SUBTRACT COMPLEX
C
  130 OUTC(1) = IN1C(1) - IN2C(1)
      OUTC(2) = IN1C(2) - IN2C(2)
      GO TO 730
C
C     MULTIPLY COMPLEX
C
  140 OUTC(1) = IN1C(1)*IN2C(1) - IN1C(2)*IN2C(2)
      OUTC(2) = IN1C(1)*IN2C(2) + IN1C(2)*IN2C(1)
      GO TO 730
C
C     DIVIDE COMPLEX
C
  150 DENOM = IN2C(1)**2 + IN2C(2)**2
      IF (DENOM .EQ. 0.0) GO TO 155
      OUTC(1) = (IN1C(1)*IN2C(1) + IN1C(2)*IN2C(2))/DENOM
      OUTC(2) = (IN1C(2)*IN2C(1) - IN1C(1)*IN2C(2))/DENOM
      GO TO 730
  155 OUTC(1) = 0.0
      OUTC(2) = 0.0
      GO TO 45
C
C     COMPLEX
C
  160 OUTC(1) = IN1R
      OUTC(2) = IN2R
      GO TO 710
C
C     COMPLEX SQUARE ROOT
C
  170 OUTC(1) = (IN1C(1)**2 + IN1C(2)**2)**0.25
     1          *COS(0.5*ATAN2(IN1C(2),IN1C(1)))
      OUTC(2) = (IN1C(1)**2 + IN1C(2)**2)**0.25
     1          *SIN(0.5*ATAN2(IN1C(2),IN1C(1)))
      GO TO 760
C
C     CONJUGATE
C
  210 OUTC(1) = IN1C(1)
      OUTC(2) =-IN1C(2)
      GO TO 760
C
C     REAL
C
  190 IN1R = OUTC(1)
      IN2R = OUTC(2)
      GO TO 770
C
C     EQUAL
C
  220 IF (IN1R .EQ. IN2R) FLAG = -1
      GO TO 660
C
C     GREATER THAN
C
  230 IF (IN1R .GT. IN2R) FLAG = -1
      GO TO 660
C
C     GREATER THAN OR EQUAL
C
  240 IF (IN1R .GE. IN2R) FLAG = -1
      GO TO 660
C
C     LESS THAN
C
  250 IF (IN1R .LT. IN2R) FLAG = -1
      GO TO 660
C
C     LESS THAN OR EQUAL
C
  260 IF (IN1R .LE. IN2R) FLAG = -1
      GO TO 660
C
C     NOT EQUAL
C
  270 IF (IN1R .NE. IN2R) FLAG = -1
      GO TO 660
C
C     FIX
C
  300 FLAG = OUTR
      GO TO 720
C
C ---------------------------------------------------
C
C     INPUT PARAMETER ECHO
C
  600 ASSIGN 620 TO IRTN3
      ASSIGN 800 TO IRTN4
  610 IF (.NOT.PRT) GO TO 615
      I = IL3 - 3
      IF (IL3 .LE. 0) WRITE (NOUT,640) ILX(3),PARM,IN1R
      IF (IL3 .GT. 0) WRITE (NOUT,640) IVPS(I),IVPS(I+1),IN1R
  615 IF (IL3 .EQ. 0) IERR = 1
      GO TO IRTN3, (620,800)
  620 IF (.NOT.PRT) GO TO 645
      J = IL4 - 3
      IF (IL4 .LE. 0) WRITE (NOUT,640) ILX(4),PARM,IN2R
      IF (IL4 .GT. 0) WRITE (NOUT,640) IVPS(J),IVPS(J+1),IN2R
  640 FORMAT (22X,2A4,3H = ,E13.6,'  (INPUT)')
  645 IF (IL4 .EQ. 0) IERR = 1
      GO TO IRTN4, (800,880,910)
C
  650 ASSIGN 800 TO IRTN3
      GO TO 610
C
  660 ASSIGN 620 TO IRTN3
      ASSIGN 910 TO IRTN4
      GO TO 610
C
  670 IF (.NOT.PRT) GO TO 685
      I = IL8 - 3
      IF (IL8 .LE. 0) WRITE (NOUT,680) ILX(8),PARM,IFLAG
      IF (IL8 .GT. 0) WRITE (NOUT,680) IVPS(I),IVPS(I+1),IFLAG
  680 FORMAT (22X,2A4,2H =,I10,'   (INPUT)')
  685 IF (IL8 .EQ. 0) IERR = 1
      GO TO 800
C
  690 IF (.NOT.PRT) GO TO 705
      I = IL5 - 3
      IF (IL5 .LE. 0) WRITE (NOUT,700) ILX(5),PARM,OUTC
      IF (IL5 .GT. 0) WRITE (NOUT,700) IVPS(I),IVPS(I+1),OUTC
  700 FORMAT (22X,2A4,4H = (,E13.6,1H,,E13.6,')   (INPUT)')
  705 IF (IL5 .EQ. 0) IERR = 1
      GO TO 800
C
  710 ASSIGN 620 TO IRTN3
      ASSIGN 880 TO IRTN4
      GO TO 610
C
  720 IF (.NOT.PRT) GO TO 725
      I = IL2 - 3
      IF (IL2 .LE. 0) WRITE (NOUT,640) ILX(2),PARM,OUTR
      IF (IL2 .GT. 0) WRITE (NOUT,640) IVPS(I),IVPS(I+1),OUTR
  725 IF (IL2 .EQ. 0) IERR = 1
      GO TO 910
C
  730 ASSIGN 750 TO IRTN6
  740 IF (.NOT.PRT) GO TO 745
      I = IL6 - 3
      IF (IL6 .LE. 0) WRITE (NOUT,700) ILX(6),PARM,IN1C
      IF (IL6 .GT. 0) WRITE (NOUT,700) IVPS(I),IVPS(I+1),IN1C
  745 IF (IL6 .EQ. 0) IERR = 1
      GO TO IRTN6, (750,880)
  750 IF (.NOT.PRT) GO TO 755
      J = IL7 - 3
      IF (IL7 .LE. 0) WRITE (NOUT,700) ILX(7),PARM,IN2C
      IF (IL7 .GT. 0) WRITE (NOUT,700) IVPS(J),IVPS(J+1),IN2C
  755 IF (IL7 .EQ. 0) IERR = 1
      GO TO 880
C
  760 ASSIGN 880 TO IRTN6
      GO TO 740
C
  770 IF (.NOT.PRT) GO TO 775
      I = IL5 - 3
      IF (IL5 .LE. 0) WRITE (NOUT,700) ILX(5),PARM,OUTC
      IF (IL5 .GT. 0) WRITE (NOUT,700) IVPS(I),IVPS(I+1),OUTC
  775 IF (IL5 .EQ. 0) IERR = 1
      GO TO 840
C
C     OUTPUT PARAMETER CHECK
C
C     SECOND PARAMETER - OUTR
C
  800 IF (IL2 .GT. 0) GO TO 820
      WRITE  (NOUT,810) ILX(2),NAM
  810 FORMAT (22X,A4,'PARAMETER IS MISSING  (OUTPUT ERROR)  ',2A4)
      IERR = 1
      GO TO 950
  820 IF (IERR .EQ. 0) VPS(IL2) = OUTR
      I = IL2 - 3
      IF (PRT) WRITE (NOUT,830) IVPS(I),IVPS(I+1),VPS(IL2)
  830 FORMAT (22X,2A4,3H = ,E13.6,'  (OUTPUT)')
      GO TO 950
C
C     THIRD AND FOURTH PARAMETERS - INR1, INR2
C
  840 IF (IL3 .GT. 0) GO TO 850
      WRITE (NOUT,810) ILX(3),NAM
      IERR = 1
      GO TO 860
  850 IF (IERR .EQ. 0) VPS(IL3) = IN1R
      I = IL3 - 3
      IF (PRT) WRITE (NOUT,830) IVPS(I),IVPS(I+1),VPS(IL3)
  860 IF (IL4 .GT. 0) GO TO 870
      WRITE (NOUT,810) ILX(4),NAM
      IERR = 1
      GO TO 950
  870 IF (IERR .EQ. 0) VPS(IL4) = IN2R
      J = IL4 - 3
      IF (PRT) WRITE (NOUT,830) IVPS(J),IVPS(J+1),VPS(IL4)
      GO TO 950
C
C     FIFTH PARAMETER - OUTC
C
  880 IF (IL5 .GT. 0) GO TO 890
      WRITE (NOUT,810) ILX(5),NAM
      IERR = 1
      GO TO 950
  890 IF (IERR .EQ. 1) GO TO 895
      VPS(IL5  ) = OUTC(1)
      VPS(IL5+1) = OUTC(2)
  895 I = IL5 - 3
      IF (PRT) WRITE (NOUT,900) IVPS(I),IVPS(I+1),VPS(IL5),VPS(IL5+1)
  900 FORMAT (22X,2A4,4H = (,E13.6,1H,,E13.6,')   (OUTPUT)')
      GO TO 950
C
C     EIGHTH PARAMETER - FLAG
C
  910 IF (IL8 .GT.  0) GO TO 920
      WRITE (NOUT,810) ILX(8),NAM
      IERR = 1
      GO TO 950
  920 IF (IERR .EQ. 0) IVPS(IL8) = FLAG
      I = IL8 - 3
      IF (PRT) WRITE (NOUT,930) IVPS(I),IVPS(I+1),IVPS(IL8)
  930 FORMAT (22X,2A4,2H =,I10,6X,'(OUTPUT)')
C
  950 IF (IERR  .EQ. 0) GO TO 990
      WRITE  (NOUT,960) UWM,NAM
  960 FORMAT (A25,' - I/O ERROR, OUTPUT NOT SAVED. OUTPUT DEFAULT ',
     1       'VALUE REMAINS ',2A4,/)
      GO TO 990
  970 WRITE  (NOUT,980)
  980 FORMAT (5X,'JOB TERMINATED DUE TO PREVIOUS ERROR(S)',/)
      CALL PEXIT
  990 IF (KSYS37 .EQ. 0) KSYS37 = IERR
      RETURN
C
      END


module timedisc_types_mod

use constants_mod

type :: auxiliary_timedisc_t

# if PP_N_DIMS == 2
    real(dp) ::  register(N_NODES,N_NODES,N_VARS)

# elif PP_N_DIMS == 3
    real(dp) ::  register(N_NODES,N_NODES,N_NODES,N_VARS)
# else
# error: unknown PP_N_DIMS
# endif

end type

end module


c /***************************************************
c   hgext.f  for dbulhalo
c  21 Mar. 2015  written by D.Kawata
c ****************************************************/
c70*******************************************************************

c /*****   add hot gas density profile to mext.dat   *****/
c also set mrhg, rmhg, rhorhg
      subroutine hgext(mtothg,cnfw,rvir,xcut,rt)
      include 'define.f'

      double precision mtothg
      double precision omg0,omz,hub,cnfw,rvir,zt
      double precision fb
      double precision rhoc,delc
      double precision gcv,rho0hg
      double precision rs
c for work
      integer i,flag
      character filen*60
c *** for radial profile ***
      double precision ri,ro,xcut,lri,lro,dlr,dr,rt
      double precision rhoi,rhoo,xo,mro
c *** external function
      double precision rhombhg,mrmbhg
      external rhombhg,mrmbhg

c hot gas mass profile parameter from thermal core NFW from Maller & Bullock (2004)

      rs=rvir/cnfw
      gcv=9.0d0*dlog(1.0d0+(4.0d0/3.0d0)*cnfw)
     &   -8.0d0*dlog(1.0d0+cnfw)-(4.0d0*cnfw/(1.0d0+cnfw))
      rho0hg=mtothg/(4.0d0*M_PI*(rs**3)*gcv)

      if(myrank.eq.0) then
        open(60,file='mbhgprof.dat',status='unknown')
      endif

      ri = frini0*rt
      ro = xcut*rt
      lri = dlog10(ri)
      lro = dlog10(ro)
      dlr = (lro-lri)/dble(ndr)
      ro = 0.0d0
      do i=0,ndr
        ri=ro
        ro=10.0d0**(lri+dlr*dble(i))
        dr=ro-ri
c Maller & Bullock profile
        xo=ro/rs
        rhoo=rho0hg*rhombhg(xo)
        mro=mtothg*mrmbhg(xo)/gcv
        if(myrank.eq.0) then
          write(60,'(3(1pE13.5))') ro*LUKPC,rhoo,mro
        endif
        mrdmh(i)=mrdmh(i)+mro
        rdmh(i) = ro
        rhodmh(i)=rhodmh(i)+rhoo
c set mass profile
        mrhg(i)=mro
        rmhg(i)=ro
        rhorhg(i)=rhoo
      enddo
      if(myrank.eq.0) then
        close(60)
      endif

c *** set common values
      lrodmh=lro
      lridmh=lri
      dlrdmh=dlr

      if(myrank.eq.0) then
        open(63,file='mexta_hg.dat',status='unknown')
        do i=0,ndr
          write(63,'(3(1pE13.5))') rdmh(i)*LUKPC,mrdmh(i)
     &     ,rhodmh(i)
        enddo
        close(63)
      endif

      return
      end