!====================================================================
!                          RODRIGO BOMBARDI
!
!	Subroutines that calculate the WIlcoxon Signed Rank test
!
!====================================================================
MODULE Wilcoxon_Signed_Rank

implicit none

contains

!========================================================================
! Giving two arrays of forecast error the subroutine calculates the exact
! test of equality skill using the Wilcoxon Signed-Rank Test at 5%
! significance level.
!  array1  = An n-element single-precision floating-point vector.
!  array2  = An n-element single-precision floating-point vector.
!  rsig    = Wilcoxon Sgned_Rank significance test flag.
!            rsig = 1.0 -> reject null hypotheis
!            rsig = 0.0 -> Do not reject null hypotheis
!  missval = Value for missing value in case the test cannot be
!            calculated.
!========================================================================

  SUBROUTINE wilcoxon(array1,array2,rsig,zscore,missval)

    IMPLICIT NONE
    integer :: tt, increment, mtot, nmiss, newdim, nd
    real    :: sigmaw, sig, sig1, sig2, mt
    real, intent(out) :: rsig, zscore
    real, intent(in)  :: missval, array1(:),array2(:)
    real, dimension(:), allocatable :: tmp1,tmp2,original,&
                                    absolute,ranked,signed

    mtot = SIZE(array1)
!------------- checking for pairs with difference equal zero ------------
    nmiss=0
    do tt=1,mtot
       if(array1(tt)-array2(tt) .eq. 0.0) nmiss=nmiss+1
    enddo
    newdim=mtot-nmiss
    if(newdim .ge. 6)then   ! statistical significance requires at
                             ! least 5 degrees of greedom
                             ! N-1 = 5 => N=6
       allocate(tmp1(newdim),tmp2(newdim),original(newdim))
       allocate(absolute(newdim),ranked(newdim),signed(newdim))

       if(nmiss .ne. 0)then
       !---- removing pairs with difference equal zero
          nd=1
          do tt=1,mtot
             if(array1(tt)-array2(tt) .ne. 0.0)then
                tmp1(nd)=array1(tt)
                tmp2(nd)=array2(tt)
                nd=nd+1
             endif
          enddo
       else
          tmp1(:)=array1(:)
          tmp2(:)=array2(:)
       endif

!-------------- calculating differences and ranks ----------------------
       original(:)=tmp1(:)-tmp2(:)
       !---- the sign function
       absolute(:)=abs(tmp1(:)-tmp2(:))
       call cranks(absolute(:),ranked(:))
       !---- calculating signed ranked scores
       where( original(:) .lt. absolute(:))
         signed=(-1.)*ranked
       elsewhere
         signed=ranked
       end where

!-------------- Wilcoxon Signed-Rank Test ------------------------------
       sigmaw=sqrt(newdim*(newdim+1.)*(2.*newdim+1.)/24.)
       mt=newdim*(newdim+1.)/4.
       sig1=0.
       sig2=0.
       do tt=1,newdim
          if(signed(tt) .gt. 0)sig1=sig1+signed(tt)
          if(signed(tt) .lt. 0)sig2=sig2+abs(signed(tt))
       enddo
       sig=max(sig1,sig2)
       zscore=(sig-mt)/sigmaw
       if(newdim .ge. 10)then !---- z score
          if(abs(zscore) .gt. 1.96) rsig=1.
          if(abs(zscore) .le. 1.96) rsig=0.
       else
          if(newdim .eq. 6)then
             if(sig .gt. 21.) rsig=1.
             if(sig .le. 21.) rsig=0.
          endif
          if(newdim .eq. 7)then
             if(sig .gt. 24.) rsig=1.
             if(sig .le. 24.) rsig=0.
          endif
          if(newdim .eq. 8)then
             if(sig .gt. 30.) rsig=1.
             if(sig .le. 30.) rsig=0.
          endif
          if(newdim .eq. 9)then
             if(sig .gt. 35.) rsig=1.
             if(sig .le. 35.) rsig=0.
          endif
       endif

       deallocate(tmp1,tmp2,original)
       deallocate(absolute,ranked,signed)

    else
       rsig=missval
    endif

  END SUBROUTINE wilcoxon

!========================================================================
! Giving an array the subroutine sorts that array and returns the
! ranks of that array. Ties between values receive the average of the ranks
!========================================================================

  SUBROUTINE cranks(array,ranks)
    IMPLICIT NONE
    INTEGER :: mtot, jt, beg, ned
    REAL, INTENT(in)  :: array(:)
    REAL, INTENT(out) :: ranks(:)
    REAL, DIMENSION(:), ALLOCATABLE :: tmp(:)

    mtot = SIZE(array)
    ALLOCATE(tmp(mtot))
    tmp(mtot)=mtot
    jt=1
    do while(jt .lt. mtot)
       if(array(jt+1) .ne. array(jt))then   !Not a tie
          tmp(jt)=jt
          jt=jt+1
       else                               ! a tie
          beg=jt
       do while(array(jt+1).eq.array(jt) .and. jt.lt.mtot)
          jt=jt+1
          ned=jt
       end do
       tmp(beg:ned)=0.5*(beg+ned)
       if(jt+1 .eq. mtot .and. array(jt+1).eq. &
          array(jt)) tmp(beg:ned+1)=0.5*(beg+ned+1)
          jt=jt+1
       endif
    enddo
    ranks(:)=tmp(:)
!  return
  END SUBROUTINE cranks

END MODULE Wilcoxon_Signed_Rank


      FUNCTION betai(a,b,x)
      REAL betai,a,b,x
CU    USES betacf,gammln
      REAL bt,betacf,gammln
      if(x.lt.0..or.x.gt.1.)pause 'bad argument x in betai'
      if(x.eq.0..or.x.eq.1.)then
        bt=0.
      else
        bt=exp(gammln(a+b)-gammln(a)-gammln(b)+a*log(x)+b*log(1.-x))
      endif
      if(x.lt.(a+1.)/(a+b+2.))then
        betai=bt*betacf(a,b,x)/a
        return
      else
        betai=1.-bt*betacf(b,a,1.-x)/b
        return
      endif
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/betai.for


!This subroutine calculates the center of mass and radius of gyrations of
!a set of polymers.

!Brad Krajina
!Written 4-27-14

subroutine getdim(N, NP, NT, R, RCOM, RCOMSQ, RGYRSQ, R2, R4, R6, DR)
   use params, only: dp
   implicit none
   integer, intent(in) :: N !Number of beads per chain
   integer, intent(in) :: NP !Number of chains
   integer, intent(in) :: NT !Total number of beads
   real(dp), intent(in) :: R(3, NT) !Bead positions
   real(dp), intent(out) ::  RCOM(3, NP) ! Center of mass matrix
   real(dp), intent(out) ::  RCOMSQ(NP) ! Center of mass squared
   real(dp), intent(out) ::  RGYRSQ(NP) ! Radius of gyration squared
   real(dp) X(3, N) ! Bead positions of particular polymer
   real(dp) XSQ(NP) !Sum of sqaures of position vectors
   real(dp) XGYR(3, N) ! Bead positions relative to center of mass
   real(dp) R2(NP) !Squared end-to-end displacement
   real(dp) R4(NP) !4th order moment
   real(dp) R6(NP) !6th order moment
   real(dp) DR(NP) !Magnitude of end-to-end distance

   integer IP !Polymer Index
   integer IB1 ! First bead on polymer (total index)
   integer IBN ! Final bead on polymer (total index)

   RCOM = 0.0d0
   RCOMSQ = 0.0d0
   RGYRSQ = 0.0d0

   !Calculate center of mass and radius of gyration squared

   do IP = 1, NP
      IB1 = N*(IP - 1) + 1
      IBN = N*IP
      X(1, :) = R(1, IB1:IBN)
      X(2, :) = R(2, IB1:IBN)
      X(3, :) = R(3, IB1:IBN)
      RCOM(:, IP) = SUM(X, DIM=2)/REAL(N, dp)
      XGYR(1, :) = X(1, :) - RCOM(1, IP)
      XGYR(2, :) = X(2, :) - RCOM(2, IP)
      XGYR(3, :) = X(3, :) - RCOM(3, IP)
      RGYRSQ(IP) = SUM(XGYR**2)/N
      R2(IP) = SUM((R(:, IB1) - R(:, IBN))**2)
      R4(IP) = SUM((R(:, IB1) - R(:, IBN))**4)
      R6(IP) = SUM((R(:, IB1) - R(:, IBN))**4)
      DR(IP) = SQRT(SUM((R(:, IB1) - R(:, IBN))**2))

   ENDdo

   !Calculate square of center of mass for each polymer

   RCOMSQ = SUM(RCOM**2, DIM=2)

   RETURN

END subroutine


! Largest palindrome product
!
! A palindromic number reads the same both ways. The largest palindrome made
! from the product of two 2-digit numbers is 9009 = 91x99.?
! Find the largest palindrome made from the product of two 3-digit numbers.
module Problem4

    implicit none
    private

    public :: solve
contains
    subroutine solve
        write (*, '(A)') 'Problem 4. Largest palindrome product.'

        write (*, '(A, I)') 'Palindrome 1: ', palindrome()
    end subroutine

    function palindrome()
        integer palindrome
        integer current
        integer number1
        integer number2

        integer number
        integer digit
        integer remaining

        palindrome = 0

        do number1 = 999, 100, -1
            do number2 = 999, 100, -1
                current = number1 * number2

                number    = current
                remaining = 0
                do while (number .gt. 0)
                    digit     = mod(number, 10)
                    remaining = remaining * 10 + digit
                    number    = number / 10
                end do

                if (remaining .eq. current) then
                    if (current .gt. palindrome) then
                        palindrome = current
                    end if
                end if
            end do
        end do
    end function
end module


      subroutine fort_init_e_from_rhoe(state,s_l1,s_l2,s_l3,s_h1,s_h2,s_h3,ns, &
                                       lo,hi,a_old) bind(C, name="fort_init_e_from_rhoe")

      use amrex_fort_module, only : rt => amrex_real
      use eos_module
      use meth_params_module, only : URHO, UMX, UMY, UMZ, UEINT, UEDEN
      use  eos_params_module

      implicit none

      integer  ,intent(in   ) :: s_l1,s_l2,s_l3,s_h1,s_h2,s_h3,ns
      real(rt) ,intent(inout) :: state(s_l1:s_h1,s_l2:s_h2,s_l3:s_h3,ns)
      integer  ,intent(in   ) :: lo(3), hi(3)
      real(rt) ,intent(in   ) :: a_old

      ! Local variables
      integer          :: i,j,k
      !
      ! Compute energy from the EOS
      !
      do k = lo(3),hi(3)
         do j = lo(2),hi(2)
            do i = lo(1),hi(1)

               state(i,j,k,UEDEN) = state(i,j,k,UEINT) + &
                  0.5d0 * (state(i,j,k,UMX)**2 + state(i,j,k,UMY)**2 + state(i,j,k,UMZ)**2) / state(i,j,k,URHO)

            enddo
         enddo
      enddo

      end subroutine fort_init_e_from_rhoe


subroutine vecpro(v1,v2,v3,n)

!-----------------------------------------------------------------------
!
! Two and three-dimensional vectorial product of two vectors  v3 = v1 x v2.
! The same pointer as for v1 or v2 may be used for v3. If N = 2, it is
!  assumed that v1 = (0,0,v1_3) and v2 = (v2_1,v2_2,0).
!
!-----------------------------------------------------------------------
  use      typre
  implicit none
  integer(ip), intent(in)  :: n
  real(rp),    intent(in)  :: v2(n),v1(3)
  real(rp),    intent(out) :: v3(n)
  real(rp)                 :: c1,c2,c3

  if(n==2) then
     c1=-v1(3)*v2(2)
     c2= v1(3)*v2(1)
     v3(1)=c1
     v3(2)=c2
  else if(n==3) then
     c1=v1(2)*v2(3)-v1(3)*v2(2)
     c2=v1(3)*v2(1)-v1(1)*v2(3)
     c3=v1(1)*v2(2)-v1(2)*v2(1)
     v3(1)=c1
     v3(2)=c2
     v3(3)=c3
  end if

end subroutine vecpro


SUBROUTINE quad(a, b, c, x1, x2)
IMPLICIT NONE
REAL, INTENT(IN) :: a, b, c
COMPLEX, INTENT(OUT) :: x1, x2
COMPLEX :: discriminant
discriminant = CMPLX(b**2 - 4. * a * c, 0)
x1 = (- b + SQRT(discriminant)) / 2. * a
x2 = (- b - SQRT(discriminant)) / 2. * a
END SUBROUTINE quad

PROGRAM quadratic
IMPLICIT NONE
REAL :: a, b, c
COMPLEX :: x1, x2
READ(*, *) a, b, c
CALL quad(a, b, c, x1, x2)
WRITE(*, *) x1, x2
END PROGRAM quadratic


!******************************************************************************
!*
!*                    VARIOUS MATHEMATICAL DISTRIBUTIONS
!*
!******************************************************************************

  !==========================================================================
  ! 1) AUTHOR: F. Galliano
  !
  ! 2) HISTORY:
  !    - Created 09/2007
  !    - 05/2015: update with Student's t and multivariate forms.
  !    - 04/2016: add the skew-normal distribution.
  !    - 05/2016: add the split-normal distribution.
  !
  ! 3) DESCRIPTION: implements various commonly used mathematical
  !                 distributions, and operations to manipulate them.
  !==========================================================================

