subroutine rdist(n, nbins, vp, rcut, rdf_y, rdf_x)
    implicit none

    integer*4,              intent(in) :: n
    integer*4,              intent(in) :: nbins
    real*8, dimension(n,3), intent(in) :: vp
    real*8                            :: rcut

    real*8, dimension(nbins), intent(out)   :: rdf_x, rdf_y
    real*8, dimension(:), allocatable       :: gr2

    real*8 :: x(n), y(n), z(n), xbox, ybox, zbox, mdl
    real*8 :: xmin, ymin, zmin, xmax, ymax, zmax
    real*8 :: xb2, yb2, zb2, xb22, yb22, zb22
    real*8 :: dva, a, rm, rm2, xl, dx, dy, dz, r2, dn, cf, xi, yi, zi
    real*8 :: ro, xlr, dxlr, dr, pi, rr1, rr2

    integer*4 :: m, n1, i, j, i1, i2, gr2size

    do i=1, n
        if (vp(i,1) > xmax) xmax = vp(i,1)
        if (vp(i,2) > ymax) ymax = vp(i,2)
        if (vp(i,3) > zmax) zmax = vp(i,3)

        if (vp(i,1) < xmin) xmin = vp(i,1)
        if (vp(i,2) < ymin) ymin = vp(i,2)
        if (vp(i,3) < zmin) zmin = vp(i,3)
    end do
    print *,"Absolute boundaries of the system"
    write(6,'(a4,f10.6,a5,f10.6,a5,f10.6)') "X0: ",xmin," Y0: ",ymin," Z0: ",zmin
    write(6,'(a4,f10.6,a5,f10.6,a5,f10.6)') "X1: ",xmax," Y1: ",ymax," Z1: ",zmax

    xbox = xmax - xmin
    ybox = ymax - ymin
    zbox = zmax - zmin

    xb2 = xbox/2.
    yb2 = ybox/2.
    zb2 = zbox/2.

    xb22 = xb2 * xb2
    yb22 = yb2 * yb2
    zb22 = zb2 * zb2

    mdl = ((xb22 + yb22 + zb22)**(1./3.))**2

    gr2size = int(mdl)

    print *,"GR2 size: ", gr2size

    allocate(gr2(gr2size))

    ! size of gr2 is half box size square

    xl=600.
    ro=0.3
    xlr=(dble(n)/ro)**(1./3.)
    dxlr=xlr/600.
    cf=xl/xlr
    dva=2.
    rm=xl/2.
    rm2=rm*rm
    dn=2./dble(n)
    a=2.**52-0.5

    if (rcut .gt. rm) rcut = rm

    print *, "Particles accepted: ",n
    print *, "Bins for rdf_y: ",nbins
    print *, "Bins for gr2: ", nbins*nbins
    print *, "RCUT set to: "

    print *, "Acquiring coordinates"
    do i = 1, n
        x(i) = vp(i,1)
        y(i) = vp(i,2)
        z(i) = vp(i,3)
    end do
    print *, "Done"

    print *, "Multiplying coords"
    do i = 1, n
        x(i) = x(i) * cf
        y(i) = y(i) * cf
        z(i) = z(i) * cf
    end do
    print *, "Done"

    print *,"Zeroing the gr2"
    do i = 1,nbins*nbins
        gr2(i) = 0.
    end do
    print *,"Done"

    n1 = n - 1

    m = 0
    print *,"Filling histogram gr2"
    do i = 1, n1
        i1 = i + 1
        xi = x(i)
        yi = y(i)
        zi = z(i)

        do j = i1, n
            dx = abs(x(j) - xi)
            dy = abs(y(j) - yi)
            dz = abs(z(j) - zi)

            if(dx.gt.rm) dx = xl - dx
            if(dy.gt.rm) dy = xl - dy
            if(dz.gt.rm) dz = xl - dz

            r2 = dx*dx + dy*dy + dz*dz

            if(r2.lt.1.) then
                write(*,*) r2
                stop
            end if

            if(r2.gt.rm2) then
                cycle
            else
                !print *,i,j,m,gr2(m),dn
                m = idint(r2) + 1
                gr2(m) = gr2(m) + dn

            end if
         end do
     end do
    print *,"Done"

    print *,"Filling rdf_y"
    do i = 1, nbins
        rdf_y(i) = 0.
        i1 = (i - 1)**2 + 1
        i2 = i**2
        do j = i1, i2
            rdf_y(i) = rdf_y(i) + gr2(j)
         end do
    end do
    print *, "Done"

    ro = dble(n) / xl**3.
    pi = 3.141592654
    dr = 1.

    print *,"Normalizing histogram rdf_y"
    do i = 1, nbins
        rr1 = dr * (i - 1)
        rr2 = dr * i
        dn  = ro * 4. * pi * (rr2**3. - rr1**3.) / 3.
        rdf_y(i) = rdf_y(i) / dn
    end do
    print *,"Done"

      print *, "Printing RDF to screen"
      do i=1,nbins
        rdf_x(i)=dxlr*(i-0.5)
        !print *, i
        !write(*,22) rdf_x(i), rdf_y(i)
      end do
      print *, "Done"
! 22   format(f10.5,f14.6)

    deallocate(gr2)

