    Program dgebal_example

!     DGEBAL Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dnrm2
      Use lapack_example_aux, Only: nagf_blas_damax_val, &
        nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dgebak, dgebal, dgehrd, dhseqr, dorghr, &
        dtrevc
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0_dp
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: r
      Integer :: i, ifail, ihi, ilo, info, k, lda, ldh, ldvl, ldvr, lwork, m, &
        n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), h(:, :), scale(:), tau(:), &
        vl(:, :), vr(:, :), wi(:), work(:), wr(:)
      Logical :: select(1)
!     .. Executable Statements ..
      Write (nout, *) 'DGEBAL Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldvl = 1
      lda = n
      ldh = n
      ldvr = n
      lwork = 64*n
      Allocate (a(lda,n), h(ldh,n), scale(n), tau(n), vl(ldvl,1), vr(ldvr,n), &
        wi(n), work(lwork), wr(n))

!     Read A from data file
      Read (nin, *)(a(i,1:n), i=1, n)

!     Balance A
      Call dgebal('Both', n, a, lda, ilo, ihi, scale, info)

!     Reduce A to upper Hessenberg form H = (Q**T)*A*Q
      Call dgehrd(n, ilo, ihi, a, lda, tau, work, lwork, info)

!     Copy A to H and VR
      h(1:n, 1:n) = a(1:n, 1:n)
      vr(1:n, 1:n) = a(1:n, 1:n)

!     Form Q explicitly, storing the result in VR
      Call dorghr(n, 1, n, vr, ldvr, tau, work, lwork, info)

!     Calculate the eigenvalues and Schur factorization of A
      Call dhseqr('Schur form', 'Vectors', n, ilo, ihi, h, ldh, wr, wi, vr, &
        ldvr, work, lwork, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else
        Write (nout, *) 'Eigenvalues'
        Write (nout, 100)(' (', wr(i), ',', wi(i), ')', i=1, n)

!       Calculate the eigenvectors of A, storing the result in VR

        Call dtrevc('Right', 'Backtransform', select, n, h, ldh, vl, ldvl, vr, &
          ldvr, n, m, work, info)

        Call dgebak('Both', 'Right', n, ilo, ihi, scale, m, vr, ldvr, info)

!       Print eigenvectors

        Write (nout, *)
        Flush (nout)

!       Normalize the eigenvectors, largest positive
        Do i = 1, m
          Call nagf_blas_damax_val(n, vr(1,i), 1, k, r)
          If (vr(k,i)<zero) Then
            vr(1:n, i) = -vr(1:n, i)
          End If
          r = dnrm2(n, vr(1,i), 1)
          vr(1:n, i) = vr(1:n, i)/r
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, m, vr, ldvr, &
          'Contents of array VR', ifail)

      End If

100   Format (1X, A, F8.4, A, F8.4, A)
    End Program


program test_mean
use stdlib_experimental_error, only: check
use stdlib_experimental_kinds, only: sp, dp, int32, int64
use stdlib_experimental_io, only: loadtxt
use stdlib_experimental_stats, only: mean
use,intrinsic :: ieee_arithmetic, only : ieee_is_nan
implicit none

real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
real(dp), parameter :: dptol = 1000 * epsilon(1._dp)

real(sp) :: s1(3) = [1.0_sp, 2.0_sp, 3.0_sp]

real(sp), allocatable :: s(:, :)
real(dp), allocatable :: d(:, :)

complex(dp), allocatable :: cs(:, :)
complex(dp), allocatable :: cd(:, :)

real(dp), allocatable :: d3(:, :, :)
real(dp), allocatable :: d4(:, :, :, :)

complex(dp), allocatable :: cd3(:, :, :)

!sp
call loadtxt("array3.dat", s)

call check( abs(mean(s) - sum(s)/real(size(s), sp)) < sptol)
call check( sum( abs( mean(s,1) - sum(s,1)/real(size(s,1), sp) )) < sptol)
call check( sum( abs( mean(s,2) - sum(s,2)/real(size(s,2), sp) )) < sptol)

! check reduction of rank one array to scalar
call check(abs(mean(s1) - sum(s1) / real(size(s1), sp)) < sptol)
call check(abs(mean(s1, dim=1) - sum(s1, dim=1) / real(size(s1, dim=1), sp)) < sptol)

!dp
call loadtxt("array3.dat", d)

call check( abs(mean(d) - sum(d)/real(size(d), dp)) < dptol)
call check( sum( abs( mean(d,1) - sum(d,1)/real(size(d,1), dp) )) < dptol)
call check( sum( abs( mean(d,2) - sum(d,2)/real(size(d,2), dp) )) < dptol)

!csp

call loadtxt("array3.dat", d)
cs = cmplx(1._sp, 1._sp)*d

call check( abs(mean(cs) - sum(cs)/real(size(cs), sp)) < sptol)
call check( sum( abs( mean(cs,1) - sum(cs,1)/real(size(cs,1), sp) )) < sptol)
call check( sum( abs( mean(cs,2) - sum(cs,2)/real(size(cs,2), sp) )) < sptol)

!cdp

call loadtxt("array3.dat", d)
cd = cmplx(1._dp, 1._dp)*d

call check( abs(mean(cd) - sum(cd)/real(size(cd), dp)) < dptol)
call check( sum( abs( mean(cd,1) - sum(cd,1)/real(size(cd,1), dp) )) < dptol)
call check( sum( abs( mean(cd,2) - sum(cd,2)/real(size(cd,2), dp) )) < dptol)

! check mask = .false.

call check( ieee_is_nan(mean(d, .false.)))
call check( any(ieee_is_nan(mean(d, 1, .false.))))
call check( any(ieee_is_nan(mean(d, 2, .false.))))

! check mask of the same shape as input
call check( abs(mean(d, d > 0) - sum(d, d > 0)/real(count(d > 0), dp)) < dptol)
call check( sum(abs(mean(d, 1, d > 0) - sum(d, 1, d > 0)/real(count(d > 0, 1), dp))) < dptol)
call check( sum(abs(mean(d, 2, d > 0) - sum(d, 2, d > 0)/real(count(d > 0, 2), dp))) < dptol)

!int32
call loadtxt("array3.dat", d)

call check( abs(mean(int(d, int32)) - sum(real(int(d, int32),dp))/real(size(d), dp)) < dptol)
call check( sum(abs( mean(int(d, int32),1) - sum(real(int(d, int32),dp),1)/real(size(d,1), dp) )) < dptol)
call check( sum(abs( mean(int(d, int32),2) - sum(real(int(d, int32),dp),2)/real(size(d,2), dp) )) < dptol)

!int64
call loadtxt("array3.dat", d)

call check( abs(mean(int(d, int64)) - sum(real(int(d, int64),dp))/real(size(d), dp)) < dptol)
call check( sum(abs( mean(int(d, int64),1) - sum(real(int(d, int64),dp),1)/real(size(d,1), dp) )) < dptol)
call check( sum(abs( mean(int(d, int64),2) - sum(real(int(d, int64),dp),2)/real(size(d,2), dp) )) < dptol)

!dp rank 3
allocate(d3(size(d,1),size(d,2),3))
d3(:,:,1)=d;
d3(:,:,2)=d*1.5;
d3(:,:,3)=d*4;

call check( abs(mean(d3) - sum(d3)/real(size(d3), dp)) < dptol)
call check( sum( abs( mean(d3,1) - sum(d3,1)/real(size(d3,1), dp) )) < dptol)
call check( sum( abs( mean(d3,2) - sum(d3,2)/real(size(d3,2), dp) )) < dptol)
call check( sum( abs( mean(d3,3) - sum(d3,3)/real(size(d3,3), dp) )) < dptol)

!cdp rank 3
allocate(cd3(size(d,1),size(d,2),3))
cd3(:,:,1)=d;
cd3(:,:,2)=d*1.5;
cd3(:,:,3)=d*4;
cd3 = cmplx(1._sp, 1._sp)*cd3

call check( abs(mean(cd3) - sum(cd3)/real(size(cd3), dp)) < dptol)
call check( sum( abs( mean(cd3,1) - sum(cd3,1)/real(size(cd3,1), dp) )) < dptol)
call check( sum( abs( mean(cd3,2) - sum(cd3,2)/real(size(cd3,2), dp) )) < dptol)
call check( sum( abs( mean(cd3,3) - sum(cd3,3)/real(size(cd3,3), dp) )) < dptol)

!dp rank 4
allocate(d4(size(d,1),size(d,2),3,9))
d4 = -1
d4(:,:,1,1)=d;
d4(:,:,2,1)=d*1.5;
d4(:,:,3,1)=d*4;
d4(:,:,3,9)=d*4;

call check( abs(mean(d4) - sum(d4)/real(size(d4), dp)) < dptol)
call check( sum( abs( mean(d4,1) - sum(d4,1)/real(size(d4,1), dp) )) < dptol)
call check( sum( abs( mean(d4,2) - sum(d4,2)/real(size(d4,2), dp) )) < dptol)
call check( sum( abs( mean(d4,3) - sum(d4,3)/real(size(d4,3), dp) )) < dptol)
call check( sum( abs( mean(d4,4) - sum(d4,4)/real(size(d4,4), dp) )) < dptol)

! check mask = .false.

call check( ieee_is_nan(mean(d4, .false.)))
call check( any(ieee_is_nan(mean(d4, 1, .false.))))
call check( any(ieee_is_nan(mean(d4, 2, .false.))))
call check( any(ieee_is_nan(mean(d4, 3, .false.))))
call check( any(ieee_is_nan(mean(d4, 4, .false.))))

! check mask of the same shape as input
call check( abs(mean(d4, d4 > 0) - sum(d4, d4 > 0)/real(count(d4 > 0), dp)) < dptol)
call check( any(ieee_is_nan(mean(d4, 1, d4 > 0))) )
call check( any(ieee_is_nan(mean(d4, 2, d4 > 0))) )
call check( any(ieee_is_nan(mean(d4, 3, d4 > 0))) )
call check( sum(abs(mean(d4, 4, d4 > 0) - sum(d4, 4, d4 > 0)/real(count(d4 > 0, 4), dp))) < dptol)

end program


!--------------------------------------------------------------------------------------
!
!Copyright (C) 2014 TopCoder Inc., All Rights Reserved.
!
!--------------------------------------------------------------------------------------

!  Contest Code Acceleration of the Calculation of Influence Coefficients of Nemoh
!
!   @author yedtoss
!   @version 1.0