! TODO: dist_splitnorm and param_splitnorm in 2D

MODULE distributions

  USE utilities, ONLY:
  USE constants, ONLY:
  USE arrays, ONLY:
  USE special_functions, ONLY:
  IMPLICIT NONE
  PRIVATE

  PUBLIC :: dist_power, dist_gauss, dist_lorentz, dist_lognormal, &
            dist_skewnorm, param_skewnorm, dist_splitnorm, param_splitnorm, &
            dist_splitlorentz, &
            histogram1D, histogram1Dmulti, histogram2D

  INTERFACE dist_gauss
    MODULE PROCEDURE dist_gauss_1D_scl, dist_gauss_1D_vect
    MODULE PROCEDURE dist_gauss_ND_scl, dist_gauss_ND_vect
  END INTERFACE dist_gauss

  INTERFACE dist_skewnorm
    MODULE PROCEDURE dist_skewnorm_1D_scl, dist_skewnorm_1D_vect
  END INTERFACE dist_skewnorm

  INTERFACE param_skewnorm
    MODULE PROCEDURE param_skewnorm_0D, param_skewnorm_1D
    MODULE PROCEDURE param_skewnorm_2D, param_skewnorm_3D
  END INTERFACE param_skewnorm

  INTERFACE dist_splitnorm
    MODULE PROCEDURE dist_splitnorm_1D_scl, dist_splitnorm_1D_vect
  END INTERFACE dist_splitnorm

  INTERFACE param_splitnorm
    MODULE PROCEDURE param_splitnorm_0D, param_splitnorm_1D
    MODULE PROCEDURE param_splitnorm_2D, param_splitnorm_3D
  END INTERFACE param_splitnorm

  INTERFACE dist_lognormal
    MODULE PROCEDURE dist_lognormal_scl, dist_lognormal_1D
  END INTERFACE dist_lognormal

  INTERFACE dist_lorentz
    MODULE PROCEDURE dist_lorentz_scl, dist_lorentz_1D
  END INTERFACE dist_lorentz

  INTERFACE dist_splitlorentz
    MODULE PROCEDURE dist_splitlorentz_scl, dist_splitlorentz_1D
  END INTERFACE dist_splitlorentz

