MODULE SIMPLE

  IMPLICIT NONE

CONTAINS

  !> @brief YAXPY point-wise operator performing Y = aX + Y (scalar a)
  SUBROUTINE YAXPY(numDim,numPoints,bufferSize,bufferInterval,a,X,Y)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: a,X(numPoints)
    REAL(KIND=8),    INTENT(INOUT)   :: Y(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Y(I) = Y(I) + a*X(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Y(bufferIndex) = Y(bufferIndex) + a*X(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Y(bufferIndex) = Y(bufferIndex) + a*X(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE YAXPY

  !> @brief ZAXPY point-wise operator performing Z = aX + Y (scalar a)
  SUBROUTINE ZAXPY(numDim,numPoints,bufferSize,bufferInterval,a,X,Y,Z)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: a,X(numPoints),Y(numPoints)
    REAL(KIND=8),    INTENT(OUT)     :: Z(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Z(I) = Y(I) + a*X(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Z(bufferIndex) = Y(bufferIndex) + a*X(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Z(bufferIndex) = Y(bufferIndex) + a*X(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE ZAXPY

  !> @brief ZAXPBY point-wise operator performing Z = aX + bY (scalar a,b)
  SUBROUTINE ZAXPBY(numDim,numPoints,bufferSize,bufferInterval,a,b,X,Y,Z)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: a,b,X(numPoints),Y(numPoints)
    REAL(KIND=8),    INTENT(OUT)     :: Z(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Z(I) = b*Y(I) + a*X(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Z(bufferIndex) = b*Y(bufferIndex) + a*X(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Z(bufferIndex) = b*Y(bufferIndex) + a*X(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE ZAXPBY

  !> @brief XAXM1 point-wise operator performing X = a/X (scalar a)
  SUBROUTINE XAXM1(numDim,numPoints,bufferSize,bufferInterval,a,X)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: a
    REAL(KIND=8),    INTENT(INOUT)   :: X(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          X(I) = a/X(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             X(bufferIndex) = a/X(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                X(bufferIndex) = a/X(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE XAXM1

  !> @brief XAM1X point-wise operator performing X = X/a (scalar a)
  SUBROUTINE XAM1X(numDim,numPoints,bufferSize,bufferInterval,a,X)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: a
    REAL(KIND=8),    INTENT(INOUT)   :: X(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          X(I) = X(I)/a
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             X(bufferIndex) = X(bufferIndex)/a
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                X(bufferIndex) = X(bufferIndex)/a
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE XAM1X

  !> @brief YAXPBY point-wise operator performing Y = aX + bY (scalar a,b)
  SUBROUTINE YAXPBY(numDim,numPoints,bufferSize,bufferInterval,a,b,X,Y)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: a,b,X(numPoints)
    REAL(KIND=8),    INTENT(INOUT)   :: Y(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Y(I) = b*Y(I) + a*X(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Y(bufferIndex) = b*Y(bufferIndex) + a*X(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Y(bufferIndex) = b*Y(bufferIndex) + a*X(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE YAXPBY

  !> @brief YAX point-wise operator performing Y = aX  (scalar a)
  SUBROUTINE YAX(numDim,numPoints,bufferSize,bufferInterval,a,X,Y)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: a,X(numPoints)
    REAL(KIND=8),    INTENT(OUT)     :: Y(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Y(I) = a*X(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Y(bufferIndex) = a*X(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Y(bufferIndex) = a*X(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE YAX

  !> @brief ZXYM1 point-wise operator performing Z = X/Y (all vectors)
  SUBROUTINE ZXYM1(numDim,numPoints,bufferSize,bufferInterval,X,Y,Z)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: X(numPoints),Y(numPoints)
    REAL(KIND=8),    INTENT(OUT)     :: Z(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Z(I) = X(I)/Y(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Z(bufferIndex) = X(bufferIndex)/Y(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Z(bufferIndex) = X(bufferIndex)/Y(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE ZXYM1

  !> @brief ZXY point-wise operator performing Z = XY (all vectors)
  !>
  !> ZXY performs Z = XY where @em X, @em Y are each contiguous arrays.
  !> Operand arrays are contiguous of size @em numPoints.
  !> The kernel operates on the rectangular interval specified by
  !> @em bufferInterval.
  !> The shape of the input and output arrays are
  !> specified by @em bufferSize, which is an @em numDim - dimensional
  !> array that specifies the size in each of @em numDim dimesions.
  !>
  !> @param numDim - const integer input specifies the number of dimensions of the input and output arrays
  !> @param numPoints - const 64-bit integer input specifies the total size of the input and output arrays
  !> @param bufferSize - const 64-bit integer array of size @em numDim specifies the size of the input and output arrays in each of @em numDim dimensions
  !> @param bufferInterval - const 64-bit integer array of size 2 x @em numDim indicating the rectangular interval in which the kernel should operate; e.g. [ @em iStart @em iEnd @em jStart @em jEnd ]
  !> @param X - const double precision input array
  !> @param Y - const double precision input array
  !> @param Z - double precision output array
  SUBROUTINE ZXY(numDim,numPoints,bufferSize,bufferInterval,X,Y,Z)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: X(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: Y(numPoints)
    REAL(KIND=8),    INTENT(OUT)     :: Z(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Z(I) = X(I)*Y(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Z(bufferIndex) = X(bufferIndex)*Y(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Z(bufferIndex) = X(bufferIndex)*Y(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE ZXY

  !> @brief ZAXY point-wise operator performing Z = aXY (scalar a, vectors X,Y)
  SUBROUTINE ZAXY(numDim,numPoints,bufferSize,bufferInterval,a,X,Y,Z)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: a
    REAL(KIND=8),    INTENT(IN)      :: X(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: Y(numPoints)
    REAL(KIND=8),    INTENT(OUT)     :: Z(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Z(I) = a*X(I)*Y(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Z(bufferIndex) = a*X(bufferIndex)*Y(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Z(bufferIndex) = a*X(bufferIndex)*Y(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE ZAXY

  !> @brief YXY point-wise operator performing Y = XY (all vectors)
  SUBROUTINE YXY(numDim,numPoints,bufferSize,bufferInterval,X,Y)

    INTEGER(KIND=4), INTENT(IN)    :: numDim
    INTEGER(KIND=8), INTENT(IN)    :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)    :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)    :: X(numPoints)
    REAL(KIND=8),    INTENT(INOUT) :: Y(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Y(I) = X(I)*Y(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Y(bufferIndex) = X(bufferIndex)*Y(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Y(bufferIndex) = X(bufferIndex)*Y(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE YXY

  !> @brief ZWXPY point-wise operator performing Z = WX + Y, where all are vectors
  SUBROUTINE ZWXPY(numDim,numPoints,bufferSize,bufferInterval,W,X,Y,Z)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: W(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: X(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: Y(numPoints)
    REAL(KIND=8),    INTENT(OUT)     :: Z(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Z(I) = X(I)*W(I) + Y(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Z(bufferIndex) = X(bufferIndex)*W(bufferIndex) + Y(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Z(bufferIndex) = X(bufferIndex)*W(bufferIndex) + Y(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE ZWXPY

  !> @brief YWXPY point-wise operator performing Y = WX + Y, where all are vectors
  SUBROUTINE YWXPY(numDim,numPoints,bufferSize,bufferInterval,W,X,Y)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: W(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: X(numPoints)
    REAL(KIND=8),    INTENT(INOUT)   :: Y(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Y(I) = X(I)*W(I) + Y(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Y(bufferIndex) = X(bufferIndex)*W(bufferIndex) + Y(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Y(bufferIndex) = X(bufferIndex)*W(bufferIndex) + Y(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE YWXPY

  !> @brief ZAWPXY point-wise operator performing Z = aW + XY
  !>
  !> ZAWPXY kernel performs Z = aW + XY with scalar @em a, contiguous input vectors
  !> @em W, @em X, and @em Y, and output vector @em Z.
  !> Operand arrays are contiguous of size @em numPoints.
  !> The kernel operates on the rectangular interval specified by
  !> @em bufferInterval.
  !> The shape of the input and output arrays are
  !> specified by @em bufferSize, which is an @em numDim - dimensional
  !> array that specifies the size in each of @em numDim dimesions.
  !>
  !> @param numDim - const integer input specifies the number of dimensions of the input and output arrays
  !> @param numPoints - const 64-bit integer input specifies the total size of the input and output arrays
  !> @param bufferSize - const 64-bit integer array of size @em numDim specifies the size of the input and output arrays in each of @em numDim dimensions
  !> @param bufferInterval - const 64-bit integer array of size 2 x @em numDim indicating the rectangular interval in which the kernel should operate; e.g. [ @em iStart @em iEnd @em jStart @em jEnd ]
  !> @param a - const input double precision scalar
  !> @param W - const double precision contiguous array of size @em numPoints
  !> @param X - const double precision contiguous array of size @em numPoints
  !> @param Y - const double precision contiguous array of size @em numPoints
  !> @param Z - output double precision contiguous array of size @em numpoints
  SUBROUTINE ZAWPXY(numDim,numPoints,bufferSize,bufferInterval,a,W,X,Y,Z)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: a
    REAL(KIND=8),    INTENT(IN)      :: W(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: X(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: Y(numPoints)
    REAL(KIND=8),    INTENT(OUT)     :: Z(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Z(I) = a*W(I) + X(I)*Y(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Z(bufferIndex) = a*W(bufferIndex) + X(bufferIndex)*Y(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Z(bufferIndex) = a*W(bufferIndex) + X(bufferIndex)*Y(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE ZAWPXY

  !> @brief ZVWPXY point-wise operator performing Z = VW + XY
  !>
  !> ZVWPXY kernel performs Z = VW + XY with contiguous double precision
  !> input arrays  @em V, @em W, @em X, and @em Y, and output array @em Z.
  !> Operand arrays are contiguous of size @em numPoints.
  !> The kernel operates on the rectangular interval specified by
  !> @em bufferInterval.
  !> The shape of the input and output arrays are
  !> specified by @em bufferSize, which is an @em numDim - dimensional
  !> array that specifies the size in each of @em numDim dimesions.
  !>
  !> @param numDim - const integer input specifies the number of dimensions of the input and output arrays
  !> @param numPoints - const 64-bit integer input specifies the total size of the input and output arrays
  !> @param bufferSize - const 64-bit integer array of size @em numDim specifies the size of the input and output arrays in each of @em numDim dimensions
  !> @param bufferInterval - const 64-bit integer array of size 2 x @em numDim indicating the rectangular interval in which the kernel should operate; e.g. [ @em iStart @em iEnd @em jStart @em jEnd ]
  !> @param V - input const double precision contiguous array of size @em numPoints
  !> @param W - input const double precision contiguous array of size @em numPoints
  !> @param X - input const double precision contiguous array of size @em numPoints
  !> @param Y - input const double precision contiguous array of size @em numPoints
  !> @param Z - output double precision contiguous array of size @em numpoints
  SUBROUTINE ZVWPXY(numDim,numPoints,bufferSize,bufferInterval,V,W,X,Y,Z)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: V(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: W(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: X(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: Y(numPoints)
    REAL(KIND=8),    INTENT(OUT)     :: Z(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Z(I) = V(I)*W(I) + X(I)*Y(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Z(bufferIndex) = V(bufferIndex)*W(bufferIndex) + &
                  X(bufferIndex)*Y(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Z(bufferIndex) = V(bufferIndex)*W(bufferIndex) + &
                     X(bufferIndex)*Y(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE ZVWPXY

  !> @brief ZWMXPY point-wise operator performing Z = W(X+Y) where all are vectors
  !
  !> ZVWPXY kernel performs Z = W(X+Y) with contiguous double precision
  !> input arrays  @em W, @em X, and @em Y, and output array @em Z.
  !> Operand arrays are contiguous of size @em numPoints.
  !> The kernel operates on the rectangular interval specified by
  !> @em bufferInterval.
  !> The shape of the input and output arrays are
  !> specified by @em bufferSize, which is an @em numDim - dimensional
  !> array that specifies the size in each of @em numDim dimesions.
  !>
  !> @param numDim - const integer input specifies the number of dimensions of the input and output arrays
  !> @param numPoints - const 64-bit integer input specifies the total size of the input and output arrays
  !> @param bufferSize - const 64-bit integer array of size @em numDim specifies the size of the input and output arrays in each of @em numDim dimensions
  !> @param bufferInterval - const 64-bit integer array of size 2 x @em numDim indicating the rectangular interval in which the kernel should operate; e.g. [ @em iStart @em iEnd @em jStart @em jEnd ]
  !> @param W - input const double precision contiguous array of size @em numPoints
  !> @param X - input const double precision contiguous array of size @em numPoints
  !> @param Y - input const double precision contiguous array of size @em numPoints
  !> @param Z - output double precision contiguous array of size @em numpoints
  SUBROUTINE ZWMXPY(numDim,numPoints,bufferSize,bufferInterval,W,X,Y,Z)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: W(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: X(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: Y(numPoints)
    REAL(KIND=8),    INTENT(OUT)     :: Z(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Z(I) = W(I)*(X(I)+Y(I))
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Z(bufferIndex) = W(bufferIndex)*(X(bufferIndex)+Y(bufferIndex))
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Z(bufferIndex) = W(bufferIndex)*(X(bufferIndex) + Y(bufferIndex))
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE ZWMXPY

  !> @brief ZXDOTY numComponents-vector inner product Z =  X * Y
  SUBROUTINE ZXDOTY(numDim,numPoints,bufferSize,bufferInterval,numComponents,X,Y,Z)

    INTEGER(KIND=4), INTENT(IN)      :: numDim, numComponents
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: X(numPoints*numComponents)
    REAL(KIND=8),    INTENT(IN)      :: Y(numPoints*numComponents)
    REAL(KIND=8),    INTENT(OUT)     :: Z(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=4) :: iComp
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd, compOffset

    REAL(KIND=8)    :: zero = 0.0_8

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    CALL ASSIGNMENTXA(numDim,numPoints,bufferSize,bufferInterval, &
         zero,Z)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          DO iComp = 0, numComponents-1
             compOffset = iComp*numPoints
             Z(I) = Z(I) + X(I+compOffset)*Y(I+compOffset)
          END DO
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             DO iComp = 0,numComponents-1
                compOffset = iComp*numPoints

                bufferIndex = yIndex + I
                Z(bufferIndex) = Z(bufferIndex) + &
                     X(bufferIndex+compOffset)*Y(bufferIndex+compOffset)
             END DO
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                DO iComp = 0,numComponents-1
                   compOffset = iComp*numPoints

                   bufferIndex = yzIndex + I
                   Z(bufferIndex) = Z(bufferIndex) + &
                        X(bufferIndex+compOffset)*Y(bufferIndex+compOffset)
                END DO
             END DO
          END DO
       END DO
    ENDIF
  END SUBROUTINE ZXDOTY

  !> @brief XAX point-wise operator performing X = aX (scalar a)
  SUBROUTINE XAX(numDim,numPoints,bufferSize,bufferInterval,a,X)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: a
    REAL(KIND=8),    INTENT(INOUT)   :: X(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          X(I) = a*X(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             X(bufferIndex) = a*X(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                X(bufferIndex) = a*X(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE XAX

  !> @brief ASSIGNMENTYX point-wise operator performing Y = X
  SUBROUTINE ASSIGNMENTYX(numDim,numPoints,bufferSize,bufferInterval,X,Y)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints
    INTEGER(KIND=8), INTENT(IN)      :: bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: X(numPoints)
    REAL(KIND=8),    INTENT(INOUT)   :: Y(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Y(I) = X(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Y(bufferIndex) = X(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Y(bufferIndex) = X(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE ASSIGNMENTYX

  !> @brief ASSIGNMENTXA point-wise operator performing X = scalar a
  SUBROUTINE ASSIGNMENTXA(numDim,numPoints,bufferSize,bufferInterval,a,X)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints
    INTEGER(KIND=8), INTENT(IN)      :: bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: a
    REAL(KIND=8),    INTENT(INOUT)   :: X(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          X(I) = a
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             X(bufferIndex) = a
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                X(bufferIndex) = a
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE ASSIGNMENTXA

  !> @brief ASSIGNMENTYABSX point-wise operator performing X = scalar a
  SUBROUTINE ASSIGNMENTYABSX(numDim,numPoints,bufferSize,bufferInterval,X,Y)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints
    INTEGER(KIND=8), INTENT(IN)      :: bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: X(numPoints)
    REAL(KIND=8),    INTENT(OUT)     :: Y(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Y(I) = ABS(X(I))
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Y(bufferIndex) = ABS(X(bufferIndex))
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Y(bufferIndex) = ABS(X(bufferIndex))
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE ASSIGNMENTYABSX

  !> @brief VECLEN point-wise operator returning the length of a numComp-dimensional vector
  SUBROUTINE VECLEN(numDim,numPoints,bufferSize,bufferInterval,numComp,V,lenV)

    INTEGER(KIND=4), INTENT(IN)      :: numDim, numComp
    INTEGER(KIND=8), INTENT(IN)      :: numPoints
    INTEGER(KIND=8), INTENT(IN)      :: bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: V(numComp*numPoints)
    REAL(KIND=8),    INTENT(OUT)     :: lenV(numPoints)

    INTEGER(KIND=8) :: I, J, K, L
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          lenV(I) = 0.0_8
          DO L = 1, numComp
             lenV(I) = lenV(I) + V((L-1)*numPoints+I)*V((L-1)*numPoints+I)
          END DO
          lenV(I) = SQRT(lenV(I))
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             lenV(bufferIndex) = 0.0_8
             DO L = 1,numComp
                lenV(bufferIndex) = lenV(bufferIndex) +  &
                     V((L-1)*numPoints+bufferIndex)*V((L-1)*numPoints+bufferIndex)
             END DO
             lenV(bufferIndex) = SQRT(lenV(bufferIndex))
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                lenV(bufferIndex) = 0.0_8
                DO L = 1,numComp
                   lenV(bufferIndex) = lenV(bufferIndex) +  &
                        V((L-1)*numPoints+bufferIndex)*V((L-1)*numPoints+bufferIndex)
                END DO
                lenV(bufferIndex) = SQRT(lenV(bufferIndex))
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE VECLEN

  !> @brief YAXM1 point-wise operator performing Y = a/X (scalar a)
  SUBROUTINE YAXM1(numDim,numPoints,bufferSize,bufferInterval,a,X,Y)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: a
    REAL(KIND=8),    INTENT(INOUT)   :: X(numPoints)
    REAL(KIND=8),    INTENT(INOUT)   :: Y(numPoints)

    INTEGER(KIND=8) :: I, J, K
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Y(I) = a/X(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             Y(bufferIndex) = a/X(bufferIndex)
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                Y(bufferIndex) = a/X(bufferIndex)
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE YAXM1

  !> @brief VASUPV point-wise operator performing V = V + aW where
  !>        a is a constant scalar, S is a scalar field, and V and W
  !>        are vectors with numDim components.
  SUBROUTINE VASUPV(numDim,numPoints,bufferSize,bufferInterval,a,S,U,V)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: a
    REAL(KIND=8),    INTENT(IN)      :: S(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: U(numDim*numPoints)
    REAL(KIND=8),    INTENT(INOUT)   :: V(numDim*numPoints)

    INTEGER(KIND=4) :: iDim
    INTEGER(KIND=8) :: I, J, K,vectorIndex
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd
    REAL(KIND=8)    :: scalFac

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          V(I) = V(I) + a*S(I)*U(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             scalFac = a*S(bufferIndex)
             DO iDim = 1, numDim
                vectorIndex = (iDim-1)*numPoints+bufferIndex
                V(vectorIndex) = V(vectorIndex) + scalFac*U(vectorIndex)
             END DO
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                scalFac = a*S(bufferIndex)
                DO iDim = 1, numDim
                   vectorIndex = (iDim-1)*numPoints+bufferIndex
                   V(vectorIndex) = V(vectorIndex) + scalFac*U(vectorIndex)
                END DO
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE VASUPV

  !> @brief YASSMWDOTUPY point-wise operator performing Y = Y + a*(S1+S2)*(W dot U) where
  !>        W, and U are vector fields with numDim components, and a is
  !>        a constant scalar, and S1, S2, and Y are scalar fields
  SUBROUTINE YASSMWDOTUPY(numDim,numPoints,bufferSize,bufferInterval,a,S1,S2,W,U,Y)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: a
    REAL(KIND=8),    INTENT(IN)      :: S1(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: S2(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: W(numDim*numPoints)
    REAL(KIND=8),    INTENT(IN)      :: U(numDim*numPoints)
    REAL(KIND=8),    INTENT(INOUT)   :: Y(numPoints)

    INTEGER(KIND=4) :: iDim
    INTEGER(KIND=8) :: I, J, K,vectorIndex
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd
    REAL(KIND=8)    :: scalFac

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Y(I) = Y(I) + a*(S1(I)+S2(I))*W(I)*U(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             scalFac = a*(S1(bufferIndex)+S2(bufferIndex))
             DO iDim = 1, numDim
                vectorIndex = (iDim-1)*numPoints+bufferIndex
                Y(bufferIndex) = Y(bufferIndex) + scalFac*W(vectorIndex)*U(vectorIndex)
             END DO
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                scalFac = a*(S1(bufferIndex)+S2(bufferIndex))
                DO iDim = 1, numDim
                   vectorIndex = (iDim-1)*numPoints+bufferIndex
                   Y(bufferIndex) = Y(bufferIndex) + scalFac*W(vectorIndex)*U(vectorIndex)
                END DO
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE YASSMWDOTUPY

  !> @brief YASMWDOTUPY point-wise operator performing Y = Y + a*S*(W dot U) where
  !>        W, and U are vector fields with numDim components, and a is
  !>        a constant scalar, and S,Y are scalar fields
  SUBROUTINE YASMWDOTUPY(numDim,numPoints,bufferSize,bufferInterval,a,S,W,U,Y)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: a
    REAL(KIND=8),    INTENT(IN)      :: S(numPoints)
    REAL(KIND=8),    INTENT(IN)      :: W(numDim*numPoints)
    REAL(KIND=8),    INTENT(IN)      :: U(numDim*numPoints)
    REAL(KIND=8),    INTENT(INOUT)   :: Y(numPoints)

    INTEGER(KIND=4) :: iDim
    INTEGER(KIND=8) :: I, J, K,vectorIndex
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd
    REAL(KIND=8)    :: scalFac

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Y(I) = Y(I) + a*S(I)*W(I)*U(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             scalFac = a*S(bufferIndex)
             DO iDim = 1, numDim
                vectorIndex = (iDim-1)*numPoints+bufferIndex
                Y(bufferIndex) = Y(bufferIndex) + scalFac*W(vectorIndex)*U(vectorIndex)
             END DO
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                scalFac = a*S(bufferIndex)
                DO iDim = 1, numDim
                   vectorIndex = (iDim-1)*numPoints+bufferIndex
                   Y(bufferIndex) = Y(bufferIndex) + scalFac*W(vectorIndex)*U(vectorIndex)
                END DO
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE YASMWDOTUPY

  !> @brief YAVDOTWPY point-wise operator performing Y = Y + a(V dot W) where
  !>        Y is a scalar field, a is a constant scalar, V and W are vector fields
  !>        with numDim components
  SUBROUTINE YAVDOTWPY(numDim,numPoints,bufferSize,bufferInterval,a,V,W,Y)

    INTEGER(KIND=4), INTENT(IN)      :: numDim
    INTEGER(KIND=8), INTENT(IN)      :: numPoints,bufferSize(numDim)
    INTEGER(KIND=8), INTENT(IN)      :: bufferInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)      :: a
    REAL(KIND=8),    INTENT(IN)      :: V(numDim*numPoints)
    REAL(KIND=8),    INTENT(IN)      :: W(numDim*numPoints)
    REAL(KIND=8),    INTENT(INOUT)   :: Y(numPoints)

    INTEGER(KIND=4) :: iDim
    INTEGER(KIND=8) :: I, J, K,vectorIndex
    INTEGER(KIND=8) :: nPlane, zIndex, yIndex, yzIndex, bufferIndex, xSize
    INTEGER(KIND=8) :: iStart,iEnd,jStart,jEnd,kStart,kEnd

    iStart = bufferInterval(1)
    iEnd   = bufferInterval(2)
    xSize  = bufferSize(1)

    IF(numDim == 1) THEN
       DO I = iStart, iEnd
          Y(I) = Y(I) + a*V(I)*W(I)
       END DO
    ELSE IF(numDim == 2) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       DO J = jStart, jEnd
          yIndex = (J-1)*xSize
          DO I = iStart, iEnd
             bufferIndex = yIndex + I
             DO iDim = 1, numDim
                vectorIndex = (iDim-1)*numPoints+bufferIndex
                Y(bufferIndex) = Y(bufferIndex) + a*V(vectorIndex)*W(vectorIndex)
             END DO
          END DO
       END DO
    ELSE IF(numDim == 3) THEN
       jStart = bufferInterval(3)
       jEnd   = bufferInterval(4)
       kStart = bufferInterval(5)
       kEnd   = bufferInterval(6)
       nPlane = xSize * bufferSize(2)
       DO K = kStart, kEnd
          zIndex = (K-1)*nPlane
          DO J = jStart, jEnd
             yzIndex = zIndex + (J-1)*xSize
             DO I = iStart, iEnd
                bufferIndex = yzIndex + I
                DO iDim = 1, numDim
                   vectorIndex = (iDim-1)*numPoints+bufferIndex
                   Y(bufferIndex) = Y(bufferIndex) + a*V(vectorIndex)*W(vectorIndex)
                END DO
             END DO
          END DO
       END DO
    ENDIF

  END SUBROUTINE YAVDOTWPY

END MODULE SIMPLE


module fcn_xlinear
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO
    use type_function,  only: function_t
    use type_point_ad,  only: point_ad_t
    use DNAD_D
    implicit none
    private

    !> X-linear function.
    !!
    !!  \f$     f(t,\vec{x}) = const + \vec{x}*slope    \f$
    !!
    !!  @author Matteo Ugolotti
    !!  @date   10/28/2018
    !!
    !-------------------------------------------------------------------
    type, extends(function_t), public :: xlinear_f

    contains

        procedure   :: init
        procedure   :: compute

    end type xlinear_f
    !********************************************************************

contains

    !>  Add function name and options
    !!
    !!  @author Matteo Ugolotti
    !!  @date   10/28/2018
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(xlinear_f),  intent(inout)   :: self

        !
        ! Set function name
        !
        call self%set_name("x_linear")

        !
        ! Set function options to default settings
        !
        call self%add_option('val',1._rk)
        call self%add_option('slope',1._rk)

    end subroutine init
    !*************************************************************************

    !> Function method to return function value.
    !!
    !!  @author Matteo Ugolotti
    !!  @date   8/31/2018
    !!
    !--------------------------------------------------------------------
    impure elemental function compute(self,time,coord) result(val)
        class(xlinear_f),  intent(inout)   :: self
        real(rk),           intent(in)      :: time
        type(point_ad_t),   intent(in)      :: coord

        type(AD_D)    :: val,a,b,x

        ! Get x coordiantes
        x = coord%c1_

        ! Define consant term
        a = x
        a = self%get_option_value('val')

        ! Define slope
        b = x
        b = self%get_option_value('slope')

        ! f(x,y,z) = const
        ! derivatives are automatically set to ZERO in this case
        val = a + b*x

    end function compute
    !********************************************************************

end module fcn_xlinear


*DECK DVJUST
      SUBROUTINE DVJUST (YH, LDYH, IORD)
      DOUBLE PRECISION YH
      INTEGER LDYH, IORD
      DIMENSION YH(LDYH,*)
C-----------------------------------------------------------------------
C Call sequence input -- YH, LDYH, IORD
C Call sequence output -- YH
C COMMON block input -- NQ, METH, LMAX, HSCAL, TAU(13), N
C COMMON block variables accessed:
C     /DVOD01/ -- HSCAL, TAU(13), LMAX, METH, N, NQ,
C
C Subroutines called by DVJUST: DAXPY
C Function routines called by DVJUST: None
C-----------------------------------------------------------------------
C This subroutine adjusts the YH array on reduction of order,
C and also when the order is increased for the stiff option (METH = 2).
C Communication with DVJUST uses the following:
C IORD  = An integer flag used when METH = 2 to indicate an order
C         increase (IORD = +1) or an order decrease (IORD = -1).
C HSCAL = Step size H used in scaling of Nordsieck array YH.
C         (If IORD = +1, DVJUST assumes that HSCAL = TAU(1).)
C See References 1 and 2 for details.
C-----------------------------------------------------------------------
C
      include "vode.H"
C
C Type declarations for local variables --------------------------------
C
      DOUBLE PRECISION ALPH0, ALPH1, HSUM, ONE, PROD, T1, XI,XIOLD, ZERO
      INTEGER I, IBACK, J, JP1, LP1, NQM1, NQM2, NQP1
      PARAMETER(ONE = 1.0D0, ZERO = 0.0D0)
C
      IF ((NQ .EQ. 2) .AND. (IORD .NE. 1)) RETURN
      NQM1 = NQ - 1
      NQM2 = NQ - 2
      GO TO (100, 200), METH
C-----------------------------------------------------------------------
C Nonstiff option...
C Check to see if the order is being increased or decreased.
C-----------------------------------------------------------------------
 100  CONTINUE
      IF (IORD .EQ. 1) GO TO 180
C Order decrease. ------------------------------------------------------
      DO 110 J = 1, LMAX
 110    EL(J) = ZERO
      EL(2) = ONE
      HSUM = ZERO
      DO 130 J = 1, NQM2
C Construct coefficients of x*(x+xi(1))*...*(x+xi(j)). -----------------
        HSUM = HSUM + TAU(J)
        XI = HSUM/HSCAL
        JP1 = J + 1
        DO 120 IBACK = 1, JP1
          I = (J + 3) - IBACK
 120      EL(I) = EL(I)*XI + EL(I-1)
 130    CONTINUE
C Construct coefficients of integrated polynomial. ---------------------
      DO 140 J = 2, NQM1
 140    EL(J+1) = REAL(NQ)*EL(J)/REAL(J)
C Subtract correction terms from YH array. -----------------------------
      DO 170 J = 3, NQ
        DO 160 I = 1, N
 160      YH(I,J) = YH(I,J) - YH(I,L)*EL(J)
 170    CONTINUE
      RETURN
C Order increase. ------------------------------------------------------
C Zero out next column in YH array. ------------------------------------
 180  CONTINUE
      LP1 = L + 1
      DO 190 I = 1, N
 190    YH(I,LP1) = ZERO
      RETURN
C-----------------------------------------------------------------------
C Stiff option...
C Check to see if the order is being increased or decreased.
C-----------------------------------------------------------------------
 200  CONTINUE
      IF (IORD .EQ. 1) GO TO 300
C Order decrease. ------------------------------------------------------
      DO 210 J = 1, LMAX
 210    EL(J) = ZERO
      EL(3) = ONE
      HSUM = ZERO
      DO 230 J = 1,NQM2
C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). ---------------
        HSUM = HSUM + TAU(J)
        XI = HSUM/HSCAL
        JP1 = J + 1
        DO 220 IBACK = 1, JP1
          I = (J + 4) - IBACK
 220      EL(I) = EL(I)*XI + EL(I-1)
 230    CONTINUE
C Subtract correction terms from YH array. -----------------------------
      DO 250 J = 3,NQ
        DO 240 I = 1, N
 240      YH(I,J) = YH(I,J) - YH(I,L)*EL(J)
 250    CONTINUE
      RETURN
C Order increase. ------------------------------------------------------
 300  DO 310 J = 1, LMAX
 310    EL(J) = ZERO
      EL(3) = ONE
      ALPH0 = -ONE
      ALPH1 = ONE
      PROD = ONE
      XIOLD = ONE
      HSUM = HSCAL
      IF (NQ .EQ. 1) GO TO 340
      DO 330 J = 1, NQM1
C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). ---------------
        JP1 = J + 1
        HSUM = HSUM + TAU(JP1)
        XI = HSUM/HSCAL
        PROD = PROD*XI
        ALPH0 = ALPH0 - ONE/REAL(JP1)
        ALPH1 = ALPH1 + ONE/XI
        DO 320 IBACK = 1, JP1
          I = (J + 4) - IBACK
 320      EL(I) = EL(I)*XIOLD + EL(I-1)
        XIOLD = XI
 330    CONTINUE
 340  CONTINUE
      T1 = (-ALPH0 - ALPH1)/PROD
C Load column L + 1 in YH array. ---------------------------------------
      LP1 = L + 1
      DO 350 I = 1, N
 350    YH(I,LP1) = T1*YH(I,LMAX)
C Add correction terms to YH array. ------------------------------------
      NQP1 = NQ + 1
      DO 370 J = 3, NQP1
        CALL DAXPY (N, EL(J), YH(1,LP1), 1, YH(1,J), 1 )
 370  CONTINUE
      RETURN
C----------------------- End of Subroutine DVJUST ----------------------
      END


subroutine fci(sav,nrow,galfa,n,ret,rf,capinc)
implicit none
INTEGER, INTENT(IN) :: n, nrow
REAL, INTENT(IN) :: ret, rf
REAL, INTENT(IN) :: sav(nrow,1), galfa(n,1)
REAL, INTENT(OUT) :: capinc(nrow,n)
REAL, ALLOCATABLE :: rp(:,:), ones(:,:)
INTEGER :: ind1, ind2
ALLOCATE (rp(n,1), ones(n,1))
ones=1.0
do ind1=1,nrow
   rp = ret*galfa+rf*(ones-galfa)
   do ind2=1,n
      capinc(ind1,ind2) = sav(ind1,1)*rp(ind2,1)
   end do
end do
DEALLOCATE(rp,ones)
end subroutine


      subroutine setprob()
      implicit none

      integer iunit
      character(len=25) fname

      double precision pi, pi2
      common /compi/ pi, pi2

      integer example
      common /example_comm/ example

      double precision init_radius, init_location(2)
      common /initradius_comm/ init_radius, init_location

      double precision revs_per_s, vcart(2),amp, freq, cart_speed
      common /stream_comm/ revs_per_s, vcart, amp, freq, cart_speed

      double precision beta, theta(2)
      common /annulus_comm/ beta, theta

      integer maxlevel, rfactor, grid_mx, mi, mj
      common /amr_comm/ maxlevel, rfactor, grid_mx, mi, mj

      integer refine_pattern
      common /refine_comm/ refine_pattern

      integer qad_mode
      common /qad_comm/ qad_mode

      double precision setaux_time
      common /setaux_comm/ setaux_time

      pi = 4.d0*atan(1.d0)
      pi2 = 2*pi

      iunit = 10
      fname = 'setprob.data'
      call opendatafile(iunit, fname)

      read(iunit,*) example
      read(iunit,*) revs_per_s
      read(iunit,*) cart_speed
      read(iunit,*) vcart(1)
      read(iunit,*) vcart(2)
      read(iunit,*) amp
      read(iunit,*) freq
      read(iunit,*) init_radius    !! radius
      read(iunit,*) init_location(1)
      read(iunit,*) init_location(2)
      read(iunit,*) beta
      read(iunit,*) theta(1)
      read(iunit,*) theta(2)

      read(iunit,*) grid_mx
      read(iunit,*) mi
      read(iunit,*) mj
      read(iunit,*) maxlevel
      read(iunit,*) rfactor
      read(iunit,*) refine_pattern
      read(iunit,*) qad_mode
      close(iunit)

      open(10,file='mapping.dat')
      write(10,*) example
      write(10,*) amp
      write(10,*) init_radius
      write(10,*) init_location(1)
      write(10,*) init_location(2)
      write(10,*) beta
      write(10,*) theta(1)
      write(10,*) theta(2)
      write(10,*) vcart(1)
      write(10,*) vcart(2)
      write(10,*) cart_speed
      write(10,*) freq
      close(10)

      setaux_time = 0

      end


      SUBROUTINE ZLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK )
*
*  -- LAPACK auxiliary test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INCV, LDC, N
      COMPLEX*16         TAU
*     ..
*     .. Array Arguments ..
      COMPLEX*16         C( LDC, * ), V( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  ZLARFY applies an elementary reflector, or Householder matrix, H,
*  to an n x n Hermitian matrix C, from both the left and the right.
*
*  H is represented in the form
*
*     H = I - tau * v * v'
*
*  where  tau  is a scalar and  v  is a vector.
*
*  If  tau  is  zero, then  H  is taken to be the unit matrix.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the upper or lower triangular part of the
*          Hermitian matrix C is stored.
*          = 'U':  Upper triangle
*          = 'L':  Lower triangle
*
*  N       (input) INTEGER
*          The number of rows and columns of the matrix C.  N >= 0.
*
*  V       (input) COMPLEX*16 array, dimension
*                  (1 + (N-1)*abs(INCV))
*          The vector v as described above.
*
*  INCV    (input) INTEGER
*          The increment between successive elements of v.  INCV must
*          not be zero.
*
*  TAU     (input) COMPLEX*16
*          The value tau as described above.
*
*  C       (input/output) COMPLEX*16 array, dimension (LDC, N)
*          On entry, the matrix C.
*          On exit, C is overwritten by H * C * H'.
*
*  LDC     (input) INTEGER
*          The leading dimension of the array C.  LDC >= max( 1, N ).
*
*  WORK    (workspace) COMPLEX*16 array, dimension (N)
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX*16         ONE, ZERO, HALF
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
     $                   ZERO = ( 0.0D+0, 0.0D+0 ),
     $                   HALF = ( 0.5D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      COMPLEX*16         ALPHA, tmp
      integer            i, ix, iy
*     ..
*     .. External Subroutines ..
      EXTERNAL           ZAXPY, ZHEMV, ZHER2
*     ..
*     .. External Functions ..
      COMPLEX*16         ZDOTC
      EXTERNAL           ZDOTC
*     ..
*     .. Executable Statements ..
*
      IF( TAU.EQ.ZERO )
     $   RETURN
*
*     Form  w:= C * v
*
      CALL ZHEMV( UPLO, N, ONE, C, LDC, V, INCV, ZERO, WORK, 1 )
*
**    zdotc crashes on some systems (MKL, MacOS); just inline it. -mgates
      tmp = ZERO
      ix = 1
      iy = 1
      do i = 1, n
         tmp = tmp + conjg(work(ix)) * v(iy)
         ix = ix + 1
         iy = iy + incv
      end do
      ALPHA = -HALF*TAU*tmp
**    ALPHA = -HALF*TAU*ZDOTC( N, WORK, 1, V, INCV )
      CALL ZAXPY( N, ALPHA, V, INCV, WORK, 1 )
*
*     C := C - v * w' - w * v'
*
      CALL ZHER2( UPLO, N, -TAU, V, INCV, WORK, 1, C, LDC )
*
      RETURN
*
*     End of ZLARFY
*
      END


program RHWaveTransport

use NumberKindsModule
use OutputWriterModule
use LoggerModule
use ParticlesModule
use EdgesModule
use FacesModule
use PolyMesh2dModule
use FieldModule
use MPISetupModule
use SphereGeomModule
use RefinementModule
use SSRFPACKInterfaceModule
use SSRFPACKRemeshModule
use SphereTransportSolverModule
use SphereTracersModule
use SphereTransportModule
use SphereTransportVelocitiesModule, velFn => RH4Velocity

implicit none

include 'mpif.h'

! mesh variables
type(TransportMesh) :: sphere
type(RefineSetup) :: refinement
integer(kint) :: initNest
integer(kint) :: maxNest
integer(kint) :: faceKind
integer(kint) :: meshSeed
integer(kint) :: amrLimit
real(kreal), parameter :: radius = 1.0_kreal
logical(klog) :: continueAMR
logical(klog) :: AMR
integer(kint) :: nParticlesBefore
integer(kint) :: nParticlesAfter
namelist /meshDefine/ faceKind, initNest, amrLimit

! test case variables
real(kreal), allocatable, dimension(:) :: trMass
integer(kint), parameter :: nTracers = 2
integer(kint), dimension(2), parameter :: tracerDims = [1,1]

! remeshing variables
type(TransportRemesh) :: remesh
integer(kint) :: remeshInterval
integer(kint) :: remeshCounter
type(TransportMesh) :: tempSphere

! timestepping
type(TransportSolver) :: solver
real(kreal) :: dt
real(kreal) :: t
real(kreal) :: tfinal
integer(kint) :: nTimesteps
integer(kint) :: timeJ
namelist /timestepping/ dt, tfinal, remeshInterval

! i/o
character(len=MAX_STRING_LENGTH) :: outputDir
character(len=MAX_STRING_LENGTH) :: outputRoot
character(len=MAX_STRING_LENGTH) :: vtkFile
character(len=MAX_STRING_LENGTH) :: matlabFile
character(len=MAX_STRING_LENGTH) :: vtkRoot
character(len=MAX_STRING_LENGTH) :: meshString
integer(kint) :: frameOut
integer(kint) :: frameCounter
namelist /fileIO/ outputDir, outputRoot, frameOut

! computing environment / general
type(Logger) :: exeLog
character(len=MAX_STRING_LENGTH) :: logString
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL
character(len=28) :: logKey = "AdvectRHWave"
integer(kint) :: mpiErrCode
real(kreal) :: timeStart, timeEnd
integer(kint) :: i
real(kreal), dimension(3) :: vec

!--------------------------------
!	initialize : setup computing environment
!--------------------------------
call MPI_INIT(mpiErrCode)
call MPI_COMM_SIZE(MPI_COMM_WORLD, numProcs, mpiErrCode)
call MPI_COMM_RANK(MPI_COMM_WORLD, procRank, mpiErrCode)

call InitLogger(exeLog, procRank)

timeStart = MPI_WTIME()

call ReadNamelistFile( procRank )

!
!	initialize mesh and spatial fields
!
t = 0.0_kreal
call New( sphere, meshSeed, initNest, maxNest, amrLimit, radius, .FALSE.)
call AddTracers(sphere, nTracers, tracerDims)
sphere%tracers(1)%name = "initialLatitude"
sphere%tracers(1)%units = "radians"
sphere%tracers(2)%name = "vorticity"
sphere%tracers(2)%units = "1/s"
call SetInitialDensityOnMesh(sphere)
do i = 1, sphere%mesh%particles%N
	vec = LagCoord(sphere%mesh%particles, i)
	call InsertScalarToField( sphere%tracers(1), Latitude(vec) )
enddo
call SetTracerOnMesh( sphere, 2, RH54Vorticity )
call SetVelocityOnMesh( sphere, velFn, t)
call SetDivergenceOnMesh(sphere)

call LogStats(sphere%mpiParticles, exeLog)

! TO DO : AMR, initial refinement

!
!	Output initial data
!
frameCounter = 0
remeshCounter = 0
if ( procRank == 0 ) then
	call LogStats(sphere, exeLog)
	if (meshSeed == ICOS_TRI_SPHERE_SEED) then
		if ( initNest == maxNest) then
			write(meshString, '(A,I1,A)') '_icosTri', initNest, '_'
		else
			write(meshString, '(2(A,I1),A)') '_icosTriAMR', initNest, 'to', maxNest, '_'
		endif
	elseif (meshSeed == CUBED_SPHERE_SEED ) then
		if ( initNest == maxNest ) then
			write(meshString, '(A,I1,A)') '_cubedSphere', initNest, '_'
		else
			write(meshString, '(2(A,I1),A)') '_cubedSphereAMR', initNest, 'to', maxNest, '_'
		endif
	endif

	write(vtkRoot,'(4A)') trim(outputDir), '/vtkOut/', trim(outputRoot), trim(meshString)
	write(vtkFile,'(A,I0.4,A)') trim(vtkRoot), frameCounter, '.vtk'

	call OutputToVTK(sphere, vtkFile)
	frameCounter = frameCounter + 1

	call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logkey)//" t = ", t)
endif

!
!	initialize time stepping
!
call New(solver, sphere)
nTimesteps = floor( tfinal/dt )
allocate(trMass( nTimesteps + 1))
trMass(1) = TracerMass(sphere,1)

!--------------------------------
!	run : evolve the problem in time
!--------------------------------
call LogMessage(exeLog, DEBUG_LOGGING_LEVEL, trim(logkey)//" ", "starting timestepping loop.")

do timeJ = 0, nTimesteps - 1

	if ( mod(timeJ+1, remeshInterval) == 0 ) then
		call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logkey)//" remesh triggered by remesh interval : ",&
			 remeshCounter)
		call New(remesh, sphere)

		call New(tempSphere, meshSeed, initNest, maxNest, amrLimit, radius, .FALSE.)
		call SetDivergenceOnMesh(tempSphere)

		call AddTracers(tempSphere, nTracers, tracerDims)
		tempSphere%tracers(1)%name = "initialLatitude"
		tempSphere%tracers(1)%units = "radians"
		tempSphere%tracers(1)%units = "radians"
		tempSphere%tracers(2)%name = "vorticity"
		tempSphere%tracers(2)%units = "1/s"

		! TO DO : Adaptive remeshing

		call LagrangianRemeshTransportWithFunctions(remesh, sphere, tempSphere, .FALSE., velFn, t, &
			tracerFn1 = InitLatTracer, tracerFn2 = RH54Vorticity )

		call LogMessage(exeLog, DEBUG_LOGGING_LEVEL, "remesh loop: ", "Remesh::LagRemesh has returned")

		call Copy(sphere, tempSphere)
		remeshCounter = remeshCounter + 1

		call Delete(tempSphere)
		call Delete(remesh)

		call Delete(solver)
		call New(solver, sphere)
	endif

	call Timestep(solver, sphere, t, dt, velFn)
	t = real(timeJ +1, kreal) * dt
	sphere%mesh%t = t

	trMass(timeJ+2) = TracerMass(sphere, 1)

	if ( procRank == 0 .AND. mod(timeJ+1, frameOut) == 0 ) then
		write(vtkFile,'(A,I0.4,A)') trim(vtkRoot), frameCounter, '.vtk'
		call OutputToVTK(sphere, vtkFile)
		frameCounter = frameCounter + 1
		call LogMessage(exelog, TRACE_LOGGING_LEVEL, trim(logKey)//" t = ", t)
	endif
enddo

!--------------------------------
!	finalize : clean up
!--------------------------------

timeEnd = MPI_WTIME()
write(logstring,'(A,F12.2,A)') "PROGRAM COMPLETE : elapsed time ", timeEnd - timeStart, " seconds."
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" ", logstring)

deallocate(trMass)
call Delete(solver)

call MPI_FINALIZE(mpiErrCode)

contains

!--------------------------------
!	subprograms used by this application
!--------------------------------

subroutine ReadNamelistFile( rank )
	integer(kint), intent(in) :: rank
	!
	character(len=MAX_STRING_LENGTH) :: namelistFilename
	integer(kint), parameter :: initBcast_intSize = 6
	integer(kint), parameter :: initBcast_realSize = 2
	integer(kint), dimension(initBcast_intSize) :: bcastIntegers
	real(kreal), dimension(initBcast_realSize) :: bcastReals
	integer(kint) :: mpiErrCode, readStat

	if ( COMMAND_ARGUMENT_COUNT() /= 1 ) then
		call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey), " ERROR: expected namelist file as 1st argument.")
		stop
	endif

	if ( rank == 0 ) then
		call GET_COMMAND_ARGUMENT(1, namelistFilename)

		open(unit=READ_UNIT, file=namelistFilename, status='OLD', action='READ', iostat=readStat)
			if ( readStat /= 0 ) then
				call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey), " ERROR: cannot read namelist file.")
				stop
			endif

			read(READ_UNIT, nml=meshDefine)
			rewind(READ_UNIT)
			read(READ_UNIT, nml=timestepping)
			rewind(READ_UNIT)
			read(READ_UNIT, nml=fileIO)
		close(READ_UNIT)

		if ( faceKind == 3 ) then
			meshSeed = ICOS_TRI_SPHERE_SEED
		elseif ( faceKind == 4) then
			meshSeed = CUBED_SPHERE_SEED
		else
			call LogMessage(exeLog, WARNING_LOGGING_LEVEL, trim(logkey)//" ReadNamelistFile WARNING : ", &
				" invalid faceKind -- using triangles.")
			meshSeed = ICOS_TRI_SPHERE_SEED
		endif

		maxNest = initNest + amrLimit

!		namelist /meshDefine/ faceKind, initNest, maxNest, amrLimit, radius
!		namelist /timestepping/ dt, tfinal
!		namelist /fileIO/ outputDir, outputRoot, frameOut

		bcastIntegers(1) = meshSeed
		bcastIntegers(2) = initNest
		bcastIntegers(3) = maxNest
		bcastIntegers(4) = amrLimit
		bcastIntegers(5) = frameOut
		bcastIntegers(6) = remeshInterval

		bcastReals(1) = dt
		bcastReals(2) = tfinal
	endif

	call MPI_BCAST(bcastIntegers, initBCAST_intSize, MPI_INTEGER, 0, MPI_COMM_WORLD, mpiErrCode)
	if ( mpiErrCode /= 0 ) then
		call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey)//" bcastIntegers, MPI_BCAST ERROR : ", mpiErrCode)
	endif

	call MPI_BCAST(bcastReals, initBCAST_realSize, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, mpiErrCode)
	if ( mpiErrCode /= 0 ) then
		call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey)//" bcastReals, MPI_BCAST ERROR : ", mpiErrCode)
	endif

	meshSeed = bcastIntegers(1)
	initNest = bcastIntegers(2)
	maxNest = bcastIntegers(3)
	amrLimit = bcastIntegers(4)
	frameOut = bcastIntegers(5)
	remeshInterval = bcastIntegers(6)

	dt = bcastReals(1)
	tfinal = bcastReals(2)
end subroutine

!> @brief Initializes a @ref Logger for this executable program.
!>
!> Output is controlled by message priority level and MPI rank.
!>
!> @param[in] log @ref Logger to initialize
!> @param[in] rank MPI rank

subroutine InitLogger(log, rank)
	type(Logger), intent(inout) :: log
	integer(kint), intent(in) :: rank
	if ( rank == 0 ) then
		call New(log, logLevel)
	else
		call New(log, ERROR_LOGGING_LEVEL)
	endif
	write(logKey,'(A,I0.2,A)') trim(logKey)//"_", rank, ":"
end subroutine

end program


C ==========================================================
      Subroutine mbaAnalytic(
C ==========================================================
c group (M)
     &      nP, MaxP, nF, MaxF, nE, MaxE, nPv,
     &      XYP, IPF, IPE, IPV,
     &      CrvFunction, ParCrv, iFnc,
     &      nEStar,
c group (D)
     &      nFv, nEv, IFV, IEV, lbE,
     &      flagAuto, status,
c group (Q)
     &      MaxSkipE, MaxQItr,
     &      MetricFunction, Quality, rQuality,
c group (W)
     &      MaxWr, MaxWi, rW, iW,
     &      iPrint, iERR)
C ==========================================================
      include 'lintrp.fd'
      include 'status.fd'
C ==========================================================
C  VARIABLES & PARAMETER are described in mba_nodal.f
C
C  MetricFunction - integer function created by the user (see
C                   example in file forlibmba.f)
C
C    Integer Function MetricFunction(x, y, z, Metric)
C
C  This routine creates a metric at the given point (x,y, z). The
C  metric is a 2x2 positive definite symmetric tensor:
C
C                M11   M12
C      Metric =
C                M12   M22
C
C  Only the upper triangular part of array Metric must be defined.
C
C
C *** Authors: K. Lipnikov (lipnikov@hotmail.com)
C              Y. Vassilevski (vasilevs@dodo.inm.ras.ru)
C ==========================================================
C group (M)
C     Integer MaxP, MaxF, MaxE, MaxFnc
      real  XYP(2, *)
      Integer IPE(3, *), IPF(4, *), IPV(*)

      EXTERNAL CrvFunction
      real   ParCrv(2, *)
      Integer  iFnc(*)

C group (D)
      Integer nFv, nEv
      Integer IFV(*), IEV(*), lbE(*)

      Logical flagAuto
      Integer status

C group (Q)
      Integer  MaxSkipE, MaxQItr
      real   Quality, rQuality
      Logical  flagAnalytic

      Integer  MetricFunction
      EXTERNAL MetricFunction

C group (W)
      real  rW(*)
      Integer iW(*)

C group (Local variables)
      real  hStar

C ==========================================================
C group (Common blocks)
      Integer iDomBnd, iMatBnd
      Common /aniBND/ iDomBnd, iMatBnd

      real  refXYP(2), scaXYP(2)
      Common /rescale/refXYP, scaXYP

C ==========================================================
      iERR = 0

      Do i = 1, 2
         refXYP(i) = 0D0
         scaXYP(i) = 1D0
      End do

c ... refine initial mesh when nE is very small
c ... it increases robustness of the code
      Do while(nE < nEStar / 15 .AND. nE.LE.500 .AND. nEv+nFv.EQ.0)
         iIFE = 1
         iiW  = iIFE + 3 * nE
         nWi  = iiW  + 3 * nE + nP
         If(nWi.GT.MaxWi) goto 100

         iSol = 1
         nWr  = iSol + MaxP
         If(nWr.GT.MaxWr) goto 100

         If(iPrint.GE.1) Write(*,5001) nP, nE

         Do i = 1, nP
            rW(iSol + i - 1) = 0D0
         End do

         Call uniformRefinement(
     &        nP, MaxP, nF, MaxF, nE, MaxE,
     &        XYP, IPF, IPE, lbE,
     &        CrvFunction, ParCrv, iFnc, iW(iIFE),
     &        rW(iSol), 1, iW(iiW), MaxWi)
      End do

 100  miLINTRP = 10 * nP + 3 * nE + 6
      mrLINTRP =  4 * nP + MaxH + 4

      inEt = 1
      inStept = inEt + MaxF
      inL2t = inStept + 4 * MaxF
      iLFnc = inL2t + MaxF
      iILt  = iLFnc + MaxF
      iL1Et = iILt + MaxF
      iL2Et = iL1Et + 2 * MaxF
      iIHolP = iL2Et + 2 * MaxF
      iIHolF = iIHolP + MaxP
      iIHolE = iIHolF + MaxF
      iICP = iIHolE + MaxE
      iIEP = iICP + MaxP
      iIFE = iIEP + MaxP
      iIEE = iIFE + 3 * MaxE
      iL1E = iIEE + 3 * MaxE
      iL2E = iL1E + 2 * MaxE
      iIPEw = iL2E + 2 * MaxE
      iiSE  = iIPEw + 3 * nE
      iIEPw = iiSE + miLINTRP
c ... we need twice less memory for backReferences
      inEPw = iIEPw + max(6 * nE, 4 * MaxF)
      nWi   = inEPw + max(3 * MaxP, 2 * MaxF)

      iHesP = 1
      itE = iHesP + 3 * MaxP
      idG = itE + MaxF
      iqE = idG + MaxP
      iHesPw = iqE + MaxE
      iXYPw = iHesPw + 3 * nP
      irSE = iXYPw + 2 * nP
      nWr  = irSE + max(mrLINTRP, max(nE, MaxF))

      iW(1) = nWi
      iW(2) = nWr
      If(nWi.GT.MaxWi) Then
         iERR = 1001
         goto 1000
      End if

      If(nWr.GT.MaxWr) Then
         iERR = 1002
         goto 1000
      End if

      Do n = 1, nWr
         rW(n) = 0D0
      End do

      Do n = 1, nWi
         iW(n) = 0
      End do

c ... compute the analytic metric
      Call iniQ_analytic(nP, XYP, MetricFunction, rW(iHesP))

c ... scale geometry to unit cube
      Call scale2Square(nP, XYP, .TRUE.)

c ... print Ani2D header
      If(iPrint.GE.1) Write(*, 5004) Quality, nEStar, MaxQItr

c ... set up default status
      Call setStatus(flagAuto, status, iPrint)

c ... call the main module
      flagAnalytic = .TRUE.
      Call ani2(
c group (M)
     &      nP, MaxP, nF, MaxF, nE, MaxE, nPv,
     &      XYP, IPF, IPE, IPV,
     &      CrvFunction, ParCrv, iFnc,
     &      nEStar, hStar,
     &      iW(iICP), iW(iIEP),
     &      iW(iIFE), iW(iIEE),
     &      iW(iL1E), iW(iL2E),
     &      iW(iIHolP), iW(iIHolF), iW(iIHolE),
     &      iW(iIEPw), iW(inEPw),
     &      iW(iIPEw), iW(iiSE),
c group (Dev)
     &      nFv, nEv, IFV, IEV, lbE,
     &      flagAuto, status,
c group (CRV)
     &      iW(iL1Et), iW(iL2Et), rW(itE),
     &      iW(inL2t), iW(inStept), iW(inEt),
     &      iW(iLFnc), iW(iILt),
c group (Q)
     &      MaxSkipE, MaxQItr, nQItr,
     &      rW(iHesP), Quality, rQuality,
     &      rW(idG), rW(iqE), rW(iXYPw), rW(iHesPw), rW(irSE),
     &      MetricFunction, flagAnalytic,
c group (ERR)
     &      iPrint, iERR)

c ... rescale geometry back
      Call scale2Square(nP, XYP, .FALSE.)

c ... returning sadditional information
      Do n = 1, nP
         iW(n) = iW(iICP + n - 1)
      End do
      iW(nP + 1) = nQItr

      rW(1) = 0D0
      rW(2) = rQuality
      rW(3) = hStar

 1000 If(iERR.EQ.0 .OR. iERR.EQ.1000) Return
      Call errMes(iERR, 'mbaMetric',
     &            'See error.f for error description')

      Return

 5001 Format('Refining mesh:', I6, ' pts  and', I7, ' elements')

 5004 Format(/,
     &    'STONE FLOWER! (1997-2007), version 2.0', /,
     &    'Target: Quality', F5.2, ' with', I8,
     &    ' triangles for at most', I8, ' iterations')
      End

C ==========================================================
      Subroutine iniQ_analytic(nP, XYP, MetricFunction, HesP)
C ==========================================================
C  Three Fortran routines below create a metric field which
C  is 2x2 variable positive definite symmetric tensor HesP,
C             F(x,y)  H(x,y)
C      HesP =
C             H(x,y)  G(x,y)
C ==========================================================
C group (M)
      real   XYP(2, *)

C group (Q)
      Integer  MetricFunction
      EXTERNAL MetricFunction

      real   HesP(3, *)

C group (Local variables)
      real   x, y, Metric(2, 2)

C ==========================================================
      real  refXYP(2), scaXYP(2)
      Common /rescale/refXYP, scaXYP

C ==========================================================
      Do n = 1, nP
         x = refXYP(1) + XYP(1, n) * scaXYP(1)
         y = refXYP(2) + XYP(2, n) * scaXYP(2)

         i = MetricFunction(x, y, Metric)

         HesP(1, n) = Metric(1, 1)
         HesP(2, n) = Metric(2, 2)
         HesP(3, n) = Metric(1, 2)
      End do

      Return
      End


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

module lib_random

  implicit none
  save

  private

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

  integer :: idum = -1204132124
  real(dp) :: u(97)

  real(dp),parameter :: pi = 3.14159265358979323846_dp
  real(sp),parameter :: pi_sp = 3.14159265358979323846_sp
  real(dp),parameter :: pi_dp = 3.14159265358979323846_dp

  real(dp),parameter :: twopi = 2._dp * pi
  real(sp),parameter :: twopi_sp = pi_sp + pi_sp
  real(dp),parameter :: twopi_dp = pi_dp + pi_dp

  public :: set_seed
  public :: set_seed_64

  public :: random
  interface random
     module procedure random_sp
     module procedure random_dp
  end interface random

  public :: random_exp
  interface random_exp
     module procedure random_exp_sp
     module procedure random_exp_dp
  end interface random_exp

  public :: random_uni
  interface random_uni
     module procedure random_uni_sp
     module procedure random_uni_dp
  end interface random_uni

  public :: random_gau
  interface random_gau
     module procedure random_gau_sp
     module procedure random_gau_dp
  end interface random_gau

  public :: random_sphere
  interface random_sphere
     module procedure random_sphere_sp
     module procedure random_sphere_dp
  end interface random_sphere

  public :: random_poisson
  interface random_poisson
     module procedure random_poisson_sp
     module procedure random_poisson_dp
  end interface random_poisson

  public :: random_planck_frequency
  interface random_planck_frequency
     module procedure random_planck_frequency_sp
     module procedure random_planck_frequency_dp
  end interface random_planck_frequency

contains

  subroutine set_seed(seed)
    implicit none
    integer,intent(in) :: seed
    idum = -abs(seed)
    call set_seed_64(abs(seed), 987654321)
  end subroutine set_seed

  subroutine set_seed_64(seed1,seed2)
    implicit none
    integer,intent(in) :: seed1,seed2
    integer i,j,x,y
    real(dp) :: s,t
    x=seed1
    y=seed2
    do i=1,97
       s=0._dp
       t=0.5_dp
       do j=1,53
          x=mod(6969*x,65543)
          y=mod(8888*x,65579)
          if (iand(ieor(x,y),32).gt.0) s=s+t
          t=0.5_dp*t
       end do
       u(i)=s
    end do
  end subroutine set_seed_64

  subroutine random_string(string)
    implicit none
    character(len=*),intent(out) :: string
    integer :: i,j
    real(dp) :: xi
    do i=1,len(string)
       call random(xi)
       j = int(xi*26._dp)
       call random(xi)
       if(xi < 0.5) then
          j = j + 65
       else
          j = j + 97
       end if
       string(i:i) = char(j)
    end do
  end subroutine random_string

  subroutine random_sp(xi)
    ! Random number between 0 and 1
    ! Inspired by Numerical Recipes
    implicit none
    real(sp),intent(out) :: xi
    real(sp),save        :: am
    integer, parameter :: ia=16807,im=2147483647,iq=127773,ir=2836
    integer, save :: ix=-1,iy=-1,k
    if (idum <= 0 .or. iy < 0) then
       am=nearest(1.0_sp,-1.0_sp)/im
       iy=ior(ieor(888889999,abs(idum)),1)
       ix=ieor(777755555,abs(idum))
       idum=abs(idum)+1
    end if
    ix=ieor(ix,ishft(ix,13))
    ix=ieor(ix,ishft(ix,-17))
    ix=ieor(ix,ishft(ix,5))
    k=iy/iq
    iy=ia*(iy-k*iq)-ir*k
    if (iy < 0) iy=iy+im
    xi=am*ior(iand(im,ieor(ix,iy)),1)
  end subroutine random_sp

  subroutine random_dp(xi)
    ! Random number between 0 and 1
    ! Based on "The 64-bit universal RNG", Marsaglia & Tsang (2004)
    implicit none
    real(dp),intent(out) :: xi
    integer,save :: i=97
    integer,save :: j=33
    real(dp),save :: c=0
    real(dp) :: x
    real(dp), parameter :: r=9007199254740881._dp/9007199254740992._dp
    real(dp), parameter :: d=362436069876._dp/9007199254740992._dp
    x=u(i)-u(j)
    if (x.lt.0.0) x=x+1.0_dp
    u(i)=x
    i=i-1
    if (i.eq.0) i=97
    j=j-1
    if (j.eq.0) j=97
    c=c-d
    if (c.lt.0.0) c=c+r
    x=x-c
    xi=x
    if (x.lt.0.) xi=x+1._dp
    return
  end subroutine random_dp

  subroutine random_uni_dp(xi,a,b)
    ! Uniform random number between a and b
    implicit none
    real(dp),intent(in)  :: a,b
    real(dp),intent(out) :: xi
    call random(xi)
    xi = a + (b-a) * xi
  end subroutine random_uni_dp

  subroutine random_gau_dp(xi,c,w)
    ! Gaussian random number with center c and 1-sigma w
    implicit none
    real(dp),intent(in)  :: c,w
    real(dp),intent(out) :: xi
    real(dp) :: r,g1,g2,x,y,t
    do
       call random_uni(x,-1._dp,+1._dp)
       call random_uni(y,-1._dp,+1._dp)
       r = x*x + y*y
       if(r.lt.1) exit
    end do
    t=sqrt(-2._dp*log(r)/r)
    g1 = x*t
    g2 = y*t
    xi = g1*w+c
  end subroutine random_gau_dp

  subroutine random_exp_dp(xi)
    ! Random number sampled from exp(-tau)
    implicit none
    real(dp),intent(out) :: xi
    do
       call random(xi)
       if(xi < 1._dp) exit
    end do
    xi = - log( 1._dp - xi )
  end subroutine random_exp_dp

  subroutine random_sphere_dp(mu,phi)
    ! Random longitude/latitude on a sphere
    implicit none
    real(dp),intent(out) :: mu,phi
    call random_uni(mu,-1._dp,+1._dp)
    call random_uni(phi,0._dp,twopi_dp)
  end subroutine random_sphere_dp

  subroutine random_poisson_dp(xi,xm)
    ! Random number drawn from Poisson distribution with
    ! expected value xm

    implicit none

    real(dp),intent(in) :: xm
    real(dp),intent(out) :: xi
    real(dp) :: em,harvest,t,y

    real(dp), save :: alxm,g,oldm=-1.0_dp,sq

    if (xm < 12.0) then
       if (xm /= oldm) then
          oldm=xm
          g=exp(-xm)
       end if
       em=-1
       t=1.0
       do
          em=em+1.0_dp
          call random_dp(harvest)
          t=t*harvest
          if (t <= g) exit
       end do
    else
       if (xm /= oldm) then
          oldm=xm
          sq=sqrt(2.0_dp*xm)
          alxm=log(xm)
          g=xm*alxm-gammln_dp(xm+1.0_dp)
       end if
       do
          do
             call random_dp(harvest)
             y=tan(pi*harvest)
             em=sq*y+xm
             if (em >= 0.0) exit
          end do
          em=int(em)
          t=0.9_dp*(1.0_dp+y**2)*exp(em*alxm-gammln_dp(em+1.0_dp)-g)
          call random_dp(harvest)
          if (harvest <= t) exit
       end do
    end if
    xi = em
  end subroutine random_poisson_dp

  subroutine random_planck_frequency_dp(nu,T)

    ! Random frequency sampled from a planck function with temperature T

    ! The algorithm is taken from 'Sampling a random variable distributed
    ! according to planck's law' by Barnett and Canfield

    implicit none

    real(dp),intent(in) :: T
    real(dp),intent(out) :: nu
    real(dp) :: x,r,r1,r2,r3,r4,a,y,z

    real(dp),parameter :: k  = 1.3806503e-23_dp ! J/K
    real(dp),parameter :: h  = 6.626068e-34_dp ! J.s

    ! Sample a random number from x^3/(exp(x)-1)

    do

       call random(r1)
       call random(r2)
       call random(r3)
       call random(r4)

       r = r1*r2*r3*r4

       if(r > 0._dp) exit

    end do

    x = - log(r)

    a = 1._dp
    y = 1._dp
    z = 1._dp

    call random(r1)
    do
       if(1.08232_dp*r1 <= a) exit
       y = y + 1._dp
       z = 1._dp/y
       a = a + z*z*z*z
    end do
    x = x * z

    ! Convert to frequency

    nu = x * k * T / h

  end subroutine random_planck_frequency_dp

  real(dp) function gammln_dp(xx)

    implicit none

    real(dp),intent(in) :: xx
    integer :: j
    real(dp) :: ser,tmp,x,y

    real(dp),save :: cof(6) = (/76.18009172947146_dp,&
         &-86.50532032941677_dp,24.01409824083091_dp,&
         &-1.231739572450155_dp,.1208650973866179e-2_dp,&
         &-.5395239384953e-5_dp/)

    real(dp),save :: stp = 2.5066282746310005_dp

    x=xx
    y=x
    tmp=x+5.5_dp
    tmp=(x+0.5_dp)*log(tmp)-tmp
    ser=1.000000000190015_dp

    do j=1,6
       y=y+1._dp
       ser=ser+cof(j)/y
    end do

    gammln_dp=tmp+log(stp*ser/x)
    return

  end function gammln_dp

  subroutine random_uni_sp(xi,a,b)
    ! Uniform random number between a and b
    implicit none
    real(sp),intent(in)  :: a,b
    real(sp),intent(out) :: xi
    call random(xi)
    xi = a + (b-a) * xi
  end subroutine random_uni_sp

  subroutine random_gau_sp(xi,c,w)
    ! Gaussian random number with center c and 1-sigma w
    implicit none
    real(sp),intent(in)  :: c,w
    real(sp),intent(out) :: xi
    real(sp) :: r,g1,g2,x,y,t
    do
       call random_uni(x,-1._sp,+1._sp)
       call random_uni(y,-1._sp,+1._sp)
       r = x*x + y*y
       if(r.lt.1) exit
    end do
    t=sqrt(-2._sp*log(r)/r)
    g1 = x*t
    g2 = y*t
    xi = g1*w+c
  end subroutine random_gau_sp

  subroutine random_exp_sp(xi)
    ! Random number sampled from exp(-tau)
    implicit none
    real(sp),intent(out) :: xi
    do
       call random(xi)
       if(xi < 1._sp) exit
    end do
    xi = - log( 1._sp - xi )
  end subroutine random_exp_sp

  subroutine random_sphere_sp(mu,phi)
    ! Random longitude/latitude on a sphere
    implicit none
    real(sp),intent(out) :: mu,phi
    call random_uni(mu,-1._sp,+1._sp)
    call random_uni(phi,0._sp,twopi_sp)
  end subroutine random_sphere_sp

  subroutine random_poisson_sp(xi,xm)
    ! Random number drawn from Poisson distribution with
    ! expected value xm

    implicit none

    real(sp),intent(in) :: xm
    real(sp),intent(out) :: xi
    real(sp) :: em,harvest,t,y

    real(sp), save :: alxm,g,oldm=-1.0_sp,sq

    if (xm < 12.0) then
       if (xm /= oldm) then
          oldm=xm
          g=exp(-xm)
       end if
       em=-1
       t=1.0
       do
          em=em+1.0_sp
          call random_sp(harvest)
          t=t*harvest
          if (t <= g) exit
       end do
    else
       if (xm /= oldm) then
          oldm=xm
          sq=sqrt(2.0_sp*xm)
          alxm=log(xm)
          g=xm*alxm-gammln_sp(xm+1.0_sp)
       end if
       do
          do
             call random_sp(harvest)
             y=tan(pi*harvest)
             em=sq*y+xm
             if (em >= 0.0) exit
          end do
          em=int(em)
          t=0.9_sp*(1.0_sp+y**2)*exp(em*alxm-gammln_sp(em+1.0_sp)-g)
          call random_sp(harvest)
          if (harvest <= t) exit
       end do
    end if
    xi = em
  end subroutine random_poisson_sp

  subroutine random_planck_frequency_sp(nu,T)

    ! Random frequency sampled from a planck function with temperature T

    ! The algorithm is taken from 'Sampling a random variable distributed
    ! according to planck's law' by Barnett and Canfield

    implicit none

    real(sp),intent(in) :: T
    real(sp),intent(out) :: nu
    real(sp) :: x,r,r1,r2,r3,r4,a,y,z

    real(sp),parameter :: k  = 1.3806503e-23_sp ! J/K
    real(sp),parameter :: h  = 6.626068e-34_sp ! J.s

    ! Sample a random number from x^3/(exp(x)-1)

    do

       call random(r1)
       call random(r2)
       call random(r3)
       call random(r4)

       r = r1*r2*r3*r4

       if(r > 0._dp) exit

    end do

    x = - log(r)

    a = 1._sp
    y = 1._sp
    z = 1._sp

    call random(r1)
    do
       if(1.08232_sp*r1 <= a) exit
       y = y + 1._sp
       z = 1._sp/y
       a = a + z*z*z*z
    end do
    x = x * z

    ! Convert to frequency

    nu = x * k * T / h

  end subroutine random_planck_frequency_sp

  real(sp) function gammln_sp(xx)

    implicit none

    real(sp),intent(in) :: xx
    integer :: j
    real(sp) :: ser,tmp,x,y

    real(sp),save :: cof(6) = (/76.18009172947146_sp,&
         &-86.50532032941677_sp,24.01409824083091_sp,&
         &-1.231739572450155_sp,.1208650973866179e-2_sp,&
         &-.5395239384953e-5_sp/)

    real(sp),save :: stp = 2.5066282746310005_sp

    x=xx
    y=x
    tmp=x+5.5_sp
    tmp=(x+0.5_sp)*log(tmp)-tmp
    ser=1.000000000190015_sp

    do j=1,6
       y=y+1._sp
       ser=ser+cof(j)/y
    end do

    gammln_sp=tmp+log(stp*ser/x)
    return

  end function gammln_sp

end module lib_random