!********************************************************************
!*             Differential equations of order N                    *
!*             by Runge-Kutta method of order 4                     *
!* ---------------------------------------------------------------- *
!* Reference: "Analyse en Turbo Pascal versions 5.5 et 6.0  By Marc *
!*             DUCAMP et Alain REVERCHON - Eyrolles, Paris 1991"    *
!*             [BIBLI 03].                                          *
!*                                                                  *
!*                             F90 Version By J-P Moreau, Paris     *
!*                                    (www.jpmoreau.fr)             *
!* ---------------------------------------------------------------- *
!* SAMPLE RUN:                                                      *
!*                                                                  *
!* Example: integrate y"=(2y'y'+yy)/y from x=4 to x=6               *
!*          with initial conditions: y(4)=2 and y'(4)=-2tan(1)      *
!*                                                                  *
!* Exact solution is:   y = 2cos(1)/cos(x-5)                        *
!*                                                                  *
!*        DIFFERENTIAL EQUATION WITH 1 VARIABLE OF ORDER N          *
!*              of type y(n) = f(y(n-1),...,y',y,x)                 *
!*                                                                  *
!*   order of equation: 2                                           *
!*   begin value x    : 4                                           *
!*   end value x      : 6                                           *
!*   y0 value at x0   : 2                                           *
!*   y1 value at x0   : -3.114815                                   *
!*   number of points : 11                                          *
!*   finesse          : 20                                          *
!*                                                                  *
!*       X            Y                                             *
!* ---------------------------                                      *
!*   4.000000     2.000000                                          *
!*   4.200000     1.551018                                          *
!*   4.400000     1.309291                                          *
!*   4.600000     1.173217                                          *
!*   4.800000     1.102583                                          *
!*   5.000000     1.080605                                          *
!*   5.200000     1.102583                                          *
!*   5.400000     1.173217                                          *
!*   5.600000     1.309291                                          *
!*   5.800000     1.551018                                          *
!*   6.000000     2.000000                                          *
!*                                                                  *
!********************************************************************

module ODE

    USE COMMON_TYPE
    implicit none
    contains

function Equadifnc(fp, xi,xf,yi,m,n,fi, param)
!***************************************************************************
!*        SOLVING DIFFERENTIAL EQUATIONS WITH 1 VARIABLE OF ORDER N        *
!*                of type y(n) = f(y(n-1),y(n-2),...,y',y,x)               *
!* ----------------------------------------------------------------------- *
!*  INPUTS:                                                                *
!*    xi, xf    Begin, end values of variable x                            *
!*    yi        Begin values at xi (of f and derivatives)                  *
!*    m         Number of points to calculate                              *
!*    n         Order of differential equation                             *
!*    fi        finesse (number of intermediate points)                    *
!*                                                                         *
!*  OUTPUTS:                                                               *
!*    t         real vector storing m results for function y               *
!* ----------------------------------------------------------------------- *
!*  EXAMPLE:    y' = (2 y'y' + yy) / y with y(4) = 2, y'(4) = -2*tan(1)    *
!*              Exact solution:  y = (2 cos(1))/cos(x-5)                   *
!***************************************************************************
integer n,m,fi
real  xi,xf
complex yi(0:10),t(50)
complex Equadifnc(50)
real  h,x,a,b,c,d
integer i,j,k,ni,n1,n2
complex  ta(0:10),tb(0:10),tc(0:10),td(0:10),y(0:10),z(0:10)
TYPE(ParamsCommonInf) :: param

interface
complex function fp(x,y, param1)
USE COMMON_TYPE
real x
complex y(0:10)
TYPE(ParamsCommonInf) :: param1

end function fp
end interface
   if (fi<1) then
    return
   end if

   if ( m == 1 ) then
    h = (xf - xi) / fi
   else
    h = (xf - xi) / fi / (m-1)
   endif
   n1=n-1; n2=n-2
   t(1)=yi(0)
   do k=0, n1
     y(k)=yi(k); z(k)=yi(k)
   end do
   do i=1, m
     ni=(i-1)*fi-1
     do j=1, fi
       x=xi+h*(ni+j)
       do k=0, n1
         y(k)=z(k)
       end do
       a=h*fp(x,y, param)
       do k=0, n2
         ta(k)=h*y(k+1); y(k)=z(k)+ta(k)/2.d0
       end do
       y(n1)=z(n1)+a/2.d0
       x=x+h/2
       b=h*fp(x,y, param)
       do k=0, n2
         tb(k)=h*y(k+1); y(k)=z(k)+tb(k)/2.d0
       end do
       y(n1)=z(n1)+b/2.d0
       c=h*fp(x,y, param)
       do k=0, n2
         tc(k)=h*y(k+1); y(k)=z(k)+tc(k)
       end do
       y(n1)=z(n1)+c
       x=x+h/2
       d=h*fp(x,y, param)
       do k=0, n2
         z(k)=z(k)+(ta(k)+2.d0*tb(k)+2.d0*tc(k)+h*y(k+1))/6.d0
       end do
       z(n1)=z(n1)+(a+b+b+c+c+d)/6.d0
     end do
     t(i+1)=z(0)
   end do
   !call subroutine Affiche
   !call Affiche(m,xi,xf,t)

   Equadifnc = t
   return
end function equadifnc
end module ODE

!Example: y'=(2y'y'+yy)/y
!real*8 FUNCTION fp(x,y)
!real*8 x,y(10)
  !if (dabs(y(0))<1.d-12)  y(0)=1.d-12
  !fp=(2.d0*y(1)*y(1)+y(0)*y(0))/y(0)
!end

!print solutions
!Subroutine Affiche(m,xi,xf,t)
 ! integer i,m
  !real*8 h,x,xi,xf,t(50)
  !h=(xf-xi)/dfloat(m-1)
  !x=xi-h
  !print *,' '
  !print *, '      X         Y     '
  !print *, '----------------------'
  !do i=1, m
   ! x=x+h
    !write(*,100)  x, t(i)
  !end do
  !print *,' '
  !return
!100 format(' ',f9.6,'  ',f9.6)
!end

!End of file teqdifn.f90


! In this file, quaternions are represented using the form
!
!     q = q[1] i + q[2] j + q[3] k + q[4],
!
! i.e., the scalar is the last coefficient in the 4-element array

! Add two arrays of quaternions
subroutine qadd(a, b, output)
  real(kind=8), dimension(:, :), intent(in) :: a
  real(kind=8), dimension(size(a, 1), size(a, 2)), intent(in) :: b
  real(kind=8), dimension(size(a, 1), size(a, 2)), intent(out) :: output

  output = a + b
end subroutine qadd

! Perform the dot product between two arrays of quaternions
subroutine qdot(a, b, output)
  real(kind=8), dimension(:, :), intent(in) :: a
  real(kind=8), dimension(size(a, 1), size(a, 2)), intent(in) :: b
  real(kind=8), dimension(size(a, 1)), intent(out) :: output
  integer :: i

  do i = 1, size(a, 1)
     output(i) = dot_product(a(i, 1:4), b(i, 1:4))
  enddo

end subroutine qdot

! Normalize an array of quaternions so that each of them has norm 1
subroutine qnorm(q, output)
  implicit none

  real(kind=8), dimension(:, :), intent(in) :: q
  real(kind=8), dimension(size(q, 1), size(q, 2)), intent(out) :: output
  real(kind=8) :: curnorm
  integer :: i

  do i = 1, size(q, 1)
     curnorm = sqrt(dot_product(q(i, 1:4), q(i, 1:4)))
     if (curnorm .gt. 0.0) then
        output(i, :) = q(i, :) / curnorm
     else
        output(i, :) = 0.0
     endif
  enddo
end subroutine qnorm

! Multiply two arrays of quaternions
subroutine qmul(a, b, output)
  implicit none

  real(kind=8), dimension(:, :), intent(in) :: a
  real(kind=8), dimension(size(a, 1), size(a, 2)), intent(in) :: b
  real(kind=8), dimension(size(a, 1), size(a, 2)), intent(out) :: output
  integer :: i

  do i = 1, size(a, 1)
     output(i, 1) = a(i, 1) * b(i, 4) + a(i, 4) * b(i, 1) + a(i, 2) * b(i, 3) - a(i, 3) * b(i, 2)
     output(i, 2) = a(i, 2) * b(i, 4) + a(i, 4) * b(i, 2) + a(i, 3) * b(i, 1) - a(i, 1) * b(i, 3)
     output(i, 3) = a(i, 3) * b(i, 4) + a(i, 4) * b(i, 3) + a(i, 1) * b(i, 2) - a(i, 2) * b(i, 1)
     output(i, 4) = a(i, 4) * b(i, 4) - a(i, 1) * b(i, 1) - a(i, 2) * b(i, 2) - a(i, 3) * b(i, 3)
  enddo

end subroutine qmul

! Build a rotation quaternion from a set of angles and rotation axes
subroutine qfromaxisangle(axes, angles, output)
  implicit none

  real(kind=8), dimension(:, :), intent(in) :: axes
  real(kind=8), dimension(size(axes, 1)), intent(in) :: angles
  real(kind=8), dimension(size(axes, 1), 4), intent(out) :: output

  integer :: i
  real(kind=8) :: sinangle
  real(kind=8) :: cosangle

  do i = 1, size(axes, 1)
     sinangle = sin(angles(i) / 2)
     cosangle = cos(angles(i) / 2)
     output(i, 1:3) = sinangle * axes(i, :)
     output(i, 4) = cosangle
  enddo
end subroutine qfromaxisangle

! Given an array of rotation quaternions, return the angles and axes of each
! rotation
subroutine qtoaxisangle(q, axes, angles)
  implicit none

  real(kind=8), dimension(:, :), intent(in) :: q
  real(kind=8), dimension(size(q, 1), 3), intent(out) :: axes
  real(kind=8), dimension(size(q, 1)), intent(out) :: angles

  integer :: idx

  do idx = 1, size(q, 1)
     angles(idx) = 2 * acos(q(idx, 4))
     if (angles(idx) == 0.0) then
        axes(idx, :) = 0.0
     else
        axes(idx, :) = q(idx, 1:3) / sin(angles(idx) / 2.0)
     endif
  end do

end subroutine qtoaxisangle

! Calculate the inverse of a rotation quaternion
subroutine qinvrot(q, output)
  implicit none

  real(kind=8), dimension(:, :), intent(in) :: q
  real(kind=8), dimension(size(q, 1), size(q, 2)), intent(out) :: output

  integer :: idx

  do idx = 1, size(q, 1)
    output(idx, 1:3) = -q(idx, 1:3)
    output(idx, 4) = q(idx, 4)
  enddo
end subroutine qinvrot

! Rotate an array of vectors using the array of rotation quaternions
! The array "buffer" should have the same size as "quat", and it is used
! as an internal memory buffer
subroutine qrotate(vec, quat, output)
  implicit none

  real(kind=8), dimension(:, :), intent(in) :: vec
  real(kind=8), dimension(size(vec, 1), 4), intent(in) :: quat
  real(kind=8), dimension(size(vec, 1), size(vec, 2)), intent(out) :: output

  ! The computation is the following (in symbols):
  !     output = inv(quat) * (vec * quat)
  ! We use "tmpq" to store the value of "vec * quat"
  real(kind=8), dimension(4) :: tmpq
  real(kind=8), dimension(4) :: invq
  integer :: i

  do i = 1, size(vec, 1)
     invq(1:3) = -quat(i, 1:3)
     invq(4) = quat(i, 4)

     ! This code is like "qmul", but it assumes that "vec" is an array of
     ! 3-element vector instead of an array of 4-element quaternions: so a few
     ! terms can be safely dropped (vec(i, 4) is always zero!)
     tmpq(1) =  vec(i, 1) * invq(4) + vec(i, 2) * invq(3) - vec(i, 3) * invq(2)
     tmpq(2) =  vec(i, 2) * invq(4) + vec(i, 3) * invq(1) - vec(i, 1) * invq(3)
     tmpq(3) =  vec(i, 3) * invq(4) + vec(i, 1) * invq(2) - vec(i, 2) * invq(1)
     tmpq(4) = -vec(i, 1) * invq(1) - vec(i, 2) * invq(2) - vec(i, 3) * invq(3)

     ! This code is again like "qmul", but we drop the last term, as we are
     ! only interested in the "vector" part of the computation (i.e., the first
     ! three elements of the "output(i, :)" quaternion)
     output(i, 1) = quat(i, 1) * tmpq(4) + quat(i, 4) * tmpq(1) &
         + quat(i, 2) * tmpq(3) - quat(i, 3) * tmpq(2)
     output(i, 2) = quat(i, 2) * tmpq(4) + quat(i, 4) * tmpq(2) &
         + quat(i, 3) * tmpq(1) - quat(i, 1) * tmpq(3)
     output(i, 3) = quat(i, 3) * tmpq(4) + quat(i, 4) * tmpq(3) &
         + quat(i, 1) * tmpq(2) - quat(i, 2) * tmpq(1)
  enddo
end subroutine qrotate


c function pcorre.f
c
c source
c   Bevington, pages 124-125.
c
c purpose
c   evaluate probability for no correlation between two variables
c
c usage
c   result = pcorre (r, npts)
c
c description of parameters
c   r      - linear correlation coefficient
c   npts   - number of data points
c
c subroutines and function subprograms required
c   gamma (x)
c      calculates gamma function for integers and half-integers
c
	function pcorre (r,npts)
	double precision r2,term,sum,fi,fnum,denom
c
c evaluate number of degrees of freedom
c
11	nfree=npts-2
	if (nfree) 13,13,15
13	pcorre=0.
	goto 60
15	r2=r**2
	if (1.-r2) 13,13,17
17	neven=2*(nfree/2)
	if (nfree-neven) 21,21,41
c
c number of degrees of freedom is even
c
21	imax=(nfree-2)/2
	free=nfree
23	term=abs(r)
	sum=term
	if (imax) 60,26,31
26	pcorre=1.-term
	goto 60
31	do 36 i=1,imax
	fi=i
	fnum=imax-i+1
	denom=2*i+1
	term=-term*r2*fnum/fi
36	sum=sum+term/denom
	pcorre=1.128379167*(gamma((free+1.)/2.)/gamma(free/2.))
	pcorre=1.-pcorre*sum
	goto 60
c
c number of degrees of freedom is odd
c
41	imax=(nfree-3)/2
42	term=abs(r)*dsqrt(1.-r2)
43	sum=datan(r2/term)
	if (imax) 57,45,51
45	sum=sum+term
	goto 57
51	sum=sum+term
52	do 56 i=1,imax
	fnum=2*i
	denom=2*i+1
	term=term*(1.-r2)*fnum/denom
56	sum=sum+term
57	pcorre=1.-0.6366197724*sum
60	return
	end


    module mod_quaternions
    use mod_vectors
    implicit none (type, external)

    reaL(wp), parameter :: q_zero(4) = [0d0,0d0,0d0,0d0]
    reaL(wp), parameter :: q_eye(4) = [0d0,0d0,0d0,1d0]

    interface rot
        procedure q_rot_matrix, q_axis_angle, q_rot_vector
    end interface

    interface inv
        procedure q_inv
    end interface

    interface operator (.o.)
        procedure q_mul, q_mul_op
    end interface

    contains

    !-- QUATERNIONS
    pure function q_axis_angle(k,u) result(q)
    real(wp), intent(in) :: k(3), u
    real(wp) :: q(4)
        q = [ k*sin(u/2), cos(u/2) ]
    end function
    !
    pure function q_angle(q) result(u)
    real(wp), intent(in) :: q(4)
    real(wp) :: u, c, s
        c = q(4)
        s = v_mag(q(1:3))
        u = 2d0*atan(s/c)
    end function

    pure function q_axis(q) result(k)
    real(wp), intent(in) :: q(4)
    real(wp) :: k(3)
        k = q(1:3)
        k = k/v_mag(k)
    end function

    pure function q_rot_vector(q,t) result(u)
    real(wp), intent(in) :: t(3), q(4)
    real(wp) :: u(3)
    real(wp) :: v(3), s, vxt(3), vxvxt(3)
        v = q(1:3)
        s = q(4)
        vxt = v .x. t
        vxvxt = v .x. vxt
        u = t + 2*s*vxt + 2*vxvxt
    end function

    pure function q_rot_matrix(q) result(R)
    real(wp), intent(in) :: q(4)
    real(wp) :: R(3,3)
    real(wp) :: v(3), s, vx(3,3), vxvx(3,3)
        v = q(1:3)
        s = q(4)
        vx = v_cross_op(v)
        vxvx = -v_mmoi(v)
        R = eye3 + 2*s*vx + 2*vxvx
        !R = eye3 + 2*matmul( s*eye3 + vx, vx)
    end function

    pure function q_inv(q) result(qi)
    real(wp), intent(in) :: q(4)
    real(wp) :: qi(4), qm2, qc(4)
        qm2 = dot_product(q,q)
        qc = [-q(1:3),q(4)]
        qi = qc/qm2
    end function
    !
    pure function q_mul(q_1, q_2) result(q_3)
    real(wp), intent(in) :: q_1(4), q_2(4)
    real(wp) :: q_3(4)
    !real(wp) :: v_1(3), v_2(3), s_1, s_2
        !v_1 = q_1(1:3)
        !s_1 = q_1(4)
        !v_2 = q_2(1:3)
        !s_2 = q_2(4)
        !
        !q_3(1:3) = s_1*v_2 + s_2*v_1 + v_cross(v_1, v_2)
        !q_3(4) = s_1*s_2 - dot_product(v_1, v_2)

        q_3 = matmul(q_mul_op(q_1), q_2)
    end function

    pure function q_mul_op(q) result(op)
    real(wp), intent(in) :: q(4)
    real(wp) :: op(4,4)
        op(:,1) = [q(4),q(3),-q(2),-q(1)]
        op(:,2) = [-q(3),q(4),q(1),-q(2)]
        op(:,3) = [q(2),-q(1),q(4),-q(3)]
        op(:,4) = q
    end function

    pure function q_der(q,omg) result(qp)
    real(wp), intent(in) :: q(4), omg(3)
    real(wp) :: qp(4), w(4)
        w = [ omg, 0d0]
        qp = 0.5d0*q_mul(w, q)
    end function

    pure function q_omg(q,qp) result(omg)
    real(wp), intent(in) :: q(4), qp(4)
    real(wp) :: omg(3), v(3), vp(3)
        v=q(1:3)
        vp=qp(1:3)
        omg=2*(q(4)*vp-qp(4)*v+(v .x. vp))
    end function

    pure function q_step_omg(q,omg,h) result(q_next)
    real(wp), intent(in) :: q(4), omg(3), h
    real(wp) :: k(3), qw(4), qp(4), u, q_next(4)
    real(wp), parameter :: rot_tol = 1d-4*deg
        u = h*mag(omg)
        if( u>rot_tol) then
            k = h*omg/u
            qw = q_axis_angle(k, u)
            q_next = q_mul(qw, q)
        else
            qp = q_der(q,omg)
            q_next = q + h*qp
        end if
    end function

    pure function q_step_qp(q,qp,h) result(q_next)
    real(wp), intent(in) :: q(4), qp(4), h
    real(wp) :: omg(3), q_next(4), u, qw(4), k(3), eps
    real(wp), parameter :: rot_tol = 1d-4*deg
        eps = dot_product(q, q)-1d0
        if( eps>rot_tol ) then
            omg = q_omg(q, qp)
            u = mag(omg)
            k = omg/u
            qw = q_axis_angle(k, u)
            q_next = q_mul(qw, q)
        else
            q_next = q + h*qp
        end if
    end function

    end module


module p2grid
  implicit none

  interface massassign
    module procedure massassign_r4,massassign_r8,massassign_long_r4,massassign_long_r8
    module procedure massassignw_r4,massassignw_r8,massassignw_long_r4,massassignw_long_r8
  endinterface massassign

  contains

  function index2lagpos(id,ng)
    implicit none
    integer(8)::id
    integer(4)::ng
    real(4)::index2lagpos(3)
    ! index range from 0 - ng^3-1
    ! output range is (0,ng]
    integer(8)::id2
    integer(4)::i,j,k
    id2=id
    k=id2/ng**2
    id2=id2-k*ng**2
    j=id2/ng
    i=id2-j*ng
    index2lagpos=[k,j,i]
  endfunction index2lagpos

  ! ===== density =====
  subroutine massassign_r4(np,pos,ng,den8,cmd)
    use omp_lib
    implicit none
    integer(4)::np
    real(4)::pos(3,np)
    integer(4)::ng
    real(8)::den8(ng,ng,ng)
    integer(4)::cmd
    ! variables for ngp
    integer(4)::ibin,jbin,kbin
    ! variables for cic
    integer(4)::il,ir,jl,jr,kl,kr
    real(kind(pos))::hx,hy,hz,hxl,hxr,hyl,hyr,hzl,hzr
    ! variables for tsc
    integer(4)::ibinm1,jbinm1,kbinm1,ibinp1,jbinp1,kbinp1
    real(kind(pos))::hx0,hy0,hz0,hxm1,hym1,hzm1,hxp1,hyp1,hzp1

    integer(kind(np))::pid
    real(8)::tmp1,tmp2
    integer(4)::i,j,k
    !$omp parallel do default(shared)
    do k=1,ng
      den8(:,:,k)=0.d0
    enddo
    !$omp end parallel do
    write(*,*) 'begin mass assignment by method',cmd
    if (cmd.eq.1) then
      ! NGP
      !$omp parallel do default(private) shared(np,pos,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        !$omp atomic
        den8(ibin,jbin,kbin)=den8(ibin,jbin,kbin)+1.d0
      enddo
      !$omp end parallel do
    elseif (cmd.eq.2) then
      ! CIC
      !$omp parallel do default(private) shared(np,ng,pos,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        hx=pos(1,pid)-ibin+0.5
        hy=pos(2,pid)-jbin+0.5
        hz=pos(3,pid)-kbin+0.5
        if (hx.gt.0.) then
          il=ibin
          ir=mod(ibin+ng,ng)+1
          hxl=1-hx
          hxr=hx
        else
          il=mod(ibin-2+ng,ng)+1
          ir=ibin
          hxl=-hx
          hxr=1+hx
        endif
        if (hy.gt.0.) then
          jl=jbin
          jr=mod(jbin+ng,ng)+1
          hyl=1-hy
          hyr=hy
        else
          jl=mod(jbin-2+ng,ng)+1
          jr=jbin
          hyl=-hy
          hyr=1+hy
        endif
        if (hz.gt.0.) then
          kl=kbin
          kr=mod(kbin+ng,ng)+1
          hzl=1-hz
          hzr=hz
        else
          kl=mod(kbin-2+ng,ng)+1
          kr=kbin
          hzl=-hz
          hzr=1+hz
        endif
        !$omp atomic
        den8(il,jl,kl)=den8(il,jl,kl)+hxl*hyl*hzl
        !$omp atomic
        den8(ir,jl,kl)=den8(ir,jl,kl)+hxr*hyl*hzl
        !$omp atomic
        den8(il,jr,kl)=den8(il,jr,kl)+hxl*hyr*hzl
        !$omp atomic
        den8(ir,jr,kl)=den8(ir,jr,kl)+hxr*hyr*hzl
        !$omp atomic
        den8(il,jl,kr)=den8(il,jl,kr)+hxl*hyl*hzr
        !$omp atomic
        den8(ir,jl,kr)=den8(ir,jl,kr)+hxr*hyl*hzr
        !$omp atomic
        den8(il,jr,kr)=den8(il,jr,kr)+hxl*hyr*hzr
        !$omp atomic
        den8(ir,jr,kr)=den8(ir,jr,kr)+hxr*hyr*hzr
      enddo
      !$omp end parallel do
    elseif (cmd.eq.3) then
      ! TSC
      !$omp parallel do default(private) shared(np,ng,pos,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        hx=pos(1,pid)-ibin+0.5
        hy=pos(2,pid)-jbin+0.5
        hz=pos(3,pid)-kbin+0.5
        hx0=0.75-hx**2
        hxp1=0.5*(0.5+hx)**2
        hxm1=0.5*(0.5-hx)**2
        hy0=0.75-hy**2
        hyp1=0.5*(0.5+hy)**2
        hym1=0.5*(0.5-hy)**2
        hz0=0.75-hz**2
        hzp1=0.5*(0.5+hz)**2
        hzm1=0.5*(0.5-hz)**2
        ibinm1=mod(ibin-2+ng,ng)+1
        jbinm1=mod(jbin-2+ng,ng)+1
        kbinm1=mod(kbin-2+ng,ng)+1
        ibinp1=mod(ibin+ng,ng)+1
        jbinp1=mod(jbin+ng,ng)+1
        kbinp1=mod(kbin+ng,ng)+1
        !$omp atomic
        den8(ibinm1,jbinm1,kbinm1)=den8(ibinm1,jbinm1,kbinm1)+hxm1*hym1*hzm1
        !$omp atomic
        den8(ibin  ,jbinm1,kbinm1)=den8(ibin  ,jbinm1,kbinm1)+hx0 *hym1*hzm1
        !$omp atomic
        den8(ibinp1,jbinm1,kbinm1)=den8(ibinp1,jbinm1,kbinm1)+hxp1*hym1*hzm1
        !$omp atomic
        den8(ibinm1,jbin  ,kbinm1)=den8(ibinm1,jbin  ,kbinm1)+hxm1*hy0 *hzm1
        !$omp atomic
        den8(ibin  ,jbin  ,kbinm1)=den8(ibin  ,jbin  ,kbinm1)+hx0 *hy0 *hzm1
        !$omp atomic
        den8(ibinp1,jbin  ,kbinm1)=den8(ibinp1,jbin  ,kbinm1)+hxp1*hy0 *hzm1
        !$omp atomic
        den8(ibinm1,jbinp1,kbinm1)=den8(ibinm1,jbinp1,kbinm1)+hxm1*hyp1*hzm1
        !$omp atomic
        den8(ibin  ,jbinp1,kbinm1)=den8(ibin  ,jbinp1,kbinm1)+hx0 *hyp1*hzm1
        !$omp atomic
        den8(ibinp1,jbinp1,kbinm1)=den8(ibinp1,jbinp1,kbinm1)+hxp1*hyp1*hzm1
        !$omp atomic
        den8(ibinm1,jbinm1,kbin  )=den8(ibinm1,jbinm1,kbin  )+hxm1*hym1*hz0
        !$omp atomic
        den8(ibin  ,jbinm1,kbin  )=den8(ibin  ,jbinm1,kbin  )+hx0 *hym1*hz0
        !$omp atomic
        den8(ibinp1,jbinm1,kbin  )=den8(ibinp1,jbinm1,kbin  )+hxp1*hym1*hz0
        !$omp atomic
        den8(ibinm1,jbin  ,kbin  )=den8(ibinm1,jbin  ,kbin  )+hxm1*hy0 *hz0
        !$omp atomic
        den8(ibin  ,jbin  ,kbin  )=den8(ibin  ,jbin  ,kbin  )+hx0 *hy0 *hz0
        !$omp atomic
        den8(ibinp1,jbin  ,kbin  )=den8(ibinp1,jbin  ,kbin  )+hxp1*hy0 *hz0
        !$omp atomic
        den8(ibinm1,jbinp1,kbin  )=den8(ibinm1,jbinp1,kbin  )+hxm1*hyp1*hz0
        !$omp atomic
        den8(ibin  ,jbinp1,kbin  )=den8(ibin  ,jbinp1,kbin  )+hx0 *hyp1*hz0
        !$omp atomic
        den8(ibinp1,jbinp1,kbin  )=den8(ibinp1,jbinp1,kbin  )+hxp1*hyp1*hz0
        !$omp atomic
        den8(ibinm1,jbinm1,kbinp1)=den8(ibinm1,jbinm1,kbinp1)+hxm1*hym1*hzp1
        !$omp atomic
        den8(ibin  ,jbinm1,kbinp1)=den8(ibin  ,jbinm1,kbinp1)+hx0 *hym1*hzp1
        !$omp atomic
        den8(ibinp1,jbinm1,kbinp1)=den8(ibinp1,jbinm1,kbinp1)+hxp1*hym1*hzp1
        !$omp atomic
        den8(ibinm1,jbin  ,kbinp1)=den8(ibinm1,jbin  ,kbinp1)+hxm1*hy0 *hzp1
        !$omp atomic
        den8(ibin  ,jbin  ,kbinp1)=den8(ibin  ,jbin  ,kbinp1)+hx0 *hy0 *hzp1
        !$omp atomic
        den8(ibinp1,jbin  ,kbinp1)=den8(ibinp1,jbin  ,kbinp1)+hxp1*hy0 *hzp1
        !$omp atomic
        den8(ibinm1,jbinp1,kbinp1)=den8(ibinm1,jbinp1,kbinp1)+hxm1*hyp1*hzp1
        !$omp atomic
        den8(ibin  ,jbinp1,kbinp1)=den8(ibin  ,jbinp1,kbinp1)+hx0 *hyp1*hzp1
        !$omp atomic
        den8(ibinp1,jbinp1,kbinp1)=den8(ibinp1,jbinp1,kbinp1)+hxp1*hyp1*hzp1
      enddo
      !$omp end parallel do
    else
      write(*,*) 'ERROR: mass assignment not specified'
    endif
    write(*,*) 'statistics:'
    tmp1=0.d0
    tmp2=0.d0
    !$omp parallel do default(shared) reduction(+:tmp1,tmp2)
    do k=1,ng
      den8(:,:,k)=den8(:,:,k)/np*real(ng)**3-1.d0
      tmp1=tmp1+sum(den8(:,:,k))/real(ng)**3
      tmp2=tmp2+sum(den8(:,:,k)**2)/real(ng)**3
    enddo
    !$omp end parallel do
    tmp2=sqrt(tmp2)
    write(*,*) 'mean:',real(tmp1)
    write(*,*) 'sigma:',real(tmp2)
  endsubroutine massassign_r4

  ! ===== density =====
  subroutine massassign_r8(np,pos,ng,den8,cmd)
    use omp_lib
    implicit none
    integer(4)::np
    real(8)::pos(3,np)
    integer(4)::ng
    real(8)::den8(ng,ng,ng)
    integer(4)::cmd
    ! variables for ngp
    integer(4)::ibin,jbin,kbin
    ! variables for cic
    integer(4)::il,ir,jl,jr,kl,kr
    real(kind(pos))::hx,hy,hz,hxl,hxr,hyl,hyr,hzl,hzr
    ! variables for tsc
    integer(4)::ibinm1,jbinm1,kbinm1,ibinp1,jbinp1,kbinp1
    real(kind(pos))::hx0,hy0,hz0,hxm1,hym1,hzm1,hxp1,hyp1,hzp1

    integer(kind(np))::pid
    real(8)::tmp1,tmp2
    integer(4)::i,j,k
    !$omp parallel do default(shared)
    do k=1,ng
      den8(:,:,k)=0.d0
    enddo
    !$omp end parallel do
    write(*,*) 'begin mass assignment by method',cmd
    if (cmd.eq.1) then
      ! NGP
      !$omp parallel do default(private) shared(np,pos,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        !$omp atomic
        den8(ibin,jbin,kbin)=den8(ibin,jbin,kbin)+1.d0
      enddo
      !$omp end parallel do
    elseif (cmd.eq.2) then
      ! CIC
      !$omp parallel do default(private) shared(np,ng,pos,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        hx=pos(1,pid)-ibin+0.5
        hy=pos(2,pid)-jbin+0.5
        hz=pos(3,pid)-kbin+0.5
        if (hx.gt.0.) then
          il=ibin
          ir=mod(ibin+ng,ng)+1
          hxl=1-hx
          hxr=hx
        else
          il=mod(ibin-2+ng,ng)+1
          ir=ibin
          hxl=-hx
          hxr=1+hx
        endif
        if (hy.gt.0.) then
          jl=jbin
          jr=mod(jbin+ng,ng)+1
          hyl=1-hy
          hyr=hy
        else
          jl=mod(jbin-2+ng,ng)+1
          jr=jbin
          hyl=-hy
          hyr=1+hy
        endif
        if (hz.gt.0.) then
          kl=kbin
          kr=mod(kbin+ng,ng)+1
          hzl=1-hz
          hzr=hz
        else
          kl=mod(kbin-2+ng,ng)+1
          kr=kbin
          hzl=-hz
          hzr=1+hz
        endif
        !$omp atomic
        den8(il,jl,kl)=den8(il,jl,kl)+hxl*hyl*hzl
        !$omp atomic
        den8(ir,jl,kl)=den8(ir,jl,kl)+hxr*hyl*hzl
        !$omp atomic
        den8(il,jr,kl)=den8(il,jr,kl)+hxl*hyr*hzl
        !$omp atomic
        den8(ir,jr,kl)=den8(ir,jr,kl)+hxr*hyr*hzl
        !$omp atomic
        den8(il,jl,kr)=den8(il,jl,kr)+hxl*hyl*hzr
        !$omp atomic
        den8(ir,jl,kr)=den8(ir,jl,kr)+hxr*hyl*hzr
        !$omp atomic
        den8(il,jr,kr)=den8(il,jr,kr)+hxl*hyr*hzr
        !$omp atomic
        den8(ir,jr,kr)=den8(ir,jr,kr)+hxr*hyr*hzr
      enddo
      !$omp end parallel do
    elseif (cmd.eq.3) then
      ! TSC
      !$omp parallel do default(private) shared(np,ng,pos,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        hx=pos(1,pid)-ibin+0.5
        hy=pos(2,pid)-jbin+0.5
        hz=pos(3,pid)-kbin+0.5
        hx0=0.75-hx**2
        hxp1=0.5*(0.5+hx)**2
        hxm1=0.5*(0.5-hx)**2
        hy0=0.75-hy**2
        hyp1=0.5*(0.5+hy)**2
        hym1=0.5*(0.5-hy)**2
        hz0=0.75-hz**2
        hzp1=0.5*(0.5+hz)**2
        hzm1=0.5*(0.5-hz)**2
        ibinm1=mod(ibin-2+ng,ng)+1
        jbinm1=mod(jbin-2+ng,ng)+1
        kbinm1=mod(kbin-2+ng,ng)+1
        ibinp1=mod(ibin+ng,ng)+1
        jbinp1=mod(jbin+ng,ng)+1
        kbinp1=mod(kbin+ng,ng)+1
        !$omp atomic
        den8(ibinm1,jbinm1,kbinm1)=den8(ibinm1,jbinm1,kbinm1)+hxm1*hym1*hzm1
        !$omp atomic
        den8(ibin  ,jbinm1,kbinm1)=den8(ibin  ,jbinm1,kbinm1)+hx0 *hym1*hzm1
        !$omp atomic
        den8(ibinp1,jbinm1,kbinm1)=den8(ibinp1,jbinm1,kbinm1)+hxp1*hym1*hzm1
        !$omp atomic
        den8(ibinm1,jbin  ,kbinm1)=den8(ibinm1,jbin  ,kbinm1)+hxm1*hy0 *hzm1
        !$omp atomic
        den8(ibin  ,jbin  ,kbinm1)=den8(ibin  ,jbin  ,kbinm1)+hx0 *hy0 *hzm1
        !$omp atomic
        den8(ibinp1,jbin  ,kbinm1)=den8(ibinp1,jbin  ,kbinm1)+hxp1*hy0 *hzm1
        !$omp atomic
        den8(ibinm1,jbinp1,kbinm1)=den8(ibinm1,jbinp1,kbinm1)+hxm1*hyp1*hzm1
        !$omp atomic
        den8(ibin  ,jbinp1,kbinm1)=den8(ibin  ,jbinp1,kbinm1)+hx0 *hyp1*hzm1
        !$omp atomic
        den8(ibinp1,jbinp1,kbinm1)=den8(ibinp1,jbinp1,kbinm1)+hxp1*hyp1*hzm1
        !$omp atomic
        den8(ibinm1,jbinm1,kbin  )=den8(ibinm1,jbinm1,kbin  )+hxm1*hym1*hz0
        !$omp atomic
        den8(ibin  ,jbinm1,kbin  )=den8(ibin  ,jbinm1,kbin  )+hx0 *hym1*hz0
        !$omp atomic
        den8(ibinp1,jbinm1,kbin  )=den8(ibinp1,jbinm1,kbin  )+hxp1*hym1*hz0
        !$omp atomic
        den8(ibinm1,jbin  ,kbin  )=den8(ibinm1,jbin  ,kbin  )+hxm1*hy0 *hz0
        !$omp atomic
        den8(ibin  ,jbin  ,kbin  )=den8(ibin  ,jbin  ,kbin  )+hx0 *hy0 *hz0
        !$omp atomic
        den8(ibinp1,jbin  ,kbin  )=den8(ibinp1,jbin  ,kbin  )+hxp1*hy0 *hz0
        !$omp atomic
        den8(ibinm1,jbinp1,kbin  )=den8(ibinm1,jbinp1,kbin  )+hxm1*hyp1*hz0
        !$omp atomic
        den8(ibin  ,jbinp1,kbin  )=den8(ibin  ,jbinp1,kbin  )+hx0 *hyp1*hz0
        !$omp atomic
        den8(ibinp1,jbinp1,kbin  )=den8(ibinp1,jbinp1,kbin  )+hxp1*hyp1*hz0
        !$omp atomic
        den8(ibinm1,jbinm1,kbinp1)=den8(ibinm1,jbinm1,kbinp1)+hxm1*hym1*hzp1
        !$omp atomic
        den8(ibin  ,jbinm1,kbinp1)=den8(ibin  ,jbinm1,kbinp1)+hx0 *hym1*hzp1
        !$omp atomic
        den8(ibinp1,jbinm1,kbinp1)=den8(ibinp1,jbinm1,kbinp1)+hxp1*hym1*hzp1
        !$omp atomic
        den8(ibinm1,jbin  ,kbinp1)=den8(ibinm1,jbin  ,kbinp1)+hxm1*hy0 *hzp1
        !$omp atomic
        den8(ibin  ,jbin  ,kbinp1)=den8(ibin  ,jbin  ,kbinp1)+hx0 *hy0 *hzp1
        !$omp atomic
        den8(ibinp1,jbin  ,kbinp1)=den8(ibinp1,jbin  ,kbinp1)+hxp1*hy0 *hzp1
        !$omp atomic
        den8(ibinm1,jbinp1,kbinp1)=den8(ibinm1,jbinp1,kbinp1)+hxm1*hyp1*hzp1
        !$omp atomic
        den8(ibin  ,jbinp1,kbinp1)=den8(ibin  ,jbinp1,kbinp1)+hx0 *hyp1*hzp1
        !$omp atomic
        den8(ibinp1,jbinp1,kbinp1)=den8(ibinp1,jbinp1,kbinp1)+hxp1*hyp1*hzp1
      enddo
      !$omp end parallel do
    else
      write(*,*) 'ERROR: mass assignment not specified'
    endif
    write(*,*) 'statistics:'
    tmp1=0.d0
    tmp2=0.d0
    !$omp parallel do default(shared) reduction(+:tmp1,tmp2)
    do k=1,ng
      den8(:,:,k)=den8(:,:,k)/np*real(ng)**3-1.d0
      tmp1=tmp1+sum(den8(:,:,k))/real(ng)**3
      tmp2=tmp2+sum(den8(:,:,k)**2)/real(ng)**3
    enddo
    !$omp end parallel do
    tmp2=sqrt(tmp2)
    write(*,*) 'mean:',real(tmp1)
    write(*,*) 'sigma:',real(tmp2)
  endsubroutine massassign_r8

  ! ===== density =====
  subroutine massassign_long_r4(np,pos,ng,den8,cmd)
    use omp_lib
    implicit none
    integer(8)::np
    real(4)::pos(3,np)
    integer(4)::ng
    real(8)::den8(ng,ng,ng)
    integer(4)::cmd
    ! variables for ngp
    integer(4)::ibin,jbin,kbin
    ! variables for cic
    integer(4)::il,ir,jl,jr,kl,kr
    real(kind(pos))::hx,hy,hz,hxl,hxr,hyl,hyr,hzl,hzr
    ! variables for tsc
    integer(4)::ibinm1,jbinm1,kbinm1,ibinp1,jbinp1,kbinp1
    real(kind(pos))::hx0,hy0,hz0,hxm1,hym1,hzm1,hxp1,hyp1,hzp1

    integer(kind(np))::pid
    real(8)::tmp1,tmp2
    integer(4)::i,j,k
    !$omp parallel do default(shared)
    do k=1,ng
      den8(:,:,k)=0.d0
    enddo
    !$omp end parallel do
    write(*,*) 'begin mass assignment by method',cmd
    if (cmd.eq.1) then
      ! NGP
      !$omp parallel do default(private) shared(np,pos,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        !$omp atomic
        den8(ibin,jbin,kbin)=den8(ibin,jbin,kbin)+1.d0
      enddo
      !$omp end parallel do
    elseif (cmd.eq.2) then
      ! CIC
      !$omp parallel do default(private) shared(np,ng,pos,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        hx=pos(1,pid)-ibin+0.5
        hy=pos(2,pid)-jbin+0.5
        hz=pos(3,pid)-kbin+0.5
        if (hx.gt.0.) then
          il=ibin
          ir=mod(ibin+ng,ng)+1
          hxl=1-hx
          hxr=hx
        else
          il=mod(ibin-2+ng,ng)+1
          ir=ibin
          hxl=-hx
          hxr=1+hx
        endif
        if (hy.gt.0.) then
          jl=jbin
          jr=mod(jbin+ng,ng)+1
          hyl=1-hy
          hyr=hy
        else
          jl=mod(jbin-2+ng,ng)+1
          jr=jbin
          hyl=-hy
          hyr=1+hy
        endif
        if (hz.gt.0.) then
          kl=kbin
          kr=mod(kbin+ng,ng)+1
          hzl=1-hz
          hzr=hz
        else
          kl=mod(kbin-2+ng,ng)+1
          kr=kbin
          hzl=-hz
          hzr=1+hz
        endif
        !$omp atomic
        den8(il,jl,kl)=den8(il,jl,kl)+hxl*hyl*hzl
        !$omp atomic
        den8(ir,jl,kl)=den8(ir,jl,kl)+hxr*hyl*hzl
        !$omp atomic
        den8(il,jr,kl)=den8(il,jr,kl)+hxl*hyr*hzl
        !$omp atomic
        den8(ir,jr,kl)=den8(ir,jr,kl)+hxr*hyr*hzl
        !$omp atomic
        den8(il,jl,kr)=den8(il,jl,kr)+hxl*hyl*hzr
        !$omp atomic
        den8(ir,jl,kr)=den8(ir,jl,kr)+hxr*hyl*hzr
        !$omp atomic
        den8(il,jr,kr)=den8(il,jr,kr)+hxl*hyr*hzr
        !$omp atomic
        den8(ir,jr,kr)=den8(ir,jr,kr)+hxr*hyr*hzr
      enddo
      !$omp end parallel do
    elseif (cmd.eq.3) then
      ! TSC
      !$omp parallel do default(private) shared(np,ng,pos,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        hx=pos(1,pid)-ibin+0.5
        hy=pos(2,pid)-jbin+0.5
        hz=pos(3,pid)-kbin+0.5
        hx0=0.75-hx**2
        hxp1=0.5*(0.5+hx)**2
        hxm1=0.5*(0.5-hx)**2
        hy0=0.75-hy**2
        hyp1=0.5*(0.5+hy)**2
        hym1=0.5*(0.5-hy)**2
        hz0=0.75-hz**2
        hzp1=0.5*(0.5+hz)**2
        hzm1=0.5*(0.5-hz)**2
        ibinm1=mod(ibin-2+ng,ng)+1
        jbinm1=mod(jbin-2+ng,ng)+1
        kbinm1=mod(kbin-2+ng,ng)+1
        ibinp1=mod(ibin+ng,ng)+1
        jbinp1=mod(jbin+ng,ng)+1
        kbinp1=mod(kbin+ng,ng)+1
        !$omp atomic
        den8(ibinm1,jbinm1,kbinm1)=den8(ibinm1,jbinm1,kbinm1)+hxm1*hym1*hzm1
        !$omp atomic
        den8(ibin  ,jbinm1,kbinm1)=den8(ibin  ,jbinm1,kbinm1)+hx0 *hym1*hzm1
        !$omp atomic
        den8(ibinp1,jbinm1,kbinm1)=den8(ibinp1,jbinm1,kbinm1)+hxp1*hym1*hzm1
        !$omp atomic
        den8(ibinm1,jbin  ,kbinm1)=den8(ibinm1,jbin  ,kbinm1)+hxm1*hy0 *hzm1
        !$omp atomic
        den8(ibin  ,jbin  ,kbinm1)=den8(ibin  ,jbin  ,kbinm1)+hx0 *hy0 *hzm1
        !$omp atomic
        den8(ibinp1,jbin  ,kbinm1)=den8(ibinp1,jbin  ,kbinm1)+hxp1*hy0 *hzm1
        !$omp atomic
        den8(ibinm1,jbinp1,kbinm1)=den8(ibinm1,jbinp1,kbinm1)+hxm1*hyp1*hzm1
        !$omp atomic
        den8(ibin  ,jbinp1,kbinm1)=den8(ibin  ,jbinp1,kbinm1)+hx0 *hyp1*hzm1
        !$omp atomic
        den8(ibinp1,jbinp1,kbinm1)=den8(ibinp1,jbinp1,kbinm1)+hxp1*hyp1*hzm1
        !$omp atomic
        den8(ibinm1,jbinm1,kbin  )=den8(ibinm1,jbinm1,kbin  )+hxm1*hym1*hz0
        !$omp atomic
        den8(ibin  ,jbinm1,kbin  )=den8(ibin  ,jbinm1,kbin  )+hx0 *hym1*hz0
        !$omp atomic
        den8(ibinp1,jbinm1,kbin  )=den8(ibinp1,jbinm1,kbin  )+hxp1*hym1*hz0
        !$omp atomic
        den8(ibinm1,jbin  ,kbin  )=den8(ibinm1,jbin  ,kbin  )+hxm1*hy0 *hz0
        !$omp atomic
        den8(ibin  ,jbin  ,kbin  )=den8(ibin  ,jbin  ,kbin  )+hx0 *hy0 *hz0
        !$omp atomic
        den8(ibinp1,jbin  ,kbin  )=den8(ibinp1,jbin  ,kbin  )+hxp1*hy0 *hz0
        !$omp atomic
        den8(ibinm1,jbinp1,kbin  )=den8(ibinm1,jbinp1,kbin  )+hxm1*hyp1*hz0
        !$omp atomic
        den8(ibin  ,jbinp1,kbin  )=den8(ibin  ,jbinp1,kbin  )+hx0 *hyp1*hz0
        !$omp atomic
        den8(ibinp1,jbinp1,kbin  )=den8(ibinp1,jbinp1,kbin  )+hxp1*hyp1*hz0
        !$omp atomic
        den8(ibinm1,jbinm1,kbinp1)=den8(ibinm1,jbinm1,kbinp1)+hxm1*hym1*hzp1
        !$omp atomic
        den8(ibin  ,jbinm1,kbinp1)=den8(ibin  ,jbinm1,kbinp1)+hx0 *hym1*hzp1
        !$omp atomic
        den8(ibinp1,jbinm1,kbinp1)=den8(ibinp1,jbinm1,kbinp1)+hxp1*hym1*hzp1
        !$omp atomic
        den8(ibinm1,jbin  ,kbinp1)=den8(ibinm1,jbin  ,kbinp1)+hxm1*hy0 *hzp1
        !$omp atomic
        den8(ibin  ,jbin  ,kbinp1)=den8(ibin  ,jbin  ,kbinp1)+hx0 *hy0 *hzp1
        !$omp atomic
        den8(ibinp1,jbin  ,kbinp1)=den8(ibinp1,jbin  ,kbinp1)+hxp1*hy0 *hzp1
        !$omp atomic
        den8(ibinm1,jbinp1,kbinp1)=den8(ibinm1,jbinp1,kbinp1)+hxm1*hyp1*hzp1
        !$omp atomic
        den8(ibin  ,jbinp1,kbinp1)=den8(ibin  ,jbinp1,kbinp1)+hx0 *hyp1*hzp1
        !$omp atomic
        den8(ibinp1,jbinp1,kbinp1)=den8(ibinp1,jbinp1,kbinp1)+hxp1*hyp1*hzp1
      enddo
      !$omp end parallel do
    else
      write(*,*) 'ERROR: mass assignment not specified'
    endif
    write(*,*) 'statistics:'
    tmp1=0.d0
    tmp2=0.d0
    !$omp parallel do default(shared) reduction(+:tmp1,tmp2)
    do k=1,ng
      den8(:,:,k)=den8(:,:,k)/np*real(ng)**3-1.d0
      tmp1=tmp1+sum(den8(:,:,k))/real(ng)**3
      tmp2=tmp2+sum(den8(:,:,k)**2)/real(ng)**3
    enddo
    !$omp end parallel do
    tmp2=sqrt(tmp2)
    write(*,*) 'mean:',real(tmp1)
    write(*,*) 'sigma:',real(tmp2)
  endsubroutine massassign_long_r4

  ! ===== density =====
  subroutine massassign_long_r8(np,pos,ng,den8,cmd)
    use omp_lib
    implicit none
    integer(8)::np
    real(8)::pos(3,np)
    integer(4)::ng
    real(8)::den8(ng,ng,ng)
    integer(4)::cmd
    ! variables for ngp
    integer(4)::ibin,jbin,kbin
    ! variables for cic
    integer(4)::il,ir,jl,jr,kl,kr
    real(kind(pos))::hx,hy,hz,hxl,hxr,hyl,hyr,hzl,hzr
    ! variables for tsc
    integer(4)::ibinm1,jbinm1,kbinm1,ibinp1,jbinp1,kbinp1
    real(kind(pos))::hx0,hy0,hz0,hxm1,hym1,hzm1,hxp1,hyp1,hzp1

    integer(kind(np))::pid
    real(8)::tmp1,tmp2
    integer(4)::i,j,k
    !$omp parallel do default(shared)
    do k=1,ng
      den8(:,:,k)=0.d0
    enddo
    !$omp end parallel do
    write(*,*) 'begin mass assignment by method',cmd
    if (cmd.eq.1) then
      ! NGP
      !$omp parallel do default(private) shared(np,pos,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        !$omp atomic
        den8(ibin,jbin,kbin)=den8(ibin,jbin,kbin)+1.d0
      enddo
      !$omp end parallel do
    elseif (cmd.eq.2) then
      ! CIC
      !$omp parallel do default(private) shared(np,ng,pos,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        hx=pos(1,pid)-ibin+0.5
        hy=pos(2,pid)-jbin+0.5
        hz=pos(3,pid)-kbin+0.5
        if (hx.gt.0.) then
          il=ibin
          ir=mod(ibin+ng,ng)+1
          hxl=1-hx
          hxr=hx
        else
          il=mod(ibin-2+ng,ng)+1
          ir=ibin
          hxl=-hx
          hxr=1+hx
        endif
        if (hy.gt.0.) then
          jl=jbin
          jr=mod(jbin+ng,ng)+1
          hyl=1-hy
          hyr=hy
        else
          jl=mod(jbin-2+ng,ng)+1
          jr=jbin
          hyl=-hy
          hyr=1+hy
        endif
        if (hz.gt.0.) then
          kl=kbin
          kr=mod(kbin+ng,ng)+1
          hzl=1-hz
          hzr=hz
        else
          kl=mod(kbin-2+ng,ng)+1
          kr=kbin
          hzl=-hz
          hzr=1+hz
        endif
        !$omp atomic
        den8(il,jl,kl)=den8(il,jl,kl)+hxl*hyl*hzl
        !$omp atomic
        den8(ir,jl,kl)=den8(ir,jl,kl)+hxr*hyl*hzl
        !$omp atomic
        den8(il,jr,kl)=den8(il,jr,kl)+hxl*hyr*hzl
        !$omp atomic
        den8(ir,jr,kl)=den8(ir,jr,kl)+hxr*hyr*hzl
        !$omp atomic
        den8(il,jl,kr)=den8(il,jl,kr)+hxl*hyl*hzr
        !$omp atomic
        den8(ir,jl,kr)=den8(ir,jl,kr)+hxr*hyl*hzr
        !$omp atomic
        den8(il,jr,kr)=den8(il,jr,kr)+hxl*hyr*hzr
        !$omp atomic
        den8(ir,jr,kr)=den8(ir,jr,kr)+hxr*hyr*hzr
      enddo
      !$omp end parallel do
    elseif (cmd.eq.3) then
      ! TSC
      !$omp parallel do default(private) shared(np,ng,pos,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        hx=pos(1,pid)-ibin+0.5
        hy=pos(2,pid)-jbin+0.5
        hz=pos(3,pid)-kbin+0.5
        hx0=0.75-hx**2
        hxp1=0.5*(0.5+hx)**2
        hxm1=0.5*(0.5-hx)**2
        hy0=0.75-hy**2
        hyp1=0.5*(0.5+hy)**2
        hym1=0.5*(0.5-hy)**2
        hz0=0.75-hz**2
        hzp1=0.5*(0.5+hz)**2
        hzm1=0.5*(0.5-hz)**2
        ibinm1=mod(ibin-2+ng,ng)+1
        jbinm1=mod(jbin-2+ng,ng)+1
        kbinm1=mod(kbin-2+ng,ng)+1
        ibinp1=mod(ibin+ng,ng)+1
        jbinp1=mod(jbin+ng,ng)+1
        kbinp1=mod(kbin+ng,ng)+1
        !$omp atomic
        den8(ibinm1,jbinm1,kbinm1)=den8(ibinm1,jbinm1,kbinm1)+hxm1*hym1*hzm1
        !$omp atomic
        den8(ibin  ,jbinm1,kbinm1)=den8(ibin  ,jbinm1,kbinm1)+hx0 *hym1*hzm1
        !$omp atomic
        den8(ibinp1,jbinm1,kbinm1)=den8(ibinp1,jbinm1,kbinm1)+hxp1*hym1*hzm1
        !$omp atomic
        den8(ibinm1,jbin  ,kbinm1)=den8(ibinm1,jbin  ,kbinm1)+hxm1*hy0 *hzm1
        !$omp atomic
        den8(ibin  ,jbin  ,kbinm1)=den8(ibin  ,jbin  ,kbinm1)+hx0 *hy0 *hzm1
        !$omp atomic
        den8(ibinp1,jbin  ,kbinm1)=den8(ibinp1,jbin  ,kbinm1)+hxp1*hy0 *hzm1
        !$omp atomic
        den8(ibinm1,jbinp1,kbinm1)=den8(ibinm1,jbinp1,kbinm1)+hxm1*hyp1*hzm1
        !$omp atomic
        den8(ibin  ,jbinp1,kbinm1)=den8(ibin  ,jbinp1,kbinm1)+hx0 *hyp1*hzm1
        !$omp atomic
        den8(ibinp1,jbinp1,kbinm1)=den8(ibinp1,jbinp1,kbinm1)+hxp1*hyp1*hzm1
        !$omp atomic
        den8(ibinm1,jbinm1,kbin  )=den8(ibinm1,jbinm1,kbin  )+hxm1*hym1*hz0
        !$omp atomic
        den8(ibin  ,jbinm1,kbin  )=den8(ibin  ,jbinm1,kbin  )+hx0 *hym1*hz0
        !$omp atomic
        den8(ibinp1,jbinm1,kbin  )=den8(ibinp1,jbinm1,kbin  )+hxp1*hym1*hz0
        !$omp atomic
        den8(ibinm1,jbin  ,kbin  )=den8(ibinm1,jbin  ,kbin  )+hxm1*hy0 *hz0
        !$omp atomic
        den8(ibin  ,jbin  ,kbin  )=den8(ibin  ,jbin  ,kbin  )+hx0 *hy0 *hz0
        !$omp atomic
        den8(ibinp1,jbin  ,kbin  )=den8(ibinp1,jbin  ,kbin  )+hxp1*hy0 *hz0
        !$omp atomic
        den8(ibinm1,jbinp1,kbin  )=den8(ibinm1,jbinp1,kbin  )+hxm1*hyp1*hz0
        !$omp atomic
        den8(ibin  ,jbinp1,kbin  )=den8(ibin  ,jbinp1,kbin  )+hx0 *hyp1*hz0
        !$omp atomic
        den8(ibinp1,jbinp1,kbin  )=den8(ibinp1,jbinp1,kbin  )+hxp1*hyp1*hz0
        !$omp atomic
        den8(ibinm1,jbinm1,kbinp1)=den8(ibinm1,jbinm1,kbinp1)+hxm1*hym1*hzp1
        !$omp atomic
        den8(ibin  ,jbinm1,kbinp1)=den8(ibin  ,jbinm1,kbinp1)+hx0 *hym1*hzp1
        !$omp atomic
        den8(ibinp1,jbinm1,kbinp1)=den8(ibinp1,jbinm1,kbinp1)+hxp1*hym1*hzp1
        !$omp atomic
        den8(ibinm1,jbin  ,kbinp1)=den8(ibinm1,jbin  ,kbinp1)+hxm1*hy0 *hzp1
        !$omp atomic
        den8(ibin  ,jbin  ,kbinp1)=den8(ibin  ,jbin  ,kbinp1)+hx0 *hy0 *hzp1
        !$omp atomic
        den8(ibinp1,jbin  ,kbinp1)=den8(ibinp1,jbin  ,kbinp1)+hxp1*hy0 *hzp1
        !$omp atomic
        den8(ibinm1,jbinp1,kbinp1)=den8(ibinm1,jbinp1,kbinp1)+hxm1*hyp1*hzp1
        !$omp atomic
        den8(ibin  ,jbinp1,kbinp1)=den8(ibin  ,jbinp1,kbinp1)+hx0 *hyp1*hzp1
        !$omp atomic
        den8(ibinp1,jbinp1,kbinp1)=den8(ibinp1,jbinp1,kbinp1)+hxp1*hyp1*hzp1
      enddo
      !$omp end parallel do
    else
      write(*,*) 'ERROR: mass assignment not specified'
    endif
    write(*,*) 'statistics:'
    tmp1=0.d0
    tmp2=0.d0
    !$omp parallel do default(shared) reduction(+:tmp1,tmp2)
    do k=1,ng
      den8(:,:,k)=den8(:,:,k)/np*real(ng)**3-1.d0
      tmp1=tmp1+sum(den8(:,:,k))/real(ng)**3
      tmp2=tmp2+sum(den8(:,:,k)**2)/real(ng)**3
    enddo
    !$omp end parallel do
    tmp2=sqrt(tmp2)
    write(*,*) 'mean:',real(tmp1)
    write(*,*) 'sigma:',real(tmp2)
  endsubroutine massassign_long_r8

  !!!!!! with weights
    ! ===== density =====
  subroutine massassignw_r4(np,pos,mass,ng,den8,cmd)
    use omp_lib
    implicit none
    integer(4)::np
    real(4)::pos(3,np)
    real(4)::mass(np)
    integer(4)::ng
    real(8)::den8(ng,ng,ng)
    integer(4)::cmd
    ! variables for ngp
    integer(4)::ibin,jbin,kbin
    ! variables for cic
    integer(4)::il,ir,jl,jr,kl,kr
    real(kind(pos))::hx,hy,hz,hxl,hxr,hyl,hyr,hzl,hzr
    ! variables for tsc
    integer(4)::ibinm1,jbinm1,kbinm1,ibinp1,jbinp1,kbinp1
    real(kind(pos))::hx0,hy0,hz0,hxm1,hym1,hzm1,hxp1,hyp1,hzp1

    integer(kind(np))::pid
    real(8)::tmp1,tmp2
    integer(4)::i,j,k
    !$omp parallel do default(shared)
    do k=1,ng
      den8(:,:,k)=0.d0
    enddo
    !$omp end parallel do
    write(*,*) 'begin mass assignment by method',cmd
    if (cmd.eq.1) then
      ! NGP
      !$omp parallel do default(private) shared(np,pos,mass,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        !$omp atomic
        den8(ibin,jbin,kbin)=den8(ibin,jbin,kbin)+mass(pid)
      enddo
      !$omp end parallel do
    elseif (cmd.eq.2) then
      ! CIC
      !$omp parallel do default(private) shared(np,ng,pos,mass,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        hx=pos(1,pid)-ibin+0.5
        hy=pos(2,pid)-jbin+0.5
        hz=pos(3,pid)-kbin+0.5
        if (hx.gt.0.) then
          il=ibin
          ir=mod(ibin+ng,ng)+1
          hxl=1-hx
          hxr=hx
        else
          il=mod(ibin-2+ng,ng)+1
          ir=ibin
          hxl=-hx
          hxr=1+hx
        endif
        if (hy.gt.0.) then
          jl=jbin
          jr=mod(jbin+ng,ng)+1
          hyl=1-hy
          hyr=hy
        else
          jl=mod(jbin-2+ng,ng)+1
          jr=jbin
          hyl=-hy
          hyr=1+hy
        endif
        if (hz.gt.0.) then
          kl=kbin
          kr=mod(kbin+ng,ng)+1
          hzl=1-hz
          hzr=hz
        else
          kl=mod(kbin-2+ng,ng)+1
          kr=kbin
          hzl=-hz
          hzr=1+hz
        endif
        !$omp atomic
        den8(il,jl,kl)=den8(il,jl,kl)+hxl*hyl*hzl*mass(pid)
        !$omp atomic
        den8(ir,jl,kl)=den8(ir,jl,kl)+hxr*hyl*hzl*mass(pid)
        !$omp atomic
        den8(il,jr,kl)=den8(il,jr,kl)+hxl*hyr*hzl*mass(pid)
        !$omp atomic
        den8(ir,jr,kl)=den8(ir,jr,kl)+hxr*hyr*hzl*mass(pid)
        !$omp atomic
        den8(il,jl,kr)=den8(il,jl,kr)+hxl*hyl*hzr*mass(pid)
        !$omp atomic
        den8(ir,jl,kr)=den8(ir,jl,kr)+hxr*hyl*hzr*mass(pid)
        !$omp atomic
        den8(il,jr,kr)=den8(il,jr,kr)+hxl*hyr*hzr*mass(pid)
        !$omp atomic
        den8(ir,jr,kr)=den8(ir,jr,kr)+hxr*hyr*hzr*mass(pid)
      enddo
    elseif (cmd.eq.3) then
      ! TSC
      !$omp parallel do default(private) shared(np,ng,pos,mass,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        hx=pos(1,pid)-ibin+0.5
        hy=pos(2,pid)-jbin+0.5
        hz=pos(3,pid)-kbin+0.5
        hx0=0.75-hx**2
        hxp1=0.5*(0.5+hx)**2
        hxm1=0.5*(0.5-hx)**2
        hy0=0.75-hy**2
        hyp1=0.5*(0.5+hy)**2
        hym1=0.5*(0.5-hy)**2
        hz0=0.75-hz**2
        hzp1=0.5*(0.5+hz)**2
        hzm1=0.5*(0.5-hz)**2
        ibinm1=mod(ibin-2+ng,ng)+1
        jbinm1=mod(jbin-2+ng,ng)+1
        kbinm1=mod(kbin-2+ng,ng)+1
        ibinp1=mod(ibin+ng,ng)+1
        jbinp1=mod(jbin+ng,ng)+1
        kbinp1=mod(kbin+ng,ng)+1
        !$omp atomic
        den8(ibinm1,jbinm1,kbinm1)=den8(ibinm1,jbinm1,kbinm1)+hxm1*hym1*hzm1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbinm1,kbinm1)=den8(ibin  ,jbinm1,kbinm1)+hx0 *hym1*hzm1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbinm1,kbinm1)=den8(ibinp1,jbinm1,kbinm1)+hxp1*hym1*hzm1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbin  ,kbinm1)=den8(ibinm1,jbin  ,kbinm1)+hxm1*hy0 *hzm1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbin  ,kbinm1)=den8(ibin  ,jbin  ,kbinm1)+hx0 *hy0 *hzm1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbin  ,kbinm1)=den8(ibinp1,jbin  ,kbinm1)+hxp1*hy0 *hzm1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbinp1,kbinm1)=den8(ibinm1,jbinp1,kbinm1)+hxm1*hyp1*hzm1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbinp1,kbinm1)=den8(ibin  ,jbinp1,kbinm1)+hx0 *hyp1*hzm1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbinp1,kbinm1)=den8(ibinp1,jbinp1,kbinm1)+hxp1*hyp1*hzm1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbinm1,kbin  )=den8(ibinm1,jbinm1,kbin  )+hxm1*hym1*hz0 *mass(pid)
        !$omp atomic
        den8(ibin  ,jbinm1,kbin  )=den8(ibin  ,jbinm1,kbin  )+hx0 *hym1*hz0 *mass(pid)
        !$omp atomic
        den8(ibinp1,jbinm1,kbin  )=den8(ibinp1,jbinm1,kbin  )+hxp1*hym1*hz0 *mass(pid)
        !$omp atomic
        den8(ibinm1,jbin  ,kbin  )=den8(ibinm1,jbin  ,kbin  )+hxm1*hy0 *hz0 *mass(pid)
        !$omp atomic
        den8(ibin  ,jbin  ,kbin  )=den8(ibin  ,jbin  ,kbin  )+hx0 *hy0 *hz0 *mass(pid)
        !$omp atomic
        den8(ibinp1,jbin  ,kbin  )=den8(ibinp1,jbin  ,kbin  )+hxp1*hy0 *hz0 *mass(pid)
        !$omp atomic
        den8(ibinm1,jbinp1,kbin  )=den8(ibinm1,jbinp1,kbin  )+hxm1*hyp1*hz0 *mass(pid)
        !$omp atomic
        den8(ibin  ,jbinp1,kbin  )=den8(ibin  ,jbinp1,kbin  )+hx0 *hyp1*hz0 *mass(pid)
        !$omp atomic
        den8(ibinp1,jbinp1,kbin  )=den8(ibinp1,jbinp1,kbin  )+hxp1*hyp1*hz0 *mass(pid)
        !$omp atomic
        den8(ibinm1,jbinm1,kbinp1)=den8(ibinm1,jbinm1,kbinp1)+hxm1*hym1*hzp1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbinm1,kbinp1)=den8(ibin  ,jbinm1,kbinp1)+hx0 *hym1*hzp1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbinm1,kbinp1)=den8(ibinp1,jbinm1,kbinp1)+hxp1*hym1*hzp1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbin  ,kbinp1)=den8(ibinm1,jbin  ,kbinp1)+hxm1*hy0 *hzp1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbin  ,kbinp1)=den8(ibin  ,jbin  ,kbinp1)+hx0 *hy0 *hzp1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbin  ,kbinp1)=den8(ibinp1,jbin  ,kbinp1)+hxp1*hy0 *hzp1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbinp1,kbinp1)=den8(ibinm1,jbinp1,kbinp1)+hxm1*hyp1*hzp1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbinp1,kbinp1)=den8(ibin  ,jbinp1,kbinp1)+hx0 *hyp1*hzp1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbinp1,kbinp1)=den8(ibinp1,jbinp1,kbinp1)+hxp1*hyp1*hzp1*mass(pid)
      enddo
      !$omp end parallel do
    else
      write(*,*) 'ERROR: mass assignment not specified'
    endif
    write(*,*) 'statistics:'
    tmp1=0.d0
    tmp2=0.d0
    !$omp parallel do default(shared) reduction(+:tmp1,tmp2)
    do k=1,ng
      den8(:,:,k)=den8(:,:,k)/np*real(ng)**3-1.d0
      tmp1=tmp1+sum(den8(:,:,k))/real(ng)**3
      tmp2=tmp2+sum(den8(:,:,k)**2)/real(ng)**3
    enddo
    !$omp end parallel do
    tmp2=sqrt(tmp2)
    write(*,*) 'mean:',real(tmp1)
    write(*,*) 'sigma:',real(tmp2)
  endsubroutine massassignw_r4

  ! ===== density =====
  subroutine massassignw_r8(np,pos,mass,ng,den8,cmd)
    use omp_lib
    implicit none
    integer(4)::np
    real(8)::pos(3,np)
    real(8)::mass(np)
    integer(4)::ng
    real(8)::den8(ng,ng,ng)
    integer(4)::cmd
    ! variables for ngp
    integer(4)::ibin,jbin,kbin
    ! variables for cic
    integer(4)::il,ir,jl,jr,kl,kr
    real(kind(pos))::hx,hy,hz,hxl,hxr,hyl,hyr,hzl,hzr
    ! variables for tsc
    integer(4)::ibinm1,jbinm1,kbinm1,ibinp1,jbinp1,kbinp1
    real(kind(pos))::hx0,hy0,hz0,hxm1,hym1,hzm1,hxp1,hyp1,hzp1

    integer(kind(np))::pid
    real(8)::tmp1,tmp2
    integer(4)::i,j,k
    !$omp parallel do default(shared)
    do k=1,ng
      den8(:,:,k)=0.d0
    enddo
    !$omp end parallel do
    write(*,*) 'begin mass assignment by method',cmd
    if (cmd.eq.1) then
      ! NGP
      !$omp parallel do default(private) shared(np,pos,mass,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        !$omp atomic
        den8(ibin,jbin,kbin)=den8(ibin,jbin,kbin)+mass(pid)
      enddo
      !$omp end parallel do
    elseif (cmd.eq.2) then
      ! CIC
      !$omp parallel do default(private) shared(np,ng,pos,mass,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        hx=pos(1,pid)-ibin+0.5
        hy=pos(2,pid)-jbin+0.5
        hz=pos(3,pid)-kbin+0.5
        if (hx.gt.0.) then
          il=ibin
          ir=mod(ibin+ng,ng)+1
          hxl=1-hx
          hxr=hx
        else
          il=mod(ibin-2+ng,ng)+1
          ir=ibin
          hxl=-hx
          hxr=1+hx
        endif
        if (hy.gt.0.) then
          jl=jbin
          jr=mod(jbin+ng,ng)+1
          hyl=1-hy
          hyr=hy
        else
          jl=mod(jbin-2+ng,ng)+1
          jr=jbin
          hyl=-hy
          hyr=1+hy
        endif
        if (hz.gt.0.) then
          kl=kbin
          kr=mod(kbin+ng,ng)+1
          hzl=1-hz
          hzr=hz
        else
          kl=mod(kbin-2+ng,ng)+1
          kr=kbin
          hzl=-hz
          hzr=1+hz
        endif
        !$omp atomic
        den8(il,jl,kl)=den8(il,jl,kl)+hxl*hyl*hzl*mass(pid)
        !$omp atomic
        den8(ir,jl,kl)=den8(ir,jl,kl)+hxr*hyl*hzl*mass(pid)
        !$omp atomic
        den8(il,jr,kl)=den8(il,jr,kl)+hxl*hyr*hzl*mass(pid)
        !$omp atomic
        den8(ir,jr,kl)=den8(ir,jr,kl)+hxr*hyr*hzl*mass(pid)
        !$omp atomic
        den8(il,jl,kr)=den8(il,jl,kr)+hxl*hyl*hzr*mass(pid)
        !$omp atomic
        den8(ir,jl,kr)=den8(ir,jl,kr)+hxr*hyl*hzr*mass(pid)
        !$omp atomic
        den8(il,jr,kr)=den8(il,jr,kr)+hxl*hyr*hzr*mass(pid)
        !$omp atomic
        den8(ir,jr,kr)=den8(ir,jr,kr)+hxr*hyr*hzr*mass(pid)
      enddo
      !$omp end parallel do
    elseif (cmd.eq.3) then
      ! TSC
      !$omp parallel do default(private) shared(np,ng,pos,mass,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        hx=pos(1,pid)-ibin+0.5
        hy=pos(2,pid)-jbin+0.5
        hz=pos(3,pid)-kbin+0.5
        hx0=0.75-hx**2
        hxp1=0.5*(0.5+hx)**2
        hxm1=0.5*(0.5-hx)**2
        hy0=0.75-hy**2
        hyp1=0.5*(0.5+hy)**2
        hym1=0.5*(0.5-hy)**2
        hz0=0.75-hz**2
        hzp1=0.5*(0.5+hz)**2
        hzm1=0.5*(0.5-hz)**2
        ibinm1=mod(ibin-2+ng,ng)+1
        jbinm1=mod(jbin-2+ng,ng)+1
        kbinm1=mod(kbin-2+ng,ng)+1
        ibinp1=mod(ibin+ng,ng)+1
        jbinp1=mod(jbin+ng,ng)+1
        kbinp1=mod(kbin+ng,ng)+1
        !$omp atomic
        den8(ibinm1,jbinm1,kbinm1)=den8(ibinm1,jbinm1,kbinm1)+hxm1*hym1*hzm1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbinm1,kbinm1)=den8(ibin  ,jbinm1,kbinm1)+hx0 *hym1*hzm1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbinm1,kbinm1)=den8(ibinp1,jbinm1,kbinm1)+hxp1*hym1*hzm1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbin  ,kbinm1)=den8(ibinm1,jbin  ,kbinm1)+hxm1*hy0 *hzm1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbin  ,kbinm1)=den8(ibin  ,jbin  ,kbinm1)+hx0 *hy0 *hzm1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbin  ,kbinm1)=den8(ibinp1,jbin  ,kbinm1)+hxp1*hy0 *hzm1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbinp1,kbinm1)=den8(ibinm1,jbinp1,kbinm1)+hxm1*hyp1*hzm1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbinp1,kbinm1)=den8(ibin  ,jbinp1,kbinm1)+hx0 *hyp1*hzm1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbinp1,kbinm1)=den8(ibinp1,jbinp1,kbinm1)+hxp1*hyp1*hzm1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbinm1,kbin  )=den8(ibinm1,jbinm1,kbin  )+hxm1*hym1*hz0 *mass(pid)
        !$omp atomic
        den8(ibin  ,jbinm1,kbin  )=den8(ibin  ,jbinm1,kbin  )+hx0 *hym1*hz0 *mass(pid)
        !$omp atomic
        den8(ibinp1,jbinm1,kbin  )=den8(ibinp1,jbinm1,kbin  )+hxp1*hym1*hz0 *mass(pid)
        !$omp atomic
        den8(ibinm1,jbin  ,kbin  )=den8(ibinm1,jbin  ,kbin  )+hxm1*hy0 *hz0 *mass(pid)
        !$omp atomic
        den8(ibin  ,jbin  ,kbin  )=den8(ibin  ,jbin  ,kbin  )+hx0 *hy0 *hz0 *mass(pid)
        !$omp atomic
        den8(ibinp1,jbin  ,kbin  )=den8(ibinp1,jbin  ,kbin  )+hxp1*hy0 *hz0 *mass(pid)
        !$omp atomic
        den8(ibinm1,jbinp1,kbin  )=den8(ibinm1,jbinp1,kbin  )+hxm1*hyp1*hz0 *mass(pid)
        !$omp atomic
        den8(ibin  ,jbinp1,kbin  )=den8(ibin  ,jbinp1,kbin  )+hx0 *hyp1*hz0 *mass(pid)
        !$omp atomic
        den8(ibinp1,jbinp1,kbin  )=den8(ibinp1,jbinp1,kbin  )+hxp1*hyp1*hz0 *mass(pid)
        !$omp atomic
        den8(ibinm1,jbinm1,kbinp1)=den8(ibinm1,jbinm1,kbinp1)+hxm1*hym1*hzp1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbinm1,kbinp1)=den8(ibin  ,jbinm1,kbinp1)+hx0 *hym1*hzp1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbinm1,kbinp1)=den8(ibinp1,jbinm1,kbinp1)+hxp1*hym1*hzp1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbin  ,kbinp1)=den8(ibinm1,jbin  ,kbinp1)+hxm1*hy0 *hzp1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbin  ,kbinp1)=den8(ibin  ,jbin  ,kbinp1)+hx0 *hy0 *hzp1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbin  ,kbinp1)=den8(ibinp1,jbin  ,kbinp1)+hxp1*hy0 *hzp1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbinp1,kbinp1)=den8(ibinm1,jbinp1,kbinp1)+hxm1*hyp1*hzp1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbinp1,kbinp1)=den8(ibin  ,jbinp1,kbinp1)+hx0 *hyp1*hzp1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbinp1,kbinp1)=den8(ibinp1,jbinp1,kbinp1)+hxp1*hyp1*hzp1*mass(pid)
      enddo
      !$omp end parallel do
    else
      write(*,*) 'ERROR: mass assignment not specified'
    endif
    write(*,*) 'statistics:'
    tmp1=0.d0
    tmp2=0.d0
    !$omp parallel do default(shared) reduction(+:tmp1,tmp2)
    do k=1,ng
      den8(:,:,k)=den8(:,:,k)/np*real(ng)**3-1.d0
      tmp1=tmp1+sum(den8(:,:,k))/real(ng)**3
      tmp2=tmp2+sum(den8(:,:,k)**2)/real(ng)**3
    enddo
    !$omp end parallel do
    tmp2=sqrt(tmp2)
    write(*,*) 'mean:',real(tmp1)
    write(*,*) 'sigma:',real(tmp2)
  endsubroutine massassignw_r8

  ! ===== density =====
  subroutine massassignw_long_r4(np,pos,mass,ng,den8,cmd)
    use omp_lib
    implicit none
    integer(8)::np
    real(4)::pos(3,np)
    real(4)::mass(np)
    integer(4)::ng
    real(8)::den8(ng,ng,ng)
    integer(4)::cmd
    ! variables for ngp
    integer(4)::ibin,jbin,kbin
    ! variables for cic
    integer(4)::il,ir,jl,jr,kl,kr
    real(kind(pos))::hx,hy,hz,hxl,hxr,hyl,hyr,hzl,hzr
    ! variables for tsc
    integer(4)::ibinm1,jbinm1,kbinm1,ibinp1,jbinp1,kbinp1
    real(kind(pos))::hx0,hy0,hz0,hxm1,hym1,hzm1,hxp1,hyp1,hzp1

    integer(kind(np))::pid
    real(8)::tmp1,tmp2
    integer(4)::i,j,k
    !$omp parallel do default(shared)
    do k=1,ng
      den8(:,:,k)=0.d0
    enddo
    !$omp end parallel do
    write(*,*) 'begin mass assignment by method',cmd
    if (cmd.eq.1) then
      ! NGP
      !$omp parallel do default(private) shared(np,pos,mass,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        !$omp atomic
        den8(ibin,jbin,kbin)=den8(ibin,jbin,kbin)+mass(pid)
      enddo
      !$omp end parallel do
    elseif (cmd.eq.2) then
      ! CIC
      !$omp parallel do default(private) shared(np,ng,pos,mass,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        hx=pos(1,pid)-ibin+0.5
        hy=pos(2,pid)-jbin+0.5
        hz=pos(3,pid)-kbin+0.5
        if (hx.gt.0.) then
          il=ibin
          ir=mod(ibin+ng,ng)+1
          hxl=1-hx
          hxr=hx
        else
          il=mod(ibin-2+ng,ng)+1
          ir=ibin
          hxl=-hx
          hxr=1+hx
        endif
        if (hy.gt.0.) then
          jl=jbin
          jr=mod(jbin+ng,ng)+1
          hyl=1-hy
          hyr=hy
        else
          jl=mod(jbin-2+ng,ng)+1
          jr=jbin
          hyl=-hy
          hyr=1+hy
        endif
        if (hz.gt.0.) then
          kl=kbin
          kr=mod(kbin+ng,ng)+1
          hzl=1-hz
          hzr=hz
        else
          kl=mod(kbin-2+ng,ng)+1
          kr=kbin
          hzl=-hz
          hzr=1+hz
        endif
        !$omp atomic
        den8(il,jl,kl)=den8(il,jl,kl)+hxl*hyl*hzl*mass(pid)
        !$omp atomic
        den8(ir,jl,kl)=den8(ir,jl,kl)+hxr*hyl*hzl*mass(pid)
        !$omp atomic
        den8(il,jr,kl)=den8(il,jr,kl)+hxl*hyr*hzl*mass(pid)
        !$omp atomic
        den8(ir,jr,kl)=den8(ir,jr,kl)+hxr*hyr*hzl*mass(pid)
        !$omp atomic
        den8(il,jl,kr)=den8(il,jl,kr)+hxl*hyl*hzr*mass(pid)
        !$omp atomic
        den8(ir,jl,kr)=den8(ir,jl,kr)+hxr*hyl*hzr*mass(pid)
        !$omp atomic
        den8(il,jr,kr)=den8(il,jr,kr)+hxl*hyr*hzr*mass(pid)
        !$omp atomic
        den8(ir,jr,kr)=den8(ir,jr,kr)+hxr*hyr*hzr*mass(pid)
      enddo
      !$omp end parallel do
    elseif (cmd.eq.3) then
      ! TSC
      !$omp parallel do default(private) shared(np,ng,pos,mass,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        hx=pos(1,pid)-ibin+0.5
        hy=pos(2,pid)-jbin+0.5
        hz=pos(3,pid)-kbin+0.5
        hx0=0.75-hx**2
        hxp1=0.5*(0.5+hx)**2
        hxm1=0.5*(0.5-hx)**2
        hy0=0.75-hy**2
        hyp1=0.5*(0.5+hy)**2
        hym1=0.5*(0.5-hy)**2
        hz0=0.75-hz**2
        hzp1=0.5*(0.5+hz)**2
        hzm1=0.5*(0.5-hz)**2
        ibinm1=mod(ibin-2+ng,ng)+1
        jbinm1=mod(jbin-2+ng,ng)+1
        kbinm1=mod(kbin-2+ng,ng)+1
        ibinp1=mod(ibin+ng,ng)+1
        jbinp1=mod(jbin+ng,ng)+1
        kbinp1=mod(kbin+ng,ng)+1
        !$omp atomic
        den8(ibinm1,jbinm1,kbinm1)=den8(ibinm1,jbinm1,kbinm1)+hxm1*hym1*hzm1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbinm1,kbinm1)=den8(ibin  ,jbinm1,kbinm1)+hx0 *hym1*hzm1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbinm1,kbinm1)=den8(ibinp1,jbinm1,kbinm1)+hxp1*hym1*hzm1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbin  ,kbinm1)=den8(ibinm1,jbin  ,kbinm1)+hxm1*hy0 *hzm1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbin  ,kbinm1)=den8(ibin  ,jbin  ,kbinm1)+hx0 *hy0 *hzm1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbin  ,kbinm1)=den8(ibinp1,jbin  ,kbinm1)+hxp1*hy0 *hzm1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbinp1,kbinm1)=den8(ibinm1,jbinp1,kbinm1)+hxm1*hyp1*hzm1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbinp1,kbinm1)=den8(ibin  ,jbinp1,kbinm1)+hx0 *hyp1*hzm1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbinp1,kbinm1)=den8(ibinp1,jbinp1,kbinm1)+hxp1*hyp1*hzm1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbinm1,kbin  )=den8(ibinm1,jbinm1,kbin  )+hxm1*hym1*hz0 *mass(pid)
        !$omp atomic
        den8(ibin  ,jbinm1,kbin  )=den8(ibin  ,jbinm1,kbin  )+hx0 *hym1*hz0 *mass(pid)
        !$omp atomic
        den8(ibinp1,jbinm1,kbin  )=den8(ibinp1,jbinm1,kbin  )+hxp1*hym1*hz0 *mass(pid)
        !$omp atomic
        den8(ibinm1,jbin  ,kbin  )=den8(ibinm1,jbin  ,kbin  )+hxm1*hy0 *hz0 *mass(pid)
        !$omp atomic
        den8(ibin  ,jbin  ,kbin  )=den8(ibin  ,jbin  ,kbin  )+hx0 *hy0 *hz0 *mass(pid)
        !$omp atomic
        den8(ibinp1,jbin  ,kbin  )=den8(ibinp1,jbin  ,kbin  )+hxp1*hy0 *hz0 *mass(pid)
        !$omp atomic
        den8(ibinm1,jbinp1,kbin  )=den8(ibinm1,jbinp1,kbin  )+hxm1*hyp1*hz0 *mass(pid)
        !$omp atomic
        den8(ibin  ,jbinp1,kbin  )=den8(ibin  ,jbinp1,kbin  )+hx0 *hyp1*hz0 *mass(pid)
        !$omp atomic
        den8(ibinp1,jbinp1,kbin  )=den8(ibinp1,jbinp1,kbin  )+hxp1*hyp1*hz0 *mass(pid)
        !$omp atomic
        den8(ibinm1,jbinm1,kbinp1)=den8(ibinm1,jbinm1,kbinp1)+hxm1*hym1*hzp1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbinm1,kbinp1)=den8(ibin  ,jbinm1,kbinp1)+hx0 *hym1*hzp1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbinm1,kbinp1)=den8(ibinp1,jbinm1,kbinp1)+hxp1*hym1*hzp1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbin  ,kbinp1)=den8(ibinm1,jbin  ,kbinp1)+hxm1*hy0 *hzp1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbin  ,kbinp1)=den8(ibin  ,jbin  ,kbinp1)+hx0 *hy0 *hzp1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbin  ,kbinp1)=den8(ibinp1,jbin  ,kbinp1)+hxp1*hy0 *hzp1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbinp1,kbinp1)=den8(ibinm1,jbinp1,kbinp1)+hxm1*hyp1*hzp1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbinp1,kbinp1)=den8(ibin  ,jbinp1,kbinp1)+hx0 *hyp1*hzp1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbinp1,kbinp1)=den8(ibinp1,jbinp1,kbinp1)+hxp1*hyp1*hzp1*mass(pid)
      enddo
      !$omp end parallel do
    else
      write(*,*) 'ERROR: mass assignment not specified'
    endif
    write(*,*) 'statistics:'
    tmp1=0.d0
    tmp2=0.d0
    !$omp parallel do default(shared) reduction(+:tmp1,tmp2)
    do k=1,ng
      den8(:,:,k)=den8(:,:,k)/np*real(ng)**3-1.d0
      tmp1=tmp1+sum(den8(:,:,k))/real(ng)**3
      tmp2=tmp2+sum(den8(:,:,k)**2)/real(ng)**3
    enddo
    !$omp end parallel do
    tmp2=sqrt(tmp2)
    write(*,*) 'mean:',real(tmp1)
    write(*,*) 'sigma:',real(tmp2)
  endsubroutine massassignw_long_r4

  ! ===== density =====
  subroutine massassignw_long_r8(np,pos,mass,ng,den8,cmd)
    use omp_lib
    implicit none
    integer(8)::np
    real(8)::pos(3,np)
    real(8)::mass(np)
    integer(4)::ng
    real(8)::den8(ng,ng,ng)
    integer(4)::cmd
    ! variables for ngp
    integer(4)::ibin,jbin,kbin
    ! variables for cic
    integer(4)::il,ir,jl,jr,kl,kr
    real(kind(pos))::hx,hy,hz,hxl,hxr,hyl,hyr,hzl,hzr
    ! variables for tsc
    integer(4)::ibinm1,jbinm1,kbinm1,ibinp1,jbinp1,kbinp1
    real(kind(pos))::hx0,hy0,hz0,hxm1,hym1,hzm1,hxp1,hyp1,hzp1

    integer(kind(np))::pid
    real(8)::tmp1,tmp2
    integer(4)::i,j,k
    !$omp parallel do default(shared)
    do k=1,ng
      den8(:,:,k)=0.d0
    enddo
    !$omp end parallel do
    write(*,*) 'begin mass assignment by method',cmd
    if (cmd.eq.1) then
      ! NGP
      !$omp parallel do default(private) shared(np,pos,mass,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        !$omp atomic
        den8(ibin,jbin,kbin)=den8(ibin,jbin,kbin)+mass(pid)
      enddo
      !$omp end parallel do
    elseif (cmd.eq.2) then
      ! CIC
      !$omp parallel do default(private) shared(np,ng,pos,mass,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        hx=pos(1,pid)-ibin+0.5
        hy=pos(2,pid)-jbin+0.5
        hz=pos(3,pid)-kbin+0.5
        if (hx.gt.0.) then
          il=ibin
          ir=mod(ibin+ng,ng)+1
          hxl=1-hx
          hxr=hx
        else
          il=mod(ibin-2+ng,ng)+1
          ir=ibin
          hxl=-hx
          hxr=1+hx
        endif
        if (hy.gt.0.) then
          jl=jbin
          jr=mod(jbin+ng,ng)+1
          hyl=1-hy
          hyr=hy
        else
          jl=mod(jbin-2+ng,ng)+1
          jr=jbin
          hyl=-hy
          hyr=1+hy
        endif
        if (hz.gt.0.) then
          kl=kbin
          kr=mod(kbin+ng,ng)+1
          hzl=1-hz
          hzr=hz
        else
          kl=mod(kbin-2+ng,ng)+1
          kr=kbin
          hzl=-hz
          hzr=1+hz
        endif
        !$omp atomic
        den8(il,jl,kl)=den8(il,jl,kl)+hxl*hyl*hzl*mass(pid)
        !$omp atomic
        den8(ir,jl,kl)=den8(ir,jl,kl)+hxr*hyl*hzl*mass(pid)
        !$omp atomic
        den8(il,jr,kl)=den8(il,jr,kl)+hxl*hyr*hzl*mass(pid)
        !$omp atomic
        den8(ir,jr,kl)=den8(ir,jr,kl)+hxr*hyr*hzl*mass(pid)
        !$omp atomic
        den8(il,jl,kr)=den8(il,jl,kr)+hxl*hyl*hzr*mass(pid)
        !$omp atomic
        den8(ir,jl,kr)=den8(ir,jl,kr)+hxr*hyl*hzr*mass(pid)
        !$omp atomic
        den8(il,jr,kr)=den8(il,jr,kr)+hxl*hyr*hzr*mass(pid)
        !$omp atomic
        den8(ir,jr,kr)=den8(ir,jr,kr)+hxr*hyr*hzr*mass(pid)
      enddo
      !$omp end parallel do
    elseif (cmd.eq.3) then
      ! TSC
      !$omp parallel do default(private) shared(np,ng,pos,mass,den8) schedule(static)
      do pid=1,np
        ibin=ceiling(pos(1,pid))
        jbin=ceiling(pos(2,pid))
        kbin=ceiling(pos(3,pid))
        hx=pos(1,pid)-ibin+0.5
        hy=pos(2,pid)-jbin+0.5
        hz=pos(3,pid)-kbin+0.5
        hx0=0.75-hx**2
        hxp1=0.5*(0.5+hx)**2
        hxm1=0.5*(0.5-hx)**2
        hy0=0.75-hy**2
        hyp1=0.5*(0.5+hy)**2
        hym1=0.5*(0.5-hy)**2
        hz0=0.75-hz**2
        hzp1=0.5*(0.5+hz)**2
        hzm1=0.5*(0.5-hz)**2
        ibinm1=mod(ibin-2+ng,ng)+1
        jbinm1=mod(jbin-2+ng,ng)+1
        kbinm1=mod(kbin-2+ng,ng)+1
        ibinp1=mod(ibin+ng,ng)+1
        jbinp1=mod(jbin+ng,ng)+1
        kbinp1=mod(kbin+ng,ng)+1
        !$omp atomic
        den8(ibinm1,jbinm1,kbinm1)=den8(ibinm1,jbinm1,kbinm1)+hxm1*hym1*hzm1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbinm1,kbinm1)=den8(ibin  ,jbinm1,kbinm1)+hx0 *hym1*hzm1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbinm1,kbinm1)=den8(ibinp1,jbinm1,kbinm1)+hxp1*hym1*hzm1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbin  ,kbinm1)=den8(ibinm1,jbin  ,kbinm1)+hxm1*hy0 *hzm1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbin  ,kbinm1)=den8(ibin  ,jbin  ,kbinm1)+hx0 *hy0 *hzm1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbin  ,kbinm1)=den8(ibinp1,jbin  ,kbinm1)+hxp1*hy0 *hzm1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbinp1,kbinm1)=den8(ibinm1,jbinp1,kbinm1)+hxm1*hyp1*hzm1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbinp1,kbinm1)=den8(ibin  ,jbinp1,kbinm1)+hx0 *hyp1*hzm1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbinp1,kbinm1)=den8(ibinp1,jbinp1,kbinm1)+hxp1*hyp1*hzm1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbinm1,kbin  )=den8(ibinm1,jbinm1,kbin  )+hxm1*hym1*hz0 *mass(pid)
        !$omp atomic
        den8(ibin  ,jbinm1,kbin  )=den8(ibin  ,jbinm1,kbin  )+hx0 *hym1*hz0 *mass(pid)
        !$omp atomic
        den8(ibinp1,jbinm1,kbin  )=den8(ibinp1,jbinm1,kbin  )+hxp1*hym1*hz0 *mass(pid)
        !$omp atomic
        den8(ibinm1,jbin  ,kbin  )=den8(ibinm1,jbin  ,kbin  )+hxm1*hy0 *hz0 *mass(pid)
        !$omp atomic
        den8(ibin  ,jbin  ,kbin  )=den8(ibin  ,jbin  ,kbin  )+hx0 *hy0 *hz0 *mass(pid)
        !$omp atomic
        den8(ibinp1,jbin  ,kbin  )=den8(ibinp1,jbin  ,kbin  )+hxp1*hy0 *hz0 *mass(pid)
        !$omp atomic
        den8(ibinm1,jbinp1,kbin  )=den8(ibinm1,jbinp1,kbin  )+hxm1*hyp1*hz0 *mass(pid)
        !$omp atomic
        den8(ibin  ,jbinp1,kbin  )=den8(ibin  ,jbinp1,kbin  )+hx0 *hyp1*hz0 *mass(pid)
        !$omp atomic
        den8(ibinp1,jbinp1,kbin  )=den8(ibinp1,jbinp1,kbin  )+hxp1*hyp1*hz0 *mass(pid)
        !$omp atomic
        den8(ibinm1,jbinm1,kbinp1)=den8(ibinm1,jbinm1,kbinp1)+hxm1*hym1*hzp1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbinm1,kbinp1)=den8(ibin  ,jbinm1,kbinp1)+hx0 *hym1*hzp1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbinm1,kbinp1)=den8(ibinp1,jbinm1,kbinp1)+hxp1*hym1*hzp1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbin  ,kbinp1)=den8(ibinm1,jbin  ,kbinp1)+hxm1*hy0 *hzp1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbin  ,kbinp1)=den8(ibin  ,jbin  ,kbinp1)+hx0 *hy0 *hzp1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbin  ,kbinp1)=den8(ibinp1,jbin  ,kbinp1)+hxp1*hy0 *hzp1*mass(pid)
        !$omp atomic
        den8(ibinm1,jbinp1,kbinp1)=den8(ibinm1,jbinp1,kbinp1)+hxm1*hyp1*hzp1*mass(pid)
        !$omp atomic
        den8(ibin  ,jbinp1,kbinp1)=den8(ibin  ,jbinp1,kbinp1)+hx0 *hyp1*hzp1*mass(pid)
        !$omp atomic
        den8(ibinp1,jbinp1,kbinp1)=den8(ibinp1,jbinp1,kbinp1)+hxp1*hyp1*hzp1*mass(pid)
      enddo
      !$omp end parallel do
    else
      write(*,*) 'ERROR: mass assignment not specified'
    endif
    write(*,*) 'statistics:'
    tmp1=0.d0
    tmp2=0.d0
    !$omp parallel do default(shared) reduction(+:tmp1,tmp2)
    do k=1,ng
      den8(:,:,k)=den8(:,:,k)/np*real(ng)**3-1.d0
      tmp1=tmp1+sum(den8(:,:,k))/real(ng)**3
      tmp2=tmp2+sum(den8(:,:,k)**2)/real(ng)**3
    enddo
    !$omp end parallel do
    tmp2=sqrt(tmp2)
    write(*,*) 'mean:',real(tmp1)
    write(*,*) 'sigma:',real(tmp2)
  endsubroutine massassignw_long_r8