CONTAINS

  !==========================================================================
  ! f[N] = DIST_POWER(x[N],alpha,xinf,xsup)
  !
  !   Returns a normalised power-law distribution of index alpha, between
  ! xinf and xsup, for the input array x. It is singular in -1.
  !==========================================================================

  FUNCTION dist_power (x,alpha,xinf,xsup)

    USE utilities, ONLY: DP, strike
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: x
    REAL(DP), INTENT(IN) :: alpha, xinf, xsup
    REAL(DP), DIMENSION(SIZE(x)) :: dist_power

    REAL(DP) :: norm, ap1

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

    ! Check arguments
    IF (alpha == -1._DP) &
      CALL STRIKE ("DIST_POWER","singular distribution (alpha=-1).")

    ! Definition
    ap1 = alpha+1._DP
    norm = ap1 / ( xsup**ap1 - xinf**ap1 )
    WHERE (x >= xinf .AND. x <= xsup)
      dist_power = norm * x**alpha
    ELSEWHERE
      dist_power = 0._DP
    ENDWHERE

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

  END FUNCTION dist_power

  !==========================================================================
  ! f[N] = DIST_GAUSS(x[N],xmean,sigma)
  ! f[N] = DIST_GAUSS(x[N,M],xmean[M],covariance[M,M])
  !
  !   Returns a normalised Gauss distribution centered n xmean, with a
  ! standard deviation sigma.
  !==========================================================================

  ! 1 variable, scalar
  PURE FUNCTION dist_gauss_1D_scl (x,xmean,sigma)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi, oneoversqrt2pi
    IMPLICIT NONE

    REAL(DP), INTENT(IN) :: x
    REAL(DP), INTENT(IN) :: xmean, sigma
    REAL(DP) :: dist_gauss_1D_scl

    REAL(DP) :: norm, twice_sig2

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

    norm = oneoversqrt2pi / sigma
    twice_sig2 = 2._DP*sigma**2
    dist_gauss_1D_scl = norm * EXP(-(x-xmean)**2/twice_sig2)

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

  END FUNCTION dist_gauss_1D_scl

  ! 1 variable, vector
  PURE FUNCTION dist_gauss_1D_vect (x,xmean,sigma)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi, oneoversqrt2pi
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: x
    REAL(DP), INTENT(IN) :: xmean, sigma
    REAL(DP), DIMENSION(SIZE(x)) :: dist_gauss_1D_vect

    REAL(DP) :: norm, twice_sig2

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

    norm = oneoversqrt2pi / sigma
    twice_sig2 = 2._DP*sigma**2
    dist_gauss_1D_vect(:) = norm * EXP(-(x(:)-xmean)**2/twice_sig2)

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

  END FUNCTION dist_gauss_1D_vect

  ! Multivariate, scalar
  PURE FUNCTION dist_gauss_ND_scl (x,xmean,invcov,detcov)

    USE utilities, ONLY: DP
    USE constants, ONLY: twopi
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: x
    REAL(DP), DIMENSION(SIZE(x)), INTENT(IN) :: xmean
    REAL(DP), DIMENSION(SIZE(x),SIZE(x)), INTENT(IN) :: invcov
    REAL(DP), INTENT(IN) :: detcov
    REAL(DP) :: dist_gauss_ND_scl

    INTEGER :: N
    REAL(DP) :: norm, quadform
    REAL(DP), DIMENSION(SIZE(x)) :: x0

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

    N = SIZE(x(:))
    norm = 1._DP / SQRT( twopi**N * detcov )
    x0(:) = x(:) - xmean(:)
    quadform = DOT_PRODUCT( x0(:), MATMUL(invcov(:,:),x0(:)) )
    dist_gauss_ND_scl = norm * EXP(- 0.5_DP * quadform )

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

  END FUNCTION dist_gauss_ND_scl

  ! Multivariate, scalar
  PURE FUNCTION dist_gauss_ND_vect (x,xmean,invcov,detcov)

    USE utilities, ONLY: DP
    USE constants, ONLY: twopi
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:,:) :: x
    REAL(DP), DIMENSION(SIZE(x,2)), INTENT(IN) :: xmean
    REAL(DP), DIMENSION(SIZE(x,2),SIZE(x,2)), INTENT(IN) :: invcov
    REAL(DP), INTENT(IN) :: detcov
    REAL(DP), DIMENSION(SIZE(x,1)) :: dist_gauss_ND_vect

    INTEGER :: i, N
    REAL(DP) :: norm
    REAL(DP), DIMENSION(SIZE(x,1)) :: quadform
    REAL(DP), DIMENSION(SIZE(x,1),SIZE(x,2)) :: x0

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

    N = SIZE(x(:,:),1)
    norm = 1._DP / SQRT( twopi**N * detcov )
    FORALL (i=1:N) x0(i,:) = x(i,:) - xmean(:)
    FORALL (i=1:N) &
      quadform(i) = DOT_PRODUCT( x0(i,:), MATMUL(invcov(:,:),x0(i,:)) )
    dist_gauss_ND_vect(:) = norm * EXP(- 0.5_DP * quadform(:) )

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

  END FUNCTION dist_gauss_ND_vect

  !==========================================================================
  ! f[N] = DIST_SKEWNORM(x[N],ksi,omega,alpha)
  !
  !   Returns a normalised skew-normal distribution with position parameter
  !  ksi, scale parameter omega and shape parameter alpha.
  !==========================================================================

  ! 1D vector
  PURE FUNCTION dist_skewnorm_1D_vect (x,ksi,omega,alpha)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: x
    REAL(DP), INTENT(IN) :: ksi, omega, alpha
    REAL(DP), DIMENSION(SIZE(x)) :: dist_skewnorm_1D_vect

    REAL(DP), DIMENSION(SIZE(x)) :: xred, gauss, repart

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

    xred(:) = ( x(:) - ksi ) / omega
    gauss(:) = EXP( -0.5_DP * xred(:)**2 ) / SQRT(2*pi)
    repart(:) = 0.5_DP * ( 1 + ERF(alpha*xred(:)/SQRT(2._DP)) )
    dist_skewnorm_1D_vect(:) = 2._DP/omega * gauss(:) * repart(:)

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

  END FUNCTION dist_skewnorm_1D_vect

  ! 1D scalar
  PURE FUNCTION dist_skewnorm_1D_scl (x,ksi,omega,alpha)
    USE utilities, ONLY: DP
    USE constants, ONLY: pi
    IMPLICIT NONE
    REAL(DP), INTENT(IN) :: x
    REAL(DP), INTENT(IN) :: ksi, omega, alpha
    REAL(DP) :: dist_skewnorm_1D_scl
    dist_skewnorm_1D_scl = MAXVAL(DIST_SKEWNORM_1D_VECT([x],ksi,omega,alpha))
  END FUNCTION dist_skewnorm_1D_scl

  !==========================================================================
  ! CALL PARAM_SKEWNORM(ksi,omega,alpha,mean,sigma,skewness,param2moment, &
  !                     moment2param)
  !
  !   Conversion between parameters of the skew-normal distribution and its
  ! moments.
  !==========================================================================

  PURE SUBROUTINE param_skewnorm_3D (ksi,omega,alpha,mean,sigma,skewness, &
                                     param2moment,moment2param)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:,:), INTENT(INOUT) :: ksi, omega, alpha
    REAL(DP), DIMENSION(:,:,:), INTENT(INOUT) :: mean, sigma, skewness
    LOGICAL, INTENT(IN), OPTIONAL :: param2moment, moment2param

    REAL(DP), PARAMETER :: eps = 1.E-4_DP
    REAL(DP), DIMENSION(SIZE(ksi,1),SIZE(ksi,2),SIZE(ksi,3)) :: delta
    LOGICAL :: param

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

    ! Determine which way to go: param -> moments or moments -> param
    IF (PRESENT(param2moment)) THEN
      param = ( .NOT. param2moment )
    ELSE IF (PRESENT(moment2param)) THEN
      param = moment2param
    ELSE
      param = .False.
    END IF

    ! Compute the parameters
    IF (param) THEN
      delta(:,:,:) = SIGN(1._DP,skewness(:,:,:)) &
                   * ABS(skewness(:,:,:))**(1._DP/3._DP) &
                   / SQRT( ((4._DP-pi)/2._DP)**(2._DP/3._DP)*2/pi &
                         + 2*ABS(skewness(:,:,:))**(2._DP/3._DP)/pi )
      WHERE (ABS(delta(:,:,:)) > 1._DP-eps) &
        delta(:,:,:) = SIGN(1._DP,delta(:,:,:)) * (1-eps)
      ksi(:,:,:) = mean(:,:,:) &
                 - delta(:,:,:) * sigma(:,:,:) &
                   * SQRT(2._DP / (pi-2*delta(:,:,:)**2))
      omega(:,:,:) = sigma(:,:,:) / SQRT( 1 - 2*delta(:,:,:)**2/pi )
      alpha(:,:,:) = delta(:,:,:) / SQRT( 1 - delta(:,:,:)**2 )
    ELSE
      delta(:,:,:) = alpha(:,:,:) / SQRT( 1 + alpha(:,:,:)**2 )
      mean(:,:,:) = ksi(:,:,:) + omega(:,:,:) * delta(:,:,:) * SQRT(2._DP/pi)
      sigma(:,:,:) = omega(:,:,:) * SQRT( 1._DP - 2*delta(:,:,:)**2/pi )
      skewness(:,:,:) = (4._DP-pi)/2._DP * (delta(:,:,:)*SQRT(2._DP/pi))**3 &
                      / (1._DP-2*delta(:,:,:)**2/pi)**1.5
    END IF

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

  END SUBROUTINE param_skewnorm_3D

  ! 2D
  PURE SUBROUTINE param_skewnorm_2D (ksi,omega,alpha,mean,sigma,skewness, &
                                     param2moment,moment2param)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: ksi, omega, alpha
    REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: mean, sigma, skewness
    LOGICAL, INTENT(IN), OPTIONAL :: param2moment, moment2param

    REAL(DP), PARAMETER :: eps = 1.E-4_DP
    REAL(DP), DIMENSION(SIZE(ksi,1),SIZE(ksi,2)) :: delta
    LOGICAL :: param

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

    ! Determine which way to go: param -> moments or moments -> param
    IF (PRESENT(param2moment)) THEN
      param = ( .NOT. param2moment )
    ELSE IF (PRESENT(moment2param)) THEN
      param = moment2param
    ELSE
      param = .False.
    END IF

    ! Compute the parameters
    IF (param) THEN
      delta(:,:) = SIGN(1._DP,skewness(:,:)) &
                 * ABS(skewness(:,:))**(1._DP/3._DP) &
                 / SQRT( ((4._DP-pi)/2._DP)**(2._DP/3._DP)*2/pi &
                       + 2*ABS(skewness(:,:))**(2._DP/3._DP)/pi )
      WHERE (ABS(delta(:,:)) > 1._DP-eps) &
        delta(:,:) = SIGN(1._DP,delta(:,:)) * (1-eps)
      ksi(:,:) = mean(:,:) &
               - delta(:,:) * sigma(:,:) * SQRT(2._DP / (pi-2*delta(:,:)**2))
      omega(:,:) = sigma(:,:) / SQRT( 1 - 2*delta(:,:)**2/pi )
      alpha(:,:) = delta(:,:) / SQRT( 1 - delta(:,:)**2 )
    ELSE
      delta(:,:) = alpha(:,:) / SQRT( 1 + alpha(:,:)**2 )
      mean(:,:) = ksi(:,:) + omega(:,:) * delta(:,:) * SQRT(2._DP/pi)
      sigma(:,:) = omega(:,:) * SQRT( 1._DP - 2*delta(:,:)**2/pi )
      skewness(:,:) = (4._DP-pi)/2._DP * (delta(:,:)*SQRT(2._DP/pi))**3 &
                  / (1._DP-2*delta(:,:)**2/pi)**1.5
    END IF

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

  END SUBROUTINE param_skewnorm_2D

  ! 1D
  PURE SUBROUTINE param_skewnorm_1D (ksi,omega,alpha,mean,sigma,skewness, &
                                     param2moment,moment2param)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(INOUT) :: ksi, omega, alpha
    REAL(DP), DIMENSION(:), INTENT(INOUT) :: mean, sigma, skewness
    LOGICAL, INTENT(IN), OPTIONAL :: param2moment, moment2param

    REAL(DP), PARAMETER :: eps = 1.E-4_DP
    REAL(DP), DIMENSION(SIZE(ksi)) :: delta
    LOGICAL :: param

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

    ! Determine which way to go: param -> moments or moments -> param
    IF (PRESENT(param2moment)) THEN
      param = ( .NOT. param2moment )
    ELSE IF (PRESENT(moment2param)) THEN
      param = moment2param
    ELSE
      param = .False.
    END IF

    ! Compute the parameters
    IF (param) THEN
      delta(:) = SIGN(1._DP,skewness(:)) * ABS(skewness(:))**(1._DP/3._DP) &
               / SQRT( ((4._DP-pi)/2._DP)**(2._DP/3._DP)*2/pi &
                     + 2*ABS(skewness(:))**(2._DP/3._DP)/pi )
      WHERE (ABS(delta(:)) > 1._DP-eps) &
        delta(:) = SIGN(1._DP,delta(:)) * (1-eps)
      ksi(:) = mean(:) - delta(:) * sigma(:) * SQRT(2._DP / (pi-2*delta(:)**2))
      omega(:) = sigma(:) / SQRT( 1 - 2*delta(:)**2/pi )
      alpha(:) = delta(:) / SQRT( 1 - delta(:)**2 )
    ELSE
      delta(:) = alpha(:) / SQRT( 1 + alpha(:)**2 )
      mean(:) = ksi(:) + omega(:) * delta(:) * SQRT(2._DP/pi)
      sigma(:) = omega(:) * SQRT( 1._DP - 2*delta(:)**2/pi )
      skewness(:) = (4._DP-pi)/2._DP * (delta(:)*SQRT(2._DP/pi))**3 &
                  / (1._DP-2*delta(:)**2/pi)**1.5
    END IF

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

  END SUBROUTINE param_skewnorm_1D

  ! Scalar interface
  ELEMENTAL SUBROUTINE param_skewnorm_0D (ksi,omega,alpha, &
                                          mean,sigma,skewness, &
                                          param2moment,moment2param)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi
    IMPLICIT NONE

    REAL(DP), INTENT(INOUT) :: ksi, omega, alpha, mean, sigma, skewness
    LOGICAL, INTENT(IN), OPTIONAL :: param2moment, moment2param

    REAL(DP), PARAMETER :: eps = 1.E-4_DP
    REAL(DP) :: delta
    LOGICAL :: param

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

    ! Determine which way to go: param -> moments or moments -> param
    IF (PRESENT(param2moment)) THEN
      param = ( .NOT. param2moment )
    ELSE IF (PRESENT(moment2param)) THEN
      param = moment2param
    ELSE
      param = .False.
    END IF

    ! Compute the parameters
    IF (param) THEN
      delta = SIGN(1._DP,skewness) * ABS(skewness)**(1._DP/3._DP) &
            / SQRT( ((4._DP-pi)/2._DP)**(2._DP/3._DP)*2/pi &
                  + 2*ABS(skewness)**(2._DP/3._DP)/pi )
      IF (ABS(delta) > 1._DP-eps) delta = SIGN(1._DP,delta) * (1-eps)
      ksi = mean - delta * sigma * SQRT(2._DP / (pi-2*delta**2))
      omega = sigma / SQRT( 1 - 2*delta**2/pi )
      alpha = delta / SQRT( 1 - delta**2 )
    ELSE
      delta = alpha / SQRT( 1 + alpha**2 )
      mean = ksi + omega * delta * SQRT(2._DP/pi)
      sigma = omega * SQRT( 1._DP - 2*delta**2/pi )
      skewness = (4._DP-pi)/2._DP * (delta*SQRT(2._DP/pi))**3 &
               / (1._DP-2*delta**2/pi)**1.5
    END IF

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

  END SUBROUTINE param_skewnorm_0D

  !==========================================================================
  ! f[N] = DIST_SPLITNORM(x[N],ksi,omega,alpha)
  !
  !   Returns a normalised split-normal distribution with position parameter
  !  mu, scale parameter lambda and shape parameter tau.
  !==========================================================================

  ! 1D vector
  PURE FUNCTION dist_splitnorm_1D_vect (x,mu,lambda,tau)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: x
    REAL(DP), INTENT(IN) :: mu, lambda, tau
    REAL(DP), DIMENSION(SIZE(x)) :: dist_splitnorm_1D_vect

    REAL(DP) :: A, tau2
    REAL(DP), DIMENSION(SIZE(x)) :: xred2

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

    A = SQRT(2/pi) / lambda / (1+tau)
    tau2 = tau**2
    xred2(:) = - 0.5_DP * ( x(:) - mu )**2 / lambda**2
    WHERE (x(:) < mu)
      dist_splitnorm_1D_vect(:) = A * EXP(xred2(:))
    ELSEWHERE
      dist_splitnorm_1D_vect(:) = A * EXP(xred2(:)/tau2)
    END WHERE

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

  END FUNCTION dist_splitnorm_1D_vect

  ! 1D scalar
  PURE FUNCTION dist_splitnorm_1D_scl (x,mu,lambda,tau)
    USE utilities, ONLY: DP
    USE constants, ONLY: pi
    IMPLICIT NONE
    REAL(DP), INTENT(IN) :: x
    REAL(DP), INTENT(IN) :: mu, lambda, tau
    REAL(DP) :: dist_splitnorm_1D_scl
    dist_splitnorm_1D_scl = MAXVAL(DIST_SPLITNORM_1D_VECT([x],mu,lambda,tau))
  END FUNCTION dist_splitnorm_1D_scl

  !==========================================================================
  ! CALL PARAM_SPLITNORM(mu,lambda,tau,mean,sigma,skewness,param2moment, &
  !                     moment2param)
  !
  !   Conversion between parameters of the split-normal distribution and its
  ! moments.
  !==========================================================================

  PURE SUBROUTINE param_splitnorm_3D (mu,lambda,tau,mean,sigma,skewness, &
                                      param2moment,moment2param)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi
    USE arrays, ONLY: ramp
    USE interpolation, ONLY: locate_sorted
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:,:), INTENT(INOUT) :: mu, lambda, tau
    REAL(DP), DIMENSION(:,:,:), INTENT(INOUT) :: mean, sigma, skewness
    LOGICAL, INTENT(IN), OPTIONAL :: param2moment, moment2param

    INTEGER, PARAMETER :: N = 10000
    INTEGER :: x, y, z, Nx, Ny, Nz
    INTEGER, DIMENSION(SIZE(mu,1),SIZE(mu,2),SIZE(mu,3)) :: i1, i2
    REAL(DP) :: sqrt2ovPi
    REAL(DP), DIMENSION(N) :: taugrid, bgrid, skewgrid, lntaugrid
    REAL(DP), DIMENSION(SIZE(mu,1),SIZE(mu,2),SIZE(mu,3)) :: b
    LOGICAL :: param

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

    ! Determine which way to go: param -> moments or moments -> param
    IF (PRESENT(param2moment)) THEN
      param = ( .NOT. param2moment )
    ELSE IF (PRESENT(moment2param)) THEN
      param = moment2param
    ELSE
      param = .False.
    END IF

    ! Compute the parameters (compute tau numerically)
    sqrt2ovPi = SQRT(2._DP/pi)
    IF (param) THEN
      Nx = SIZE(mu(:,:,:),1)
      Ny = SIZE(mu(:,:,:),2)
      Nz = SIZE(mu(:,:,:),3)
      taugrid(:) = RAMP(N,1.E-2_DP,1.E2_DP,XLOG=.True.) ! tau=1.E2 => skew=0.99
      lntaugrid(:) = LOG(taugrid(:))
      bgrid(:) = (pi-2._DP)/pi * (taugrid(:)-1._DP)**2 + taugrid(:)
      skewgrid(:) = bgrid(:)**(-1.5_DP) * sqrt2ovPi * (taugrid(:)-1._DP) &
                  * ( (4/pi-1._DP)*(taugrid(:)-1._DP)**2 + taugrid(:) )
      FORALL (x=1:Nx,y=1:Ny,z=1:Nz) &
        i1(x,y,z) = LOCATE_SORTED(skewgrid(:),skewness(x,y,z))
      i2(:,:,:) = i1(:,:,:) + 1
      FORALL (x=1:Nx,y=1:Ny,z=1:Nz) &
        tau(x,y,z) = EXP( lntaugrid(i1(x,y,z)) &
                        + (lntaugrid(i2(x,y,z))-lntaugrid(i1(x,y,z))) &
                        / (skewgrid(i2(x,y,z))-skewgrid(i1(x,y,z))) &
                        * (skewness(x,y,z)-skewgrid(i1(x,y,z))) )
      b(:,:,:) = (pi-2._DP)/pi * (tau(:,:,:)-1._DP)**2 + tau(:,:,:)
      lambda(:,:,:) = sigma(:,:,:) / SQRT(b(:,:,:))
      mu(:,:,:) = mean(:,:,:) - sqrt2ovPi * lambda(:,:,:) * (tau(:,:,:)-1._DP)
    ELSE
      b(:,:,:) = (pi-2._DP)/pi * (tau(:,:,:)-1._DP)**2 + tau(:,:,:)
      mean(:,:,:) = mu(:,:,:) + sqrt2ovPi * lambda(:,:,:) * (tau(:,:,:)-1._DP)
      sigma(:,:,:) = SQRT(b(:,:,:)) * lambda(:,:,:)
      skewness(:,:,:) = b(:,:,:)**(-1.5_DP) * sqrt2ovPi * (tau(:,:,:)-1._DP) &
                      * ( (4/pi-1._DP)*(tau(:,:,:)-1._DP)**2 + tau(:,:,:) )
    END IF

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

  END SUBROUTINE param_splitnorm_3D

  ! 2D
  PURE SUBROUTINE param_splitnorm_2D (mu,lambda,tau,mean,sigma,skewness, &
                                      param2moment,moment2param)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi
    USE arrays, ONLY: ramp
    USE interpolation, ONLY: locate_sorted
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: mu, lambda, tau
    REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: mean, sigma, skewness
    LOGICAL, INTENT(IN), OPTIONAL :: param2moment, moment2param

    INTEGER, PARAMETER :: N = 10000
    INTEGER :: x, y, Nx, Ny
    INTEGER, DIMENSION(SIZE(mu,1),SIZE(mu,2)) :: i1, i2
    REAL(DP) :: sqrt2ovPi
    REAL(DP), DIMENSION(N) :: taugrid, bgrid, skewgrid, lntaugrid
    REAL(DP), DIMENSION(SIZE(mu,1),SIZE(mu,2)) :: b
    LOGICAL :: param

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

    ! Determine which way to go: param -> moments or moments -> param
    IF (PRESENT(param2moment)) THEN
      param = ( .NOT. param2moment )
    ELSE IF (PRESENT(moment2param)) THEN
      param = moment2param
    ELSE
      param = .False.
    END IF

    ! Compute the parameters (compute tau numerically)
    sqrt2ovPi = SQRT(2._DP/pi)
    IF (param) THEN
      Nx = SIZE(mu(:,:),1)
      Ny = SIZE(mu(:,:),2)
      taugrid(:) = RAMP(N,1.E-2_DP,1.E2_DP,XLOG=.True.) ! tau=1.E2 => skew=0.99
      lntaugrid(:) = LOG(taugrid(:))
      bgrid(:) = (pi-2._DP)/pi * (taugrid(:)-1._DP)**2 + taugrid(:)
      skewgrid(:) = bgrid(:)**(-1.5_DP) * sqrt2ovPi * (taugrid(:)-1._DP) &
                  * ( (4/pi-1._DP)*(taugrid(:)-1._DP)**2 + taugrid(:) )
      FORALL (x=1:Nx,y=1:Ny) &
        i1(x,y) = LOCATE_SORTED(skewgrid(:),skewness(x,y))
      i2(:,:) = i1(:,:) + 1
      FORALL (x=1:Nx,y=1:Ny) &
        tau(x,y) = EXP( lntaugrid(i1(x,y)) &
                      + (lntaugrid(i2(x,y))-lntaugrid(i1(x,y))) &
                      / (skewgrid(i2(x,y))-skewgrid(i1(x,y))) &
                      * (skewness(x,y)-skewgrid(i1(x,y))) )
      b(:,:) = (pi-2._DP)/pi * (tau(:,:)-1._DP)**2 + tau(:,:)
      lambda(:,:) = sigma(:,:) / SQRT(b(:,:))
      mu(:,:) = mean(:,:) - sqrt2ovPi * lambda(:,:) * (tau(:,:)-1._DP)
    ELSE
      b(:,:) = (pi-2._DP)/pi * (tau(:,:)-1._DP)**2 + tau(:,:)
      mean(:,:) = mu(:,:) + sqrt2ovPi * lambda(:,:) * (tau(:,:)-1._DP)
      sigma(:,:) = SQRT(b(:,:)) * lambda(:,:)
      skewness(:,:) = b(:,:)**(-1.5_DP) * sqrt2ovPi * (tau(:,:)-1._DP) &
                    * ( (4/pi-1._DP)*(tau(:,:)-1._DP)**2 + tau(:,:) )
    END IF

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

  END SUBROUTINE param_splitnorm_2D

  ! 1D
  PURE SUBROUTINE param_splitnorm_1D (mu,lambda,tau,mean,sigma,skewness, &
                                      param2moment,moment2param)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi
    USE arrays, ONLY: ramp
    USE interpolation, ONLY: locate_sorted
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(INOUT) :: mu, lambda, tau
    REAL(DP), DIMENSION(:), INTENT(INOUT) :: mean, sigma, skewness
    LOGICAL, INTENT(IN), OPTIONAL :: param2moment, moment2param

    INTEGER, PARAMETER :: N = 10000
    INTEGER :: x, Nx
    INTEGER, DIMENSION(SIZE(mu)) :: i1, i2
    REAL(DP) :: sqrt2ovPi
    REAL(DP), DIMENSION(N) :: taugrid, bgrid, skewgrid, lntaugrid
    REAL(DP), DIMENSION(SIZE(mu)) :: b
    LOGICAL :: param

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

    ! Determine which way to go: param -> moments or moments -> param
    IF (PRESENT(param2moment)) THEN
      param = ( .NOT. param2moment )
    ELSE IF (PRESENT(moment2param)) THEN
      param = moment2param
    ELSE
      param = .False.
    END IF

    ! Compute the parameters (compute tau numerically)
    sqrt2ovPi = SQRT(2._DP/pi)
    IF (param) THEN
      Nx = SIZE(mu(:))
      taugrid(:) = RAMP(N,1.E-2_DP,1.E2_DP,XLOG=.True.) ! tau=1.E2 => skew=0.99
      lntaugrid(:) = LOG(taugrid(:))
      bgrid(:) = (pi-2._DP)/pi * (taugrid(:)-1._DP)**2 + taugrid(:)
      skewgrid(:) = bgrid(:)**(-1.5_DP) * sqrt2ovPi * (taugrid(:)-1._DP) &
                  * ( (4/pi-1._DP)*(taugrid(:)-1._DP)**2 + taugrid(:) )
      FORALL (x=1:Nx) &
        i1(x) = LOCATE_SORTED(skewgrid(:),skewness(x))
      i2(:) = i1(:) + 1
      FORALL (x=1:Nx) &
        tau(x) = EXP( lntaugrid(i1(x)) &
                    + (lntaugrid(i2(x))-lntaugrid(i1(x))) &
                    / (skewgrid(i2(x))-skewgrid(i1(x))) &
                    * (skewness(x)-skewgrid(i1(x))) )
      b(:) = (pi-2._DP)/pi * (tau(:)-1._DP)**2 + tau(:)
      lambda(:) = sigma(:) / SQRT(b(:))
      mu(:) = mean(:) - sqrt2ovPi * lambda(:) * (tau(:)-1._DP)
    ELSE
      b(:) = (pi-2._DP)/pi * (tau(:)-1._DP)**2 + tau(:)
      mean(:) = mu(:) + sqrt2ovPi * lambda(:) * (tau(:)-1._DP)
      sigma(:) = SQRT(b(:)) * lambda(:)
      skewness(:) = b(:)**(-1.5_DP) * sqrt2ovPi * (tau(:)-1._DP) &
                    * ( (4/pi-1._DP)*(tau(:)-1._DP)**2 + tau(:) )
    END IF

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

  END SUBROUTINE param_splitnorm_1D

  ! 1D
  PURE SUBROUTINE param_splitnorm_0D (mu,lambda,tau,mean,sigma,skewness, &
                                      param2moment,moment2param)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi
    USE arrays, ONLY: ramp
    USE interpolation, ONLY: locate_sorted
    IMPLICIT NONE

    REAL(DP), INTENT(INOUT) :: mu, lambda, tau
    REAL(DP), INTENT(INOUT) :: mean, sigma, skewness
    LOGICAL, INTENT(IN), OPTIONAL :: param2moment, moment2param

    INTEGER, PARAMETER :: N = 10000
    INTEGER :: i1, i2
    REAL(DP) :: sqrt2ovPi
    REAL(DP), DIMENSION(N) :: taugrid, bgrid, skewgrid, lntaugrid
    REAL(DP) :: b
    LOGICAL :: param

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

    ! Determine which way to go: param -> moments or moments -> param
    IF (PRESENT(param2moment)) THEN
      param = ( .NOT. param2moment )
    ELSE IF (PRESENT(moment2param)) THEN
      param = moment2param
    ELSE
      param = .False.
    END IF

    ! Compute the parameters (compute tau numerically)
    sqrt2ovPi = SQRT(2._DP/pi)
    IF (param) THEN
      taugrid(:) = RAMP(N,1.E-2_DP,1.E2_DP,XLOG=.True.) ! tau=1.E2 => skew=0.99
      lntaugrid(:) = LOG(taugrid(:))
      bgrid(:) = (pi-2._DP)/pi * (taugrid(:)-1._DP)**2 + taugrid(:)
      skewgrid(:) = bgrid(:)**(-1.5_DP) * sqrt2ovPi * (taugrid(:)-1._DP) &
                  * ( (4/pi-1._DP)*(taugrid(:)-1._DP)**2 + taugrid(:) )
      i1 = LOCATE_SORTED(skewgrid(:),skewness)
      i2 = i1 + 1
      tau = EXP( lntaugrid(i1) &
               + (lntaugrid(i2)-lntaugrid(i1)) / (skewgrid(i2)-skewgrid(i1)) &
               * (skewness-skewgrid(i1)) )
      b = (pi-2._DP)/pi * (tau-1._DP)**2 + tau
      lambda = sigma / SQRT(b)
      mu = mean - sqrt2ovPi * lambda * (tau-1._DP)
    ELSE
      b = (pi-2._DP)/pi * (tau-1._DP)**2 + tau
      mean = mu + sqrt2ovPi * lambda * (tau-1._DP)
      sigma = SQRT(b) * lambda
      skewness = b**(-1.5_DP) * sqrt2ovPi * (tau-1._DP) &
               * ( (4/pi-1._DP)*(tau-1._DP)**2 + tau )
    END IF

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

  END SUBROUTINE param_splitnorm_0D

  !==========================================================================
  ! f[N] = DIST_LOGNORMAL(x[N],lnxmean,sigma)
  !
  !   Returns a normalised log-normal distribution centered in xmean, with a
  ! standard deviation sigma.
  !==========================================================================

  PURE FUNCTION dist_lognormal_1D (x,lnxmean,sigma)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: x
    REAL(DP), INTENT(IN) :: lnxmean, sigma
    REAL(DP), DIMENSION(SIZE(x)) :: dist_lognormal_1D

    REAL(DP) :: norm, twice_sig2

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

    norm = 1._DP / (sigma*SQRT(2._DP*pi))
    twice_sig2 = 2._DP*sigma**2
    dist_lognormal_1D(:) = norm * EXP(-(LOG(x(:))-lnxmean)**2/twice_sig2) / x(:)

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

  END FUNCTION dist_lognormal_1D

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

  PURE FUNCTION dist_lognormal_scl (x,lnxmean,sigma)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), INTENT(IN) :: x
    REAL(DP), INTENT(IN) :: lnxmean, sigma
    REAL(DP) :: dist_lognormal_scl
    dist_lognormal_scl = MAXVAL(DIST_LOGNORMAL_1D([x],lnxmean,sigma))
  END FUNCTION dist_lognormal_scl

  !==========================================================================
  ! f[N] = DIST_LORENTZ(x[N],xmean,sigma)
  !
  !   Returns a normalised Lorentz distribution centered in xmean, with a
  ! width WIDTH.
  !==========================================================================

  PURE FUNCTION dist_lorentz_1D (x,xmean,width)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: x
    REAL(DP), INTENT(IN) :: xmean, width
    REAL(DP), DIMENSION(SIZE(x)) :: dist_lorentz_1D

    REAL(DP) :: norm, quarter_wid2

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

    norm = width / (2._DP*pi)
    quarter_wid2 = width**2/4._DP
    dist_lorentz_1D = norm / ((x-xmean)**2 + quarter_wid2)

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

  END FUNCTION dist_lorentz_1D

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

  PURE FUNCTION dist_lorentz_scl (x,xmean,width)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), INTENT(IN) :: x
    REAL(DP), INTENT(IN) :: xmean, width
    REAL(DP) :: dist_lorentz_scl
    dist_lorentz_scl = MAXVAL(DIST_LORENTZ_1D([x],xmean,width))
  END FUNCTION dist_lorentz_scl

  !==========================================================================
  ! f[N] = DIST_SPLITLORENTZ(x[N],mu,lambda,tau)
  !
  !   Returns a normalised Split-Lorentz distribution centered in xmean, with a
  ! width WIDTH and a shape parameter TAU.
  !==========================================================================

  PURE FUNCTION dist_splitlorentz_1D (x,mu,lambda,tau)

    USE utilities, ONLY: DP
    USE constants, ONLY: pi
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: x
    REAL(DP), INTENT(IN) :: mu, lambda, tau
    REAL(DP), DIMENSION(SIZE(x)) :: dist_splitlorentz_1D

    REAL(DP) :: norm

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

    norm = lambda / pi / ( 1._DP + tau )
    WHERE (x(:) < mu)
      dist_splitlorentz_1D(:) = norm / ((x(:)-mu)**2 + lambda**2/4._DP)
    ELSEWHERE
      dist_splitlorentz_1D(:) = norm*tau**2 / ((x(:)-mu)**2 &
                                              + lambda**2*tau**2/4._DP)
    END WHERE

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

  END FUNCTION dist_splitlorentz_1D

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

  PURE FUNCTION dist_splitlorentz_scl (x,mu,lambda,tau)
    USE utilities, ONLY: DP
    IMPLICIT NONE
    REAL(DP), INTENT(IN) :: x
    REAL(DP), INTENT(IN) :: mu, lambda, tau
    REAL(DP) :: dist_splitlorentz_scl
    dist_splitlorentz_scl = MAXVAL(DIST_SPLITLORENTZ_1D([x],mu,lambda,tau))
  END FUNCTION dist_splitlorentz_scl

  !==========================================================================
  ! CALL HISTOGRAM1D (x[N](IN),xbin[Nb](OUT),pbin[Nb](OUT),xlimits,
  !                   Nperbinmax(IN)])
  !
  !   Make an histogram of the array X. XBIN contains the center of each bin
  ! and PBIN the probability distribution (number-per-bin/N). The grid is
  ! regular and depends on the parameter Nperbinmax (30 by default).
  !==========================================================================

  SUBROUTINE histogram1D (x,xbin,pbin,xlimits,Nperbinmax,Nbinmax,norm)

    USE utilities, ONLY: DP
    USE arrays, ONLY: sort, reallocate
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: x
    REAL(DP), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: xbin, pbin
    REAL(DP), DIMENSION(2), INTENT(IN), OPTIONAL :: xlimits
    INTEGER, INTENT(IN), OPTIONAL :: Nperbinmax, Nbinmax
    LOGICAL, INTENT(IN), OPTIONAL :: norm

    INTEGER :: i
    INTEGER :: N, Npbmax, Nmax, Nref, Nbin0, Nbin1
    INTEGER, DIMENSION(:), ALLOCATABLE :: Ndist0, Ndist1
    REAL(DP), DIMENSION(:), ALLOCATABLE :: xinf0, xinf1, xsup0, xsup1
    REAL(DP), DIMENSION(2) :: xrange
    LOGICAL, DIMENSION(:), ALLOCATABLE :: refine0, refine1, inbin
    LOGICAL :: normalize

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

    ! 1) Preparation
    !---------------
    N = SIZE(x)
    IF (PRESENT(xlimits)) THEN
      xrange(:) = xlimits(:)
      IF (xlimits(1) < MINVAL(x(:))) xrange(1) = MINVAL(x(:))
      IF (xlimits(2) > MAXVAL(x(:))) xrange(2) = MAXVAL(x(:))
    ELSE
      xrange(:) = [MINVAL(x(:)),MAXVAL(x(:))]
    END IF
    IF (PRESENT(norm)) THEN
      normalize = norm
    ELSE
      normalize = .False.
    END IF

    ! Maximum number of elements per bin
    IF (PRESENT(Nbinmax)) THEN
      Nmax = Nbinmax
    ELSE
      Nmax = 30000
    END IF
    IF (PRESENT(Nperbinmax)) THEN
      Npbmax = Nperbinmax
    ELSE
      Npbmax = 30
    END IF

    ! 2) Iteratively adpated bin grid
    !--------------------------------
    ! a. Initialization
    Nbin0 = 1
    ALLOCATE (refine0(Nbin0),Ndist0(Nbin0),xinf0(Nbin0),xsup0(Nbin0))
    refine0(:) = .True.
    xinf0(:) = xrange(1)
    xsup0(:) = xrange(2)
    Ndist0(:) = N
    Nref = 1

    ! b. Iteration
    ALLOCATE (inbin(N))
    adaptive: DO
      ! Initialize
      Nbin1 = 2*Nbin0
      CALL REALLOCATE(refine1,Nbin1)
      CALL REALLOCATE(xinf1,Nbin1)
      CALL REALLOCATE(xsup1,Nbin1)
      CALL REALLOCATE(Ndist1,Nbin1)
      ! Refine
      xinf1(1:Nbin1-1:2) = xinf0(1:Nbin0)
      xinf1(2:Nbin1:2) = ( xsup0(1:Nbin0) + xinf0(1:Nbin0) ) / 2._DP
      xsup1(1:Nbin1-1) = xinf1(2:Nbin1)
      xsup1(Nbin1) = xsup0(Nbin0)
      DO i=1,Nbin1
        inbin(:) = ( x(:) >= xinf1(i) .AND. x(:) < xsup1(i) )
        Ndist1(i) = COUNT(inbin(:))
      END DO
      refine1(:) = ( Ndist1(:) >= Npbmax )
      ! Exit?
      Nref = COUNT(refine1(:))
      IF (Nref == 0 .OR. Nbin1 >= Nmax) THEN
        EXIT
      ELSE
        Nbin0 = Nbin1
        CALL REALLOCATE(refine0,Nbin0)
        CALL REALLOCATE(xinf0,Nbin0)
        CALL REALLOCATE(xsup0,Nbin0)
        CALL REALLOCATE(Ndist0,Nbin0)
        refine0(:) = refine1(:)
        xinf0(:) = xinf1(:)
        xsup0(:) = xsup1(:)
        Ndist0(:) = Ndist1(:)
      END IF
    END DO adaptive

    ! 3) Output
    !----------
    ALLOCATE (xbin(Nbin1))
    ALLOCATE (pbin(Nbin1))
    xbin(:) = ( xsup1(:) + xinf1(:) ) / 2._DP
    pbin(:) = REAL(Ndist1(:),DP)
    IF (normalize) pbin(:) = pbin(:) / REAL(N,DP)

    ! Free memory space
    DEALLOCATE (Ndist0,Ndist1,xinf0,xinf1,xsup0,xsup1,refine0,refine1,inbin)

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

  END SUBROUTINE histogram1D

  !==========================================================================
  ! CALL HISTOGRAM1DMULTI (x[N,M](IN),xbin[Nb](OUT),pbin[Nb,M](OUT),xlimits,
  !                        Nperbinmax(IN)])
  !
  !   Make an histogram of the array X. Bin along N only, and keep the M
  ! dimension unchanged.
  !==========================================================================

  SUBROUTINE histogram1Dmulti (x,xbin,pbin,xlimits,Nperbinmax,Nbinmax,norm)

    USE utilities, ONLY: DP
    USE arrays, ONLY: sort, reallocate
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:), INTENT(IN) :: x
    REAL(DP), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: xbin
    REAL(DP), DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: pbin
    REAL(DP), DIMENSION(2), INTENT(IN), OPTIONAL :: xlimits
    INTEGER, INTENT(IN), OPTIONAL :: Nperbinmax, Nbinmax
    LOGICAL, INTENT(IN), OPTIONAL :: norm

    INTEGER :: i, j
    INTEGER :: Nx, Ny, Nmax, Npbmax, Nref, Nbin0, Nbin1
    INTEGER, DIMENSION(:,:), ALLOCATABLE :: Ndist0, Ndist1
    REAL(DP), DIMENSION(:), ALLOCATABLE :: xinf0, xinf1, xsup0, xsup1
    REAL(DP), DIMENSION(2) :: xrange
    LOGICAL, DIMENSION(:), ALLOCATABLE :: refine0, refine1, inbin
    LOGICAL :: normalize

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

    ! 1) Preparation
    !---------------
    Nx = SIZE(x,1)
    Ny = SIZE(x,2)
    IF (PRESENT(xlimits)) THEN
      xrange(:) = xlimits(:)
      IF (xlimits(1) < MINVAL(x(:,:))) xrange(1) = MINVAL(x(:,:))
      IF (xlimits(2) > MAXVAL(x(:,:))) xrange(2) = MAXVAL(x(:,:))
    ELSE
      xrange(:) = [ MINVAL(x(:,:)), MAXVAL(x(:,:)) ]
    END IF
    IF (PRESENT(norm)) THEN
      normalize = norm
    ELSE
      normalize = .False.
    END IF

    ! Maximum number of elements per bin
    IF (PRESENT(Nbinmax)) THEN
      Nmax = Nbinmax
    ELSE
      Nmax = 30000
    END IF
    IF (PRESENT(Nperbinmax)) THEN
      Npbmax = Nperbinmax
    ELSE
      Npbmax = 30
    END IF

    ! 2) Iteratively adpated bin grid
    !--------------------------------
    ! a. Initialization
    Nbin0 = 1
    ALLOCATE (refine0(Nbin0),Ndist0(Nbin0,Ny),xinf0(Nbin0),xsup0(Nbin0))
    refine0(:) = .True.
    xinf0(:) = xrange(1)
    xsup0(:) = xrange(2)
    Ndist0(:,:) = Nx
    Nref = 1

    ! b. Iteration
    ALLOCATE (inbin(Nx))
    adaptive: DO
      ! Initialize
      Nbin1 = 2*Nbin0
      CALL REALLOCATE(refine1,Nbin1)
      CALL REALLOCATE(xinf1,Nbin1)
      CALL REALLOCATE(xsup1,Nbin1)
      CALL REALLOCATE(Ndist1,Nbin1,Ny)
      ! Refine
      xinf1(1:Nbin1-1:2) = xinf0(1:Nbin0)
      xinf1(2:Nbin1:2) = ( xsup0(1:Nbin0) + xinf0(1:Nbin0) ) / 2._DP
      xsup1(1:Nbin1-1) = xinf1(2:Nbin1)
      xsup1(Nbin1) = xsup0(Nbin0)
      DO i=1,Nbin1
        DO j=1,Ny
          inbin(:) = ( x(:,j) >= xinf1(i) .AND. x(:,j) < xsup1(i) )
          Ndist1(i,j) = COUNT(inbin(:))
        END DO
        refine1(i) = ANY(Ndist1(i,:) >= Npbmax)
      END DO
      ! Exit?
      Nref = COUNT(refine1(:))
      IF (Nref == 0 .OR. Nbin1 >= Nmax) THEN
        EXIT
      ELSE
        Nbin0 = Nbin1
        CALL REALLOCATE(refine0,Nbin0)
        CALL REALLOCATE(xinf0,Nbin0)
        CALL REALLOCATE(xsup0,Nbin0)
        CALL REALLOCATE(Ndist0,Nbin0,Ny)
        refine0(:) = refine1(:)
        xinf0(:) = xinf1(:)
        xsup0(:) = xsup1(:)
        Ndist0(:,:) = Ndist1(:,:)
      END IF
    END DO adaptive

    ! 3) Output
    !----------
    ALLOCATE (xbin(Nbin1))
    ALLOCATE (pbin(Nbin1,Ny))
    xbin(:) = ( xsup1(:) + xinf1(:) ) / 2._DP
    pbin(:,:) = REAL(Ndist1(:,:),DP)
    IF (normalize) pbin(:,:) = pbin(:,:) / REAL(Nx,DP)

    ! Free memory space
    DEALLOCATE (Ndist0,Ndist1,xinf0,xinf1,xsup0,xsup1,refine0,refine1,inbin)

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

  END SUBROUTINE histogram1Dmulti

  !==========================================================================
  ! CALL HISTOGRAM2D (x[N](IN),y[N](IN),xbin[Nb](OUT),ybin[Nb](OUT),
  !                   pbin[Nb,Nb](OUT),Nperbinmax(IN),xlimits(IN),ylimits(IN)])
  !
  !   Makes a 2D histogram of the arrays X and Y. It is similar to HISTOGRAM1D.
  !==========================================================================

  SUBROUTINE histogram2D (x,y,xbin,ybin,pbin,xlimits,ylimits,Nperbinmax, &
                          Nbinmax,norm)

    USE utilities, ONLY: DP, strike
    USE arrays, ONLY: reallocate
    IMPLICIT NONE

    REAL(DP), DIMENSION(:), INTENT(IN) :: x, y
    REAL(DP), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: xbin, ybin
    REAL(DP), DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: pbin
    REAL(DP), DIMENSION(2), INTENT(IN), OPTIONAL :: xlimits, ylimits
    INTEGER, INTENT(IN), OPTIONAL :: Nperbinmax, Nbinmax
    LOGICAL, INTENT(IN), OPTIONAL :: norm

    INTEGER :: ix, iy
    INTEGER :: N, Nmax, Npbmax, Nref, Nbin0, Nbin1
    INTEGER, DIMENSION(:,:), ALLOCATABLE :: Ndist0, Ndist1
    REAL(DP), DIMENSION(:), ALLOCATABLE :: xinf0, xinf1, xsup0, xsup1
    REAL(DP), DIMENSION(:), ALLOCATABLE :: yinf0, yinf1, ysup0, ysup1
    REAL(DP), DIMENSION(2) :: xrange, yrange
    LOGICAL, DIMENSION(:), ALLOCATABLE :: inbin
    LOGICAL, DIMENSION(:,:), ALLOCATABLE :: refine0, refine1
    LOGICAL :: normalize

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

    ! 1) Preparation
    !---------------
    N = SIZE(x)
    IF (SIZE(y) /= N) CALL STRIKE ("HISTOGRAM2D","wrong dimensions of X and Y")
    IF (PRESENT(xlimits)) THEN
      xrange(:) = xlimits(:)
      IF (xlimits(1) < MINVAL(x(:))) xrange(1) = MINVAL(x(:))
      IF (xlimits(2) > MAXVAL(x(:))) xrange(2) = MAXVAL(x(:))
    ELSE
      xrange(:) = [MINVAL(x(:)),MAXVAL(x(:))]
    END IF
    IF (PRESENT(ylimits)) THEN
      yrange(:) = ylimits(:)
      IF (ylimits(1) < MINVAL(y(:))) yrange(1) = MINVAL(y(:))
      IF (ylimits(2) > MAXVAL(y(:))) yrange(2) = MAXVAL(y(:))
    ELSE
      yrange(:) = [MINVAL(y(:)),MAXVAL(y(:))]
    END IF
    IF (PRESENT(norm)) THEN
      normalize = norm
    ELSE
      normalize = .False.
    END IF

    ! Maximum number of elements per bin
    IF (PRESENT(Nbinmax)) THEN
      Nmax = Nbinmax
    ELSE
      Nmax = 30000
    END IF
    IF (PRESENT(Nperbinmax)) THEN
      Npbmax = Nperbinmax
    ELSE
      Npbmax = 30
    END IF

    ! 2) Iteratively adpated bin grid
    !--------------------------------
    ! a. Initialization
    Nbin0 = 1
    ALLOCATE ( refine0(Nbin0,Nbin0), Ndist0(Nbin0,Nbin0), &
               xinf0(Nbin0), xsup0(Nbin0), &
               yinf0(Nbin0), ysup0(Nbin0) )
    refine0(:,:) = .True.
    xinf0(:) = xrange(1)
    xsup0(:) = xrange(2)
    yinf0(:) = yrange(1)
    ysup0(:) = yrange(2)
    Ndist0(:,:) = N
    Nref = 1

    ! b. Iteration
    ALLOCATE (inbin(N))
    adaptive: DO
      ! Initialize
      Nbin1 = 2*Nbin0
      CALL REALLOCATE(refine1,Nbin1,Nbin1)
      CALL REALLOCATE(xinf1,Nbin1)
      CALL REALLOCATE(xsup1,Nbin1)
      CALL REALLOCATE(yinf1,Nbin1)
      CALL REALLOCATE(ysup1,Nbin1)
      CALL REALLOCATE(Ndist1,Nbin1,Nbin1)
      ! Refine
      xinf1(1:Nbin1-1:2) = xinf0(1:Nbin0)
      xinf1(2:Nbin1:2) = ( xsup0(1:Nbin0) + xinf0(1:Nbin0) ) / 2._DP
      xsup1(1:Nbin1-1) = xinf1(2:Nbin1)
      xsup1(Nbin1) = xsup0(Nbin0)
      yinf1(1:Nbin1-1:2) = yinf0(1:Nbin0)
      yinf1(2:Nbin1:2) = ( ysup0(1:Nbin0) + yinf0(1:Nbin0) ) / 2._DP
      ysup1(1:Nbin1-1) = yinf1(2:Nbin1)
      ysup1(Nbin1) = ysup0(Nbin0)
      DO ix=1,Nbin1
        DO iy=1,Nbin1
          inbin(:) = ( x(:) >= xinf1(ix) .AND. x(:) < xsup1(ix) &
                     .AND. y(:) >= yinf1(iy) .AND. y(:) < ysup1(iy) )
          Ndist1(ix,iy) = COUNT(inbin(:))
        END DO
      END DO
      refine1(:,:) = ( Ndist1(:,:) >= Npbmax )
      ! Exit?
      Nref = COUNT(refine1(:,:))
      IF (Nref == 0 .OR. Nbin1 >= Nmax) THEN
        EXIT
      ELSE
        Nbin0 = Nbin1
        CALL REALLOCATE(refine0,Nbin0,Nbin0)
        CALL REALLOCATE(xinf0,Nbin0)
        CALL REALLOCATE(xsup0,Nbin0)
        CALL REALLOCATE(yinf0,Nbin0)
        CALL REALLOCATE(ysup0,Nbin0)
        CALL REALLOCATE(Ndist0,Nbin0,Nbin0)
        refine0(:,:) = refine1(:,:)
        xinf0(:) = xinf1(:)
        xsup0(:) = xsup1(:)
        yinf0(:) = yinf1(:)
        ysup0(:) = ysup1(:)
        Ndist0(:,:) = Ndist1(:,:)
      END IF
    END DO adaptive

    ! 3) Output
    !----------
    ALLOCATE (xbin(Nbin1))
    ALLOCATE (ybin(Nbin1))
    ALLOCATE (pbin(Nbin1,Nbin1))
    xbin(:) = ( xsup1(:) + xinf1(:) ) / 2._DP
    ybin(:) = ( ysup1(:) + yinf1(:) ) / 2._DP
    pbin(:,:) = REAL(Ndist1(:,:),DP)
    IF (normalize) pbin(:,:) = pbin(:,:) / REAL(N,DP)

    ! Free memory space
    DEALLOCATE (Ndist0,Ndist1,xinf0,xinf1,xsup0,xsup1,yinf0,yinf1,ysup0,ysup1, &
                refine0,refine1,inbin)

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

  END SUBROUTINE histogram2D

