MODULE euler3d_mappedgrid

  REAL(kind=8), PARAMETER :: pi=3.1415926535897932385,twopi=2*pi
  REAL(kind=8), PARAMETER :: rEarth=637120000.0

CONTAINS
  !-------------------------------------------------------------------------
  ! Name:
  !   volumeOfHex(x,y,z):
  !
  ! Description:
  !   Compute Volume of an LD Hexahedron given the 8 vertices
  !    from paper:
  !    @book{Grandy_1997,
  !    title={Efficient computation of volume of hexahedral cells},
  !    url={http://www.osti.gov/scitech/servlets/purl/632793},
  !    DOI={10.2172/632793},
  !    abstractNote={This report describes an efficient method to compute
  !                  the volume of hexahedral cells used in three-dimensional
  !                  hydrodynamics simulation. Two common methods for
  !                  creating the hexahedron using triangular boundaries are
  !                  considered.},
  !    author={Grandy, J.}, year={1997}, month={Oct}}
  !    http://dx.doi.org/10.2172/632793
  !
  !    6*V_LD =
  ! |x6-x0  x3-x0  x2-x7|   |x6-x0  x4-x0  x7-x5|   |x6-x0  x1-x0  x5-x2|
  ! |y6-y0  y3-y0  y2-y7| + |y6-y0  y4-y0  y7-y5| + |y6-y0  y1-y0  y5-y2|
  ! |z6-z0  z3-z0  z2-z7|   |z6-z0  z4-z0  z7-z5|   |z6-z0  z1-z0  z5-z2|
  !
  ! Inputs:
  !   x[:],y[:],z[:]  : x,y, and z coordinates of eight hexahedron vertices
  !
  ! Output:
  !   volumeOfHex     : Volume of LD hexahedron
  !-------------------------------------------------------------------------
  REAL(kind=8) FUNCTION volumeOfHex(x,y,z)

    IMPLICIT NONE

    REAL(kind=8), DIMENSION(8), INTENT(IN) :: x,y,z

    ! Compute Volume of Hexahedron
    volumeOfHex = &
         (x(7)-x(1))*((y(4)-y(1))*(z(3)-z(8)) - (y(3)-y(8))*(z(4)-z(1)))+&
         (x(4)-x(1))*((y(3)-y(8))*(z(7)-z(1)) - (y(7)-y(1))*(z(3)-z(8)))+&
         (x(3)-x(8))*((y(7)-y(1))*(z(4)-z(1)) - (y(4)-y(1))*(z(7)-z(1)))&
         +&
         (x(7)-x(1))*((y(5)-y(1))*(z(8)-z(6)) - (y(8)-y(6))*(z(5)-z(1)))+&
         (x(5)-x(1))*((y(8)-y(6))*(z(7)-z(1)) - (y(7)-y(1))*(z(8)-z(6)))+&
         (x(8)-x(6))*((y(7)-y(1))*(z(5)-z(1)) - (y(5)-y(1))*(z(7)-z(1)))&
         +&
         (x(7)-x(1))*((y(2)-y(1))*(z(6)-z(3)) - (y(6)-y(3))*(z(2)-z(1)))+&
         (x(2)-x(1))*((y(6)-y(3))*(z(7)-z(1)) - (y(7)-y(1))*(z(6)-z(3)))+&
         (x(6)-x(3))*((y(7)-y(1))*(z(2)-z(1)) - (y(2)-y(1))*(z(7)-z(1)))
    volumeOfHex = ABS(volumeOfHex)/6.d0
    RETURN
  END FUNCTION volumeOfHex

  !---------------------------------------------------------------------------
  ! Name: mapc2pWrapper(xc,yc,zc,mx,my,mz,xyz0,xyzN,mapType,xp,yp,zp)
  !
  ! Description: mapping from computational to physical space
  !
  ! Inputs:
  !        xc,yc,zc <REAL>     : computational coordinate values
  !        mx,my,mz <INTEGER>  : grid sizes
  !        xyz0,xyzN <REAL>    : altitude at bottom and top of grid
  !        mapType <CHARACTER> : type of mapping to compute
  !
  ! Outputs:
  !        xp,yp,zp <REAL>     : physical coordinate values
  !---------------------------------------------------------------------------
  SUBROUTINE mapc2pWrapper(xc,yc,zc,mz,xyz0,xyzN,mapType,xp,yp,zp)

    IMPLICIT NONE

    ! Input
    REAL(kind=8), DIMENSION(:), INTENT(IN) :: xc,yc,zc
    REAL(kind=8), DIMENSION(3), INTENT(IN) :: xyz0,xyzN
    INTEGER, INTENT(IN) :: mz
    CHARACTER(20) :: mapType

    ! Output
    REAL(kind=8), DIMENSION(SIZE(xc)), INTENT(OUT) :: xp
    REAL(kind=8), DIMENSION(SIZE(yc)), INTENT(OUT) :: yp
    REAL(kind=8), DIMENSION(SIZE(zc)), INTENT(OUT) :: zp

    ! Compute Physical Grid From Computational
    SELECT CASE(mapType)
    CASE("Identity")
       CALL mapc2pIdentity(xc,yc,zc,xp,yp,zp)
    CASE("ZeroToOne")
       CALL mapc2pZeroToOne(xc,yc,zc,xyz0,xyzN,xp,yp,zp)
    CASE("Rotate")
       CALL mapc2pRotate(xc,yc,zc,xyz0,xyzN,xp,yp,zp)
    CASE("Spherical")
       CALL mapc2pSpherical(xc,yc,zc,xyz0,xyzN,xp,yp,zp)
    CASE DEFAULT
       WRITE(*,*)"Invalid mapType: ",mapType
       STOP
    END SELECT

    RETURN
  END SUBROUTINE mapc2pWrapper

  !---------------------------------------------------------------------------
  ! Name: mapc2pIdentity(xc,yc,zc,xp,yp,zp)
  !
  ! Description: Identity mapping from computational to physical space
  !
  ! Inputs:
  !        xc,yc,zc <REAL>     : computational coordinate values
  ! Outputs:
  !        xp,yp,zp <REAL>     : physical coordinate values
  !---------------------------------------------------------------------------
  SUBROUTINE mapc2pIdentity(xc,yc,zc,xp,yp,zp)

    IMPLICIT NONE

    ! Input
    REAL(kind=8), DIMENSION(:), INTENT(IN) :: xc,yc,zc

    ! Output
    REAL(kind=8), DIMENSION(SIZE(xc)), INTENT(OUT) :: xp
    REAL(kind=8), DIMENSION(SIZE(yc)), INTENT(OUT) :: yp
    REAL(kind=8), DIMENSION(SIZE(zc)), INTENT(OUT) :: zp

    ! x,xi coordinate
    xp = xc

    ! y,eta coordinate
    yp = yc

    ! z,phi coordinate
    zp = zc

    RETURN
  END SUBROUTINE mapc2pIdentity

  !---------------------------------------------------------------------------
  ! Name: mapc2pZeroToOne(xc,yc,zc,xyz0,xyzN,xp,yp,zp)
  !
  ! Description: mapping from computational to physical space using a
  !                computational grid from 0 to 1
  !
  ! Inputs:
  !        xc,yc,zc <REAL>     : computational coordinate values
  !        xyz0,xyzN <REAL>    : physical coordinates at bottom and top of grid
  !
  ! Outputs:
  !        xp,yp,zp <REAL>     : physical coordinate values
  !---------------------------------------------------------------------------
  SUBROUTINE mapc2pZeroToOne(xc,yc,zc,xyz0,xyzN,xp,yp,zp)

    IMPLICIT NONE

    ! Input
    REAL(kind=8), DIMENSION(:), INTENT(IN) :: xc,yc,zc
    REAL(kind=8), DIMENSION(3), INTENT(IN) :: xyz0,xyzN

    ! Output
    REAL(kind=8), DIMENSION(SIZE(xc)), INTENT(OUT) :: xp
    REAL(kind=8), DIMENSION(SIZE(yc)), INTENT(OUT) :: yp
    REAL(kind=8), DIMENSION(SIZE(zc)), INTENT(OUT) :: zp

    ! x,xi coordinate
    xp = xyz0(1) + xc*(xyzN(1)-xyz0(1))

    ! y,eta coordinate
    yp = xyz0(2) + yc*(xyzN(2)-xyz0(2))

    ! z,phi coordinate
    zp = xyz0(3) + zc*(xyzN(3)-xyz0(3))

    RETURN
  END SUBROUTINE mapc2pZeroToOne

  !---------------------------------------------------------------------------
  ! Name: mapc2pRotate(xc,yc,zc,xyz0,xyzN,xp,yp,zp)
  !
  ! Description: mapping from computational to physical space using a
  !                computational grid from 0 to 1 and rotated by angle theta
  !
  ! Inputs:
  !        xc,yc,zc <REAL>     : computational coordinate values
  !        xyz0,xyzN <REAL>    : physical coordinates at bottom and top of grid
  !
  ! Outputs:
  !        xp,yp,zp <REAL>     : physical coordinate values
  !---------------------------------------------------------------------------
  SUBROUTINE mapc2pRotate(xc,yc,zc,xyz0,xyzN,xp,yp,zp)

    IMPLICIT NONE

    ! Input
    REAL(kind=8), DIMENSION(:), INTENT(IN) :: xc,yc,zc
    REAL(kind=8), DIMENSION(3), INTENT(IN) :: xyz0,xyzN

    ! Output
    REAL(kind=8), DIMENSION(SIZE(xc)), INTENT(OUT) :: xp
    REAL(kind=8), DIMENSION(SIZE(yc)), INTENT(OUT) :: yp
    REAL(kind=8), DIMENSION(SIZE(zc)), INTENT(OUT) :: zp

    ! Local
    REAL(kind=8) :: theta
    REAL(kind=8), DIMENSION(SIZE(xc)) :: xp0
    REAL(kind=8), DIMENSION(SIZE(yc)) :: yp0
    REAL(kind=8), DIMENSION(SIZE(zc)) :: zp0

    theta=0.d0*pi/180.d0

    ! x,xi coordinate
    xp = xyz0(1) + xc*(xyzN(1)-xyz0(1))

    ! y,eta coordinate
    yp = xyz0(2) + yc*(xyzN(2)-xyz0(2))

    ! z,phi coordinate
    zp = xyz0(3) + zc*(xyzN(3)-xyz0(3))

    xp0 = xp
    yp0 = yp
    zp0 = zp
    ! Rotate about x-axis by angle theta
    xp = xp0
    yp = yp0*COS(theta) - zp0*SIN(theta)
    zp = yp0*SIN(theta) + zp0*COS(theta)

    xp0 = xp
    yp0 = yp
    zp0 = zp
    ! Rotate about y-axis by angle theta
    xp = xp0*COS(theta) + zp0*SIN(theta)
    yp = yp0
    zp =-xp0*SIN(theta) + zp0*COS(theta)

    xp0 = xp
    yp0 = yp
    zp0 = zp
    ! Rotate about z-axis by angle theta
    xp = xp0*COS(theta) - yp0*SIN(theta)
    yp = xp0*SIN(theta) + yp0*COS(theta)
    zp = zp0

    RETURN
  END SUBROUTINE mapc2pRotate

  !---------------------------------------------------------------------------
  ! Name: mapc2pSpherical(xc,yc,zc,xyz0,xyzN,xp,yp,zp)
  !
  ! Description: mapping from computational to physical space using a
  !                computational grid from 0 to 1 and then using a
  !                spherical transformation
  !
  ! Inputs:
  !        xc,yc,zc <REAL>     : computational coordinate values
  !        xyz0,xyzN <REAL>    : physical coordinates at bottom and top of grid
  !
  ! Outputs:
  !        xp,yp,zp <REAL>     : physical coordinate values
  !---------------------------------------------------------------------------
  SUBROUTINE mapc2pSpherical(xc,yc,zc,xyz0,xyzN,xp,yp,zp)

    IMPLICIT NONE

    ! Input
    REAL(kind=8), DIMENSION(:), INTENT(IN) :: xc,yc,zc
    REAL(kind=8), DIMENSION(3), INTENT(IN) :: xyz0,xyzN

    ! Output
    REAL(kind=8), DIMENSION(SIZE(xc)), INTENT(OUT) :: xp
    REAL(kind=8), DIMENSION(SIZE(yc)), INTENT(OUT) :: yp
    REAL(kind=8), DIMENSION(SIZE(zc)), INTENT(OUT) :: zp

    ! Local
    REAL(kind=8), DIMENSION(SIZE(xc)) :: theta
    REAL(kind=8), DIMENSION(SIZE(yc)) :: phi
    REAL(kind=8), DIMENSION(SIZE(zc)) :: r

    ! x,xi coordinate
    xp = xyz0(1) + xc*(xyzN(1)-xyz0(1))

    ! y,eta coordinate
    yp = xyz0(2) + yc*(xyzN(2)-xyz0(2))

    ! z,phi coordinate
    zp = xyz0(3) + zc*(xyzN(3)-xyz0(3))

    ! Spherical to Cartesian Coordinates
    theta = xp
    phi = yp
    r = zp
    xp = r*SIN(theta)*COS(phi)
    yp = r*SIN(theta)*SIN(phi)
    zp = r*COS(theta)

    RETURN
  END SUBROUTINE mapc2pSpherical

  !---------------------------------------------------------------------------
  ! Name: determinant(A,detA)
  !
  ! Description: Compute the determinant of a 3x3 array
  !
  ! Inputs:  A <REAL>    : 3x3 Array
  !
  ! Outputs: detA <REAL> : determinant of A
  !---------------------------------------------------------------------------
  SUBROUTINE determinant(A,detA)

    IMPLICIT NONE

    ! Input
    REAL(kind=8), DIMENSION(3,3), INTENT(IN) :: A

    ! Output
    REAL(kind=8), INTENT(OUT) :: detA

    detA = A(1,1)*A(2,2)*A(3,3) &
         + A(2,1)*A(3,2)*A(1,3) &
         + A(3,1)*A(1,2)*A(2,3) &
         - A(3,1)*A(2,2)*A(1,3) &
         - A(2,1)*A(1,2)*A(3,3) &
         - A(1,1)*A(3,2)*A(2,3)

    RETURN
  END SUBROUTINE determinant

  !---------------------------------------------------------------------------
  ! Name: unitNormal(a,b,c,n)
  !
  ! Description: Compute the unit normal of given 3 indices in 3D space
  !
  ! Inputs:  a,b,c <REAL> : indices with x,y, and z coordinates
  !
  ! Outputs: n <REAL>     : unit normals of plane defined from points a,b,c
  !---------------------------------------------------------------------------
  SUBROUTINE unitNormal(a,b,c,n)

    IMPLICIT NONE

    ! Input
    REAL(kind=8), DIMENSION(3), INTENT(IN) :: a,b,c

    ! Output
    REAL(kind=8), DIMENSION(3), INTENT(OUT) :: n

    ! Local
    REAL(kind=8), DIMENSION(3,3) :: D
    REAL(kind=8) :: magnitude

    D(:,1) = (/1.d0,a(2),a(3)/)
    D(:,2) = (/1.d0,b(2),b(3)/)
    D(:,3) = (/1.d0,c(2),c(3)/)
    CALL determinant(D,n(1))
    D(:,1) = (/a(1),1.d0,a(3)/)
    D(:,2) = (/b(1),1.d0,b(3)/)
    D(:,3) = (/c(1),1.d0,c(3)/)
    CALL determinant(D,n(2))
    D(:,1) = (/a(1),a(2),1.d0/)
    D(:,2) = (/b(1),b(2),1.d0/)
    D(:,3) = (/c(1),c(2),1.d0/)
    CALL determinant(D,n(3))

    magnitude = SQRT(n(1)**2 + n(2)**2 + n(3)**2)
    n(1) = n(1)/magnitude
    n(2) = n(2)/magnitude
    n(3) = n(3)/magnitude

    RETURN
  END SUBROUTINE unitNormal

  !---------------------------------------------------------------------------
  ! Name: dot(a,b,adotb)
  !
  ! Description: Compute the dot product of vectors a and b
  !
  ! Inputs:  a,b <REAL>   : 3D vectors
  !
  ! Outputs: adotb <REAL> : dot product of a and b
  !---------------------------------------------------------------------------
  SUBROUTINE dot(a,b,adotb)

    IMPLICIT NONE

    ! Input
    REAL(kind=8), DIMENSION(3), INTENT(IN) :: a,b

    ! Output
    REAL(kind=8), INTENT(OUT) :: adotb

    adotb = a(1)*b(1) + a(2)*b(2) + a(3)*b(3)

    RETURN
  END SUBROUTINE dot

  !---------------------------------------------------------------------------
  ! Name: cross(a,b,c)
  !
  ! Description: Compute the cross product of vectors a and b
  !
  ! Inputs:  a,b <REAL> : 3D vectors
  !
  ! Outputs: c <REAL>   : cross product of a and b
  !---------------------------------------------------------------------------
  SUBROUTINE cross(a,b,c)

    IMPLICIT NONE

    ! Input
    REAL(kind=8), DIMENSION(3), INTENT(IN) :: a,b

    ! Output
    REAL(kind=8), DIMENSION(3), INTENT(OUT) :: c

    c(1) = a(2)*b(3) - a(3)*b(2)
    c(2) = a(3)*b(1) - a(1)*b(3)
    c(3) = a(1)*b(2) - a(2)*b(1)

    RETURN
  END SUBROUTINE cross

  !---------------------------------------------------------------------------
  ! Name: areaPolygon(poly)
  !
  ! Description: Compute the area of a polygon given its vertices
  !
  ! Inputs:  poly <REAL> : vertices of polygon
  !
  ! Outputs: area <REAL> : area of polygon
  !---------------------------------------------------------------------------
  SUBROUTINE areaPolygon(poly,polyArea)

    IMPLICIT NONE

    ! Input
    REAL(kind=8), DIMENSION(:,:), INTENT(IN) :: poly

    ! Output
    REAL(kind=8), INTENT(OUT) :: polyArea

    ! Local
    INTEGER :: i,np
    REAL(kind=8), DIMENSION(3) :: total,prod,vi1,vi2,n

    ! Compute Area of a Polygon Given its Vertices
    np = SIZE(poly,2)
    IF(np < 3)THEN
       WRITE(*,*)"This is not a polygon, no area"
       STOP
    END IF
    total=0
    DO i = 1,np
       vi1 = poly(:,i)
       IF(i == np)THEN
          vi2 = poly(:,1)
       ELSE
          vi2 = poly(:,i+1)
       END IF
       CALL cross(vi1,vi2,prod)
       total(1) = total(1) + prod(1)
       total(2) = total(2) + prod(2)
       total(3) = total(3) + prod(3)
    END DO
    CALL unitNormal(poly(:,1),poly(:,2),poly(:,3),n)
    CALL dot(total,n,polyArea)
    polyArea = ABS(polyArea*0.5d0)

    RETURN
  END SUBROUTINE areaPolygon

  !---------------------------------------------------------------------------
  ! Name: setAuxiliaryVariables(num_aux,mbc,mx,my,mz,xlower,ylower,zlower,&
  !                             dxc,dyc,dzc,xyz0,xyzN,aux)
  !
  ! Description: Compute auxiliary variables for non-uniform/mapped grids
  !
  ! Inputs:
  !         xc,yc,zc <REAL>    : computational coordinate values
  !         mx,my,mz <INTEGER> : grid sizes
  !         xyz0,xyzN <REAL>   : altitude at bottom and top of grid
  !
  ! Outputs:
  !         xp,yp,zp <REAL>    : physical coordinate values
  !---------------------------------------------------------------------------
  SUBROUTINE setAuxiliaryVariables(num_aux,mbc,mx,my,mz,xlower,ylower,zlower,&
       dxc,dyc,dzc,xyz0,xyzN,mapType,aux)

    IMPLICIT NONE

    ! Input
    INTEGER, INTENT(IN) :: num_aux,mbc,mx,my,mz
    REAL(kind=8), INTENT(IN) :: xlower,ylower,zlower,dxc,dyc,dzc
    REAL(kind=8), DIMENSION(3), INTENT(IN) :: xyz0,xyzN
    CHARACTER(20) :: mapType

    ! Output
    REAL(kind=8), DIMENSION(num_aux,mx+2*mbc,my+2*mbc,mz+2*mbc), &
         INTENT(OUT) :: aux

    ! Local
    REAL(kind=8), DIMENSION(3) :: norm
    REAL(kind=8), DIMENSION(3,4) :: poly
    REAL(kind=8), DIMENSION(8) :: xcCorner,ycCorner,zcCorner,&
         xpCorner,ypCorner,zpCorner
    INTEGER :: i,j,k
    REAL(kind=8) :: vHex,area
    REAL(kind=8), DIMENSION(1) :: xc,yc,zc,xp,yp,zp

    ! Compute Auxiliary Variables
    DO i = 1,mx+2*mbc
       DO j = 1,my+2*mbc
          DO k = 1,mz+2*mbc

             ! Compute Physical Coordinates of Corners of Hexahedron

             ! i-1/2, j-1/2, k-1/2 Corner
             xcCorner(1) = xlower + (i-1)*dxc
             ycCorner(1) = ylower + (j-1)*dyc
             zcCorner(1) = zlower + (k-1)*dzc
             xc(1) = xcCorner(1)
             yc(1) = ycCorner(1)
             zc(1) = zcCorner(1)
             CALL mapc2pWrapper(xc,yc,zc,mz,xyz0,xyzN,mapType,xp,yp,zp)
             xpCorner(1) = xp(1)
             ypCorner(1) = yp(1)
             zpCorner(1) = zp(1)

             ! i+1/2, j-1/2, k-1/2 Corner
             xcCorner(2) = xcCorner(1) + dxc
             ycCorner(2) = ycCorner(1)
             zcCorner(2) = zcCorner(1)
             xc(1) = xcCorner(2)
             yc(1) = ycCorner(2)
             zc(1) = zcCorner(2)
             CALL mapc2pWrapper(xc,yc,zc,mz,xyz0,xyzN,mapType,xp,yp,zp)
             xpCorner(2) = xp(1)
             ypCorner(2) = yp(1)
             zpCorner(2) = zp(1)

             ! i+1/2, j+1/2, k-1/2 Corner
             xcCorner(3) = xcCorner(1) + dxc
             ycCorner(3) = ycCorner(1) + dyc
             zcCorner(3) = zcCorner(1)
             xc(1) = xcCorner(3)
             yc(1) = ycCorner(3)
             zc(1) = zcCorner(3)
             CALL mapc2pWrapper(xc,yc,zc,mz,xyz0,xyzN,mapType,xp,yp,zp)
             xpCorner(3) = xp(1)
             ypCorner(3) = yp(1)
             zpCorner(3) = zp(1)

             ! i-1/2, j+1/2, k-1/2 Corner
             xcCorner(4) = xcCorner(1)
             ycCorner(4) = ycCorner(1) + dyc
             zcCorner(4) = zcCorner(1)
             xc(1) = xcCorner(4)
             yc(1) = ycCorner(4)
             zc(1) = zcCorner(4)
             CALL mapc2pWrapper(xc,yc,zc,mz,xyz0,xyzN,mapType,xp,yp,zp)
             xpCorner(4) = xp(1)
             ypCorner(4) = yp(1)
             zpCorner(4) = zp(1)

             ! i-1/2, j-1/2, k+1/2 Corner
             xcCorner(5) = xcCorner(1)
             ycCorner(5) = ycCorner(1)
             zcCorner(5) = zcCorner(1) + dzc
             xc(1) = xcCorner(5)
             yc(1) = ycCorner(5)
             zc(1) = zcCorner(5)
             CALL mapc2pWrapper(xc,yc,zc,mz,xyz0,xyzN,mapType,xp,yp,zp)
             xpCorner(5) = xp(1)
             ypCorner(5) = yp(1)
             zpCorner(5) = zp(1)

             ! i+1/2, j-1/2, k+1/2 Corner
             xcCorner(6) = xcCorner(1) + dxc
             ycCorner(6) = ycCorner(1)
             zcCorner(6) = zcCorner(1) + dzc
             xc(1) = xcCorner(6)
             yc(1) = ycCorner(6)
             zc(1) = zcCorner(6)
             CALL mapc2pWrapper(xc,yc,zc,mz,xyz0,xyzN,mapType,xp,yp,zp)
             xpCorner(6) = xp(1)
             ypCorner(6) = yp(1)
             zpCorner(6) = zp(1)

             ! i+1/2, j+1/2, k+1/2 Corner
             xcCorner(7) = xcCorner(1) + dxc
             ycCorner(7) = ycCorner(1) + dyc
             zcCorner(7) = zcCorner(1) + dzc
             xc(1) = xcCorner(7)
             yc(1) = ycCorner(7)
             zc(1) = zcCorner(7)
             CALL mapc2pWrapper(xc,yc,zc,mz,xyz0,xyzN,mapType,xp,yp,zp)
             xpCorner(7) = xp(1)
             ypCorner(7) = yp(1)
             zpCorner(7) = zp(1)

             ! i-1/2, j+1/2, k+1/2 Corner
             xcCorner(8) = xcCorner(1)
             ycCorner(8) = ycCorner(1) + dyc
             zcCorner(8) = zcCorner(1) + dzc
             xc(1) = xcCorner(8)
             yc(1) = ycCorner(8)
             zc(1) = zcCorner(8)
             CALL mapc2pWrapper(xc,yc,zc,mz,xyz0,xyzN,mapType,xp,yp,zp)
             xpCorner(8) = xp(1)
             ypCorner(8) = yp(1)
             zpCorner(8) = zp(1)

             ! Compute Aux Variables (Normals/Area Ratios/Volume Ratio)

             ! \xi normal
             poly(:,1) = (/xpCorner(1),ypCorner(1),zpCorner(1)/)
             poly(:,2) = (/xpCorner(4),ypCorner(4),zpCorner(4)/)
             poly(:,3) = (/xpCorner(8),ypCorner(8),zpCorner(8)/)
             poly(:,4) = (/xpCorner(5),ypCorner(5),zpCorner(5)/)
             CALL unitNormal(poly(:,1),poly(:,2),poly(:,3),norm)
             aux(1,i,j,k) = norm(1) ! nx(i-1/2,j,k)
             aux(2,i,j,k) = norm(2) ! ny(i-1/2,j,k)
             aux(3,i,j,k) = norm(3) ! nz(i-1/2,j,k)
             CALL areaPolygon(poly,area)
             aux(4,i,j,k) = area/(dyc*dzc) ! gamma(i-1/2,j,k)

             ! \eta normal
             poly(:,1) = (/xpCorner(1),ypCorner(1),zpCorner(1)/)
             poly(:,2) = (/xpCorner(5),ypCorner(5),zpCorner(5)/)
             poly(:,3) = (/xpCorner(6),ypCorner(6),zpCorner(6)/)
             poly(:,4) = (/xpCorner(2),ypCorner(2),zpCorner(2)/)
             CALL unitNormal(poly(:,1),poly(:,2),poly(:,3),norm)
             aux(5,i,j,k) = norm(1) ! nx(i,j-1/2,k)
             aux(6,i,j,k) = norm(2) ! ny(i,j-1/2,k)
             aux(7,i,j,k) = norm(3) ! nz(i,j-1/2,k)
             CALL areaPolygon(poly,area)
             aux(8,i,j,k) = area/(dxc*dzc) ! gamma(i,j-1/2,k)

             ! \phi normal
             poly(:,1) = (/xpCorner(1),ypCorner(1),zpCorner(1)/)
             poly(:,2) = (/xpCorner(2),ypCorner(2),zpCorner(2)/)
             poly(:,3) = (/xpCorner(3),ypCorner(3),zpCorner(3)/)
             poly(:,4) = (/xpCorner(4),ypCorner(4),zpCorner(4)/)
             CALL unitNormal(poly(:,1),poly(:,2),poly(:,3),norm)
             aux(9,i,j,k) =  norm(1) ! nx(i,j,k-1/2)
             aux(10,i,j,k) = norm(2) ! ny(i,j,k-1/2)
             aux(11,i,j,k) = norm(3) ! nz(i,j,k-1/2)
             CALL areaPolygon(poly,area)
             aux(12,i,j,k) = area/(dxc*dyc) ! gamma(i,j,k-1/2)

             ! Volume of hexahedron
             vHex = volumeOfHex(xpCorner,ypCorner,zpCorner)

             ! Capacity Function (Ratio of Physical:Computational volume)
             aux(13,i,j,k) = vHex/(dxc*dyc*dzc) ! kappa(i,j,k)

             ! Grid Delta in Direction of Gravity
             SELECT CASE(mapType)
             CASE("Identity","ZeroToOne","Rotate")
                aux(14,i,j,k) = ABS(zpCorner(5)-zpCorner(1)) ! dz
                aux(15,i,j,k) = (zpCorner(5) + zpCorner(1))/2.d0 ! z
             CASE("Spherical")
                aux(14,i,j,k) = &
                     ABS(SQRT(xpCorner(5)**2+ypCorner(5)**2+zpCorner(5)**2) &
                     - SQRT(xpCorner(1)**2+ypCorner(1)**2+zpCorner(1)**2)) ! dr
                aux(15,i,j,k) = (SQRT(xpCorner(5)**2+ypCorner(5)**2+zpCorner(5)**2) &
                     + SQRT(xpCorner(1)**2+ypCorner(1)**2+zpCorner(1)**2))/2.d0 &
                     - rEarth
             END SELECT

          END DO
       END DO
    END DO

    RETURN
  END SUBROUTINE setAuxiliaryVariables

END MODULE euler3d_mappedgrid


MODULE random
    ! A module for random number generation from the following distributions:
    !
    !     Distribution                    Function/subroutine name
    !
    !     Normal (Gaussian)               random_normal
    !     Gamma                           random_gamma
    !     Chi-squared                     random_chisq
    !     Exponential                     random_exponential
    !     Weibull                         random_Weibull
    !     Beta                            random_beta
    !     t                               random_t
    !     Multivariate normal             random_mvnorm
    !     Generalized inverse Gaussian    random_inv_gauss
    !     Poisson                         random_Poisson
    !     Binomial                        random_binomial1   *
    !                                     random_binomial2   *
    !     Negative binomial               random_neg_binomial
    !     von Mises                       random_von_Mises
    !     Cauchy                          random_Cauchy
    !
    !  Generate a random ordering of the integers 1 .. N
    !                                     random_order
    !     Initialize (seed) the uniform random number generator for ANY compiler
    !                                     seed_random_number

    !     Lognormal - see note below.

    !  ** Two functions are provided for the binomial distribution.
    !  If the parameter values remain constant, it is recommended that the
    !  first function is used (random_binomial1).   If one or both of the
    !  parameters change, use the second function (random_binomial2).

    ! The compilers own random number generator, SUBROUTINE RANDOM_NUMBER(r),
    ! is used to provide a source of uniformly distributed random numbers.

    ! N.B. At this stage, only one random number is generated at each call to
    !      one of the functions above.

    ! The module uses the following functions which are included here:
    ! bin_prob to calculate a single binomial probability
    ! lngamma  to calculate the logarithm to base e of the gamma function

    ! Some of the code is adapted from Dagpunar's book:
    !     Dagpunar, J. 'Principles of random variate generation'
    !     Clarendon Press, Oxford, 1988.   ISBN 0-19-852202-9
    !
    ! In most of Dagpunar's routines, there is a test to see whether the value
    ! of one or two floating-point parameters has changed since the last call.
    ! These tests have been replaced by using a logical variable FIRST.
    ! This should be set to .TRUE. on the first call using new values of the
    ! parameters, and .FALSE. if the parameter values are the same as for the
    ! previous call.

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Lognormal distribution
    ! If X has a lognormal distribution, then log(X) is normally distributed.
    ! Here the logarithm is the natural logarithm, that is to base e, sometimes
    ! denoted as ln.  To generate random variates from this distribution, generate
    ! a random deviate from the normal distribution with mean and variance equal
    ! to the mean and variance of the logarithms of X, then take its exponential.

    ! Relationship between the mean & variance of log(X) and the mean & variance
    ! of X, when X has a lognormal distribution.
    ! Let m = mean of log(X), and s^2 = variance of log(X)
    ! Then
    ! mean of X     = exp(m + 0.5s^2)
    ! variance of X = (mean(X))^2.[exp(s^2) - 1]

    ! In the reverse direction (rarely used)
    ! variance of log(X) = log[1 + var(X)/(mean(X))^2]
    ! mean of log(X)     = log(mean(X) - 0.5var(log(X))

    ! N.B. The above formulae relate to population parameters; they will only be
    !      approximate if applied to sample values.
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! Version 1.13, 2 October 2000
    ! Changes from version 1.01
    ! 1. The random_order, random_Poisson & random_binomial routines have been
    !    replaced with more efficient routines.
    ! 2. A routine, seed_random_number, has been added to seed the uniform random
    !    number generator.   This requires input of the required number of seeds
    !    for the particular compiler from a specified I/O unit such as a keyboard.
    ! 3. Made compatible with Lahey's ELF90.
    ! 4. Marsaglia & Tsang algorithm used for random_gamma when shape parameter > 1.
    ! 5. INTENT for array f corrected in random_mvnorm.

    !     Author: Alan Miller
    !     e-mail: amiller @ bigpond.net.au

    IMPLICIT NONE
    REAL, PRIVATE      :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0,   &
        vsmall = TINY(1.0), vlarge = HUGE(1.0)
    !PRIVATE            :: integral
    INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12, 60)

CONTAINS

    FUNCTION random_normal() RESULT(fn_val)

        ! Adapted from the following Fortran 77 code
        !      ALGORITHM 712, COLLECTED ALGORITHMS FROM ACM.
        !      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
        !      VOL. 18, NO. 4, DECEMBER, 1992, PP. 434-435.

        !  The function random_normal() returns a normally distributed pseudo-random
        !  number with zero mean and unit variance.

        !  The algorithm uses the ratio of uniforms method of A.J. Kinderman
        !  and J.F. Monahan augmented with quadratic bounding curves.

        REAL :: fn_val

        !     Local variables
        REAL     :: s = 0.449871, t = -0.386595, a = 0.19600, b = 0.25472,    &
            r1 = 0.27597, r2 = 0.27846, u, v, x, y, q

        !     Generate P = (u,v) uniform in rectangle enclosing acceptance region

        DO
            CALL RANDOM_NUMBER(u)
            CALL RANDOM_NUMBER(v)
            v = 1.7156 * (v - half)

            !     Evaluate the quadratic form
            x = u - s
            y = ABS(v) - t
            q = x**2 + y*(a*y - b*x)

            !     Accept P if inside inner ellipse
            IF (q < r1) EXIT
            !     Reject P if outside outer ellipse
            IF (q > r2) CYCLE
            !     Reject P if outside acceptance region
            IF (v**2 < -4.0*LOG(u)*u**2) EXIT
        END DO

        !     Return ratio of P's coordinates as the normal deviate
        fn_val = v/u
        RETURN

    END FUNCTION random_normal

END MODULE random


!*****************************************************************************************
!>
!  Test of [[dbint4]] routine

    program dbint4_test

    use bspline_module
    use bspline_kinds_module, only: wp,ip
    use pyplot_module
    use, intrinsic :: iso_fortran_env

    implicit none

    integer(ip),parameter :: nx = 7     !! number of points in x
    integer(ip),parameter :: kx = 4     !! order in x

    logical,parameter :: extrap = .true.
    real(wp),parameter :: rad2deg = 180.0_wp / acos(-1.0_wp)  !! deg. to radians conversion factor

    real(wp) :: x(nx)
    real(wp),dimension(:),allocatable :: xval,fval  !(nx+2)
    real(wp) :: fcn_1d(nx)
    real(wp),dimension(:),allocatable :: tx      !(nx+2+kx)
    real(wp),dimension(:),allocatable :: bcoef   !(nx+2)
    real(wp) :: tol,val,tru,err,errmax,fbcr,fbcl
    logical  :: fail
    integer(ip)  :: n,i,idx,iflag,inbvx,ibcl,ibcr,kntopt
    real(wp),dimension(5,nx+2) :: w
    type(pyplot) :: plt
    integer :: istat
    integer :: icase
    real(wp),dimension(3) :: tleft, tright
    real(wp),dimension(3*kx) :: w1_1d

    character(len=*),dimension(7),parameter :: labels = ['not-a-knot [db1ink]          ', &
                                                         '2nd der=0, kntopt=1 [dbint4] ', &
                                                         '1st der=0, kntopt=1 [dbint4] ', &
                                                         '2nd der=0, kntopt=2 [dbint4] ', &
                                                         '1st der=0, kntopt=2 [dbint4] ', &
                                                         '2nd der=0, kntopt=3 [dbint4] ', &
                                                         '1st der=0, kntopt=3 [dbint4] ']
    character(len=*),dimension(7),parameter :: linestyles = ['r-', &
                                                             'g-', &
                                                             'b-', &
                                                             'c-', &
                                                             'm-', &
                                                             'c:', &
                                                             'm:' ]

    fail   = .false.
    tol    = 100 * epsilon(1.0_wp)
    idx    = 0
    x      = real([1,2,3,4,5,6,7], wp)  ! nx points
    fcn_1d = f1(x)

    !initialize the plot:
    call plt%initialize(grid=.true.,xlabel='x (deg)',ylabel='f(x)',&
                        title='B-Spline End Conditions',legend=.true.)
    call plt%add_plot(real(x*rad2deg,real64),real(fcn_1d,real64),&
                        label='Function $f(x) = \sin(x)$',&
                        linestyle='ko',markersize=5,linewidth=2,istat=istat)

    if (extrap) then
        ! points to evaluate [with extrapolation]:
        xval = real([(real(i)/100.0_wp, i=50, 750)], wp)
    else
        ! points to evaluate [no extrapolation]:
        xval = real([(real(i)/100.0_wp, i=100, 700, 10)], wp)
    end if
    allocate(fval(size(xval)))

    do icase = 1, 7

        write(*,*) ''
        write(*,*) '==============================================='
        write(*,'(I3,1X,A)') icase, ' ... '//trim(labels(icase))//' ... '

        ! 1 - use db1ink
        ! 2 - use dbint4 - constrain 2nd derivative, kntopt = 1
        ! 3 - use dvint4 - constrain 1st derivative, kntopt = 1
        ! 4 - use dbint4 - constrain 2nd derivative, kntopt = 2
        ! 5 - use dvint4 - constrain 1st derivative, kntopt = 2
        ! 6 - use dbint4 - constrain 2nd derivative, kntopt = 3
        ! 7 - use dvint4 - constrain 1st derivative, kntopt = 3

        if (allocated(bcoef)) deallocate(bcoef)
        if (allocated(tx))    deallocate(tx)

        ! initialize
        ! write(*,*) '==============================================='
        ! write(*,*) 'initialize'
        ! write(*,*) '==============================================='
        if (icase==1) then
            ! use the original init routine
            allocate(bcoef(nx))
            allocate(tx(nx+kx))
            call db1ink(x,nx,fcn_1d,kx,0_ip,tx,bcoef,iflag)
        else
            ! use the dbint4 routine and specify the endpoint derivatives
            allocate(bcoef(nx+2))
            allocate(tx(nx+2+kx))
            if (icase==2 .or. icase==4 .or. icase==6) then
                ! constrain 2nd derivative
                ibcl = 2
                ibcr = 2
            else
                ! constrain 1st derivative
                ibcl = 1
                ibcr = 1
            end if
            fbcl = 0.0_wp
            fbcr = 0.0_wp

            write(*,*) 'kntopt:  ', kntopt

            ! WARNING: kntopt seems to have no effect on result for this example.

            select case (icase)
            case(2,3)
                kntopt = 1
                call db1ink(x,nx,fcn_1d,kx,ibcl,ibcr,fbcl,fbcr,kntopt,tx,bcoef,iflag)
            case(4,5)
                kntopt = 2
                call db1ink(x,nx,fcn_1d,kx,ibcl,ibcr,fbcl,fbcr,kntopt,tx,bcoef,iflag)
            case(6,7)
                kntopt = 3
                w = 0.0_wp
                ! WARNING: the knot values seem to make no difference in the result
                tleft  = [-999.0_wp,-999.0_wp,-999.0_wp]
                tright = [999.0_wp, 999.0_wp, 999.0_wp]
                call db1ink(x,nx,fcn_1d,kx,ibcl,ibcr,fbcl,fbcr,tleft,tright,tx,bcoef,iflag)
            end select

            write(*,*) ''
            write(*,*) 'x:  ', x
            write(*,*) ''
            write(*,*) 'tx: ', tx
            write(*,*) ''

        end if
        if (iflag/=0) then
            write(*,*) 'Error initializing 1D spline: '//get_status_message(iflag)
            stop
        end if

        ! compute max error at interpolation points
        ! write(*,*) ''
        ! write(*,*) '==============================================='
        ! write(*,*) 'db1val'
        ! write(*,*) '==============================================='

        inbvx = 1    !have to set this before the first evaluate call
        val = 0.0_wp
        errmax = 0.0_wp
        err = -99999.9_wp
        fval = 0.0_wp
        do i=1,size(xval)
            if (icase==1) then
                call db1val(xval(i),idx,tx,nx,kx,bcoef,val,iflag,inbvx,w1_1d,extrap=extrap)
            else
                call db1val(xval(i),idx,tx,nx+2,kx,bcoef,val,iflag,inbvx,w1_1d,extrap=extrap)
            end if
            fval(i) = val  ! save it for plot
            tru     = f1(xval(i))
            err     = abs(tru-val)
            errmax  = max(err,errmax)
            !write(*,*) '1D: xval(i),err = ', xval(i),err
            if (iflag/=0) then
                write(*,*) 'Error evaluating 1D spline: '//get_status_message(iflag)
                write(*,*) 'x = ', xval(i)
                stop
            end if
        end do
        !write(*,*) '==============================================='

        ! check max error against tolerance
        write(*,*) '1D: max error:', errmax
        if (errmax >= tol) then
            write(*,*)  ' ** test failed ** '
        else
            write(*,*)  ' ** test passed ** '
        end if
        !write(*,*) ''
        !write(*,*) '==============================================='

        call plt%add_plot(real(xval*rad2deg,real64),real(fval,real64),&
                label=trim(labels(icase)),&
                linestyle=linestyles(icase),linewidth=2,istat=istat)

    end do

    call plt%savefig('dbint4_test.png',istat=istat)

    contains

        pure elemental real(wp) function f1(x) !! 1d test function
        implicit none
        real(wp),intent(in) :: x
        f1 = sin(x)
        !f1 = 0.5_wp * (x*exp(-x) + sin(x) )
        end function f1

    end program dbint4_test


    MODULE random_beta_mod
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
    CONTAINS

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

      FUNCTION random_beta(a,b)
!**********************************************************************
!     REAL FUNCTION GENBET( A, B )
!               GeNerate BETa random deviate
!                              Function
!     Returns A_LOCAL single random deviate from the beta distribution with
!     parameters A_LOCAL and B_LOCAL.  The density of the beta is
!               x^(A_LOCAL-1) * (1-x)^(B_LOCAL-1) / B_LOCAL(A_LOCAL,B_LOCAL) for 0 < x < 1
!                              Arguments
!     A --> First parameter of the beta distribution
!                         REAL A_LOCAL
!     JJV                 (A_LOCAL > 1.0E-37)
!     B --> Second parameter of the beta distribution
!                         REAL B_LOCAL
!     JJV                 (B_LOCAL > 1.0E-37)
!                              Method
!     R. C. H. Cheng
!     Generating Beta Variates with Nonintegral Shape Parameters
!     Communications of the ACM, 21:317-322  (1978)
!     (Algorithms B and BC)
!**********************************************************************
!     JJV changed these to ridiculous values
! .. Use Statements ..
        USE random_standard_uniform_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Function Return Value ..
        REAL :: random_beta
! ..
! .. Parameters ..
        REAL, PARAMETER :: expmax = 87.49823, infnty = 1.0E38, &
          minlog = 1.0E-37
! ..
! .. Scalar Arguments ..
        REAL, INTENT (IN) :: a, b
! ..
! .. Local Scalars ..
        REAL, SAVE :: alpha, a_local, beta, b_local, gamma, k1, k2, olda, &
          oldb
        REAL :: delta, r, s, t, u1, u2, v, w, y, z
        LOGICAL :: qsame
! ..
! .. Intrinsic Functions ..
        INTRINSIC EXP, LOG, MAX, MIN, SQRT
! ..
! .. Data Statements ..
        DATA olda, oldb/ -1.0E37, -1.0E37/
! ..
! .. Executable Statements ..

        qsame = olda == a .AND. oldb == b
        IF ( .NOT. qsame) THEN
!     JJV added small minimum for small log problem in calc of W
          IF (a<minlog .OR. b<minlog) THEN
            WRITE (*,*) ' A or B < ', minlog, ' in GENBET - Abort!'
            WRITE (*,*) ' A: ', a, ' B ', b
            STOP ' A or B too small in GENBET - Abort!'
          END IF

          olda = a
          oldb = b
        END IF
        IF (MIN(a,b)>1.0) THEN

!     Algorithm B

!     Initialize

          IF ( .NOT. qsame) THEN
            a_local = MIN(a,b)
            b_local = MAX(a,b)
            alpha = a_local + b_local
            beta = SQRT((alpha-2.0)/(2.0*a_local*b_local-alpha))
            gamma = a_local + 1.0/beta
          END IF
10        CONTINUE
          u1 = random_standard_uniform()

!     Step 1

          u2 = random_standard_uniform()
          v = beta*LOG(u1/(1.0-u1))
!     JJV altered this
          IF (v>expmax) GO TO 20
!     JJV added checker to see if A_LOCAL*exp(v) will overflow
!     JJV 50 _was_ w = A_LOCAL*exp(v); also note here A_LOCAL > 1.0
          w = EXP(v)
          IF (w>infnty/a_local) GO TO 20
          w = a_local*w
          GO TO 30
20        CONTINUE
          w = infnty

30        CONTINUE
          z = u1**2*u2
          r = gamma*v - 1.3862944
          s = a_local + r - w

!     Step 2

          IF (s+2.609438>=5.0*z) GO TO 40

!     Step 3

          t = LOG(z)
          IF (s>t) GO TO 40

!     Step 4

!     JJV added checker to see if log(alpha/(B_LOCAL+w)) will
!     JJV overflow.  If so, we count the log as -INF, and
!     JJV consequently evaluate conditional as true, i.e.
!     JJV the algorithm rejects the trial and starts over
!     JJV May not need this here since ALPHA > 2.0
          IF (alpha/(b_local+w)<minlog) GO TO 10

          IF (r+alpha*LOG(alpha/(b_local+w))<t) GO TO 10

!     Step 5

40        CONTINUE
          IF (a==a_local) THEN
            random_beta = w/(b_local+w)
          ELSE

            random_beta = b_local/(b_local+w)
          END IF
        ELSE

!     Algorithm BC

!     Initialize

          IF ( .NOT. qsame) THEN
            a_local = MAX(a,b)
            b_local = MIN(a,b)
            alpha = a_local + b_local
            beta = 1.0/b_local
            delta = 1.0 + a_local - b_local
            k1 = delta*(0.0138889+0.0416667*b_local)/ &
              (a_local*beta-0.777778)
            k2 = 0.25 + (0.5+0.25/delta)*b_local
          END IF
50        CONTINUE
          u1 = random_standard_uniform()

!     Step 1

          u2 = random_standard_uniform()
          IF (u1<0.5) THEN

!     Step 2

            y = u1*u2
            z = u1*y
            IF (0.25*u2+z-y>=k1) GO TO 50
          ELSE

!     Step 3

            z = u1**2*u2
            IF (z<=0.25) THEN
              v = beta*LOG(u1/(1.0-u1))

!     JJV instead of checking v > expmax at top, I will check
!     JJV if A_LOCAL < 1, then check the appropriate values

              IF (a_local<=1.0) THEN
!     JJV A_LOCAL < 1 so it can help out if EXP(V) would overflow
                IF (v<=expmax) THEN
                  w = a_local*EXP(v)
                  GO TO 90
                END IF
                w = v + LOG(a_local)
                IF (w>expmax) GO TO 60
                w = EXP(w)
                GO TO 90
              END IF

!     JJV in this case A_LOCAL > 1
              IF (v>expmax) GO TO 60
              w = EXP(v)
              IF (w>infnty/a_local) GO TO 60
              w = a_local*w
              GO TO 90
60            CONTINUE
              w = infnty
              GO TO 90
            END IF

            IF (z>=k2) GO TO 50
          END IF

!     Step 4

!     Step 5

          v = beta*LOG(u1/(1.0-u1))

!     JJV same kind of checking as above
          IF (a_local<=1.0) THEN
!     JJV A_LOCAL < 1 so it can help out if EXP(V) would overflow
            IF (v<=expmax) THEN
              w = a_local*EXP(v)
              GO TO 80
            END IF
            w = v + LOG(a_local)
            IF (w>expmax) GO TO 70
            w = EXP(w)
            GO TO 80
          END IF

!     JJV in this case A_LOCAL > 1
          IF (v>expmax) GO TO 70
          w = EXP(v)
          IF (w>infnty/a_local) GO TO 70
          w = a_local*w
          GO TO 80

70        CONTINUE
          w = infnty

!     JJV here we also check to see if log overlows; if so, we treat it
!     JJV as -INF, which means condition is true, i.e. restart
80        CONTINUE
          IF (alpha/(b_local+w)<minlog) GO TO 50
          IF (alpha*(LOG(alpha/(b_local+w))+v)-1.3862944<LOG(z)) GO TO 50

!     Step 6

90        CONTINUE
          IF (a_local==a) THEN
            random_beta = w/(b_local+w)
          ELSE

            random_beta = b_local/(b_local+w)
          END IF
        END IF
        RETURN

      END FUNCTION random_beta

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

    END MODULE random_beta_mod


program converge_pi

   use iso_fortran_env

   implicit none

   integer, parameter :: knd = max(selected_real_kind(15), selected_real_kind(33))
   integer, parameter :: n = huge(1)/1000
   real(kind=knd), parameter :: pi_ref = 3.1415926535897932384626433832795028841971_knd

   integer :: i
   real(kind=knd) :: pi = 0.0, t

   print *, 'KIND      : ', knd
   print *, 'PRECISION : ', precision(pi)
   print *, 'RANGE     : ', range(pi)

   !$ACC PARALLEL LOOP PRIVATE(t) REDUCTION(+:pi)
   do i = 0, n - 1
      t = real(i + 0.5, kind=knd)/n
      pi = pi + 4.0*(1.0/(1.0 + t*t))
   end do
   !$ACC END PARALLEL LOOP

   print *, ""
   print *, "Number of terms in the series : ", n
   print *, "Computed value : ", pi/n
   print *, "Reference vaue : ", pi_ref
   print *, "ABS difference with reference : ", abs(pi_ref - pi/n)

end program converge_pi


      RECURSIVE FUNCTION factorial(num) RESULT(fact)
      USE stel_kinds
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: num
      REAL(rprec) :: fact
      INTEGER:: nfact

      IF(num == 1 .or. num == 0) THEN
         nfact = 1
      ELSE
         nfact = num*factorial(num-1)
      END IF

      fact = nfact

      END FUNCTION factorial