endmodule p2grid


PROGRAM stats_5
!
!  Purpose:
!    To calculate mean, median, and standard deviation of an input
!    data set read from a file.  This program uses allocatable arrays
!    to use only the memory required to solve each problem.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/17/06    S. J. Chapman        Original code
! 1. 11/19/06    S. J. Chapman        Modified for dynamic memory
!
IMPLICIT NONE

! Data dictionary: declare variable types & definitions
REAL,ALLOCATABLE,DIMENSION(:) :: a ! Data array to sort
CHARACTER(len=20) :: filename    ! Input data file name
INTEGER :: i                     ! Loop index
INTEGER :: iptr                  ! Pointer to smallest value
INTEGER :: j                     ! Loop index
REAL :: median                   ! The median of the input samples
INTEGER :: nvals = 0             ! Number of values to process
INTEGER :: status                ! Status: 0 for success
REAL :: std_dev                  ! Standard deviation of input samples
REAL :: sum_x = 0.               ! Sum of input values
REAL :: sum_x2 = 0.              ! Sum of input values squared
REAL :: temp                     ! Temporary variable for swapping
REAL :: x_bar                    ! Average of input values

! Get the name of the file containing the input data.
WRITE (*,1000)
1000 FORMAT (1X,'Enter the file name with the data to be sorted:')
READ (*,'(A20)') filename