END MODULE distributions


!this mod is use to find  x such as Ux=b(LU) or Rx=b(QR)
!you should make sure that R b x have the same row and R is a upmatrix(n)
MODULE upmatrix_mod
    IMPLICIT NONE
    PRIVATE
    PUBLIC :: upmatrix
CONTAINS
    SUBROUTINE upmatrix(R,b)
        INTEGER(4)::m,n,i,ii
        REAL(4)::sum
        REAL(4),DIMENSION(:,:),INTENT(IN)::R
        REAL(4),DIMENSION(:,:),INTENT(INOUT)::b
        m=size(R,1)
        n=size(R,2)
        DO i=n,1,-1
            IF (i==n) b(i,1)=b(i,1)/R(i,i)
            IF (i/=n) THEN
                sum=0
                DO ii=i+1,n
                    sum=sum+R(i,ii)*b(ii,1)
                END DO
                b(i,1)=(b(i,1)-sum)/R(i,i)
            END IF
        END DO
     END SUBROUTINE upmatrix
END MODULE


subroutine Merge(A,NA,B,NB,C,NC)

   integer, intent(in) :: NA,NB,NC         ! Normal usage: NA+NB = NC
   integer, intent(in out) :: A(NA)        ! B overlays C(NA+1:NC)
   integer, intent(in)     :: B(NB)
   integer, intent(in out) :: C(NC)

   integer :: I,J,K

   I = 1; J = 1; K = 1;
   do while(I <= NA .and. J <= NB)
      if (A(I) <= B(J)) then
         C(K) = A(I)
         I = I+1
      else
         C(K) = B(J)
         J = J+1
      endif
      K = K + 1
   enddo
   do while (I <= NA)
      C(K) = A(I)
      I = I + 1
      K = K + 1
   enddo
   return