end subroutine rdist


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id$
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE COSTF1(N,INC,X,WSAVE,WORK,IER)
      REAL       X(INC,*)       ,WSAVE(*)
      DOUBLE PRECISION           DSUM
      IER = 0
      NM1 = N-1
      NP1 = N+1
      NS2 = N/2
      IF (N-2) 200,101,102
  101 X1H = X(1,1)+X(1,2)
      X(1,2) = .5*(X(1,1)-X(1,2))
      X(1,1) = .5*X1H
      GO TO 200
  102 IF (N .GT. 3) GO TO 103
      X1P3 = X(1,1)+X(1,3)
      TX2 = X(1,2)+X(1,2)
      X(1,2) = .5*(X(1,1)-X(1,3))
      X(1,1) = .25*(X1P3+TX2)
      X(1,3) = .25*(X1P3-TX2)
      GO TO 200
  103 DSUM = X(1,1)-X(1,N)
      X(1,1) = X(1,1)+X(1,N)
      DO 104 K=2,NS2
         KC = NP1-K
         T1 = X(1,K)+X(1,KC)
         T2 = X(1,K)-X(1,KC)
         DSUM = DSUM+WSAVE(KC)*T2
         T2 = WSAVE(K)*T2
         X(1,K) = T1-T2
         X(1,KC) = T1+T2
  104 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .EQ. 0) GO TO 124
      X(1,NS2+1) = X(1,NS2+1)+X(1,NS2+1)
  124 LENX = INC*(NM1-1)  + 1
      LNSV = NM1 + INT(LOG(REAL(NM1))) + 4
      LNWK = NM1
C
      CALL RFFT1F(NM1,INC,X,LENX,WSAVE(N+1),LNSV,WORK,
     1            LNWK,IER1)
      IF (IER1 .NE. 0) THEN
        IER = 20
        CALL XERFFT ('COSTF1',-5)
        GO TO 200
      ENDIF
C
      SNM1 = 1./FLOAT(NM1)
      DSUM = SNM1*DSUM
      IF(MOD(NM1,2) .NE. 0) GO TO 30
      X(1,NM1) = X(1,NM1)+X(1,NM1)
   30 DO 105 I=3,N,2
         XI = .5*X(1,I)
         X(1,I) = .5*X(1,I-1)
         X(1,I-1) = DSUM
         DSUM = DSUM+XI
  105 CONTINUE
      IF (MODN .NE. 0) GO TO 117
      X(1,N) = DSUM
  117 X(1,1) = .5*X(1,1)
      X(1,N) = .5*X(1,N)
  200 RETURN
      END


double precision function philim_user(a,b,meth)
    implicit none

    double precision a,b
    integer meth

    double precision wlimitr, th, r

!!     # Compute a limiter based on wave strengths a and b.
!!     # meth determines what limiter is used.
!!     # a is assumed to be nonzero.

!!     # NOTE: This routine is obsolete.  Instead of using limiter.f,
!!     # which calls philim.f for every wave, it is more efficient to
!!     # use inlinelimiter.f, which eliminates all these function calls
!!     # to philim.  If you wish to change the limiter function and are
!!     # using inlinelimiter.f, the formulas must be changed in that routine.

    r = b/a

    if (meth .eq. 6) then
        !! ------------------------------
        !! # Sweby
        !! ------------------------------
        wlimitr = dmax1(0.d0, dmin1(r,1.5d0),dmin1(1.5d0*r,1.d0))

    else if (meth .eq. 7) then
        !! ------------------------------
        !! # Generalized minmod
        !! ------------------------------
        th = 1.3
        wlimitr = dmax1(0.d0, dmin1(th*r,(1+r)/2.d0,th));
    endif

    philim_user = wlimitr

    return
end function philim_user


MODULE PolynomialBasisMappingModule

  USE KindModule, ONLY: &
    DP
  USE ProgramHeaderModule, ONLY: &
    nDOFX, nDOFZ
  USE QuadratureModule, ONLY: &
    xG5, wG5
  USE PolynomialBasisModule_Lagrange, ONLY: &
    IndL_Q, IndLX_Q, L_E, L_X1, L_X2, L_X3
  USE PolynomialBasisModule_Legendre, ONLY: &
    IndP_Q, IndPX_Q, P_E, P_X1, P_X2, P_X3, &
    MassP, MassPX

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: InitializePolynomialBasisMapping
  PUBLIC :: MapNodalToModalX
  PUBLIC :: MapNodalToModalZ
  PUBLIC :: MapNodalToModal_Fluid
  PUBLIC :: MapNodalToModal_Radiation_X
  PUBLIC :: MapNodalToModal_Radiation
  PUBLIC :: MapModalToNodalX
  PUBLIC :: MapModalToNodalZ
  PUBLIC :: MapModalToNodal_Fluid
  PUBLIC :: MapModalToNodal_Radiation_X
  PUBLIC :: MapModalToNodal_Radiation

  REAL(DP), DIMENSION(:,:), ALLOCATABLE, PUBLIC :: Kij_X, Pij_X
  REAL(DP), DIMENSION(:,:), ALLOCATABLE         :: Kij_Z, Pij_Z

