C$Procedure      RAXISA ( Rotation axis of a matrix )

      SUBROUTINE RAXISA ( MATRIX, AXIS, ANGLE )

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

      DOUBLE PRECISION    MATRIX ( 3, 3 )
      DOUBLE PRECISION    AXIS   (    3 )
      DOUBLE PRECISION    ANGLE

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     MATRIX     I   3x3 rotation matrix in double precision.
C     AXIS       O   Axis of the rotation.
C     ANGLE      O   Angle through which the rotation is performed.
C
C$ Detailed_Input
C
C     MATRIX     is a 3x3 rotation matrix in double precision.
C
C$ Detailed_Output
C
C     AXIS       is a unit vector pointing along the axis of the
C                rotation.  In other words, AXIS is a unit eigenvector
C                of the input matrix, corresponding to the eigenvalue
C                1.  If the input matrix is the identity matrix, AXIS
C                will be the vector (0, 0, 1). If the input rotation is
C                a rotation by PI radians, both AXIS and -AXIS may be
C                regarded as the axis of the rotation.
C
C     ANGLE      is the angle between V and MATRIX*V for any non-zero
C                vector V orthogonal to AXIS.  Angle is given in
C                radians.  The angle returned will be in the range from
C                0 to PI.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If the input matrix is not a rotation matrix (where a fairly
C        loose tolerance is used to check this) a routine in the
C        call tree of this routine will signal an error indicating
C        the problem.
C
C     2) If the input matrix is the identity matrix, this routine
C        returns an angle of 0.0, and an axis of ( 0.0, 0.0, 1.0 ).
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Every rotation matrix has an axis A such any vector, V, parallel
C     to that axis satisfies the equation
C
C        V = MATRIX * V
C
C     This routine returns a unit vector AXIS parallel to the axis of
C     the input rotation matrix.  Moreover for any vector W orthogonal
C     to the axis of the rotation
C
C        AXIS  and  W x MATRIX*W
C
C        (where "x" denotes the cross product operation)
C
C     will be positive scalar multiples of one another (at least to
C     within the ability to make such computations with double
C     precision arithmetic, and under the assumption that the MATRIX
C     does not represent a rotation by zero or Pi radians).
C
C     The angle returned will be the angle between W and MATRIX*W for
C     any vector orthogonal to AXIS.
C
C     If the input matrix is a rotation by 0 or PI radians some choice
C     must be made for the AXIS returned.  In the case of a rotation by
C     0 radians, AXIS is along the positive z-axis. In the case of a
C     rotation by 180 degrees, two choices are
C
C$ Examples
C
C     This routine can be used to numerically approximate the
C     instantaneous angular velocity vector of a rotating object.
C
C     Suppose that R(t) is the rotation matrix whose columns represent
C     the inertial pointing vectors of the bodyfixed axes of an object
C     at time t.
C
C     Then the angular velocity vector points along the vector given
C     by:
C                             T
C         limit  AXIS( R(t+h)R )
C         h-->0
C
C     And the magnitude of the angular velocity at time t is given by:
C
C                             T
C         d ANGLE ( R(t+h)R(t) )
C         ----------------------   at   h = 0
C         dh
C
C     Thus to approximate the angular velocity vector the following
C     code fragment will do
C
C            Load t      into the double precision variable T
C            Load h      into the double precision variable H
C            Load R(t+h) into the 3 by 3 double precision array RTH
C            Load R(t)   into the 3 by 3 double precision array RT
C               .
C               .
C               .
C            compute the infinitesimal rotation R(t+h)R(t)**T
C
C            CALL MXMT   ( RTH,    RT,   INFROT )
C
C            compute the AXIS and ANGLE of the infinitesimal rotation
C
C            CALL RAXISA ( INFROT, AXIS, ANGLE  )
C
C            scale axis to get the angular velocity vector
C
C            CALL VSCL   ( ANGLE/H, AXIS, ANGVEL )
C
C
C$ Restrictions
C
C     1) If the input matrix is not a rotation matrix but is close
C        enough to pass the tests this routine performs on it, no error
C        will be signaled, but the results may have poor accuracy.
C
C     2) The input matrix is taken to be an object that acts on
C        (rotates) vectors---it is not regarded as a coordinate
C        transformation.  To find the axis and angle of a coordinate
C        transformation, input the transpose of that matrix to this
C        routine.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber      (JPL)
C     F.S. Turner     (JPL)
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    SPICELIB Version 2.1.2, 02-JAN-2008 (EDW)
C
C        Minor edit to the ANGLE declaration strictly
C        identifying the constant as a double.
C
C        From:
C
C           ANGLE = 2.0 * DATAN2( VNORM(Q(1)), Q(0) )
C
C        To:
C
C           ANGLE = 2.D0 * DATAN2( VNORM(Q(1)), Q(0) )
C
C-    SPICELIB Version 2.1.1, 05-JAN-2005 (NJB)
C
C        Minor edits and formatting changes were made.
C
C-    SPICELIB Version 2.1.0, 30-MAY-2002 (FST)
C
C        This routine now participates in error handling properly.
C
C-    SPICELIB Version 2.0.0, 19-SEP-1999 (WLT)
C
C        The routine was re-written so as to avoid the numerical
C        instabilities present in the previous implementation for
C        rotations very near zero or 180 degrees.
C
C-    SPICELIB Version 1.1.0, 29-FEB-1996 (KRG)
C
C        The declaration for the SPICELIB function PI is now
C        preceded by an EXTERNAL statement declaring PI to be an
C        external function. This removes a conflict with any
C        compilers that have a PI intrinsic function.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     axis and angle of a rotation matrix
C
C-&

C$ Revisions
C
C-    SPICELIB Version 2.1.0, 30-MAY-2002 (FST)
C
C        Calls to CHKIN and CHKOUT in the standard SPICE error
C        handling style were added.  Versions prior to 2.0.0
C        were error free, however the call to M2Q introduced in
C        version 2.0.0 signals an error if the input matrix is
C        not sufficiently close to a rotation.
C
C        Additionally, FAILED is now checked after the call to
C        M2Q.  This prevents garbage from being placed into the
C        output arguments.
C
C-    SPICELIB Version 2.0.0, 21-SEP-1999 (WLT)
C
C        The routine was re-written so as to avoid the numerical
C        instabilities present in the previous implementation for
C        rotations very near zero or 180 degrees.
C
C-    SPICELIB Version 1.1.0, 29-FEB-1996 (KRG)
C
C        The declaration for the SPICELIB function PI is now
C        preceded by an EXTERNAL statement declaring PI to be an
C        external function. This removes a conflict with any
C        compilers that have a PI intrinsic function.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-    Beta Version 1.1.0, 3-JAN-1989 (WLT)
C
C     Even though the routine stipulates that the input matrix
C     should be a rotation matrix, it might not be.  As a result
C     we could have negative numbers showing up where we need
C     to take square roots.  This fix simply bounds these values
C     so that Fortran intrinsics always get reasonable input values.
C
C     Add and example to the header.
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      VNORM
      LOGICAL               FAILED
      LOGICAL               RETURN
      LOGICAL               VZERO

      EXTERNAL              PI
      DOUBLE PRECISION      PI

C
C     Local Variables
C
      DOUBLE PRECISION      Q ( 0: 3 )

C
C     Standard SPICE error handling.
C
      IF ( RETURN() ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'RAXISA' )
      END IF

C
C     Construct the quaternion corresponding to the input rotation
C     matrix
C
      CALL M2Q ( MATRIX, Q )

C
C     Check FAILED and return if an error has occurred.
C
      IF ( FAILED() ) THEN
         CALL CHKOUT ( 'RAXISA' )
         RETURN
      END IF

C
C     The quaternion we've just constructed is of the form:
C
C         cos(ANGLE/2) + sin(ANGLE/2) * AXIS
C
C     We take a few precautions to handle the case of an identity
C     rotation.
C
      IF ( VZERO(Q(1)) ) THEN

         ANGLE = 0
         AXIS(1) = 0.0D0
         AXIS(2) = 0.0D0
         AXIS(3) = 1.0D0

      ELSE IF ( Q(0) .EQ. 0.0D0 ) THEN

         ANGLE   = PI()
         AXIS(1) = Q(1)
         AXIS(2) = Q(2)
         AXIS(3) = Q(3)

      ELSE

         CALL VHAT ( Q(1), AXIS )
         ANGLE = 2.D0 * DATAN2 ( VNORM(Q(1)), Q(0) )

      END IF

      CALL CHKOUT ( 'RAXISA' )
      RETURN

      END


 ATAN2(y,x) ! Arctangent(y/x), ''-pi < result <= +pi''
 SINH(x)    ! Hyperbolic sine
 COSH(x)    ! Hyperbolic cosine
 TANH(x)    ! Hyperbolic tangent


FUNCTION q_lngm(x) RESULT(b)

! Extended arithmetic calculation of the logarithm of the gamma
! function (N.B. gamma(x) = (x-1)! in factorial notation):
!  b = ln (gamma (x))
! where all quantities are in quadruple-precision.
! The result (b) may occupy the same location as the input value (x).
! x must not equal a negative integer; in this case a warning is given
! and no result is calculated.

! Algorithm:  The true Stirling's approximation (not the version derived by
! de Moivre which is usually quoted in textbooks) is used for x >= 16.
! For smaller arguments, a Lanczos-type approximation is used.

! Programmer: Alan Miller
!
! Latest Fortran 77 revision - 11 May 1988
! Fortran 90 version - 21 August 1997