end subroutine merge

recursive subroutine MergeSort(A,N,T)

   integer, intent(in) :: N
   integer, dimension(N), intent(in out) :: A
   integer, dimension((N+1)/2), intent (out) :: T

   integer :: NA,NB,V

   if (N < 2) return
   if (N == 2) then
      if (A(1) > A(2)) then
         V = A(1)
         A(1) = A(2)
         A(2) = V
      endif
      return
   endif
   NA=(N+1)/2
   NB=N-NA

   call MergeSort(A,NA,T)
   call MergeSort(A(NA+1),NB,T)

   if (A(NA) > A(NA+1)) then
      T(1:NA)=A(1:NA)
      call Merge(T,NA,A(NA+1),NB,A,N)
   endif
   return

end subroutine MergeSort

program TestMergeSort

   integer, parameter :: N = 8
   integer, dimension(N) :: A = (/ 1, 5, 2, 7, 3, 9, 4, 6 /)
   integer, dimension ((N+1)/2) :: T
   call MergeSort(A,N,T)
   write(*,'(A,/,10I3)')'Sorted array :',A

end program TestMergeSort


    module metodosLineales

    contains

    !-------------------------------------------------------------
    !--------Friccion1Pto-----------------------------------------
    !-------------------------------------------------------------
    function friccion1Pto(ksd, Re,semilla_f)
        implicit none
        !variables externas
        real :: friccion1Pto, ksd, semilla_f
        integer::Re

        !variables internas
        real :: fi, fi_1
        integer :: i

        !parameters
        real, parameter :: E = 1e-8

        if (Re > 2200) then
            fi= semilla_f
            print"(a10,a15,a18,a18)", "fi","x","g(x)","fi_1"

            do i = 1,15

                fi_1 = (-2 * log10((ksd / (3.7)) + (2.51 / (Re * sqrt(fi))))) ** (-2) !ksd es ks/d, por esta razon no esta d en la formula

                print *, fi, 1/sqrt(fi),1/sqrt(fi_1),fi_1
                if (abs(fi - fi_1)<E) then
                    exit
                else
                    fi = fi_1
                end if
            end do

            friccion1Pto = fi
        else
            friccion1Pto = 64/Re

        end if

    end function friccion1Pto

    !-------------------------------------------------------------
    !--------friccionNewtonRapshon--------------------------------
    !-------------------------------------------------------------
    function friccionNewtonRapshon(ksd, Re,semilla_f)
        implicit none
        !variables externas
        real :: friccionNewtonRapshon, ksd, semilla_f
        integer::Re

        !variables internas
        real :: fi, xi, xi_1, Fx, dFx
        integer :: i

        !parameters
        real, parameter :: E = 1e-8

        if (Re > 2200) then
            fi = semilla_f
            print"(a10,a15,a18,a18,a18)", "fi","x","x+1","F(x)","dF(x)"

            xi = 1/sqrt(fi)

            do i = 1,15

                Fx = -2 * log10((ksd / 3.7) + (2.51 * xi / Re)) !ksd es ks/d, por esta razon no esta d en la formula
                dFx = (-2 / log(10.0)) * (2.51/Re)
                dFx = dFx /((ksd/3.7)+(2.51*xi/Re))

                xi_1 = xi - (Fx - xi)/(dFx - 1)

                print *, fi, xi,xi_1,Fx,dFx
                if (abs(xi - xi_1)<E) then
                    exit
                else
                    xi = xi_1
                end if
            end do

            friccionNewtonRapshon = 1/(xi_1 ** 2)
        else
            friccionNewtonRapshon = 64/Re

        end if
    end function

    !-------------------------------------------------------------
    !--------EjemploFriccion--------------------------------------
    !-------------------------------------------------------------
    subroutine EjemploFriccion()
        use messages
        implicit none
        real:: f, ksd
        integer:: Re, i, methodSelection
        character :: option !es la opción par cambiar los ejemplos (y/n)
        print mensajeSeleccionFriccion

        ksd=0.0001; Re=20000; f=0.001;

        print"('Por defecto, se cargaran datos del ejemplo 2.1'/)"
        do i = 1,10

        print datosEjercicio3, ksd, Re, f

        write(*,'(a)',ADVANCE="NO") "Desea continuar con estos datos (y/n)? "
        read(*,*) option
        if (option == 'y')then
            exit
        else
            write(*,*) char(10),"introduzca los valores(3) como un vector con el sgte formato: "
            print*,"ksd, Re, f"
            read(*,*)ksd, Re, f  !DEBUG
            print*, char(10)
        end if
        end do
        do while (.true.)
            print *, ""
            print *, "1: Metodo 1 punto  (Newton)"
            print *, "2: Metodo derivada (Newton Raphson)"
            write(*,'(a)',ADVANCE="NO") "Seleccione una opcion  (1 o 2)? "
            read(*,*) methodSelection

            select case (methodSelection)
                case (1)
                    print *, "Metodo Newton punto: "
                    f = friccion1Pto(ksd,Re,f)
                    print "(/'f= ', es10.3/)", f
                    print *, "FIN"
                    read(*,*)
                    exit

                case (2)
                    print *, "Metodo NewtonPapshon punto: "
                    f= friccionNewtonRapshon(ksd,Re,f)
                    print "(/'f= ', es10.3/)", f
                    print *, "FIN"
                    read(*,*)
                    exit
                case default
                    print *, "opcion invalida"
            end select
        end do

    end subroutine EjemploFriccion

    end module