! Open input data file.  Status is OLD because the input data must
! already exist.
OPEN ( UNIT=9, FILE=filename, STATUS='OLD', ACTION='READ', &
     IOSTAT=status )

! Was the OPEN successful?
fileopen: IF ( status == 0 ) THEN       ! Open successful

   ! The file was opened successfully, so read the data to find
   ! out how many values are in the file, and allocate the
   ! required space.
   DO
      READ (9, *, IOSTAT=status) temp      ! Get value
      IF ( status /= 0 ) EXIT              ! Exit on end of data
      nvals = nvals + 1                    ! Bump count
   END DO

   ! Allocate memory
   WRITE (*,*) ' Allocating a: size = ', nvals
   ALLOCATE ( a(nvals), STAT=status)       ! Allocate memory

   ! Was allocation successful?  If so, rewind file, read in
   ! data, and process it.
   allocate_ok: IF ( status == 0 ) THEN

      REWIND ( UNIT=9 )                    ! Rewind file

      ! Now read in the data.  We know that there are enough
      ! values to fill the array.
      READ (9, *) a                        ! Get value

      ! Sort the data.
      outer: DO i = 1, nvals-1

         ! Find the minimum value in a(i) through a(nvals)
         iptr = i
         inner: DO j = i+1, nvals
            minval: IF ( a(j) < a(iptr) ) THEN
               iptr = j
            END IF minval
         END DO inner

         ! iptr now points to the minimum value, so swap a(iptr)
         ! with a(i) if i /= iptr.
         swap: IF ( i /= iptr ) THEN
            temp    = a(i)
            a(i)    = a(iptr)
            a(iptr) = temp
         END IF swap

      END DO outer

      ! The data is now sorted.  Accumulate sums to calculate
      ! statistics.
      sums: DO i = 1, nvals
         sum_x  = sum_x + a(i)
         sum_x2 = sum_x2 + a(i)**2
      END DO sums

      ! Check to see if we have enough input data.
      enough: IF ( nvals < 2 ) THEN

         ! Insufficient data.
         WRITE (*,*) ' At least 2 values must be entered.'

      ELSE

         ! Calculate the mean, median, and standard deviation
         x_bar   = sum_x / real(nvals)
         std_dev = sqrt( (real(nvals) * sum_x2 - sum_x**2) &
                 / (real(nvals) * real(nvals-1)) )
         even: IF ( mod(nvals,2) == 0 ) THEN
            median = ( a(nvals/2) + a(nvals/2+1) ) / 2.
         ELSE
            median = a(nvals/2+1)
         END IF even

         ! Tell user.
         WRITE (*,*) ' The mean of this data set is:  ', x_bar
         WRITE (*,*) ' The median of this data set is:', median
         WRITE (*,*) ' The standard deviation is:     ', std_dev
         WRITE (*,*) ' The number of data points is:  ', nvals

      END IF enough

      ! Deallocate the array now that we are done.
      DEALLOCATE ( a, STAT=status )

   END IF allocate_ok