USE quadruple_precision
IMPLICIT NONE
TYPE (quad), INTENT(IN) :: x
TYPE (quad)             :: b

! Local variables

LOGICAL            :: large
INTEGER            :: i, j
TYPE (quad)        :: z, total, temp, zz, term
REAL (dp)          :: zero = 0._dp, half = 0.5_dp, one = 1.0_dp
INTEGER, PARAMETER :: g = 14

! Table of values of
!   a(2j) = B(2j).[2**(2j-1) - 1]/[2j.(2j-1).2**(2j-1)]
! where the B(2j)'s are the Bernouilli numbers.
! Stirling's approximation for log(gamma(x)) is then
!   log(gamma(x)) = 0.5*log(2.pi) + z.log(z) - z - sum[a(2j)/z**(2j-1)]
! where z = x - 0.5.

TYPE (quad), PARAMETER :: st_coeff(16) = (/  &
    quad( 0.4166666666666667D-01, -.4625929269271486D-17),  &
    quad( -.2430555555555556D-02, 0.4722302795714642D-18),  &
    quad( 0.7688492063492064D-03, -.8742455613057720D-19),  &
    quad( -.5905877976190476D-03, -.3820521941139396D-19),  &
    quad( 0.8401067971380472D-03, -.2482348408384320D-19),  &
    quad( -.1916590625086719D-02, 0.2283600073631585D-18),  &
    quad( 0.6409473908253206D-02, -.7561615151693776D-18),  &
    quad( -.2954975178039152D-01, 0.2751974392739155D-17),  &
    quad( 0.1796430017910384D+00, 0.5451863036096252D-16),  &
    quad( -.1392429561052216D+01, 0.1922261747261675D-16),  &
    quad( 0.1340285765318479D+02, -.1330122271048497D-14),  &
    quad( -.1568482659282295D+03, 0.5486595470093716D-13),  &
    quad( 0.2193103267973761D+04, -.1576457483073076D-12),  &
    quad( -.3610877098469368D+05, -.1128718158624283D-11),  &
    quad( 0.6914722675633456D+06, -.9528010535925612D-11),  &
    quad( -.1523822153940742D+08, 0.4711160925202246D-08) /)

!     Lanczos-type coeffs. for g = 14

TYPE (quad), PARAMETER :: a(16) = (/  &
    quad( 0.1000000000000000D+01, 0.4846757479531194D-21),  &
    quad( 0.1069184011592089D+07, -.5763228334420908D-09),  &
    quad( -.4731034435392098D+07, 0.1831263028328363D-09),  &
    quad( 0.8831027007071320D+07, -.3562876555263793D-09),  &
    quad( -.9057605936125744D+07, -.8123034251454294D-09),  &
    quad( 0.5575099541767454D+07, 0.4521232468551490D-09),  &
    quad( -.2113664276594438D+07, 0.2261448706472902D-09),  &
    quad( 0.4882973818694724D+06, -.2584262485630417D-10),  &
    quad( -.6580271859490060D+05, 0.6829382319982582D-11),  &
    quad( 0.4754359892166024D+04, -.6321699947095538D-12),  &
    quad( -.1588514130362740D+03, 0.1630647068074753D-13),  &
    quad( 0.1878850329497677D+01, -.5694435459399838D-16),  &
    quad( -.4589872822043718D-02, 0.3894567587921014D-18),  &
    quad( 0.5931363621107230D-06, -.1388883823219028D-21),  &
    quad( 0.1024789274886151D-11, 0.2637600537816092D-27),  &
    quad( -.3355721053959592D-12, 0.4593372363497046D-29) /)

! Check negative arguments.

IF (x%hi <= zero) THEN
  WRITE(*, *)' *** Negative argument in q_lngm ***'
  RETURN
END IF

IF (x%hi == one .OR. x%hi == 2.d0) THEN
  IF (x%lo == zero) THEN
    b%hi = zero
    b%lo = zero
    RETURN
  END IF
END IF

IF (x%hi >= 16._dp) GO TO 20

!  Fit a Lanczos-type approximation if x%hi < 16.
!  i.e. ln(gamma(x)) = lnsqrt(2.pi) + (x-.5)ln(x+g-.5) - (x+g-.5) + ln(A(x))
!  where A(x) = a0 + a1/x + a2/(x+1) + ... + ak/(x+g).
!  g = 14 here to achieve about 29 significant digits accuracy, except in the
!  vicinity of 1 and 2, where ln(gamma) = 0, where the absolute accuracy is
!  about 30 decimal digits.

z = a(1)
DO i = 2, g + 2
  z = z + a(i) / (x + DBLE(i-2))
END DO
temp = x - half
zz = temp + DBLE(g)
b = lnsqrt2pi + temp*log(zz) - zz + log(z)

RETURN

! Stirling's approximation.

20 total = lnsqrt2pi
z = x - half
total = total + z * log(z) - z
zz = z * z
term = z
large = .true.
DO j = 1, 16
  IF (large) THEN
    temp = st_coeff(j) / term
    total = total - temp
    term = term * zz
    IF (ABS(temp%hi) < ABS(total%lo)) large = .false.
  ELSE
    temp%lo = st_coeff(j)%hi / term%hi
    total%lo = total%lo - temp%lo
    IF (ABS(temp%lo) < 1.d-30) CYCLE
    term%hi = term%hi * zz%hi
  END IF
END DO

! The smallest bit of sum%hi & the largest bit of sum%lo may be out
! of alignment, so add zero to re-align.

b = total + zero

RETURN
END FUNCTION q_lngm

PROGRAM test_q_lngm
! Test the quadruple-precision lngamma function using
!    lngamma(m+x) - lngamma(n+x) = log[ (m+x-1).(m+x-2) .. (n+x) ]

USE quadruple_precision
IMPLICIT NONE

INTEGER                :: m, n, i
TYPE (quad)            :: x, lngmm, lngmn, diff, log_prod, error, temp
TYPE (quad), PARAMETER :: qone = quad( 1.0_dp, 0.0_dp)

INTERFACE
  FUNCTION q_lngm(x) RESULT(b)
    USE quadruple_precision
    IMPLICIT NONE
    TYPE (quad), INTENT(IN) :: x
    TYPE (quad)             :: b
  END FUNCTION q_lngm
END INTERFACE

DO
  WRITE(*, '(a)', ADVANCE='NO') ' Enter 2 different positive integers: '
  READ(*, *) m, n
  IF (m == n) THEN
    WRITE(*, *) 'The integers must be different - try again!'
    CYCLE
  END IF
  IF (n > m) THEN
    i = m
    m = n
    n = i
  END IF
  CALL RANDOM_NUMBER(x%hi)
  x%lo = 0._dp
  lngmm = q_lngm(x+DBLE(m))
  WRITE(*, '(" lngamma(", f20.15, ") = ", f22.16)') x%hi+DBLE(m), lngmm%hi
  lngmn = q_lngm(x+DBLE(n))
  WRITE(*, '(" lngamma(", f20.15, ") = ", f22.16)') x%hi+DBLE(n), lngmn%hi
  diff = lngmm - lngmn
  temp = x + DBLE(m-1)
  log_prod = log(temp)
  DO i = 1, m-n-1
    temp = temp - qone
    log_prod = log_prod + log(temp)
  END DO
  error = diff - log_prod
  WRITE(*, '(" Diff =", f20.15, "  log_prod =", f20.15, "  Error =", g11.3)')  &
                diff%hi, log_prod%hi, error%hi
END DO

STOP
END PROGRAM test_q_lngm


subroutine invert(a,nmax,ndm)

!-----------------------------------------------------------------------
!
! This routine performs the inversion of a ndm*ndm square matrix
! or just part of it (nmax*nmax)
!
!-----------------------------------------------------------------------
  use      typre
  implicit none
  integer(ip), intent(in)    :: ndm,nmax
  real(rp),    intent(inout) :: a(ndm,ndm)
  real(rp)                   :: d
  integer(ip)                :: n,j,i

  do n = 1,nmax
     d = a(n,n)
     do j = 1,nmax
        a(n,j) = -a(n,j)/d
     end do
     do i = 1,nmax
        if(n/=i) then
           do j = 1,nmax
              if(n/=j) a(i,j) = a(i,j) +a(i,n)*a(n,j)
           end do
        end if
        a(i,n) = a(i,n)/d
     end do
     a(n,n) = 1.0_rp/d
  end do

end subroutine invert


module m_poisson_solver
    use mpifft
    use m_constants, only: PI
    use m_get_default, only: get_default
    implicit none

    !> 3d poisson equation solver.
    !>
    !> Poisson equation:
    !>     ∂^2p/∂^2 + ∂^2p/∂y^2 + ∂^2p/∂z^2 = f(x, y, z)
    type :: t_PoissonSolver3d
        double precision, private :: dx
        double precision, private :: dy
        double precision, private :: dz
        class(t_MPI_FFTExecutor3d), allocatable, private :: fft3d
        double precision, allocatable, private :: modified_wave_number(:, :, :)
        double precision, private :: boundary_condition_terms(2, 3)
    contains
        procedure :: solve => poissonSolver3d_solve
    end type

    private
    public t_PoissonSolver3d
    public new_PoissonSolver3d