c square matrix multiplication
      program matmul
      integer n
      parameter (n=10)
      real*8 a(n,n), b(n,n), c(n,n)
      integer i, j, k
c
c selection of options...
c
cfcd$ setbool('HPFC_LAZY_MESSAGES',0)
cfcd$ setbool('HPFC_USE_BUFFERS', 0)
c
c initial mapping: A, B and C are aligned and block distributed
c
chpf$ dynamic a, b
chpf$ template t(n,n)
chpf$ processors p(2,2)
chpf$ distribute t(block,block) onto p
chpf$ align a(i,j), b(i,j), c(i,j) with t(i,j)
c
c initialization of array A and B
c
chpf$ independent(j,i)
      do j=1, n
         do i=1, n
            a(i,j) = real(i-(n/2))/real(j)
            b(i,j) = real(j-3)/real(i)
         enddo
      enddo
c
c matrix multiply: C=A*B
c a remapping is needed to ensure data locality
c
cfcd$ timeon
chpf$ realign a(i,*) with t(i,*)
chpf$ realign b(*,j) with t(*,j)
chpf$ independent(j,i)
      do j=1, n
         do i=1, n
            c(i,j) = 0.
            do k=1, n
               c(i,j) = c(i,j) + a(i,k)*b(k,j)
            enddo
         enddo
      enddo
cfcd$ timeoff('matrix multiplication')
c
c output of the result
c
      print *, ((c(i,j), i=1, n), j=1, n)
      end


! Statistics
!
! ------------------------------------------------------------------------------
! Copyright (c) 2009-13, Thomas P. Robitaille
!
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
!  * Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
!
!  * Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ------------------------------------------------------------------------------

module lib_statistics

  use lib_array
  implicit none
  save

  private

  integer,parameter :: idp = selected_int_kind(13)
  integer,parameter :: sp = selected_real_kind(p=6,r=37)
  integer,parameter :: dp = selected_real_kind(p=15,r=307)

  public :: mean
  interface mean
     module procedure mean_sp
     module procedure mean_dp
  end interface mean

  public :: median
  interface median
     module procedure median_sp
     module procedure median_dp
  end interface median

  public :: quantile
  interface quantile
     module procedure quantile_sp
     module procedure quantile_dp
  end interface quantile

  public :: variance
  interface variance
     module procedure variance_sp
     module procedure variance_dp
  end interface variance

  public :: clipped_mean
  interface clipped_mean
     module procedure clipped_mean_sp
     module procedure clipped_mean_dp
  end interface clipped_mean

contains

  !!@FOR real(sp):sp real(dp):dp

  @T function mean_<T>(x, mask)
    implicit none
    @T,intent(in) :: x(:)
    logical,intent(in),optional :: mask(:)
    if(present(mask)) then
       mean_<T> = sum(x, mask=mask)/size(x)
    else
       mean_<T> = sum(x)/size(x)
    end if
  end function mean_<T>

  @T function median_<T>(x)
    implicit none
    @T,intent(in) :: x(:)
    @T,dimension(size(x)) :: x_sorted
    integer :: n
    n = size(x)
    x_sorted = x
    call quicksort(x_sorted)
    if(mod(n,2).eq.0) then
       median_<T>=(x_sorted(n/2)+x_sorted(n/2+1))/2.
    else
       median_<T>=x_sorted((n-1)/2+1)
    end if
  end function median_<T>

  @T function quantile_<T>(x, percent, mask)
    implicit none
    @T,intent(in) :: x(:), percent
    logical,intent(in),optional :: mask(:)
    @T,allocatable :: x_sorted(:)
    integer :: n, ipos
    if(present(mask)) then
       n = count(mask)
       allocate(x_sorted(n))
       x_sorted = pack(x, mask)
    else
       n = size(x)
       allocate(x_sorted(n))
       x_sorted = x
    end if
    call quicksort(x_sorted)
    if(percent >= 100._<T>) then
       ipos = n
    else if(percent <= 0._<T>) then
       ipos = 1
    else
       ipos=nint(percent/100._<T>*real(n-1, <T>))+1
    end if
    quantile_<T>=x_sorted(ipos)
  end function quantile_<T>

  @T function variance_<T>(x, mask)
    implicit none
    @T,intent(in) :: x(:)
    logical,intent(in),optional :: mask(:)
    variance_<T> = sum(x-mean(x, mask=mask)**2._<T>)/(size(x)-1)
  end function variance_<T>

  @T function clipped_mean_<T>(x, n)
    implicit none
    @T,intent(in) :: x(:)
    integer,intent(in) :: n
    logical,dimension(size(x)) :: keep
    @T :: sigma
    integer :: n_before
    keep = .true.
    n_before = 0
    do
       clipped_mean_<T> = mean(x, mask=keep)
       sigma = sqrt(variance(x, mask=keep))
       keep = keep .and. abs(x-clipped_mean_<T>) < real(n, <T>) * sigma
       if(count(keep)==n_before) exit
       n_before = count(keep)
    end do
  end function clipped_mean_<T>

  !!@END FOR