ELSE fileopen

   ! Else file open failed.  Tell user.
   WRITE (*,1050) status
   1050 FORMAT (1X,'File open failed--status = ', I6)

END IF fileopen

END PROGRAM stats_5


PROGRAM birthdays
IMPLICIT NONE
  INTEGER :: assign_birthdays
  LOGICAL :: find_match
  REAL :: get_probability

  INTEGER, PARAMETER :: MAX_PEOPLE = 65
  INTEGER, DIMENSION(MAX_PEOPLE) :: birthday_list
  INTEGER :: i
  REAL :: prob

  !WRITE(*, '(2X,A,2X,A)') "People", "Shared B-Day Prob"
  !WRITE(*, '(2X,A,2X,A)') "------", "-----------------"
  DO i = 2, MAX_PEOPLE
    prob = get_probability(birthday_list, i)
    WRITE(*, 100) i, prob
    100 FORMAT (I8, 2X, F17.6)
  END DO

END PROGRAM birthdays

SUBROUTINE assign_birthdays(arr, arr_size)
IMPLICIT NONE
  INTEGER, INTENT(IN) :: arr_size
  INTEGER, DIMENSION(arr_size), INTENT(INOUT) :: arr
  INTEGER :: i

  DO i = 1, arr_size
    arr(i) = CEILING(RAND() * 365)
  END DO