contains

    function new_PoissonSolver3d(local_block, global_block, fft3d, dx, dy, dz, boundary_values) result(obj)
        type(t_Block), intent(in) :: local_block
        type(t_Block), intent(in) :: global_block
        class(t_MPI_FFTExecutor3d), intent(in) :: fft3d
        double precision, intent(in) :: dx
        double precision, intent(in), optional :: dy
        double precision, intent(in), optional :: dz
        double precision, intent(in), optional :: boundary_values(2, 3)
        type(t_PoissonSolver3d) :: obj

        integer :: start(3), end(3)
        integer :: kx, ky, kz

        obj%fft3d = fft3d
        obj%dx = dx
        obj%dy = get_default(dy, dx)
        obj%dz = get_default(dz, dx)

        if (present(boundary_values)) then
            obj%boundary_condition_terms(:, 1) = &
                calc_boundary_term(boundary_values(:, 1), obj%fft3d%boundary_types(1), obj%dx)
            obj%boundary_condition_terms(:, 2) = &
                calc_boundary_term(boundary_values(:, 2), obj%fft3d%boundary_types(2), obj%dy)
            obj%boundary_condition_terms(:, 3) = &
                calc_boundary_term(boundary_values(:, 3), obj%fft3d%boundary_types(3), obj%dz)
        else
            obj%boundary_condition_terms(:, :) = 0.0d0
        end if

        allocate (obj%modified_wave_number(local_block%sizes(1), &
                                           local_block%sizes(2), &
                                           local_block%sizes(3)))

        start(:) = local_block%start(:) - global_block%start(:)
        end(:) = local_block%end(:) - global_block%start(:)
        do concurrent(kz=start(3):end(3), ky=start(2):end(2), kx=start(1):end(1))
            block
                double precision :: wx, wy, wz

                integer :: ix, iy, iz
                double precision :: wn

                wx = calc_wave_number(kx, fft3d%nx, fft3d%boundary_types(1))
                wy = calc_wave_number(ky, fft3d%ny, fft3d%boundary_types(2))
                wz = calc_wave_number(kz, fft3d%nz, fft3d%boundary_types(3))

                ix = kx + global_block%start(1) - local_block%start(1) + 1
                iy = ky + global_block%start(2) - local_block%start(2) + 1
                iz = kz + global_block%start(3) - local_block%start(3) + 1
                wn = wx/(obj%dx*obj%dx) + wy/(obj%dy*obj%dy) + wz/(obj%dz*obj%dz)

                obj%modified_wave_number(ix, iy, iz) = wn
            end block
        end do
    end function

    pure function calc_boundary_term(boundary_values, boundary_type, gridwidth) result(terms)
        double precision, intent(in) :: boundary_values(2)
        integer, intent(in) :: boundary_type
        double precision, intent(in) :: gridwidth
        double precision :: terms(2)

        select case (boundary_type)
        case (BoundaryType_Periodic)
            terms(:) = boundary_values(:)

        case (BoundaryType_Dirichlet)
            terms(:) = [-boundary_values(1)/(gridwidth*gridwidth), &
                        -boundary_values(2)/(gridwidth*gridwidth)]

        case (BoundaryType_Neumann)
            terms(:) = [2.0d0*boundary_values(1)/gridwidth, &
                        -2.0d0*boundary_values(2)/gridwidth]

        case (BoundaryType_Dirichlet_Neumann)
            terms(:) = [-boundary_values(1)/(gridwidth*gridwidth), &
                        -2.0d0*boundary_values(2)/gridwidth]

        case (BoundaryType_Neumann_Dirichlet)
            terms(:) = [-boundary_values(1)/(gridwidth*gridwidth), &
                        -2.0d0*boundary_values(2)/gridwidth]
        end select
    end function

    pure function calc_wave_number(k, n, boundary_type) result(wn)
        integer, intent(in) :: k
        integer, intent(in) :: n
        integer, intent(in) :: boundary_type
        double precision :: wn

        select case (boundary_type)
        case (BoundaryType_Periodic)
            if (k <= int(n/2)) then
                wn = 2.0d0*sin(PI*k/dble(n))
            else
                wn = 2.0d0*sin(PI*(k - int(n/2))/dble(n))
            end if

        case (BoundaryType_Dirichlet)
            wn = 2.0d0*(cos(PI*(k + 1)/dble(n + 1)) - 1.0d0)

        case (BoundaryType_Neumann)
            wn = 2.0d0*(cos(PI*k/dble(n)) - 1.0d0)

        case (BoundaryType_Dirichlet_Neumann)
            wn = 2.0d0*(cos(PI*(k + 0.5d0)/dble(n + 1)) - 1.0d0)

        case (BoundaryType_Neumann_Dirichlet)
            wn = 2.0d0*(cos(PI*(k + 0.5d0)/dble(n + 1)) - 1.0d0)

        end select
    end function

    subroutine poissonSolver3d_solve(self, f, p)
        class(t_PoissonSolver3d), intent(inout) :: self
        double precision, intent(in) :: f(:, :, :)
        double precision, intent(out) :: p(:, :, :)

        double precision, allocatable :: ftmp(:, :, :)
        double precision, allocatable :: fk(:, :, :)
        double precision, allocatable :: pk(:, :, :)

        allocate (ftmp, source=f)
        allocate (fk, mold=f)
        allocate (pk, mold=p)

        ftmp(1, :, :) = ftmp(1, :, :) + self%boundary_condition_terms(1, 1)
        ftmp(:, 1, :) = ftmp(:, 1, :) + self%boundary_condition_terms(1, 2)
        ftmp(:, :, 1) = ftmp(:, :, 1) + self%boundary_condition_terms(1, 3)

        ftmp(self%fft3d%nx, :, :) = ftmp(self%fft3d%nx, :, :) + self%boundary_condition_terms(2, 1)
        ftmp(:, self%fft3d%ny, :) = ftmp(:, self%fft3d%ny, :) + self%boundary_condition_terms(2, 2)
        ftmp(:, :, self%fft3d%nz) = ftmp(:, :, self%fft3d%nz) + self%boundary_condition_terms(2, 3)

        call self%fft3d%forward(f(:, :, :), fk(:, :, :))

        pk(:, :, :) = f(:, :, :)/self%modified_wave_number(:, :, :)

        call self%fft3d%backward(pk(:, :, :), p(:, :, :))
    end subroutine

end module


      real*8 function aunif (x1) result (unif)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    This function generates random numbers ranging from 0.0 to 1.0.
!!    In the process of calculating the random number, the seed (x1) is
!!    set to a new value.
!!    This function implements the prime-modulus generator
!!    xi = 16807 xi Mod(2**(31) - 1)
!!    using code which ensures that no intermediate result uses more than
!!    31 bits
!!    the theory behind the code is summarized in
!!    Bratley, P., B.L. Fox and L.E. Schrage. 1983. A Guide to Simulation.
!!        Springer-Verlag, New York. (pages 199-202)

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name       |units          |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    x1         |none           |random number generator seed (integer)
!!                               |where  0 < x1 < 2147483647
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name       |units          |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    unif       |none           |random number between 0.0 and 1.0
!!    x1         |none           |random number generator seed (integer)
!!                               |set to new value where 0 < x1 < 2147483647
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name       |units          |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    x2         |none           |variable to hold calculation results
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!     ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      integer, intent (in out) :: x1
      integer :: x2

      x2 = 0
      unif = 0.

      x2 = x1 / 127773
      x1 = 16807 * (x1-x2*127773) - x2 * 2836
      if (x1 < 0) x1 = x1 + 2147483647
      unif = x1 * 4.656612875d-10

      return
      end


FUNCTION GET_TUNIV(z)

  !compute age of Universe in Gyr at redshift z
  !assumes flat universe w/ only matter and lambda
  !assumes om0,ol0,H0 set in sps_vars.f90

  USE sps_vars
  IMPLICIT NONE
  INTEGER :: i
  INTEGER, PARAMETER :: ii=10000
  REAL(SP), INTENT(in) :: z
  REAL(SP) :: get_tuniv, thub
  REAL(SP), DIMENSION(ii) :: lnstig, hub

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

  get_tuniv = 0.0

  !Hubble time in Gyr
  thub = 0.978E3 / H0

  DO i=1,ii
     lnstig(i) = REAL(i)/ii*(LOG(1E4)-LOG(1+z))+LOG(1+z)
  ENDDO

  hub = SQRT( om0*EXP(lnstig)**3 + ol0 )

  DO i=1,ii-1
     get_tuniv = get_tuniv + 0.5*(1/hub(i)+1/hub(i+1))
  ENDDO
  get_tuniv = get_tuniv * thub * (lnstig(2)-lnstig(1))

END FUNCTION GET_TUNIV


! ------------------------------------------------------ !
!             filtro compatto 3x5                        !
!             F. Califano, Marzo 2001                    !
! ------------------------------------------------------ !
! A (f_i-1 + f_i+1) + f_i = a_filt f_i +                 !
!       b_filt (f_i-2 + f_i+2) + c_filt (f_i-1 + f_i+1)  !
! ------------------------------------------------------ !

!**************************************************
!  MPI PARALLEL VERSION: VALENTINI-FAGANELLO 2009
!**************************************************

           subroutine filtro_open_x(QW)

use box_mod
use parameter_mod
use filtro_open_mod

IMPLICIT NONE

  integer :: i
  REAL(dp), dimension (nx) :: QW, TW

!     Soluzione del sistema lineare tridiagonale fattorizzato LU
!     Differenze finite compatte 3x5

     TW = QW