end module lib_statistics


!-------------------------------------------------------------------------------
! Copyright (c) 2021, Whitman T. Dailey
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
! 1. Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
! 3. Neither the name of the copyright holder nor the names of its
!    contributors may be used to endorse or promote products derived from
!    this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!-------------------------------------------------------------------------------
Module Interpolation

    Implicit None
    Private
    Public :: Linear_Interp
    Public :: Cubic_Interp
    Public :: Hermite_Cubic_Interp
    Public :: LogLog_Interp
    Public :: LogLin_Interp
    Public :: LinLog_Interp

    Interface Linear_Interp
        Module Procedure Lin_Interp
        Module Procedure BiLin_Interp
    End Interface

    Interface Cubic_Interp
        Module Procedure Cub_Interp  !1-D cubic interpolation
        Module Procedure Cub_Sec_Interp  !1-D cubic interpolation using secant approximation
        Module Procedure BiCub_Interp  !2-D cubic interpolation
        Module Procedure BiCub_Sec_Interp  !2-D cubic interpolation using secant approximation
    End Interface

    !Hermite routines provided by Kirk Mathews
    Interface Hermite_Cubic_Interp
        Module Procedure Hermite_Cubic_1D
        Module Procedure Hermite_Cubic_2D
    End Interface
    ! This module provides tools for Hermite cubic interpolation in 1 dimension
    !   and for Cartesian-Product Hermite cubic interpolation in 2 dimensions
    ! Note that the cost of general bi-cubic interpolation is 272 arithmetic operations
    !   whereas the cost of Cartesian-product Hermite cubic interpolation is only 60.
    ! Hermite cubic interpolation for a function f(x)
    !   that has continuous derivatives through order 4 has error term E(x) = f(x) - h(x), where
    ! E(x) = (1-u)^2 * (1+u)^2 * ((xR-xL)^4 / 384) * d4f(x)/dx4 at some point xi in [xL,xR]
    ! Note that, with this definition, E is the correction to the error, because f(x) = h(x) + E(x)
    ! The corresponding error for linear interpolation is
    !   E(x) = -(1-u) * (1+u) * ((xR-xL)^2 / 2) * d2f(x)/dx2
    ! Once the interval is reduced enough that the relative change in the derivatives
    !   is small in the interval, halving the interval reduces
    !   linear interpolation by a factor of 4, but reduces
    !   Hermite cubic interterpolation by a factor of 16.
    ! For the same amount of stored data, in 2 dimensions,
    !   linear has half the grid spacing as Hermite cubic,
    !   but for higher accuracy requirements, the factor of 16 dominates.
    !   Also, the denominator of 384 vs. the denominator of 2
    !   gives Hermite a factor of 174 better performance.

Contains

Elemental Function Cub_Interp(x,x1,x2,y1,y2,dy1,dy2) Result(y)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: y
    Real(dp), Intent(In) :: x
    Real(dp), Intent(In) :: x1,x2
    Real(dp), Intent(In) :: y1,y2
    Real(dp), Intent(In) :: dy1,dy2
    Real(dp) :: t,a,b

    t = (x-x1) / (x2-x1)
    a = dy1*(x2-x1) - (y2-y1)
    b = -dy2*(x2-x1) + (y2-y1)
    y = (1._dp - t)*y1 + t*y2 + t*(1._dp - t)*(a*(1._dp - t) + b*t)
End Function Cub_Interp

Function Cub_Sec_Interp(x,xi,yi) Result(y)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: y
    Real(dp), Intent(In) :: x
    Real(dp), Intent(In) :: xi(0:3)
    Real(dp), Intent(In) :: yi(0:3)
    Real(dp) :: dy1,dy2

    dy1 = (yi(2)-yi(0)) / (xi(2)-xi(0))
    dy2 = (yi(3)-yi(1)) / (xi(3)-xi(1))
    y = Cub_Interp(x,xi(1),xi(2),yi(1),yi(2),dy1,dy2)
End Function Cub_Sec_Interp

Function BiCub_Sec_Interp(x,xi,y,yi,zi) Result(z)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: z
    Real(dp), Intent(In) :: x
    Real(dp), Intent(In) :: xi(0:3)
    Real(dp), Intent(In) :: y
    Real(dp), Intent(In) :: yi(0:3)
    Real(dp), Intent(In) :: zi(0:3,0:3)
    Real(dp) :: dz_dx11,dz_dx12,dz_dx21,dz_dx22
    Real(dp) :: dz_dy11,dz_dy12,dz_dy21,dz_dy22
    Real(dp) :: d2z_dx_dy11,d2z_dx_dy12,d2z_dx_dy21,d2z_dx_dy22

    dz_dx11 = (zi(2,1)-zi(0,1)) / (xi(2)-xi(0))
    dz_dx12 = (zi(2,2)-zi(0,2)) / (xi(2)-xi(0))
    dz_dx21 = (zi(3,1)-zi(1,1)) / (xi(3)-xi(1))
    dz_dx22 = (zi(3,2)-zi(1,2)) / (xi(3)-xi(1))
    dz_dy11 = (zi(1,2)-zi(1,0)) / (yi(2)-yi(0))
    dz_dy12 = (zi(1,3)-zi(1,1)) / (yi(3)-yi(1))
    dz_dy21 = (zi(2,2)-zi(2,0)) / (yi(2)-yi(0))
    dz_dy22 = (zi(2,3)-zi(2,1)) / (yi(3)-yi(1))
    d2z_dx_dy11 = (zi(2,2)-zi(2,0)-zi(0,2)+zi(0,0)) / ((xi(2)-xi(0))*(yi(2)-yi(0)))
    d2z_dx_dy12 = (zi(2,3)-zi(2,1)-zi(0,3)+zi(0,1)) / ((xi(2)-xi(0))*(yi(3)-yi(1)))
    d2z_dx_dy21 = (zi(3,2)-zi(3,0)-zi(1,2)+zi(1,0)) / ((xi(3)-xi(1))*(yi(2)-yi(0)))
    d2z_dx_dy22 = (zi(3,3)-zi(3,1)-zi(1,3)+zi(1,1)) / ((xi(3)-xi(1))*(yi(3)-yi(1)))
    z = BiCub_Interp( x,xi(1),xi(2),y,yi(1),yi(2), &
                    & zi(1,1),zi(1,2),zi(2,1),zi(2,2), &
                    & dz_dx11,dz_dx12,dz_dx21,dz_dx22, &
                    & dz_dy11,dz_dy12,dz_dy21,dz_dy22, &
                    & d2z_dx_dy11,d2z_dx_dy12,d2z_dx_dy21,d2z_dx_dy22 )
End Function BiCub_Sec_Interp

Elemental Function BiCub_Interp( x,x1,x2,y,y1,y2, &
                               & z11,z12,z21,z22, &
                               & dz_dx11,dz_dx12,dz_dx21,dz_dx22, &
                               & dz_dy11,dz_dy12,dz_dy21,dz_dy22, &
                               & d2z_dx_dy11,d2z_dx_dy12,d2z_dx_dy21,d2z_dx_dy22 ) Result(z)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: z
    Real(dp), Intent(In) :: x
    Real(dp), Intent(In) :: x1,x2
    Real(dp), Intent(In) :: y
    Real(dp), Intent(In) :: y1,y2
    Real(dp), Intent(In) :: z11,z12,z21,z22
    Real(dp), Intent(In) :: dz_dx11,dz_dx12,dz_dx21,dz_dx22
    Real(dp), Intent(In) :: dz_dy11,dz_dy12,dz_dy21,dz_dy22
    Real(dp), Intent(In) :: d2z_dx_dy11,d2z_dx_dy12,d2z_dx_dy21,d2z_dx_dy22
    Real(dp) :: z1,z2
    Real(dp) :: dz_dy1,dz_dy2

    z1 = Cub_Interp(x,x1,x2,z11,z12,dz_dx11,dz_dx12)
    z2 = Cub_Interp(x,x1,x2,z21,z22,dz_dx21,dz_dx22)
    dz_dy1 = Cub_Interp(x,x1,x2,dz_dy11,dz_dy12,d2z_dx_dy11,d2z_dx_dy12)
    dz_dy2 = Cub_Interp(x,x1,x2,dz_dy21,dz_dy22,d2z_dx_dy21,d2z_dx_dy22)
    z = Cub_Interp(y,y1,y2,z1,z2,dz_dy1,dz_dy2)
End Function BiCub_Interp

Elemental Function Lin_Interp(x,x1,x2,y1,y2) Result(y)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: y
    Real(dp), Intent(In) :: x
    Real(dp), Intent(In) :: x1,x2
    Real(dp), Intent(In) :: y1,y2

    y = y1 + (y2-y1) * (x-x1) / (x2-x1)
End Function Lin_Interp

Elemental Function BiLin_Interp(x,x1,x2,y,y1,y2,z11,z12,z21,z22) Result(z)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: z
    Real(dp), Intent(In) :: x
    Real(dp), Intent(In) :: x1,x2
    Real(dp), Intent(In) :: y
    Real(dp), Intent(In) :: y1,y2
    Real(dp), Intent(In) :: z11,z12,z21,z22
    Real(dp) :: z1,z2

    z1 = lin_interp(x,x1,x2,z11,z12)
    z2 = lin_interp(x,x1,x2,z21,z22)
    z = lin_interp(y,y1,y2,z1,z2)
End Function BiLin_Interp

Elemental Function LogLog_Interp(x,x1,x2,y1,y2) Result(y)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: y
    Real(dp), Intent(In) :: x
    Real(dp), Intent(In) :: x1,x2
    Real(dp), Intent(In) :: y1,y2

    !Exponentiate a value linearly interpolated in Log(x) and Log(y)
    y = Exp( Linear_Interp(Log(x),Log(x1),Log(x2),Log(y1),Log(y2)) )
End Function LogLog_Interp

Elemental Function LogLin_Interp(x,x1,x2,y1,y2) Result(y)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: y
    Real(dp), Intent(In) :: x
    Real(dp), Intent(In) :: x1,x2
    Real(dp), Intent(In) :: y1,y2

    !Exponentiate a Linearly interpolated in Lin(x) and Log(y)
    y = Exp( Linear_Interp(x,x1,x2,Log(y1),Log(y2)) )
End Function LogLin_Interp

Elemental Function LinLog_Interp(x,x1,x2,y1,y2) Result(y)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: y
    Real(dp), Intent(In) :: x
    Real(dp), Intent(In) :: x1,x2
    Real(dp), Intent(In) :: y1,y2

    !Linearly interpolated in Log(x) and Lin(y)
    y = Linear_Interp(Log(x),Log(x1),Log(x2),y1,y2)
End Function LinLog_Interp

Function Hermite_Cubic_1D(x, xL, xR, f, dfdx) Result(h)
    ! Hermite cubic interpolation for a function f(x),
    !   given tables of f and df(x)/dx
    ! h(x) = wfL*f(xL) + wfR*f(xR) + wfxL*dfdx(xL) + wfxR*gR
    ! The weights are computed by Function Hermite_Cubic_Weights
    ! The interpolation in 1D is performed using Dot_Product(w, fg), where:
    ! w = (/ wfL, wfR, wgL, wgR /)
    ! fg = (/ fL, fR, gL, gR /)
    Use Kinds, Only: dp
    Implicit None
    Real(dp):: h                        ! Interpolated value
    Real(dp), Intent(In):: x            ! location at which to interpolate
    Real(dp), Intent(In):: xL, xR       ! locations of the data
    Real(dp), Intent(In):: f(1:2)       ! function at xL and xR
    Real(dp), Intent(In):: dfdx(1:2)    ! derivative at xL and xR
    Real(dp):: w(1:4)                   ! Vector of weights
    Real(dp):: d(1:4)                   ! (/ f(xL), f(xR), dfdx(xL), dfdx(xR) /)

    d(1:2) = f
    d(3:4) = dfdx
    w = Hermite_Cubic_Weights(x, xL, xR)
    h = Dot_Product(w, d)   ! This linear-algebra formalism is used because it extends to 2D
    ! computational cost: 24 arithmetic operations
    !   (multiply & add is one operation in dot products)
End Function Hermite_Cubic_1D