END SUBROUTINE assign_birthdays

LOGICAL FUNCTION find_match(arr, arr_size)
IMPLICIT NONE
  INTEGER, INTENT(IN) :: arr_size
  INTEGER, DIMENSION(arr_size), INTENT(IN) :: arr
  INTEGER :: i, j

  DO i = 1, arr_size
    DO j = i + 1, arr_size
      IF (arr(j) .eq. arr(i)) THEN
        find_match = .true.
        RETURN
      END IF
    END DO
  END DO
  find_match = .false.
END FUNCTION find_match

REAL FUNCTION get_probability(arr, arr_size)
IMPLICIT NONE
  LOGICAL :: find_match

  INTEGER, INTENT(IN) :: arr_size
  INTEGER, DIMENSION(arr_size), INTENT(INOUT) :: arr

  INTEGER, PARAMETER :: NUM_TESTS = 10000
  LOGICAL :: found_match = .false.
  INTEGER :: i, j, matches

  matches = 0
  DO i = 1, NUM_TESTS
    CALL assign_birthdays(arr, arr_size)
    found_match = find_match(arr, arr_size)
    IF (found_match) THEN
      matches = matches + 1
    END IF
  END DO
  !WRITE(*, *) matches
  get_probability = REAL(matches) / REAL(NUM_TESTS)