CONTAINS

  SUBROUTINE InitializePolynomialBasisMapping &
    ( Nodes_E, Nodes_X1, Nodes_X2, Nodes_X3 )

    REAL(DP), INTENT(in) :: Nodes_E (:)
    REAL(DP), INTENT(in) :: Nodes_X1(:)
    REAL(DP), INTENT(in) :: Nodes_X2(:)
    REAL(DP), INTENT(in) :: Nodes_X3(:)

    INTEGER :: i, j
    INTEGER :: qE, qX1, qX2, qX3

    ALLOCATE( Kij_X(1:nDOFX,1:nDOFX), Pij_X(1:nDOFX,1:nDOFX) )

    Kij_X = 0.0_DP
    DO j = 1, nDOFX
    DO i = 1, nDOFX

      DO qX3 = 1, SIZE( xG5 )
      DO qX2 = 1, SIZE( xG5 )
      DO qX1 = 1, SIZE( xG5 )

        Kij_X(i,j) &
          = Kij_X(i,j) &
              + wG5(qX1) * wG5(qX2) * wG5(qX3) &
                  * P_X1(IndPX_Q(1,i)) % P( xG5(qX1) ) &
                  * P_X2(IndPX_Q(2,i)) % P( xG5(qX2) ) &
                  * P_X3(IndPX_Q(3,i)) % P( xG5(qX3) ) &
                  * L_X1(IndLX_Q(1,j)) % P( xG5(qX1) ) &
                  * L_X2(IndLX_Q(2,j)) % P( xG5(qX2) ) &
                  * L_X3(IndLX_Q(3,j)) % P( xG5(qX3) )

      END DO
      END DO
      END DO

      Pij_X(i,j) &
        =   P_X1(IndPX_Q(1,j)) % P( Nodes_X1(IndLX_Q(1,i)) ) &
          * P_X2(IndPX_Q(2,j)) % P( Nodes_X2(IndLX_Q(2,i)) ) &
          * P_X3(IndPX_Q(3,j)) % P( Nodes_X3(IndLX_Q(3,i)) )

    END DO
    END DO

    ALLOCATE( Kij_Z(1:nDOFZ,1:nDOFZ), Pij_Z(1:nDOFZ,1:nDOFZ) )

    Kij_Z = 0.0_DP
    DO j = 1, nDOFZ
    DO i = 1, nDOFZ

      DO qX3 = 1, SIZE( xG5 )
      DO qX2 = 1, SIZE( xG5 )
      DO qX1 = 1, SIZE( xG5 )
      DO qE  = 1, SIZE( xG5 )

        Kij_Z(i,j) &
          = Kij_Z(i,j) &
              + wG5(qE) * wG5(qX1) * wG5(qX2) * wG5(qX3) &
                  * P_E (IndP_Q(0,i)) % P( xG5(qE ) ) &
                  * P_X1(IndP_Q(1,i)) % P( xG5(qX1) ) &
                  * P_X2(IndP_Q(2,i)) % P( xG5(qX2) ) &
                  * P_X3(IndP_Q(3,i)) % P( xG5(qX3) ) &
                  * L_E (IndL_Q(0,j)) % P( xG5(qE ) ) &
                  * L_X1(IndL_Q(1,j)) % P( xG5(qX1) ) &
                  * L_X2(IndL_Q(2,j)) % P( xG5(qX2) ) &
                  * L_X3(IndL_Q(3,j)) % P( xG5(qX3) )

      END DO
      END DO
      END DO
      END DO

      Pij_Z(i,j) &
        =   P_E (IndP_Q(0,j)) % P( Nodes_E (IndL_Q(0,i)) ) &
          * P_X1(IndP_Q(1,j)) % P( Nodes_X1(IndL_Q(1,i)) ) &
          * P_X2(IndP_Q(2,j)) % P( Nodes_X2(IndL_Q(2,i)) ) &
          * P_X3(IndP_Q(3,j)) % P( Nodes_X3(IndL_Q(3,i)) )

    END DO
    END DO

  END SUBROUTINE InitializePolynomialBasisMapping

  ! --- Nodal to Modal ---

  SUBROUTINE MapNodalToModalX( uN, uM )

    REAL(DP), DIMENSION(nDOFX), INTENT(in)  :: uN
    REAL(DP), DIMENSION(nDOFX), INTENT(out) :: uM

    uM = MassPX * MATMUL( Kij_X, uN )

  END SUBROUTINE MapNodalToModalX

  SUBROUTINE MapNodalToModalZ( uN, uM )

    REAL(DP), DIMENSION(nDOFZ), INTENT(in)  :: uN
    REAL(DP), DIMENSION(nDOFZ), INTENT(out) :: uM

    uM = MassP * MATMUL( Kij_Z, uN )

  END SUBROUTINE MapNodalToModalZ

  SUBROUTINE MapNodalToModal_Fluid( uN, uM )

    REAL(DP), DIMENSION(nDOFX), INTENT(in)  :: uN
    REAL(DP), DIMENSION(nDOFX), INTENT(out) :: uM

    uM = MassPX * MATMUL( Kij_X, uN )

  END SUBROUTINE MapNodalToModal_Fluid

  SUBROUTINE MapNodalToModal_Radiation_X( uN, uM )

    REAL(DP), DIMENSION(nDOFX), INTENT(in)  :: uN
    REAL(DP), DIMENSION(nDOFX), INTENT(out) :: uM

    uM = MassPX * MATMUL( Kij_X, uN )

  END SUBROUTINE MapNodalToModal_Radiation_X

  SUBROUTINE MapNodalToModal_Radiation( uN, uM )

    REAL(DP), DIMENSION(nDOFZ), INTENT(in)  :: uN
    REAL(DP), DIMENSION(nDOFZ), INTENT(out) :: uM

    uM = MassP * MATMUL( Kij_Z, uN )

  END SUBROUTINE MapNodalToModal_Radiation

  ! --- Modal to Nodal ---

  SUBROUTINE MapModalToNodalX( uN, uM )

    REAL(DP), DIMENSION(nDOFX), INTENT(out) :: uN
    REAL(DP), DIMENSION(nDOFX), INTENT(in)  :: uM

    uN = MATMUL( Pij_X, uM )

  END SUBROUTINE MapModalToNodalX

  SUBROUTINE MapModalToNodalZ( uN, uM )

    REAL(DP), DIMENSION(nDOFZ), INTENT(out) :: uN
    REAL(DP), DIMENSION(nDOFZ), INTENT(in)  :: uM

    uN = MATMUL( Pij_Z, uM )

  END SUBROUTINE MapModalToNodalZ

  SUBROUTINE MapModalToNodal_Fluid( uN, uM )

    REAL(DP), DIMENSION(nDOFX), INTENT(out) :: uN
    REAL(DP), DIMENSION(nDOFX), INTENT(in)  :: uM

    uN = MATMUL( Pij_X, uM )

  END SUBROUTINE MapModalToNodal_Fluid

  SUBROUTINE MapModalToNodal_Radiation_X( uN, uM )

    REAL(DP), DIMENSION(nDOFX), INTENT(out) :: uN
    REAL(DP), DIMENSION(nDOFX), INTENT(in)  :: uM

    uN = MATMUL( Pij_X, uM )

  END SUBROUTINE MapModalToNodal_Radiation_X

  SUBROUTINE MapModalToNodal_Radiation( uN, uM )

    REAL(DP), DIMENSION(nDOFZ), INTENT(out) :: uN
    REAL(DP), DIMENSION(nDOFZ), INTENT(in)  :: uM

    uN = MATMUL( Pij_Z, uM )

  END SUBROUTINE MapModalToNodal_Radiation