Function Hermite_Cubic_2D(x, xL, xR, y, yB, yT, f, fx, fy, fxy) Result(h)
    ! Cartesian-product of Hermite cubic in x and in y within a rectangle of data.
    !   L is for Left side of rectangle, R is for Right side, B for Bottom, and T for Top
    ! To pass in f, where the calling routine has an array of data F(0:iMax,0:jMax),
    !   to interpolate at some point (X,Y) with x(i) <= X <= x(i+1) and y(j) <= Y <= y(j+1)
    !   put F(i:i+1,j:j+1) in the location for argument f,
    !   and similarly for the various derivatives.
    ! Note: Module Utilities, Function Find_Data_Pair_Index(x, xList, kStart)
    !   returns the index i that is needed when passed the list x(0:iMax)
    !   and similarly for j when passed y(0:iMax)
    Use Kinds, Only: dp
    Implicit None
    Real(dp):: h                        ! Interpolated value
    Real(dp), Intent(In):: x, y         ! location at which to interpolate
    Real(dp), Intent(In):: xL, xR       ! x coordinates of the data
    Real(dp), Intent(In):: yB, yT       ! y coordinates of the data
    Real(dp), Intent(In):: f(1:2,1:2)   ! f(1,1) is f(xL,yB), f(1,2) is f(xL,yT), and so on
    Real(dp), Intent(In):: fx(1:2,1:2)  ! same for fx = df/dx
    Real(dp), Intent(In):: fy(1:2,1:2)  ! same for fy = df/dy
    Real(dp), Intent(In):: fxy(1:2,1:2) ! same for fxy = d2f/dxdy
    Real(dp):: wx(1:4)                  ! Vector of weights for interpolation in x
    Real(dp):: wy(1:4)                  ! Vector of weights for interpolation in y
    Real(dp):: D(1:4, 1:4)              ! This is a matrix of data that combines f, fx, fy, fxy
    Integer:: j

    D(1:2,1:2) = f
    D(1:2,3:4) = fx
    D(3:4,1:2) = fy
    D(3:4,3:4) = fxy
    wx = Hermite_Cubic_Weights(x, xL, xR)   ! cost 20
    wy = Hermite_Cubic_Weights(y, yB, yT)   ! cost 20
        ! h is calculated as the general quadratic form wy.D.wx
        ! where wy is a vector, D is a matrix, and wx is a vector
        ! The dot-product is used for multiplying wy with each column-vector of D.
        !   This choice takes advantage of the column-major storage used by Fortran
    h = 0.0_dp
    Do j = 1, 4
        h = h + Dot_Product(wy,D(:,j)) * wx(j) ! cost 5 each j
    End do
    ! computational cost: 60 arithmetic operations
    !   (counting multiply & add as one operation in accumulations)
End Function Hermite_Cubic_2D

Function Hermite_Cubic_Weights(x, xL, xR) Result(w)
    Use Kinds, Only: dp
    Implicit None
    Real(dp):: w(1:4)                   ! Weight vector to dot with (/ fL, fR, gL, gR /)
    Real(dp), Intent(In):: x            ! location at which to interpolate
    Real(dp), Intent(In):: xL, xR       ! locations of the data
    Real(dp):: u                        ! As x goes from xL to xR, u goes from -1 to +1
    Real(dp):: xBar                     ! center of interval
    Real(dp):: DeltaX                   ! half-width of interval
        ! Units of DeltaX cancel the units of dx in the derivative df/dx
    Real(dp):: m, p                     ! (1-u) & (1+u) for efficiency
    Real(dp):: wfL, wfR, wgL, wgR       ! scalar variables for elements of w

    xBar = 0.5_dp * (xR + xL)
    DeltaX = 0.5_dp * (xR - xL)
    u = (x - xBar) / DeltaX
    m = 1._dp - u
    p = 1._dp + u
    wfL = m**2
    wgL = p * wfL
    wfL = 0.25_dp * (wfL + wgL)
    wgL = 0.25_dp * wgL * DeltaX
    wfR = p**2
    wgR = -m * wfR
    wfR = 0.25_dp * (wfR - wgR)
    wgR = 0.25_dp * wgR * DeltaX
    w = (/ wfL, wfR, wgL, wgR /)
End Function Hermite_Cubic_Weights

End Module Interpolation


module jacobi_mod
    use,intrinsic :: iso_fortran_env
    implicit none
    real(real64),parameter:: pi = acos(-1d0)
    private
    public:: jacobi

contains
    subroutine  jacobi(a,n)
        integer(int32),intent(in):: n
        real(real64), intent(inout):: a(n,n)
        integer(int32):: iter,x,y,i
        real(real64):: theta

        do iter = 1,100
            call search_max(a,n,x,y)
            theta = calc_theta(a,n,x,y)
            call calc_new_a(a,n,x,y,theta)
            print*, "#",iter,x,y
            do i=1,n
                print'(*(f8.4))', a(:,i)
            end do
        end do
    end subroutine

    subroutine search_max(a,n,x,y)
        integer(int32),intent(in):: n
        real(real64), intent(in):: a(n,n)
        integer(int32),intent(out):: x,y
        real(real64):: axy
        integer(int32)::i,j

        axy = 0d0
        do i=1,n
            do j=1,n
                if (i==j) cycle
                if (abs(a(j,i)) > axy) then
                    axy = abs(a(j,i))
                    y=i; x=j
                end if
            end do
        end do
    end subroutine

    function calc_theta(a,n,x,y) result(theta)
        integer(int32),intent(in):: x,y,n
        real(real64),intent(in)::a(n,n)
        real(real64):: theta

        if (a(x,x) == a(y,y)) then
            theta = pi/4d0
        else
            theta = atan(-2*a(x,y)/(a(y,y)-a(x,x)))/2d0
        end if
    end function

    subroutine calc_new_a(a,n,x,y,theta)
        integer(int32),intent(in):: x,y,n
        real(real64),intent(inout):: a(n,n)
        real(real64),intent(in):: theta
        real(real64):: new_a(n,n), ct, st

        ct = cos(theta)
        st = sin(theta)

        new_a(:,:) = a(:,:)
        new_a(:,x) = ct*a(:,x) + st*a(:,y)
        new_a(:,y) = ct*a(:,y) - st*a(:,x)
        new_a(x,:) = ct*a(x,:) + st*a(y,:)
        new_a(y,:) = ct*a(y,:) - st*a(x,:)
        new_a(x,x) = st*(st*a(y,y)+ct*a(x,y)) + ct*(st*a(x,y) + ct*a(x,x))
        new_a(y,y) = ct*(ct*a(y,y)-st*a(x,y)) - st*(ct*a(x,y) - st*a(x,x))
        new_a(x,y) = st*(ct*a(y,y)-st*a(x,y)) + ct*(ct*a(x,y) - st*a(x,x))
        new_a(y,x) = st*(ct*a(y,y)-st*a(x,y)) + ct*(ct*a(x,y) - st*a(x,x))
        a(:,:) = new_a(:,:)
    end subroutine
end module


!==============================================================================!
  module Math_Mod
!------------------------------------------------------------------------------!
!   This is a prototype of a small module which would contain some basic       !
!   mathematic and related functions.                                          !
!------------------------------------------------------------------------------!
  implicit none
!==============================================================================!

  ! Default precision for "Approx_Real" and "Smaller_Real" functions
  real, parameter :: DEFAULT_TOLERANCE = 1.0e-9

  contains

  include 'Math_Mod/Approx_Real.f90'
  include 'Math_Mod/Approx_String.f90'
  include 'Math_Mod/Cross_Product.f90'
  include 'Math_Mod/Distance.f90'
  include 'Math_Mod/Distance_Squared.f90'
  include 'Math_Mod/Smaller_Real.f90'
  include 'Math_Mod/Tet_Volume.f90'
  include 'Math_Mod/Tri_Area_Z.f90'

  end module


module module_modint
  use, intrinsic :: iso_fortran_env
  implicit none
  integer(int64) :: modu = 1000000007_8
  type modint
    integer(int64), private :: val = 0_8
  contains
    procedure, private :: asgn => asgn
    procedure, private :: add => add
    procedure, private :: sub => sub
    procedure, private :: mul => mul
    procedure, private :: div => div
    procedure, private :: pow => pow
    procedure, public :: inv => inv
    procedure, public :: get => get
    generic, public :: assignment(=) => asgn
    generic, public :: operator(+) => add
    generic, public :: operator(-) => sub
    generic, public :: operator(*) => mul
    generic, public :: operator(/) => div
    generic, public :: operator(**) => pow
  end type
  interface modint
    module procedure :: new_modint, new_modint_with_num
  end interface modint
  interface operator(+)
    module procedure :: add_r
  end interface
  interface operator(-)
    module procedure :: sub_r
  end interface
  interface operator(*)
    module procedure :: mul_r
  end interface
  interface operator(/)
    module procedure :: div_r
  end interface
  interface dot_product
    module procedure :: dot_prod
  end interface dot_product
  interface matmul
    module procedure :: matmul1, matmul2, matmul3
  end interface matmul
contains
  pure elemental integer(int64) function to_int64(num) result(ret)
    class(*), intent(in) :: num
    select type (num)
    type is (integer(int64))
      ret = num
    type is (integer(int32))
      ret = int(num, int64)
    type is (integer(int16))
      ret = int(num, int64)
    type is (integer(int8))
      ret = int(num, int64)
    class default
      ret = 0_8
      ret = 1_8/ret
    end select
  end
  pure elemental type(modint) function new_modint()
  end
  pure elemental type(modint) function new_modint_with_num(num) result(ret)
    class(*), intent(in) :: num
    ret%val = to_int64(num)
  end
  pure elemental subroutine asgn(this,other)
    class(modint), intent(inout) :: this
    class(*), intent(in) :: other
    integer(int64) :: val
    select type (other)
    type is (modint)
      this%val = other%val
    class default
      val = to_int64(other)
      if (0_8 <= val .and. val < modu) then
        this%val = val
      else
        this%val = modulo(val,modu)
      end if
    end select
  end
  pure elemental type(modint) function add(this,other) result(ret)
    class(modint), intent(in) :: this
    class(*), intent(in) :: other
    integer(int64) :: val
    select type (other)
    type is (modint)
      if (0_8 <= this%val+other%val .and. this%val+other%val < modu) then
        ret%val = this%val+other%val
      else
        ret%val = this%val+other%val-modu
      end if
    class default
      val = to_int64(other)
      if (0_8 <= this%val+val .and. this%val+val < modu) then
        ret%val = this%val+val
      else
        ret%val = modulo(this%val+val,modu)
      end if
    end select
  end
  pure elemental type(modint) function sub(this,other) result(ret)
    class(modint), intent(in) :: this
    class(*), intent(in) :: other
    integer(int64) :: val
    select type (other)
    type is (modint)
      if (0_8 <= this%val-other%val .and. this%val-other%val < modu) then
        ret%val = this%val-other%val
      else
        ret%val = this%val-other%val+modu
      end if
    class default
      val = to_int64(other)
      if (0_8 <= this%val-val .and. this%val-val < modu) then
        ret%val = this%val-val
      else
        ret%val = modulo(this%val-val,modu)
      end if
    end select
  end
  pure elemental type(modint) function mul(this,other) result(ret)
    class(modint), intent(in) :: this
    class(*), intent(in) :: other
    integer(int64) :: val
    select type (other)
    type is (modint)
      val = other%val
    class default
      val = to_int64(other)
    end select
    if (0_8 <= this%val*val .and. this%val*val < modu) then
      ret%val = this%val*val
    else
      ret%val = modulo(this%val*val,modu)
    end if
  end
  pure elemental type(modint) function div(this,other) result(ret)
    class(modint), intent(in) :: this
    class(*), intent(in) :: other
    type(modint) :: tmp
    call asgn(tmp,other)
    call asgn(ret,mul(this,inv(tmp)))
  end
  pure elemental integer(int64) function get(this)
    class(modint), intent(in) :: this
    get = this%val
  end
  pure elemental type(modint) function inv(this)
    class(modint), intent(in) :: this
    integer(int64) :: a, b, c, n
    integer(int64) :: x, y, z, m
    a = this%val
    b = modu
    c = 0_8
    n = 1_8
    do while (b /= 0_8)
      x = b
      y = mod(a,b)
      z = n-a/b*c
      m = c
      a = x
      b = y
      c = z
      n = m
    end do
    call asgn(inv,n)
  end
  pure elemental type(modint) function pow(this,other)
    class(modint), intent(in) :: this
    class(*), intent(in) :: other
    integer(int64) :: n
    type(modint) :: i
    pow%val = 1_8
    i%val = this%val
    n = to_int64(other)
    do while (n > 0_8)
      if (btest(n,0)) call asgn(pow,mul(pow,i))
      call asgn(i,mul(i,i))
      n = rshift(n,1)
    end do
  end
  pure elemental type(modint) function add_r(other,this) result(ret)
    class(modint), intent(in) :: this
    class(*), intent(in) :: other
    call asgn(ret,add(this,other))
  end
  pure elemental type(modint) function sub_r(other,this) result(ret)
    class(modint), intent(in) :: this
    class(*), intent(in) :: other
    call asgn(ret,sub(this,other))
  end
  pure elemental type(modint) function mul_r(other,this) result(ret)
    class(modint), intent(in) :: this
    class(*), intent(in) :: other
    call asgn(ret,mul(this,other))
  end
  pure elemental type(modint) function div_r(other,this) result(ret)
    class(modint), intent(in) :: this
    class(*), intent(in) :: other
    call asgn(ret,div(this,other))
  end
  pure type(modint) function dot_prod(x,y) result(ret)
    type(modint), intent(in) :: x(:), y(:)
    integer :: i
    if (size(x,1) /= size(y,1)) i = to_int64('')
    do i = 1, size(x,1)
      call asgn(ret,add(ret,mul(x(i),y(i))))
    end do
  end
  pure function matmul1(x,y) result(ret)
    type(modint), intent(in) :: x(:,:), y(:)
    type(modint) :: ret(size(x,1))
    integer :: i
    do i = 1, size(x,1)
      call asgn(ret(i),dot_prod(x(i,:),y))
    end do
  end
  pure function matmul2(x,y) result(ret)
    type(modint), intent(in) :: x(:), y(:,:)
    type(modint) :: ret(size(y,2))
    integer :: i
    do i = 1, size(y,2)
      call asgn(ret(i),dot_prod(x,y(:,i)))
    end do
  end
  pure function matmul3(x,y) result(ret)
    type(modint), intent(in) :: x(:,:), y(:,:)
    type(modint) :: ret(size(x,1),size(y,2))
    integer :: i
    do i = 1, size(x,1)
      call asgn(ret(i,:),matmul2(x(i,:),y))
    end do
  end
end module module_modint