!    Filtro IV ordine, Lele 1992, pag. 40, C.2.4

  !!  do i = 3, nx2
  !!   QW(i) = a_filt * TW(i) + b_filt * (TW(i+1) + TW(i-1)) &
  !!                          + c_filt * (TW(i+2) + TW(i-2))
  !!  enddo

!    Filtro VI ordine, Lele 1992, pag. 40, C.2.5

    do i = 4, nx3
     QW(i) = a_filt * TW(i) + b_filt * (TW(i+1) + TW(i-1)) &
           + c_filt * (TW(i+2) + TW(i-2)) + d_filt * (TW(i+3) + TW(i-3))
    enddo

!   Boundary conditions

     !! QW(1)   = TW(1)
     !! QW(2)   = TW(2)
     !! QW(nx)  = TW(nx)
     !! QW(nx1) = TW(nx1)

!   Boundary conditions VI ordine

     !! QW(3)   = TW(3)
     !! QW(nx2) = TW(nx2)

!   Boundary conditions VI ordine, Lele pag. 41, C.2.11.a,b,c

     QW(1) = a11_filt * TW(1) + a12_filt * TW(2) + a13_filt * TW(3) &
           + a14_filt * TW(4) + a15_filt * TW(5)
     QW(2) = a21_filt * TW(1) + a22_filt * TW(2) + a23_filt * TW(3) &
           + a24_filt * TW(4) + a25_filt * TW(5)
     QW(3) = a31_filt * TW(1) + a32_filt * TW(2) + a33_filt * TW(3) &
           + a34_filt * TW(4) + a35_filt * TW(5)

     QW(nx ) = a11_filt * TW(nx ) + a12_filt * TW(nx1) + a13_filt * TW(nx2) &
             + a14_filt * TW(nx3) + a15_filt * TW(nx4)
     QW(nx1) = a21_filt * TW(nx ) + a22_filt * TW(nx1) + a23_filt * TW(nx2) &
             + a24_filt * TW(nx3) + a25_filt * TW(nx4)
     QW(nx2) = a31_filt * TW(nx ) + a32_filt * TW(nx1) + a33_filt * TW(nx2) &
             + a34_filt * TW(nx3) + a35_filt * TW(nx4)

!   Boundary conditions IV ordine, Lele 1992, pag. 40, C.2.11a,b,c

!    QW(1) = a11_filt * TW(1) + a12_filt * TW(2) + a13_filt * TW(3) &
!                             + a14_filt * TW(4) + a15_filt * TW(5)
!
!    QW(2) = a21_filt * TW(1) + a22_filt * TW(2) + a23_filt * TW(3) &
!                             + a24_filt * TW(4) + a25_filt * TW(5)
!
!    QW(nx1) = a21_filt * TW(nx) + a22_filt * TW(nx1) &
!     + a23_filt * TW(nx2) + a24_filt * TW(nx-3) + a25_filt * TW(nx-4)
!
!    QW(nx)  = a11_filt * TW(nx) + a12_filt * TW(nx1) &
!     + a13_filt * TW(nx2) + a14_filt * TW(nx-3) + a15_filt * TW(nx-4)

 CALL  DGTTRS(TARNS,nx,LRHS,filt_m,filt_d,filt_p,filt_2,ipv_f,QW,ldb,INFO)

   if (info > 0 .or. info < 0) then
    write(*,*) 'Problemi soluzione, info:', info
    stop
   endif

 end subroutine


module maptran

  use assert, only: wp,isclose
  implicit none
  private

  type,public :: Ellipsoid
     real(wp) :: SemimajorAxis, Flattening, SemiminorAxis
  end type

  real(wp), parameter :: pi = 4._wp * atan(1.0_wp)

  type(Ellipsoid), parameter, public :: wgs84Ellipsoid = &
        Ellipsoid(SemimajorAxis=6378137._wp, &
                  SemiminorAxis=6378137._wp * (1._wp - 1._wp / 298.2572235630_wp), &
                  Flattening = 1. / 298.2572235630_wp)

  public :: ecef2geodetic, geodetic2ecef, aer2enu, enu2aer, aer2ecef, ecef2aer, &
            enu2ecef, ecef2enu, aer2geodetic, geodetic2enu,&
            geodetic2aer,enu2geodetic,degrees,radians, anglesep

contains

elemental subroutine ecef2geodetic(x, y, z, lat, lon, alt, spheroid, deg)

! convert ECEF (meters) to geodetic coordintes

! Algorithm is based on
! http://www.astro.uni.torun.pl/~kb/Papers/geod/Geod-BG.htm
! This algorithm provides a converging solution to the latitude equation
! in terms of the parametric or reduced latitude form (v)
! This algorithm provides a uniform solution over all latitudes as it does
! not involve division by cos(phi) or sin(phi)

  real(wp), intent(in) :: x,y,z
  type(Ellipsoid), intent(in), optional :: spheroid
  logical, optional,value :: deg
  real(wp), intent(out) :: lat, lon, alt

  real(wp) :: ea, eb, rad, rho, c, vnew, v
  integer :: i
  type(Ellipsoid) :: ell

  ell = merge(spheroid, wgs84Ellipsoid, present(spheroid))

  if (.not.present(deg)) deg = .true.

  ea = ell%SemimajorAxis
  eb = ell%SemiminorAxis
  rad = hypot(x, y)
! Constant required for Latitude equation
  rho = atan2(eb * z, ea * rad)
! Constant required for latitude equation
  c = (ea**2 - eb**2) / hypot(ea * rad, eb * z)
! Starter for the Newtons Iteration Method
  vnew = atan2(ea * z, eb * rad)
! Initializing the parametric latitude
  v = 0._wp
  do i = 1,5
    v = vnew
   ! Newtons Method for computing iterations
    vnew = v - ((2 * sin(v - rho) - c * sin(2 * v)) / &
              (2 * (cos(v - rho) - c * cos(2 * v))))

    if (isclose(v,vnew)) exit
  enddo

! Computing latitude from the root of the latitude equation
  lat = atan2(ea * tan(vnew), eb)
! by inspection
  lon = atan2(y, x)

  alt = ((rad - ea * cos(vnew)) * cos(lat)) + &
         ((z - eb * sin(vnew)) * sin(lat))

  if (deg) then
    lat = degrees(lat)
    lon = degrees(lon)
  endif

end subroutine ecef2geodetic

elemental subroutine geodetic2ecef(lat,lon,alt, x,y,z, spheroid, deg)
! geodetic2ecef   convert from geodetic to ECEF coordiantes
!
! Inputs
! ------
! lat,lon, alt:  ellipsoid geodetic coordinates of point(s) (degrees, degrees, meters)
! spheroid: Ellipsoid parameter struct
! deg: .true. degrees
!
! outputs
! -------
! x,y,z:  ECEF coordinates of test point(s) (meters)
!
  real(wp), value :: lat,lon
  real(wp), intent(in) :: alt
  real(wp), intent(out) :: x,y,z
  type(Ellipsoid), intent(in), optional :: spheroid
  logical, optional, value :: deg

  real(wp) :: N
  type(Ellipsoid) :: ell

  ell = merge(spheroid, wgs84Ellipsoid, present(spheroid))

  if (.not.present(deg)) deg=.true.

  if (deg) then
    lat = radians(lat)
    lon = radians(lon)
  endif

! Radius of curvature of the prime vertical section
  N = radius_normal(lat, ell)
! Compute cartesian (geocentric) coordinates given  (curvilinear) geodetic coordinates.

  x = (N + alt) * cos(lat) * cos(lon)
  y = (N + alt) * cos(lat) * sin(lon)
  z = (N * (ell%SemiminorAxis / ell%SemimajorAxis)**2 + alt) * sin(lat)

end subroutine geodetic2ecef

elemental subroutine aer2geodetic(az, el, slantRange, lat0, lon0, alt0, lat1, lon1, alt1, spheroid, deg)
! aer2geodetic  convert azimuth, elevation, range of target from observer to geodetic coordiantes
!
! Inputs
! ------
! az, el, slantrange: look angles and distance to point under test (degrees, degrees, meters)
! az: azimuth clockwise from local north
! el: elevation angle above local horizon
! lat0, lon0, alt0: ellipsoid geodetic coordinates of observer/reference (degrees, degrees, meters)
! spheroid: Ellipsoid parameter struct
! deg: .true.: degrees
!
! Outputs
! -------
! lat1,lon1,alt1: geodetic coordinates of test points (degrees,degrees,meters)

  real(wp), intent(in) :: az, el, slantRange, lat0, lon0, alt0
  type(Ellipsoid), intent(in), optional :: spheroid
  logical, intent(in), optional :: deg
  real(wp), intent(out) :: lat1,lon1,alt1

  real(wp) :: x,y,z

  call aer2ecef(az, el, slantRange, lat0, lon0, alt0, x, y, z, spheroid, deg)

  call ecef2geodetic(x, y, z, lat1, lon1, alt1, spheroid, deg)
end subroutine aer2geodetic