END MODULE PolynomialBasisMappingModule


      subroutine bjnser (x, l, jl, nl, ifl)

c-----------------------------------------------------------------------
c
c     subroutine: bjnser (x,l,jl,nl,ifl)
c
c     purpose:  to calculate the spherical bessel functions jl and nl
c
c     arguments:
c       x = argument of jl and nl
c       l = l value calculated (no offset)
c       jl = jl bessel function (abramowitz conventions)
c       nl = nl bessel function (abramowitz yl conventions)
c       ifl = 0 return both jl and nl
c             1 return jl only
c             2 return nl only
c
c     notes:  jl and nl are calculated by a series
c             expansion according to 10.1.2 and 10.1.3
c             in abramowitz and stegun (ninth printing),
c             page 437
c
c             error msgs written with PRINT statements.
c
c     first coded by r. c. albers on 26 jan 83
c
c     version 2
c
c     last modified: 27 jan 83 by r. c. albers
c
c-----------------------------------------------------------------------

      implicit double precision (a-h,o-z)

      complex*16 x,u,ux,del,pj,pn
      complex*16 jl,nl

      character*512 slog

      parameter (niter = 160, tol = 1.e-15)

      if (l .lt. 0) then
         call wlog(' l .lt. 0 in bjnser')
         stop 'bjnser 1'
      endif
      if (dble(x).lt. 0.) then
         write(slog,30) x
         call wlog(slog)
   30    format (' x = ', 1p, 2e14.6, ' is .le. 0 in bjnser')
         stop 'bjnser 2'
      endif

      lp1 = l+1
      u = x**2 / 2

c     make djl = 1 * 3 * 5 * ... * (2*l+1),
c          dnl = 1 * 3 * 5 * ... * (2*l-1)
      djl = 1
      fac = -1
      do 50 il = 1, lp1
         fac = fac + 2
         djl = fac * djl
   50 continue
      dnl = djl / (2*l+1)

      if (ifl .eq. 2)   goto 90
c     make jl
c     pj is term in { } in 10.1.2, del is last factor in the series
c     convergence test is (last factor)/(total term) <= tol
      pj = 1
      nf = 1
      nfac = 2*l + 3
      den = nfac
      sgn = -1
      ux = u
      do 60 il = 1, niter
         del = sgn*ux / den
         pj = pj + del
         trel = abs (del / pj)
         if (trel .le. tol)  goto 80
         sgn = -sgn
         ux = u*ux
         nf = nf+1
         nfac = nfac+2
         den = nf * nfac * den
   60 continue
      stop  'jl does not converge in bjnser'
   80 jl = pj * (x**l) / djl

   90 if (ifl.eq.1) return
c     make nl
c     pn is term in { } in 10.1.3, del is last factor in the series
c     convergence test is (last factor)/(total term) <= tol
      pn = 1
      nf = 1
      nfac = 1 - 2*l
      den = nfac
      sgn = -1
      ux = u
      do 100  il = 1, niter
         del = sgn * ux / den
         pn = pn + del
         trel = abs (del / pn)
         if (trel .le. tol) goto 120
         sgn = -sgn
         ux = u*ux
         nf = nf+1
         nfac = nfac+2
         den = nf * nfac * den
  100 continue
      stop  'nl does not converge in bjnser'
  120 nl = -pn * dnl / (x**lp1)

      return
      end


C     LAST UPDATE 15/02/95
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      REAL FUNCTION PSNINT(A1,A3,A4)
      IMPLICIT NONE
C
C Purpose: Y(X;A) is Pearson VII. The amplitude. centre and widths of
C          the Pearson VII are stored in consecutive locations of A:
C          A(1) = B,  A(2) = E,  A(3) = G1, A(4) = G2
C          This function returns the integrated area under the curve.
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameter:
C
      DOUBLE PRECISION PI,TINY
      PARAMETER (PI=3.14159265359D0,TINY=1.0D-10)
C
C Arguments:
C
      DOUBLE PRECISION A1,A3,A4
C
C Local variables:
C
      INTEGER N,I
      DOUBLE PRECISION FRAC,ARG
      REAL A,B,SS
C
C External function:
C
      REAL POWCOS
      EXTERNAL POWCOS
C
C Common block:
C
      DOUBLE PRECISION DEL
      COMMON /PSNCOM/ DEL
C
C-----------------------------------------------------------------------
C
      IF(A4.LT.TINY)THEN
        PSNINT=0.
        RETURN
      ENDIF
      B = SNGL(PI/2.0D0)
      A = -B
      FRAC = 1.0D0
      IF(A4.LT.1.0D0)THEN
         DEL = 2.0D0*(A4-1.0D0)
c      ELSEIF(A4.GT.1.0D3)THEN
c         DEL = 0.0
      ELSE
         N = INT(A4-1.0D0)
         ARG = DBLE(N)
         DEL = 2.0D0*(A4-ARG-1.0D0)
         DO 10 I=1,2*N,2
            ARG = DBLE(I)
            FRAC = FRAC*(ARG+DEL)/(ARG+DEL+1.0D0)
 10      CONTINUE
      ENDIF
      IF(DEL.LT.TINY)THEN
         SS = SNGL(PI)
      ELSE
         CALL QGAUS(POWCOS,A,B,SS)
      ENDIF
      FRAC = FRAC/(2.0D0*SQRT(2.0D0**(1.0D0/A4)-1.0D0))
      PSNINT = SNGL(A1*A3*FRAC)*SS
      RETURN
      END

      REAL FUNCTION POWCOS(X)
      REAL X
      DOUBLE PRECISION CX
      DOUBLE PRECISION DEL
      COMMON /PSNCOM/ DEL
      CX = DBLE(COS(X))
      POWCOS = SNGL(CX**DEL)
      RETURN
      END


      SUBROUTINE IVELT(VTP,AVEVEL,ST,TSI,NSAMPS)