END FUNCTION get_probability


program im_re
implicit none
integer, parameter :: wp = kind(1.0)
complex(kind=wp)   :: z,v(2)
z = (3.0_wp,4.0_wp)  ! set real and imaginary parts
z = cmplx(3.0_wp,4.0_wp,kind=wp) ! same as above
print*,z%re,real(z)  ! 3.000000 3.000000
print*,z%im,aimag(z) ! 4.000000 4.000000
print*,abs(z)        ! 5.000000
print*,conjg(z)      ! (3.000000,-4.000000) complex conjugate
print*,aimag(2*z)    ! 8.000000
! line below not allowed: %re and %im do not apply to expressions
! print*,(2*z)%im
z%re = 1.0_wp ! set real part of z
z%im = 5.0_wp ! set imaginary part of z
print*,z ! (1.000000,5.000000)
v = [z,2*z]
print*,v ! (1.00000000,5.00000000) (2.00000000,10.0000000)
v%re = 0.0_wp ! set real part of complex array to scalar
! set imaginary part of complex array to array of same shape
v%im = [0.1_wp,0.2_wp]
print*,v ! (0.0000000E+00,0.1000000) (0.0000000E+00,0.2000000)
end program im_re


program P2622
    implicit none
    integer :: length_sum
    integer :: a, b, c
    integer :: count = 0
    read *, length_sum
    do a = 1, length_sum / 3
        do b = a, length_sum
            c = length_sum - a - b
            if (b <= c .and. (a + b) > c) then
                count = count + 1
            end if
        end do
    end do
    write (*, '(I0)') count