elemental subroutine geodetic2aer(lat, lon, alt, lat0, lon0, alt0, az, el, slantRange, spheroid, deg)
! geodetic2aer   from an observer's perspective, convert target coordinates to azimuth, elevation, slant range.
!
! Inputs
! ------
! lat,lon, alt:  ellipsoid geodetic coordinates of point under test (degrees, degrees, meters)
! lat0, lon0, alt0: ellipsoid geodetic coordinates of observer/reference (degrees, degrees, meters)
! spheroid: Ellipsoid parameter struct
! angleUnit: string for angular units. Default 'd': degrees, otherwise Radians
!
! Outputs
! -------
! az, el, slantrange: look angles and distance to point under test (degrees, degrees, meters)
! az: azimuth clockwise from local north
! el: elevation angle above local horizon

  real(wp), intent(in) :: lat,lon,alt, lat0, lon0, alt0
  type(Ellipsoid), intent(in), optional :: spheroid
  logical, intent(in), optional :: deg
  real(wp), intent(out) :: az, el, slantRange

  real(wp) :: east,north,up

  call geodetic2enu(lat, lon, alt, lat0, lon0, alt0, east,north,up, spheroid, deg)
  call enu2aer(east, north, up, az, el, slantRange, deg)

end subroutine geodetic2aer

elemental subroutine geodetic2enu(lat, lon, alt, lat0, lon0, alt0, east, north, up, spheroid, deg)
! geodetic2enu    convert from geodetic to ENU coordinates
!
! Inputs
! ------
! lat,lon, alt:  ellipsoid geodetic coordinates of point under test (degrees, degrees, meters)
! lat0, lon0, alt0: ellipsoid geodetic coordinates of observer/reference (degrees, degrees, meters)
! spheroid: Ellipsoid parameter struct
! angleUnit: string for angular units. Default 'd': degrees
!
! outputs
! -------
! e,n,u:  East, North, Up coordinates of test points (meters)

  real(wp), intent(in) :: lat, lon, alt, lat0, lon0, alt0
  type(Ellipsoid), intent(in), optional :: spheroid
  logical, intent(in), optional :: deg
  real(wp), intent(out) :: east, north, up

  real(wp) x1,y1,z1,x2,y2,z2, dx,dy,dz

  call geodetic2ecef(lat,lon,alt,x1,y1,z1,spheroid,deg)
  call geodetic2ecef(lat0,lon0,alt0,x2,y2,z2,spheroid,deg)

  dx = x1-x2;
  dy = y1-y2;
  dz = z1-z2;

  call ecef2enuv(dx, dy, dz, lat0, lon0, east, north, up, deg)

end subroutine geodetic2enu

elemental subroutine enu2geodetic(east, north, up, lat0, lon0, alt0, lat, lon, alt, spheroid, deg)
! enu2geodetic   convert from ENU to geodetic coordinates
!
! Inputs
! ------
!  East, North, Up: coordinates of point(s) (meters)
! lat0, lon0, alt0: ellipsoid geodetic coordinates of observer/reference (degrees, degrees, meters)
! spheroid: Ellipsoid parameter struct
! deg: .true. degrees
!
! outputs
! -------
! lat,lon,alt: geodetic coordinates of test points (degrees,degrees,meters)

  real(wp), intent(in) :: east, north, up, lat0, lon0, alt0
  type(Ellipsoid), intent(in), optional :: spheroid
  logical, intent(in), optional :: deg
  real(wp), intent(out) :: lat, lon, alt

  real(wp) :: x,y,z

  call enu2ecef(east, north, up, lat0, lon0, alt0, x, y, z, spheroid, deg)
  call ecef2geodetic(x, y, z, lat, lon, alt, spheroid,deg)

end subroutine enu2geodetic

elemental subroutine aer2ecef(az, el, slantRange, lat0, lon0, alt0, x,y,z, spheroid, deg)
! aer2ecef  convert azimuth, elevation, range to target from observer to ECEF coordinates
!
! Inputs
! ------
! az, el, slantrange: look angles and distance to point under test (degrees, degrees, meters)
! az: azimuth clockwise from local north
! el: elevation angle above local horizon
! lat0, lon0, alt0: ellipsoid geodetic coordinates of observer/reference (degrees, degrees, meters)
! spheroid: Ellipsoid parameter struct
! deg: .true. degrees
!
! outputs
! -------
! x,y,z: Earth Centered Earth Fixed (ECEF) coordinates of test point (meters)

  real(wp), intent(in) :: az,el, slantRange, lat0, lon0, alt0
  type(Ellipsoid), intent(in), optional :: spheroid
  logical, intent(in), optional :: deg
  real(wp), intent(out) :: x,y,z

  real(wp) :: x0,y0,z0, e,n,u,dx,dy,dz

! Origin of the local system in geocentric coordinates.
  call geodetic2ecef(lat0, lon0, alt0,x0, y0, z0, spheroid,deg)
! Convert Local Spherical AER to ENU
  call aer2enu(az, el, slantRange, e, n, u,deg)
! Rotating ENU to ECEF
  call enu2uvw(e, n, u, lat0, lon0, dx, dy, dz,deg)
! Origin + offset from origin equals position in ECEF
  x = x0 + dx
  y = y0 + dy
  z = z0 + dz

end subroutine aer2ecef

elemental subroutine ecef2aer(x, y, z, lat0, lon0, alt0, az, el, slantRange, spheroid, deg)
! ecef2aer  convert ECEF of target to azimuth, elevation, slant range from observer
!
! Inputs
! ------
! x,y,z: Earth Centered Earth Fixed (ECEF) coordinates of test point (meters)
! lat0, lon0, alt0: ellipsoid geodetic coordinates of observer/reference (degrees, degrees, meters)
! spheroid: Ellipsoid parameter struct
! deg: .true.: degrees
!
! Outputs
! -------
! az, el, slantrange: look angles and distance to point under test (degrees, degrees, meters)
! az: azimuth clockwise from local north
! el: elevation angle above local horizon

  real(wp), intent(in) :: x,y,z, lat0, lon0, alt0
  type(Ellipsoid), intent(in), optional :: spheroid
  logical, intent(in), optional :: deg
  real(wp), intent(out) :: az,el, slantRange

  real(wp) :: east, north, up

  call ecef2enu(x, y, z, lat0, lon0, alt0, east, north, up, spheroid, deg)
  call enu2aer(east, north, up, az, el, slantRange, deg)

end subroutine ecef2aer

elemental subroutine aer2enu(az, el, slantRange, east, north, up, deg)
! aer2enu  convert azimuth, elevation, range to ENU coordinates
!
! Inputs
! ------
! az, el, slantrange: look angles and distance to point under test (degrees, degrees, meters)
! az: azimuth clockwise from local north
! el: elevation angle above local horizon
! angleUnit: string for angular units. Default 'd': degrees
!
! Outputs
! -------
! e,n,u:  East, North, Up coordinates of test points (meters)

  real(wp), value :: az,el
  real(wp), intent(in) :: slantRange
  logical, optional, value :: deg
  real(wp),intent(out) :: east, north,up

  real(wp) :: r

  if(.not.present(deg)) deg=.true.

  if (deg) then
    az = radians(az)
    el = radians(el)
  endif

! Calculation of AER2ENU
   up = slantRange * sin(el)
   r = slantRange * cos(el)
   east = r * sin(az)
   north = r * cos(az)

end subroutine aer2enu

elemental subroutine enu2aer(east, north, up, az, elev, slantRange, deg)
! enu2aer   convert ENU to azimuth, elevation, slant range
!
! Inputs
! ------
! e,n,u:  East, North, Up coordinates of test points (meters)
! deg: .true. degrees
!
! outputs
! -------
! az, el, slantrange: look angles and distance to point under test (degrees, degrees, meters)
! az: azimuth clockwise from local north
! el: elevation angle above local horizon

  real(wp),intent(in) :: east,north,up
  logical, optional, value :: deg
  real(wp), intent(out) :: az, elev, slantRange

  real(wp) :: r

  if (.not.present(deg)) deg = .true.

  r = hypot(east, north)
  slantRange = hypot(r, up)
  ! radians
  elev = atan2(up, r)
  az = modulo(atan2(east, north), 2._wp * atan2(0._wp, -1._wp))

  if (deg) then
    elev = degrees(elev)
    az = degrees(az)
  endif

end subroutine enu2aer

elemental subroutine enu2ecef(e, n, u, lat0, lon0, alt0, x, y, z, spheroid, deg)
! enu2ecef  convert from ENU to ECEF coordiantes
!
! Inputs
! ------
! e,n,u:  East, North, Up coordinates of test points (meters)
! lat0, lon0, alt0: ellipsoid geodetic coordinates of observer/reference (degrees, degrees, meters)
! spheroid: Ellipsoid parameter struct
! angleUnit: string for angular units. Default 'd': degrees
!
! outputs
! -------
! x,y,z: Earth Centered Earth Fixed (ECEF) coordinates of test point (meters)
  real(wp), intent(in) :: e,n,u,lat0,lon0,alt0
  type(Ellipsoid), intent(in), optional :: spheroid
  logical, intent(in), optional :: deg
  real(wp), intent(out) :: x,y,z

  real(wp) :: x0,y0,z0,dx,dy,dz

  call geodetic2ecef(lat0, lon0, alt0, x0, y0, z0, spheroid, deg)
  call enu2uvw(e, n, u, lat0, lon0, dx, dy, dz, deg)

   x = x0 + dx
   y = y0 + dy
   z = z0 + dz
end subroutine enu2ecef