C      IVELT IS A SUBPROGRAM TO CONVERT VELOCITY TIME PAIRS INTO AN ARRAY OF
C  VELOCITIES, EACH SEPARATED IN TIME UNIFORMLY.  (I.E.  THERE'S A VELOCITY
C  FOR EACH TIME SAMPLE.)  LINEAR INTERPOLATION IS USED TO OBTAIN VELOCITIES
C  BETWEEN THE TIMES SPECIFIED.  THE VELOCITY IS HELD CONSTANT FOR TIMES OUTSIDE
C  THE FIRST AND LAST SPECIFIED TIMES. AT LEAST 2 PAIRS MUST BE GIVEN.
C  EXCEED THE BOUNDS OF THE VTP.
C       ARGUMENTS:
C            VTP    - AN ARRAY OF VELOCITY-TIME PAIRS.  VTP(1) IS A VELOCITY,
C                     VTP(2) IS THE TIME, IN SECONDS, OF THE VELOCITY VTP(1),
C                     VTP(3) IS THE NEXT VELOCITY, AND VTP(4) IS THE TIME OF
C                     VTP(3), ETC..  ALL TIMES MUST BE STRICTLY MONOTONICALLY
C                     INCREASING.  IF ST<VTP(2) THEN ALL TIMES FROM ST TO VTP(2)
C                     WILL BE SET TO VTP(1)  ( EXTRAPOLATED.).  LIKEWISE, ALL
C                     TIMES EXCEEDING THE LAST VTP TIME WILL BE SET TO THE LAST
C                     VELOCITY.  THE VTP ARRAY MUST BE TERMINATED BY A TIME <=0
C                     OR A TIME EXCEEDING THE LAST VTP.
C            AVEVEL - AN ARRAY TO RECEIVE THE UNIFORMLY SPACED VELOCITIES.  MUST
C                     BE AT LEAST NSAMPS LONG.
C            ST     - START TIME IN SECONDS OF THE AVEVEL ARRAY.  AVEVEL(1)
C                     WILL HAVE A TIME OF ST ASSOCIATED WITH IT.
C            TSI    - TIME SAMPLE INTERVAL, IN SECONDS.  THE TIME DIFFERENCE
C                     BETWEEN CONSECUTIVE TIME SAMPLES.
C            NSAMPS - THE NUMBER OF TIME SAMPLES.  THE NUMBER OF VELOCITIES TO
C                     COMPUTE AND STORE INTO AVEVEL.
C
C      PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, MAY 1979
C
      DIMENSION VTP(111),AVEVEL(111)
      TIME=ST
      INDX=1
      N2=1                                                               /* THE POINTER TO A VTP PAIR
C
C    EXTRAPOLATE ANY TIMES LESS THAN VTP(2)
C
   10 IF(TIME.GT.VTP(2)) GO TO 100
C
      AVEVEL(INDX)=VTP(1)
      INDX=INDX+1
      TIME=TIME+TSI
      IF(INDX.GT.NSAMPS) RETURN
      GO TO 10
  100 IF(ST.LE.VTP(N2+3)) GO TO 200
      N2=N2+2                                                            /* STILL TRYING TO FIND A VTP
      IF(VTP(N2+1).GE.0) GO TO 100
      PRINT 120,ST
  120 FORMAT(' ***  ERROR  ***  NO TIME IN THE VTP EXCEEDS THE START ',
     *     'TIME OF ',F10.2,' (IVELT)')
      STOP
C
C    INTERPOLATE VALUES BETWEEN VTP TIMES
C
  200 CONTINUE
      IF(VTP(N2+3).NE.VTP(N2+1)) GO TO 205                              /* CONSTANT VELOCITY
      VT=0.                                                             /* WATCH OUT FOR DIVIDE BY 0.!
      GO TO 210
  205 VT=(VTP(N2+2)-VTP(N2))/(VTP(N2+3)-VTP(N2+1))
  210 CONTINUE
      IF(TIME.LE.VTP(N2+3)) GO TO 300
      N2=N2+2                                                           /*  SET UP THE NEXT VTP PAIR
      IF(VTP(N2+3).GT.0) GO TO 200
      V=AVEVEL(INDX-1)                                                   /*  EXTRAPOLATE TO TO END
      DO 220 I=INDX,NSAMPS
  220 AVEVEL(I)=V
      RETURN
  300 AVEVEL(INDX)=(TIME-VTP(N2+1))*VT+VTP(N2)
      INDX=INDX+1
      TIME=TIME+TSI
      IF(INDX.LE.NSAMPS) GO TO 210
      RETURN
      END


*> \brief \b SPTTRF
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SPTTRF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SPTTRF( N, D, E, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, N
*       ..
*       .. Array Arguments ..
*       REAL               D( * ), E( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SPTTRF computes the L*D*L**T factorization of a real symmetric
*> positive definite tridiagonal matrix A.  The factorization may also
*> be regarded as having the form A = U**T*D*U.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*>          D is REAL array, dimension (N)
*>          On entry, the n diagonal elements of the tridiagonal matrix
*>          A.  On exit, the n diagonal elements of the diagonal matrix
*>          D from the L*D*L**T factorization of A.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*>          E is REAL array, dimension (N-1)
*>          On entry, the (n-1) subdiagonal elements of the tridiagonal
*>          matrix A.  On exit, the (n-1) subdiagonal elements of the
*>          unit bidiagonal factor L from the L*D*L**T factorization of A.
*>          E can also be regarded as the superdiagonal of the unit
*>          bidiagonal factor U from the U**T*D*U factorization of A.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0: successful exit
*>          < 0: if INFO = -k, the k-th argument had an illegal value
*>          > 0: if INFO = k, the leading minor of order k is not
*>               positive definite; if k < N, the factorization could not
*>               be completed, while if k = N, the factorization was
*>               completed, but D(N) <= 0.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup auxOTHERcomputational
*
*  =====================================================================
      SUBROUTINE SPTTRF( N, D, E, INFO )
*
*  -- LAPACK computational routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER            INFO, N
*     ..
*     .. Array Arguments ..
      REAL               D( * ), E( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, I4
      REAL               EI
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MOD
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
         CALL XERBLA( 'SPTTRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Compute the L*D*L**T (or U**T*D*U) factorization of A.
*
      I4 = MOD( N-1, 4 )
      DO 10 I = 1, I4
         IF( D( I ).LE.ZERO ) THEN
            INFO = I
            GO TO 30
         END IF
         EI = E( I )
         E( I ) = EI / D( I )
         D( I+1 ) = D( I+1 ) - E( I )*EI
   10 CONTINUE
*
      DO 20 I = I4 + 1, N - 4, 4
*
*        Drop out of the loop if d(i) <= 0: the matrix is not positive
*        definite.
*
         IF( D( I ).LE.ZERO ) THEN
            INFO = I
            GO TO 30
         END IF
*
*        Solve for e(i) and d(i+1).
*
         EI = E( I )
         E( I ) = EI / D( I )
         D( I+1 ) = D( I+1 ) - E( I )*EI
*
         IF( D( I+1 ).LE.ZERO ) THEN
            INFO = I + 1
            GO TO 30
         END IF
*
*        Solve for e(i+1) and d(i+2).
*
         EI = E( I+1 )
         E( I+1 ) = EI / D( I+1 )
         D( I+2 ) = D( I+2 ) - E( I+1 )*EI
*
         IF( D( I+2 ).LE.ZERO ) THEN
            INFO = I + 2
            GO TO 30
         END IF
*
*        Solve for e(i+2) and d(i+3).
*
         EI = E( I+2 )
         E( I+2 ) = EI / D( I+2 )
         D( I+3 ) = D( I+3 ) - E( I+2 )*EI
*
         IF( D( I+3 ).LE.ZERO ) THEN
            INFO = I + 3
            GO TO 30
         END IF
*
*        Solve for e(i+3) and d(i+4).
*
         EI = E( I+3 )
         E( I+3 ) = EI / D( I+3 )
         D( I+4 ) = D( I+4 ) - E( I+3 )*EI
   20 CONTINUE
*
*     Check d(n) for positive definiteness.
*
      IF( D( N ).LE.ZERO )
     $   INFO = N
*
   30 CONTINUE
      RETURN
*
*     End of SPTTRF
*
      END


      subroutine intrc (ks,ke,x,yin,xin,yout,yout1)
c
c***********************************************************************
c     interpolation with monotonized piecewise cubic polynomials
c
c     source: M. STEFFEN (1990) AA, 239, 443
c***********************************************************************
c
      include'titan.imp'
      include'titan.par'
c
c.......................................................................
c     input:
      dimension x(mgr), yin(mgr), xin(mgr)
c.......................................................................
c     output:
      dimension yout(mgr), yout1(mgr)
c.......................................................................
c     internal:
      dimension h(mgr), s(mgr), p(mgr), y1(mgr),
     .          a(mgr), b(mgr), c(mgr),  d(mgr)
c
c=======================================================================
c-----------------------------------------------------------------------
c     mesh spacing and slope of the secant through the data
c-----------------------------------------------------------------------
c
      do 1 k = ks, ke - 1
      h(k) =     x(k+1) -   x(k)
      s(k) = ( yin(k+1) - yin(k) ) / h(k)
    1 continue
c
c-----------------------------------------------------------------------
c     parabola through the data
c-----------------------------------------------------------------------
c
           k  = ks
      p   (k) =   s(k  ) * ( 1.D0 + h(k) / ( h(k) + h(k+1) ) )
     .          - s(k+1) *          h(k) / ( h(k) + h(k+1) )
c
      do 2 k  = ks + 1, ke - 1
      p   (k) = ( s(k-1) * h(k) + s(k) * h(k-1) ) / ( h(k-1) + h(k) )
    2 continue
c
           k  = ke
      p   (k) =   s(k-1) * ( 1.D0 + h(k-1) / ( h(k-1) + h(k-2) ) )
     .          - s(k-2) *          h(k-1) / ( h(k-1) + h(k-2) )
c
c-----------------------------------------------------------------------
c     slope to satisfy monotonicity
c-----------------------------------------------------------------------
c
           k  = ks
      y1  (k) = ( sign(1.D0, s(k  ) ) + sign(1.D0, p(k) ) )
     .          *  min( abs( s(k  ) ), 0.5D0* abs( p(k) ) )
c
      do 3 k  = ks + 1, ke - 1
      y1  (k) = ( sign(1.D0, s(k-1) ) +              sign(1.D0, s(k) ) )
     .          *  min( abs( s(k-1) ), 0.5D0* abs( p(k) ), abs( s(k) ) )
    3 continue
c
           k  = ke
      y1  (k) = ( sign(1.D0, s(k-1) ) + sign(1.D0, p(k) ) )
     .          *  min( abs( s(k-1) ), 0.5D0* abs( p(k) ) )
c
c-----------------------------------------------------------------------
c     coefficients of cubic polynomial
c-----------------------------------------------------------------------
c
      do 4 k  = ks, ke - 1
      a   (k) = + (        y1(k) + y1(k+1) - 2.D0 * s(k) ) / h(k)**2
      b   (k) = - ( 2.D0 * y1(k) + y1(k+1) - 3.D0 * s(k) ) / h(k)
      c   (k) =            y1(k)
      d   (k) =           yin(k)
    4 continue
c
c-----------------------------------------------------------------------
c    find interval [x(k),x(k+1)] containing xin(j) and interpolate
c-----------------------------------------------------------------------
c
      yout (ks) = yin(ks)
      yout1(ks) = 0.D0
      do 5 k  = ks + 1, ke - 1
           do 6 j  = ke - 1, ks, - 1
	   if ( ( xin(j)-x(k) ) .ge. 0.D0 ) go to 7
    6      continue
    7      continue
      yout (k) = ( ( a(k)  *( xin(j)-x(k) )
     .             + b(k) )*( xin(j)-x(k) )
     .           +   c(k) )*( xin(j)-x(k) ) + d(k)
      yout1(k) =   ( a(k)  *( xin(j)-x(k) )
     .             + b(k) )*( xin(j)-x(k) ) + c(k)
    5 continue
      yout (ke) = yin(ke)
      yout1(ke) = 0.D0
c
c-----------------------------------------------------------------------
c
      return
      end


subroutine MakeEllipseCoord(coord, lat, lon, dec, A_theta, B_theta, &
                            cinterval, cnum, exitstatus)
!------------------------------------------------------------------------------
!
!   This subroutine will return the latitude and longitude
!   coordinates of an ellipse with semi-major and semi-minor axes
!   A_theta and B_theta (in degrees) at postition LAT and LON (in degrees)
!   and with a clockwise rotation of the semi-major axis DEC with respect
!   to local north (in degrees).
!
!   Calling Parameters
!
!       IN
!           lat         Latitude and longitude in degrees.
!           lon         Latitude and longitude in degrees.
!           A_theta     Angular radius of the semi-major axis in degrees.
!           B_theta     Angular radius of the semi-minor axis in degrees.
!           dec         Clockwise rotation of the semi-major axis with
!                       respect to local north in degrees.
!
!       OUT
!           coord       360/interval (latitude, longitude) coordinates.
!
!       OPTIONAL, IN
!           cinterval   Angular spacing of latitude and longitude points
!                       in degrees (default=1).
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!-------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp), intent(in) :: lat, lon, A_theta, B_theta, dec
    real(dp), intent(out) :: coord(:,:)
    real(dp), intent(in), optional :: cinterval
    integer, intent(out), optional :: cnum, exitstatus
    real(dp) :: pi, interval, xold, yold, zold, x, y, z, x1, phi, r
    integer :: k, num

    if (present(exitstatus)) exitstatus = 0

    if (present(cinterval)) then
        interval = cinterval
    else
        interval = 1.0_dp
    end if

    num = int(360.0_dp / interval)

    if (present(cnum)) then
        cnum = num
    end if

    if (size(coord(:,1)) < num .or. size(coord(1,:)) < 2) then
        print*, "Error --- MakeEllipseCoord"
        print*, "COORD must be dimensioned as (NUM, 2) where NUM is ", NUM
        print*, "Input array is dimensioned as ", size(coord(:,1)), &
                size(coord(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if
    end if

    pi = acos(-1.0_dp)

    !--------------------------------------------------------------------------
    !
    !   Calculate grid points. First create a cirlce, then rotate these
    !   points.
    !
    !--------------------------------------------------------------------------

    do k = 1, num

        phi = pi - dble(k-1) * (2.0_dp * pi / dble(num))
        r = a_theta * b_theta / sqrt( (b_theta*cos(phi))**2 &
            + (a_theta * sin(phi))**2)
        xold = sin(r * pi / 180.0_dp) * cos(phi - dec * pi / 180.0_dp)
        yold = sin(r * pi / 180.0_dp) * sin(phi - dec * pi / 180.0_dp)
        zold = cos(r * pi / 180.0_dp)

        ! rotate coordinate system 90-lat degrees about y axis

        x1 = xold * cos(pi / 2.0_dp - lat * pi / 180.0_dp) + &
             zold * sin(pi / 2.0_dp - lat * pi / 180.0_dp)
        z = -xold * sin(pi / 2.0_dp - lat * pi / 180.0_dp) + &
            zold * cos(pi / 2.0_dp - lat * pi / 180.0_dp)

        ! rotate coordinate system lon degrees about z axis

        x = x1 * cos(lon * pi / 180.0_dp) - yold * sin(lon * pi / 180.0_dp)
        y = x1 * sin(lon * pi / 180.0_dp) + yold * cos(lon * pi/180.0_dp)

        coord(k, 1) = (pi / 2.0_dp - acos(z / sqrt(x**2 + y**2 + z**2))) * &
                      180.0_dp / pi
        coord(k, 2) = atan2(y, x) * 180.0_dp / pi

    end do

end subroutine MakeEllipseCoord


module Mod_SmoothedFieldGradient

contains

   subroutine ComputeSmoothedFieldGradient(Mesh,Memor,ndofn,Displacement,SmoothedG)
      use typre
      use Mod_Mesh
      use Mod_Element
      use Mod_Memor
      implicit none
      class(FemMesh) :: Mesh
      type(MemoryMan) :: Memor
      integer(ip) :: ndofn
      real(rp) :: Displacement(ndofn,*)
      real(rp), target :: SmoothedG(*)

      real(rp), pointer :: SmoothedGradient(:,:,:) => NULL()

      class(FiniteElement), pointer :: e => NULL()
      real(rp), allocatable :: gradDisp(:,:),eldisp(:,:),elrhsSG(:,:,:)

      real(rp) :: dvol

      integer(ip) :: idofn,inode,ipoin,npoin,idime,ielem,nelem,igaus

      call Mesh%GetNpoin(npoin)
      call Mesh%ElementAlloc(e,Memor,'ForceClosedRule','ComputeSmoothedGradient')
      call Memor%Alloc(ndofn,e%mnode,eldisp,'eldisp','plcd_EnditeElmope')
      call Memor%Alloc(ndofn,e%ndime,gradDisp,'gradDisp','plcd_EnditeElmope')

      call Memor%Alloc(ndofn,e%ndime,e%mnode,elrhsSG,'elrhsSG','plcd_EnditeElmope')

      SmoothedGradient(1:ndofn,1:e%ndime,1:npoin) => SmoothedG(1:ndofn*e%ndime*npoin)
      SmoothedGradient(:,:,:) = 0.0_rp

      call Mesh%GetNelem(nelem)
      elements : do ielem = 1,nelem
         !Load Element
         call Mesh%ElementLoad(ielem,e)

         call e%gather(ndofn,eldisp,Displacement)

         elrhsSG = 0.0_rp

         !Compute linear derivatives
         call e%elmdel

         gauss_points : do igaus=1,e%pgaus
            e%igaus = igaus

            call e%elmder
            dvol = e%detjm*e%weigp(e%igaus)

            call e%gradient(ndofn,eldisp,gradDisp)
            do inode = 1,e%pnode
               do idofn = 1,ndofn
                  do idime = 1,e%ndime
                     elrhsSG(idofn,idime,inode) = elrhsSG(idofn,idime,inode) + e%shape(inode,e%igaus)*dvol*gradDisp(idofn,idime)
                  enddo
               enddo
            enddo

         enddo gauss_points

         call Mesh%AssemblyToArray(e,ndofn*e%ndime,elrhsSG,SmoothedGradient)
      enddo elements

      call Memor%dealloc(ndofn,e%ndime,e%mnode,elrhsSG,'elrhsSG','SmoothGradientInitializations')

      call Memor%deAlloc(ndofn,e%mnode,eldisp,'eldisp','plcd_EnditeElmope')
      call Memor%deAlloc(ndofn,e%ndime,gradDisp,'gradDisp','plcd_EnditeElmope')

      call Mesh%Smooth(ndofn*e%ndime,SmoothedGradient)

      !DeallocateElement
      call Mesh%ElementDeAlloc(e,Memor,'ForceClosedRule','plcd_Elmope')

   end subroutine

   subroutine PostprocessGaussPointGradient(Mesh,Memor,ndofn,Displacement,fieldname,FilePostpr,istep,ctime)
      use typre
      use Mod_Memor
      use Mod_Element
      use Mod_Mesh
      use Mod_Postpr
      use Mod_RPMeshAllocator
      implicit none
      class(FemMesh) :: Mesh
      type(MemoryMan) :: Memor
      integer(ip) :: ndofn
      real(rp) :: Displacement(ndofn,*)
      character(*) :: fieldname
      class(PostprFile) :: FilePostpr
      integer(ip) :: istep
      real(rp) :: ctime

      class(FiniteElement), pointer :: e => NULL()
      real(rp), allocatable :: gradDisp(:,:),eldisp(:,:)
      type(r3p), allocatable :: GaussPointField(:)

      real(rp) :: dvol

      integer(ip) :: idofn,inode,ipoin,npoin,idime,ielem,nelem,igaus,ndime

      call Mesh%GetNpoin(npoin)
      call Mesh%ElementAlloc(e,Memor,'ForceClosedRule','ComputeSmoothedGradient')
      call Memor%Alloc(ndofn,e%mnode,eldisp,'eldisp','plcd_EnditeElmope')
      call Memor%Alloc(ndofn,e%ndime,gradDisp,'gradDisp','plcd_EnditeElmope')

      call Mesh%GetNdime(ndime)
      call AllocR3P(Memor,Mesh,ndofn,ndime,GaussPointField)

      call Mesh%GetNelem(nelem)
      elements : do ielem = 1,nelem
         !Load Element
         call Mesh%ElementLoad(ielem,e)

         call e%gather(ndofn,eldisp,Displacement)

         !Compute linear derivatives
         call e%elmdel

         gauss_points : do igaus=1,e%pgaus
            e%igaus = igaus

            call e%elmder
            dvol = e%detjm*e%weigp(e%igaus)

            call e%gradient(ndofn,eldisp,gradDisp)

            GaussPointField(ielem)%a(:,:,e%igaus) = gradDisp

         enddo gauss_points

      enddo elements

      !Postprocess
      call FilePostpr%postgp(GaussPointField,fieldname,istep,ctime,Mesh)

      call Memor%deAlloc(ndofn,e%mnode,eldisp,'eldisp','plcd_EnditeElmope')
      call Memor%deAlloc(ndofn,e%ndime,gradDisp,'gradDisp','plcd_EnditeElmope')

      !DeallocateElement
      call Mesh%ElementDeAlloc(e,Memor,'ForceClosedRule','plcd_Elmope')

      call Mesh%GetNdime(ndime)
      call DeAllocR3P(Memor,Mesh,ndime,ndofn,GaussPointField)

   end subroutine
end module


!==============================================================================!
  subroutine Bulk_Mod_Adjust_P_Drops(bulk, dt)
!------------------------------------------------------------------------------!
!   Recalculate the pressure drop to keep the constant mass flux               !
!                                                                              !
!   First Newtons law:                                                         !
!                                                                              !
!   F = m * a                                                                  !
!                                                                              !
!   where:                                                                     !
!                                                                              !
!   a = dv / dt = dFlux / dt * 1 / (A * rho)                                   !
!   m = rho * v                                                                !
!   F = Pdrop * l * A = Pdrop * v                                              !
!                                                                              !
!   finally:                                                                   !
!                                                                              !
!   Pdrop * v = rho * v * dFlux / dt * 1 / (A * rho)                           !
!                                                                              !
!   after cancelling: v and rho, it yields:                                    !
!                                                                              !
!   Pdrop = dFlux/dt/A                                                         !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Bulk_Type)    :: bulk
  real               :: dt
!==============================================================================!

  if( abs(bulk % flux_x_o) >= TINY ) then
    bulk % p_drop_x = (bulk % flux_x_o - bulk % flux_x) &
                       / (dt * bulk % area_x + TINY)
  end if
  if( abs(bulk % flux_y_o) >= TINY ) then
    bulk % p_drop_y = (bulk % flux_y_o - bulk % flux_y) &
                       / (dt * bulk % area_y + TINY)
  end if
  if( abs(bulk % flux_z_o) >= TINY ) then
    bulk % p_drop_z = (bulk % flux_z_o - bulk % flux_z) &
                       / (dt * bulk % area_z + TINY)
  end if

  end subroutine