end program P2622


function compute_pi(n) result(pi)
    integer, intent(in) :: n
    real(kind=8) :: pi, x, y
    integer :: i

    do i = 1, n
        call random_number(x)
        call random_number(y)
        if (x**2.0D00 + y**2.0D00 <= 1.0D00) then
            pi = pi + 1.0D00
        end if
    end do
    pi = 4.0D00*pi/n
end function compute_pi


PROGRAM inpoly_test

use mo_kind,   only: dp, i4
use mo_ansi_colors, only: color, c_red, c_green
use mo_poly, only: inpoly, areapoly, center_of_mass

implicit none

integer(i4)                             :: N
real(dp), dimension(:,:), allocatable   :: coord
integer(i4)                             :: inside
real(dp)                                :: area
real(dp),dimension(2)                   :: com

logical                                 :: isgood

! USAGE: VERY EASY TESTING POLYGON

N=4

allocate (coord(N,2))
coord(:,1) = (/ 1.0_dp,2.0_dp,2.0_dp,1.0_dp /)
coord(:,2) = (/ 1.0_dp,1.0_dp,2.0_dp,2.0_dp /)
isgood = .true.

call inpoly( (/1.5_dp,1.5_dp/) , coord, inside)
if (inside .ne. 1_i4) isgood=.false.

select case (inside)
case(-1)
   print*, 'THE POINT IS OUTSIDE THE POLYGON'
case(1)
   print*, 'THE POINT IS INSIDE THE POLYGON'
case(0)
   print*, 'THE POINT IS ON AN EDGE OR AT A VERTEX'
end select

call inpoly( (/0.5_dp,1.5_dp/) , coord, inside)
if (inside .ne. -1_i4) isgood=.false.

select case (inside)
case(-1)
   print*, 'THE POINT IS OUTSIDE THE POLYGON'
case(1)
   print*, 'THE POINT IS INSIDE THE POLYGON'
case(0)
   print*, 'THE POINT IS ON AN EDGE OR AT A VERTEX'
end select

call inpoly( (/1.5_dp,1.0_dp/) , coord, inside)
if (inside .ne. 0_i4) isgood=.false.

select case (inside)
case(-1)
   print*, 'THE POINT IS OUTSIDE THE POLYGON'
case(1)
   print*, 'THE POINT IS INSIDE THE POLYGON'
case(0)
   print*, 'THE POINT IS ON AN EDGE OR AT A VERTEX'
end select

area = areapoly(coord)
if ( abs(area - 1.0_dp) .gt. tiny(1.0_dp) ) isgood = .false.
print*, 'AREA OF POLYGON IS ', area

com = center_of_mass(coord)
if ( ( abs(com(1)- 1.5_dp) .gt. tiny(1.0_dp) ) .or. ( abs(com(2)- 1.5_dp) .gt. tiny(1.0_dp) ) )  isgood = .false.
print*, 'CENTER OF MASS FOR POLYGON IS ', com

if (isgood) then
   write(*,*) 'mo_poly ', color('o.k.', c_green)
else
   write(*,*) 'mo_poly ', color('failed!', c_red)
endif

END PROGRAM inpoly_test


!/ ------------------------------------------------------------------- /
      MODULE W3CONSTANTS
!/
!/                  +-----------------------------------+
!/                  | WAVEWATCH III           NOAA/NCEP |
!/                  |           H. L. Tolman            |
!/                  |                        FORTRAN 90 |
!/                  | Last update :         29-May-2009 |
!/                  +-----------------------------------+
!/
!/    11-Nov-1999 : Fortran 90 version.                 ( version 2.00 )
!/    29-May-2009 : Preparing distribution version.     ( version 3.14 )
!/
!/    Copyright 2009 National Weather Service (NWS),
!/       National Oceanic and Atmospheric Administration.  All rights
!/       reserved.  WAVEWATCH III is a trademark of the NWS.
!/       No unauthorized use without permission.
!/
!  1. Purpose :
!
!     Define some much-used constants for global use (all defined
!     as PARAMETER).
!
!  2. Variables and types :
!
!      Name      Type  Scope    Description
!     ----------------------------------------------------------------
!      GRAV      Real  Global   Acc. of gravity                 (m/s2)
!      DWAT      Real  Global   Density of water               (kg/m3)
!      DAIR      Real  Global   Density of air                 (kg/m3)
!      PI        Real  Global   pi.
!      TPI       Real  Global   2pi.
!      HPI       Real  Global   0.5pi.
!      TPIINV    Real  Global   1/2pi.
!      HPIINV    Real  Global   2/pi.
!      RADE      Real  Global   Conv. factor from radians to degrees.
!      DERA      Real  Global   Conv. factor from degrees to radians.
!      RADIUS    Real  Global   Radius of the earth.             (m)
!     ----------------------------------------------------------------
!
!/ ------------------------------------------------------------------- /
!/
      REAL, PARAMETER         :: GRAV   =    9.806
      REAL, PARAMETER         :: DWAT   = 1000.
      REAL, PARAMETER         :: DAIR   =    1.225
!
      REAL, PARAMETER         :: PI     = 3.1415927
      REAL, PARAMETER         :: TPI    = 2.0 * PI
      REAL, PARAMETER         :: HPI    = 0.5 * PI
      REAL, PARAMETER         :: TPIINV = 1. / TPI
      REAL, PARAMETER         :: HPIINV = 1. / HPI
      REAL, PARAMETER         :: RADE   = 180. / PI
      REAL, PARAMETER         :: DERA   = PI / 180.
!
      REAL, PARAMETER         :: RADIUS = 4.E7 * TPIINV
!
      REAL, PARAMETER         :: G2PI3I = 1. / ( GRAV**2 * TPI**3 )
      REAL, PARAMETER         :: G1PI1I = 1. / ( GRAV * TPI )
!/
!/ End of module CONSTANTS ------------------------------------------- /
!/
      END MODULE W3CONSTANTS


subroutine rk_step(fun, t, y, f, h, A, B, C, K, y_new, f_new, n, n_stages)
  ! Perform a single Runge-Kutta step.
  !
  ! This subroutine computes a prediction of an explicit Runge-Kutta method and
  ! also estimates the error of a less accurate method.
  !
  ! Notation for Butcher tableau is as in [1]_.
  !
  ! Parameters
  ! ----------
  ! fun : callable
  !     Right-hand side of the system.
  ! t : float
  !     Current time.
  ! y : ndarray, shape (n,)
  !     Current state.
  ! f : ndarray, shape (n,)
  !     Current value of the derivative, i.e., ``fun(t, y)``.
  ! h : float
  !     Step to use.
  ! A : ndarray, shape (n_stages, n_stages)
  !     Coefficients for combining previous RK stages to compute the next
  !     stage. For explicit methods the coefficients at and above the main
  !     diagonal are zeros.
  ! B : ndarray, shape (n_stages,)
  !     Coefficients for combining RK stages for computing the final
  !     prediction.
  ! C : ndarray, shape (n_stages,)
  !     Coefficients for incrementing time for consecutive RK stages.
  !     The value for the first stage is always zero.
  ! K : ndarray, shape (n_stages + 1, n)
  !     Storage array for putting RK stages here. Stages are stored in rows.
  !     The last row is a linear combination of the previous rows with
  !     coefficients
  !
  ! Hidden parameters (found by looking at inputs)
  ! -------
  ! n : number of independent variables (i.e. length of vector y)
  ! n_stages: number of stages in the RK method
  !
  ! Returns
  ! -------
  ! y_new : ndarray, shape (n,)
  !     Solution at t + h computed with a higher accuracy.
  ! f_new : ndarray, shape (n,)
  !     Derivative ``fun(t + h, y_new)``.
  !
  ! References
  ! ----------
  ! .. [1] E. Hairer, S. P. Norsett G. Wanner, "Solving Ordinary Differential
  !        Equations I: Nonstiff Problems", Sec. II.4.

  use, intrinsic :: iso_fortran_env

  implicit none

  external :: fun
  real(real64), intent(in) :: t
  real(real64), intent(in), dimension(0:n-1) :: y
  real(real64), intent(in), dimension(0:n-1) :: f
  real(real64), intent(in) :: h
  real(real64), intent(in), dimension(0:n_stages-1, 0:n_stages-1) :: A
  real(real64), intent(in), dimension(0:n_stages-1) :: B
  real(real64), intent(in), dimension(0:n_stages-1) :: C
  real(real64), intent(inout), dimension(0:n_stages, 0:n-1) :: K
  real(real64), intent(out), dimension(0:n-1) :: y_new
  real(real64), intent(out), dimension(0:n-1) :: f_new
  integer :: n, n_stages
  integer :: i ! for iterating
  real(real64), dimension(0:n-1) :: dy
  real(real64), dimension(0:n-1) :: f_temp

! f2py intent(in, out) K
! f2py integer intent (hide), depend(y) :: n=shape(y,0)
! f2py integer intent (hide), depend(C) :: n_stages=shape(C,0)

  K(0, :) = f

  do i = 1, n_stages - 1
    dy = matmul(A(i, 0:i-1), K(0:i-1, :)) * h
    call fun(t + C(i) * h, y + dy, f_temp, n)
    K(i, :) = f_temp
  end do

  y_new = y + h * matmul(B, K(0: n_stages - 1, :))
  call fun(t + h, y_new, f_new, n)

  K(n_stages, :) = f_new

end subroutine


c=======================================================================
c
c     subroutine PEBM
c
c     Simulation of a Brownian process (Wiener process)
c
c                dW(t) = W(t+dt) - W(t) := N(0,1)*std
c
c     Method: Euler discretization of SDE
c
c                w(1)    = S
c                W(1+t)  = W(t) + sqrt(dt)*N(0,1) for t in [1,T]
c
c                with dt = T/(N-1)
c
c-----------------------------------------------------------------------
      SUBROUTINE pebm ( T, N, S, y, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            T      : time (days, months, years)                 integer
c            N      : number of sub-division(s)                  integer
c            S      : initial value                               double
c
c     OUTPUT
c            y      : generated process (N)                       double
c            info   : diagnostic information                     integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER T, N, info
      DOUBLE PRECISION S, y(*)
c
c     local variables
      INTEGER i, M
      DOUBLE PRECISION dt
c
c     external functions
      DOUBLE PRECISION rn
      EXTERNAL rn
c
c     intrinsic functions
      INTRINSIC dfloat, sqrt
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
c
c     discetization step
      M = N - 1
      dt = (dfloat(T)/M)
c
c     Wienner process - Brownian motion
      y(1) = S
      DO i = 1,M
         y(i + 1) = y(i) + sqrt(dt) * rn()
      ENDDO
c
      RETURN
      END