elemental subroutine ecef2enu(x, y, z, lat0, lon0, alt0, east, north, up, spheroid, deg)
! ecef2enu  convert ECEF to ENU
!
! Inputs
! ------
! x,y,z: Earth Centered Earth Fixed (ECEF) coordinates of test point (meters)
! lat0, lon0, alt0: ellipsoid geodetic coordinates of observer/reference (degrees, degrees, meters)
! spheroid: Ellipsoid parameter struct
! angleUnit: string for angular units. Default 'd': degrees
!
! outputs
! -------
! e,n,u:  East, North, Up coordinates of test points (meters)

  real(wp), intent(in) :: x,y,z,lat0,lon0,alt0
  type(Ellipsoid), intent(in), optional :: spheroid
  logical, intent(in), optional :: deg
  real(wp), intent(out) :: east,north,up

  real(wp) :: x0,y0,z0

  call geodetic2ecef(lat0, lon0, alt0, x0,y0,z0, spheroid,deg)
  call ecef2enuv(x - x0, y - y0, z - z0, lat0, lon0, east, north, up, deg)
end subroutine ecef2enu

elemental subroutine ecef2enuv(u, v, w, lat0, lon0, east, north, up, deg)
! ecef2enuv convert *vector projection* UVW to ENU
!
! Inputs
! ------
! u,v,w: meters
! lat0,lon0: geodetic latitude and longitude (degrees)
! deg: .true. degrees
!
! Outputs
! -------
! e,n,Up:  East, North, Up vector

  real(wp), intent(in) :: u,v,w
  real(wp), value :: lat0,lon0
  logical, optional, value :: deg
  real(wp), intent(out) :: east, north, up

  real(wp) :: t

  if (.not.present(deg)) deg = .true.

  if (deg) then
    lat0 = radians(lat0)
    lon0 = radians(lon0)
  endif

  t     =  cos(lon0) * u + sin(lon0) * v
  east  = -sin(lon0) * u + cos(lon0) * v
  up    =  cos(lat0) * t + sin(lat0) * w
  north = -sin(lat0) * t + cos(lat0) * w
end subroutine ecef2enuv

elemental subroutine enu2uvw(e,n,up,lat0,lon0,u,v,w,deg)
! enu2uvw   convert from ENU to UVW coordinates
!
! Inputs
! ------
! e,n,up:  East, North, Up coordinates of point(s) (meters)
! lat0,lon0: geodetic coordinates of observer/reference point (degrees)
! deg: ,true. degrcees
!
! outputs
! -------
! u,v,w:   coordinates of test point(s) (meters)
  real(wp), intent(in) :: e,n,up
  real(wp), value :: lat0,lon0
  real(wp), intent(out) :: u,v,w
  logical, optional, value :: deg

  real(wp) :: t

  if(.not.present(deg)) deg=.true.

  if (deg) then
    lat0 = radians(lat0)
    lon0 = radians(lon0)
  endif

  t = cos(lat0) * up - sin(lat0) * n
  w = sin(lat0) * up + cos(lat0) * n

  u = cos(lon0) * t - sin(lon0) * e
  v = sin(lon0) * t + cos(lon0) * e

end subroutine enu2uvw

elemental real(wp) function radius_normal(lat,E)
    real(wp), intent(in) :: lat
    type(Ellipsoid), intent(in) :: E

    radius_normal = E%SemimajorAxis**2 / sqrt( E%SemimajorAxis**2 * cos(lat)**2 + E%SemiminorAxis**2 * sin(lat)**2 )

end function radius_normal

elemental real(wp) function anglesep(lon0,lat0,lon1,lat1)
! angular separation between two points on sphere
! all input/output in DEGREES

  real(wp), intent(in) :: lat0,lon0,lat1,lon1
  real(wp) :: la0,lo0,la1,lo1

  la0 = radians(lat0)
  lo0 = radians(lon0)
  la1 = radians(lat1)
  lo1 = radians(lon1)

  anglesep = degrees(2 * asin(sqrt(haversine(la1 - la0) + &
                        cos(la0) * cos(la1) * haversine(lo1 - lo0))))

end function anglesep

elemental real(wp) function haversine(theta)
! theta: angle in RADIANS

  real(wp), intent(in) :: theta

  haversine =  (1 - cos(theta)) / 2.

end function haversine

elemental real(wp) function degrees(rad)
    real(wp), intent(in) :: rad

    degrees = 180._wp / pi * rad
end function degrees

elemental real(wp) function radians(deg)
    real(wp), intent(in) :: deg

    radians = pi / 180._wp * deg
end function radians

end module


 SUBROUTINE ZPOSV_F95( A, B, UPLO, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
    USE LA_PRECISION, ONLY: WP => DP
    USE LA_AUXMOD, ONLY: ERINFO, LSAME
    USE F77_LAPACK, ONLY: POSV_F77 => LA_POSV
!   .. IMPLICIT STATEMENT ..
    IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
    CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!   .. ARRAY ARGUMENTS ..
    COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:,:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!    LA_POSV computes the solution to a linear system of equations
! A*X=B, where A is real symmetric or complex Hermitian and, in either
! case, positive definite, and where X and B are rectangular matrices
! or vectors. The Cholesky decomposition is used to factor A as
! A = U^H*U if UPLO = 'U', or A = L*L^H if UPLO = 'L'
! where U is an upper triangular matrix and L is a lower triangular
! matrix (L = U^H ). The factored form of A is then used to solve the
! above system.
!
! =========
!
!         SUBROUTINE LA_POSV( A, B, UPLO=uplo, INFO=info )
!            <type>(<wp>), INTENT(INOUT) :: A(:,:), <rhs>
!            CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!            INTEGER, INTENT(OUT), OPTIONAL :: INFO
!         where
!            <type> ::= REAL | COMPLEX
!            <wp>   ::= KIND(1.0) | KIND(1.0D0)
!            <rhs>  ::= B(:,:) | B(:)
!
! Arguments
! =========
!
! A     (input/output) REAL or COMPLEX square array, shape (:,:).
!       On entry, the matrix A.
!       If UPLO = 'U', the upper triangular part of A contains the upper
!       triangular part of the matrix A, and the strictly lower triangular
!       part of A is not referenced. If UPLO = 'L', the lower triangular
!       part of A contains the lower triangular part of the matrix A, and
!       the strictly upper triangular part of A is not referenced.
!       On exit, the factor U or L from the Cholesky factorization
!       A = U^H*U = L*L^H.
! B     (input/output) REAL or COMPLEX array, shape (:,:) with
!       size(B,1) = size(A,1) or shape (:) with size(B) = size(A,1).
!       On entry, the matrix B.
!       On exit, the solution matrix X.
! UPLO  Optional (input) CHARACTER(LEN=1)
!        = 'U': Upper triangle of A is stored;
!        = 'L': Lower triangle of A is stored.
!       Default value: 'U'.
! INFO  Optional (output) INTEGER
!       = 0: sauccessful exit.
!       < 0: if INFO = -i, the i-th argument had an illegal value.
!       > 0: if INFO = i, the leading minor of order i of A is not
!            positive definite, so the factorization could not be
! 	   completed and the solution could not be computed.
!       If INFO is not present and an error occurs, then the program is
!       terminated with an error message.
!----------------------------------------------------------------------
!   .. PARAMETERS ..
    CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_POSV'
!   .. LOCAL SCALARS ..
    CHARACTER(LEN=1) :: LUPLO
    INTEGER :: LINFO, N, NRHS
!   .. INTRINSIC FUNCTIONS ..
    INTRINSIC SIZE, PRESENT
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0; N = SIZE(A,1); NRHS = SIZE(B,2)
    IF( PRESENT(UPLO) )THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
!   .. TEST THE ARGUMENTS
    IF( SIZE( A, 2 ) /= N .OR. N < 0 ) THEN; LINFO = -1
    ELSE IF( SIZE( B, 1 ) /= N .OR. NRHS < 0 ) THEN; LINFO = -2
    ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -3
    ELSE IF ( N > 0 ) THEN
       CALL POSV_F77( LUPLO, N, NRHS, A, N, B, N, LINFO )
    END IF
    CALL ERINFO( LINFO, SRNAME, INFO )
 END SUBROUTINE ZPOSV_F95


program test_varn
    use stdlib_experimental_error, only: check
    use stdlib_experimental_kinds, only: sp, dp, int32, int64
    use stdlib_experimental_stats, only: var
    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)

    integer(int32) :: i321(5) = [1, 2, 3, 4, 5]

    integer(int32), allocatable :: i32(:,:), i323(:, :, :)

    real(sp) :: s1(5) = [1.0_sp, 2.0_sp, 3.0_sp, 4.0_sp, 5.0_sp]
    real(dp) :: d1(5) = [1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp]

    real(sp), allocatable :: s(:, :), s3(:, :, :)
    real(dp), allocatable :: d3(:, :, :)
    real(dp) :: d(4, 3) = reshape([1._dp, 3._dp, 5._dp, 7._dp,&
                                   2._dp, 4._dp, 6._dp, 8._dp,&
                                   9._dp, 10._dp, 11._dp, 12._dp], [4, 3])

    complex(dp) :: cd1(5) = [ cmplx(0.57706_dp, 0.00000_dp),&
                            cmplx(0.00000_dp, 1.44065_dp),&
                            cmplx(1.26401_dp, 0.00000_dp),&
                            cmplx(0.00000_dp, 0.88833_dp),&
                            cmplx(1.14352_dp, 0.00000_dp)]
    complex(dp) :: cd(5,3)

    !sp
    !1dim
    print*,' test_sp_1dim'
    call check( abs(var(s1, corrected=.false.) - 2.5*(4./5.)) < sptol)
    call check( abs(var(s1, dim=1, corrected=.false.) - 2.5*(4./5.)) < sptol)

    print*,' test_sp_1dim_mask'
    call check( ieee_is_nan(var(s1, .false., corrected=.false.)))
    call check( ieee_is_nan(var(s1, 1, .false., corrected=.false.)))

    print*,' test_sp_1dim_mask_array'
    call check( abs(var(s1, s1 < 5, corrected=.false.) - 5./4.) < sptol)
    call check( ieee_is_nan((var(s1, s1 < 0., corrected=.false.))))
    call check( abs(var(s1, s1 == 1., corrected=.false.)) < sptol)
    call check( abs(var(s1, 1, s1 < 5, corrected=.false.) - 5./4.) < sptol)

    !2dim
    print*,' test_sp_2dim'
    s = d
    call check( abs(var(s, corrected=.false.) - 13.*11./12.) < sptol)
    call check( all( abs( var(s, 1, corrected=.false.) - [20., 20., 5.]/4.) < sptol))
    call check( all( abs( var(s, 2, corrected=.false.) -&
                      [19.0, 43. / 3., 31. / 3. , 7.0]*2./3.) < sptol))

    print*,' test_sp_2dim_mask'
    call check( ieee_is_nan(var(s, .false., corrected=.false.)))
    call check( any(ieee_is_nan(var(s, 1, .false., corrected=.false.))))
    call check( any(ieee_is_nan(var(s, 2, .false., corrected=.false.))))

    print*,' test_sp_2dim_mask_array'
    call check( abs(var(s, s < 11, corrected=.false.) - 2.75*3.) < sptol)
    call check( all( abs( var(s, 1, s < 11, corrected=.false.) -&
                      [5., 5., 0.25]) < sptol))
    call check( all( abs( var(s, 2, s < 11, corrected=.false.) -&
                      [19.0*2./3., 43./9.*2., 0.25 , 0.25]) < sptol))

    !3dim
    allocate(s3(size(s,1),size(s,2),3))
    s3(:,:,1)=s;
    s3(:,:,2)=s*2;
    s3(:,:,3)=s*4;

    print*,' test_sp_3dim'
    call check( abs(var(s3, corrected=.false.) - 153.4*35./36.) < sptol)
    call check( all( abs( var(s3, 1, corrected=.false.) -&
                 reshape([20. / 3., 20. / 3., 5. / 3.,&
                          4* 20. / 3., 4* 20. / 3., 4* 5. / 3.,&
                          16* 20. / 3., 16* 20. / 3., 16* 5. / 3.],&
                          [size(s3,2), size(s3,3)])*3./4.)&
                 < sptol))
    call check( all( abs( var(s3, 2, corrected=.false.) -&
                 reshape([19.0, 43. / 3., 31. / 3. , 7.0,&
                          4* 19.0, 4* 43. / 3., 4* 31. / 3. , 4* 7.0,&
                          16* 19.0, 16* 43. / 3., 16* 31. / 3. , 16* 7.0],&
                          [size(s3,1), size(s3,3)] )*2./3.)&
                 < sptol))
    call check( all(abs( var(s3, 3, corrected=.false.) -&
                 reshape([ 7./3., 21., 175./3.,&
                           343./3., 28./3., 112./3.,&
                           84., 448./3., 189.,&
                           700./3., 847./3., 336.], [size(s3,1), size(s3,2)] )*2./3.)&
                 < sptol))

    print*,' test_sp_3dim_mask'
    call check( ieee_is_nan(var(s3, .false., corrected=.false.)))
    call check( any(ieee_is_nan(var(s3, 1, .false., corrected=.false.))))
    call check( any(ieee_is_nan(var(s3, 2, .false., corrected=.false.))))
    call check( any(ieee_is_nan(var(s3, 3, .false., corrected=.false.))))

    print*,' test_sp_3dim_mask_array'
    call check( abs(var(s3, s3 < 11, corrected=.false.) - 7.73702383_sp) < sptol)
    call check( all( abs( var(s3, 1, s3 < 45, corrected=.false.) -&
                  reshape([5., 5., 1.25,  20., 20., 5., 80., 80., 32./3.],&
                  [size(s3, 2), size(s3, 3)])) < sptol ))
    call check( all( abs( var(s3, 2, s3 < 45, corrected=.false.) -&
                  reshape([ 38./3., 86./9., 6.88888931, 14./3., 152./3.,&
                            38.2222214, 27.5555573, 18.6666660, 202.666672,&
                            152.888885, 110.222229, 4.&
                           ],&
                  [size(s3, 1), size(s3, 3)])) < sptol ))
    call check( all( abs( var(s3, 3, s3 < 45, corrected=.false.) -&
                 reshape([1.555555, 14., 38.888888, 76.222222, 6.2222222,&
                          24.888888, 56., 99.5555, 126., 155.555555, 188.22222, 36.&
                           ], [size(s3,1), size(s3,2)] ))&
                 < sptol ))

    !dp
    !1dim
    print*,' test_dp_1dim'
    call check( abs(var(d1, corrected=.false.) - 2.5_dp*(4._dp/5.)) < dptol)
    call check( abs(var(d1, dim=1, corrected=.false.) - 2.5_dp*(4._dp/5.)) < dptol)

    print*,' test_dp_1dim_mask'
    call check( ieee_is_nan(var(d1, .false., corrected=.false.)))
    call check( ieee_is_nan(var(d1, 1, .false., corrected=.false.)))

    print*,' test_dp_1dim_mask_array'
    call check( abs(var(d1, d1 < 5, corrected=.false.) - 5._dp/4.) < dptol)
    call check( ieee_is_nan((var(d1, d1 < 0, corrected=.false.))))
    call check( abs(var(d1, d1 == 1, corrected=.false.)) < dptol)
    call check( abs(var(d1, 1, d1 < 5, corrected=.false.) - 5._dp/4.) < dptol)

    !2dim
    print*,' test_dp_2dim'
    call check( abs(var(d, corrected=.false.) - 13._dp*11./12.) < dptol)
    call check( all( abs( var(d, 1, corrected=.false.) - [20., 20., 5.]/4._dp) < dptol))
    call check( all( abs( var(d, 2, corrected=.false.) -&
                      [38._dp, 86._dp / 3._dp, 62._dp / 3._dp , 14._dp]/3._dp) < dptol))

    print*,' test_dp_2dim_mask'
    call check( ieee_is_nan(var(d, .false., corrected=.false.)))
    call check( any(ieee_is_nan(var(d, 1, .false., corrected=.false.))))
    call check( any(ieee_is_nan(var(d, 2, .false., corrected=.false.))))

    print*,' test_dp_2dim_mask_array'
    call check( abs(var(d, d < 11, corrected=.false.) - 2.75_dp*3._dp) < dptol)
    call check( all( abs( var(d, 1, d < 11, corrected=.false.) -&
                      [5._dp, 5._dp, 0.25_dp]) < dptol))
    call check( all( abs( var(d, 2, d < 11, corrected=.false.) -&
                      [38._dp/3., 86._dp/9., 0.25_dp , 0.25_dp]) < dptol))

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

    print*,' test_dp_3dim'
    call check( abs(var(d3, corrected=.false.) - 153.4_dp*35._dp/36._dp) < dptol)
    call check( all( abs( var(d3, 1, corrected=.false.) -&
                 reshape([20._dp , 20._dp , 5._dp ,&
                          4* 20._dp , 4* 20._dp , 4* 5._dp ,&
                          16* 20._dp , 16* 20._dp , 16* 5._dp ],&
                          [size(d3,2), size(d3,3)])/4._dp)&
                 < dptol))
    call check( all( abs( var(d3, 2, corrected=.false.) -&
                 reshape([38._dp, 86. / 3._dp, 62. / 3._dp , 14._dp,&
                          8* 19._dp, 8* 43. / 3._dp, 8* 31. / 3._dp, 8* 7._dp,&
                          32* 19._dp, 32* 43. / 3._dp, 32* 31. / 3._dp, 32* 7._dp],&
                          [size(d3,1), size(d3,3)] )/3._dp)&
                 < dptol))
    print*,' test_dp_3dim'
    call check( all(abs( var(d3, 3, corrected=.false.) -&
                 reshape([ 7._dp/3., 21._dp, 175._dp/3.,&
                           343._dp/3., 28._dp/3., 112._dp/3.,&
                           84._dp, 448._dp/3., 189._dp,&
                           700._dp/3., 847._dp/3., 336._dp],&
                           [size(d3,1), size(d3,2)] )*2._dp/3._dp)&
                 < dptol))

    print*,' test_dp_3dim_mask'
    call check( ieee_is_nan(var(d3, .false., corrected=.false.)))
    call check( any(ieee_is_nan(var(d3, 1, .false., corrected=.false.))))
    call check( any(ieee_is_nan(var(d3, 2, .false., corrected=.false.))))
    call check( any(ieee_is_nan(var(d3, 3, .false., corrected=.false.))))

    print*,' test_dp_3dim_mask_array'
    call check( abs(var(d3, d3 < 11, corrected=.false.) -&
                     7.7370242214532876_dp) < dptol)
    call check( all( abs( var(d3, 1, d3 < 45, corrected=.false.) -&
                  reshape([5._dp, 5._dp, 1.25_dp,  20._dp, 20._dp, 5._dp,&
                           80._dp, 80._dp, 32._dp/3.],&
                           [size(d3, 2), size(d3, 3)])) < dptol ))
    call check( all( abs( var(d3, 2, d3 < 45, corrected=.false.) -&
                  reshape([ 38._dp/3., 86._dp/9., 62._dp/9., 14._dp/3., 152._dp/3.,&
                            344._dp/9., 248._dp/9., 168._dp/9., 1824._dp/9.,&
                            1376._dp/9., 992._dp/9., 4._dp&
                           ],&
                  [size(d3, 1), size(d3, 3)])) < dptol ))
    print*,' test_dp_3dim_mask_array'
    call check( all( abs( var(d3, 3, d3 < 45, corrected=.false.) -&
                 reshape([14._dp/9., 14._dp, 350._dp/9., 686._dp/9., 56._dp/9.,&
                          224._dp/9., 56._dp, 896._dp/9., 126._dp, 1400._dp/9.,&
                          1694._dp/9., 36._dp&
                           ], [size(d3,1), size(d3,2)] ))&
                 < dptol ))

    !int32
    !1dim
    print*,' test_int32_1dim'
    call check( abs(var(i321, corrected=.false.) - 2.5_dp*(4._dp/5.)) < dptol)
    call check( abs(var(i321, dim=1, corrected=.false.) - 2.5_dp*(4._dp/5.)) < dptol)

    print*,' test_int32_1dim_mask'
    call check( ieee_is_nan(var(i321, .false., corrected=.false.)))
    call check( ieee_is_nan(var(i321, 1, .false., corrected=.false.)))

    print*,' test_int32_1dim_mask_array'
    call check( abs(var(i321, i321 < 5, corrected=.false.) - 5._dp/4.) < dptol)
    call check( ieee_is_nan((var(i321, i321 < 0, corrected=.false.))))
    call check( abs(var(i321, i321 == 1, corrected=.false.)) < dptol)
    call check( abs(var(i321, 1, i321 < 5, corrected=.false.) - 5._dp/4.) < dptol)

    !2dim
    i32 = d
    print*,' test_int32_2dim'
    call check( abs(var(i32, corrected=.false.) - 13._dp*11./12.) < dptol)
    call check( all( abs( var(i32, 1, corrected=.false.) -&
                      [20., 20., 5.]/4._dp) < dptol))
    call check( all( abs( var(i32, 2, corrected=.false.) -&
                      [38._dp, 86._dp / 3._dp, 62._dp / 3._dp , 14._dp]/3._dp) < dptol))

    print*,' test_int32_2dim_mask'
    call check( ieee_is_nan(var(i32, .false., corrected=.false.)))
    call check( any(ieee_is_nan(var(i32, 1, .false., corrected=.false.))))
    call check( any(ieee_is_nan(var(i32, 2, .false., corrected=.false.))))

    print*,' test_int32_2dim_mask_array'
    call check( abs(var(i32, i32 < 11, corrected=.false.) - 2.75_dp*3._dp) < dptol)
    call check( all( abs( var(i32, 1, i32 < 11, corrected=.false.) -&
                      [5._dp, 5._dp, 0.25_dp]) < dptol))
    call check( all( abs( var(i32, 2, i32 < 11, corrected=.false.) -&
                      [38._dp/3., 86._dp/9., 0.25_dp , 0.25_dp]) < dptol))

    !3dim
    allocate(i323(size(i32,1),size(i32,2),3))
    i323(:,:,1)=i32;
    i323(:,:,2)=i32*2;
    i323(:,:,3)=i32*4;

    print*,' test_int32_3dim'
    call check( abs(var(i323, corrected=.false.) - 153.4_dp*35._dp/36._dp) < dptol)
    call check( all( abs( var(i323, 1, corrected=.false.) -&
                 reshape([20._dp , 20._dp , 5._dp ,&
                          4* 20._dp , 4* 20._dp , 4* 5._dp ,&
                          16* 20._dp , 16* 20._dp , 16* 5._dp ],&
                          [size(i323,2), size(i323,3)])/4._dp)&
                 < dptol))
    call check( all( abs( var(i323, 2, corrected=.false.) -&
                 reshape([38._dp, 86. / 3._dp, 62. / 3._dp , 14._dp,&
                          8* 19._dp, 8* 43. / 3._dp, 8* 31. / 3._dp, 8* 7._dp,&
                          32* 19._dp, 32* 43. / 3._dp, 32* 31. / 3._dp, 32* 7._dp],&
                          [size(i323,1), size(i323,3)] )/3._dp)&
                 < dptol))
    print*,' test_int32_3dim'
    call check( all(abs( var(i323, 3, corrected=.false.) -&
                 reshape([ 7._dp/3., 21._dp, 175._dp/3.,&
                           343._dp/3., 28._dp/3., 112._dp/3.,&
                           84._dp, 448._dp/3., 189._dp,&
                           700._dp/3., 847._dp/3., 336._dp],&
                           [size(i323,1), size(i323,2)] )*2._dp/3._dp)&
                 < dptol))

    print*,' test_int32_3dim_mask'
    call check( ieee_is_nan(var(i323, .false., corrected=.false.)))
    call check( any(ieee_is_nan(var(i323, 1, .false., corrected=.false.))))
    call check( any(ieee_is_nan(var(i323, 2, .false., corrected=.false.))))
    call check( any(ieee_is_nan(var(i323, 3, .false., corrected=.false.))))

    print*,' test_int32_3dim_mask_array'
    call check( abs(var(i323, i323 < 11, corrected=.false.) -&
                     7.7370242214532876_dp) < dptol)
    call check( all( abs( var(i323, 1, i323 < 45, corrected=.false.) -&
                  reshape([5._dp, 5._dp, 1.25_dp,  20._dp, 20._dp, 5._dp,&
                           80._dp, 80._dp, 32._dp/3.],&
                           [size(i323, 2), size(i323, 3)])) < dptol ))
    call check( all( abs( var(i323, 2, i323 < 45, corrected=.false.) -&
                  reshape([ 38._dp/3., 86._dp/9., 62._dp/9., 14._dp/3., 152._dp/3.,&
                            344._dp/9., 248._dp/9., 168._dp/9., 1824._dp/9.,&
                            1376._dp/9., 992._dp/9., 4._dp&
                           ],&
                  [size(i323, 1), size(i323, 3)])) < dptol ))
    print*,' test_int32_3dim_mask_array'
    call check( all( abs( var(i323, 3, i323 < 45, corrected=.false.) -&
                 reshape([14._dp/9., 14._dp, 350._dp/9., 686._dp/9., 56._dp/9.,&
                          224._dp/9., 56._dp, 896._dp/9., 126._dp, 1400._dp/9.,&
                          1694._dp/9., 36._dp&
                           ], [size(i323,1), size(i323,2)] ))&
                 < dptol ))

    !cdp
    !1dim
    print*,' test_cdp_1dim'
    call check( abs(var(cd1, corrected=.false.) -&
                 (var(real(cd1), corrected=.false.) +&
                  var(aimag(cd1), corrected=.false.))) < dptol)
    call check( abs(var(cd1, dim=1, corrected=.false.) -&
                 (var(real(cd1), dim=1, corrected=.false.) +&
                  var(aimag(cd1), dim=1, corrected=.false.))) < dptol)

    print*,' test_cdp_1dim_mask'
    call check( ieee_is_nan(var(cd1, .false., corrected=.false.)))
    call check( ieee_is_nan(var(cd1, 1, .false., corrected=.false.)))

    print*,' test_cdp_1dim_mask_array'
    call check( abs(var(cd1, aimag(cd1) == 0, corrected=.false.) -&
                     var(real(cd1), aimag(cd1) == 0, corrected=.false.)) < dptol)
    call check( abs(var(cd1, 1, aimag(cd1) == 0, corrected=.false.) -&
                     var(real(cd1), 1, aimag(cd1) == 0, corrected=.false.)) < dptol)
    call check( ieee_is_nan((var(cd1, (real(cd1) == 0 .and. aimag(cd1) == 0),&
                            corrected=.false.))))
    call check( abs(var(cd1, (real(cd1) > 1.2 .and. aimag(cd1) == 0),&
                     corrected=.false.)) < dptol)

    !2dim
    cd(:,1) = cd1
    cd(:,2) = cd1*3_sp
    cd(:,3) = cd1*1.5_sp

    print*,' test_cdp_2dim'
    call check( abs(var(cd, corrected=.false.) -&
                    (var(real(cd), corrected=.false.) +&
                     var(aimag(cd), corrected=.false.))) < dptol)
    call check( all( abs(var(cd, 1, corrected=.false.) -&
                         (var(real(cd), 1, corrected=.false.) +&
                          var(aimag(cd), 1, corrected=.false.))) < dptol))
    call check( all( abs(var(cd, 2, corrected=.false.) -&
                         (var(real(cd), 2, corrected=.false.) +&
                          var(aimag(cd), 2, corrected=.false.))) < dptol))

    print*,' test_cdp_2dim_mask'
    call check( ieee_is_nan(var(cd, .false., corrected=.false.)))
    call check( any(ieee_is_nan(var(cd, 1, .false., corrected=.false.))))
    call check( any(ieee_is_nan(var(cd, 2, .false., corrected=.false.))))

    print*,' test_cdp_2dim_mask_array'
    call check( abs(var(cd, aimag(cd) == 0, corrected=.false.) -&
                     var(real(cd), aimag(cd) == 0, corrected=.false.)) < dptol)
    call check( all( abs( var(cd, 1, aimag(cd) == 0, corrected=.false.) -&
                           var(real(cd), 1, aimag(cd) == 0, corrected=.false.)) < dptol))
    call check( any( ieee_is_nan( var(cd, 2, aimag(cd) == 0, corrected=.false.))))

end program