      SUBROUTINE MB01OS( UPLO, TRANS, N, H, LDH, X, LDX, P, LDP, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute P = H*X or P = X*H, where H is an upper Hessenberg
C     matrix and X is a symmetric matrix.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Specifies which triangle of the symmetric matrix X is
C             given as follows:
C             = 'U':  the upper triangular part is given;
C             = 'L':  the lower triangular part is given.
C
C     TRANS   CHARACTER*1
C             Specifies the operation to be performed as follows:
C             = 'N':         compute P = H*X;
C             = 'T' or 'C':  compute P = X*H.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices H, X, and P.  N >= 0.
C
C     H       (input) DOUBLE PRECISION array, dimension (LDH,N)
C             On entry, the leading N-by-N upper Hessenberg part of this
C             array must contain the upper Hessenberg matrix H.
C             The remaining part of this array is not referenced.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= MAX(1,N).
C
C     X       (input) DOUBLE PRECISION array, dimension (LDX,N)
C             On entry, if UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular part of the symmetric matrix X and the strictly
C             lower triangular part of the array is not referenced.
C             On entry, if UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular part of the symmetric matrix X and the strictly
C             upper triangular part of the array is not referenced.
C
C     LDX     INTEGER
C             The leading dimension of the array X.  LDX >= MAX(1,N).
C
C     P       (output) DOUBLE PRECISION array, dimension (LDP,N)
C             On exit, the leading N-by-N part of this array contains
C             the computed matrix P.
C
C     LDP     INTEGER
C             The leading dimension of the array P.  LDP >= MAX(1,N).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -k, the k-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix expression is efficiently evaluated taking the
C     structure into account, and using inline code and BLAS routines.
C     Let X = U + sL, where U is upper triangular and sL is strictly
C     lower triangular. Then, P = H*X = H*U + H*sL = H*U + H*sU', where
C     sU is the strictly upper triangular part of X.
C     Similarly, P = X*H = L'*H + sL*H, where L is lower triangular, and
C     X = L + sL'. Note that H*U and L'*H are both upper Hessenberg.
C     However, when UPLO = 'L' and TRANS = 'N', or when UPLO = 'U' and
C     TRANS = 'T', then the matrix P is full. The computations are done
C     similarly.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires approximately N**3/2 operations.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2019.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix algebra, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         TRANS, UPLO
      INTEGER           INFO, LDH, LDP, LDX, N
C     .. Array Arguments ..
      DOUBLE PRECISION  H(LDH,*), P(LDP,*), X(LDX,*)
C     .. Local Scalars ..
      DOUBLE PRECISION  TEMP
      INTEGER           I, J, J3
      LOGICAL           LTRANS, LUPLO
C     .. Local Arrays ..
      DOUBLE PRECISION  TMP(1)
C     .. External Functions ..
      DOUBLE PRECISION  DDOT
      LOGICAL           LSAME
      EXTERNAL          DDOT, LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEMV, DTRMM, DTRMV, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO   = 0
      LUPLO  = LSAME( UPLO, 'U' )
      LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      IF ( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -1
      ELSE IF ( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF ( N.LT.0 ) THEN
         INFO = -3
      ELSE IF ( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF ( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF ( LDP.LT.MAX( 1, N ) ) THEN
         INFO = -9
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01OS', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 )
     $   RETURN
C
      IF ( .NOT.LTRANS ) THEN
C
         IF ( LUPLO ) THEN
            TMP(1) = ZERO
C
C           Compute  P := H*U + H*sU'.
C
            DO 30 J = 1, N - 1
               CALL DCOPY( J, X(1,J), 1, P(1,J), 1 )
               CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J, H, LDH, P(1,J),
     $                     1 )
               CALL DCOPY( N-J, TMP, 0, P(J+1,J), 1 )
C
               DO 10 I = 2, J + 1
                  P(I,J) = P(I,J) + H(I,I-1)*X(I-1,J)
   10          CONTINUE
C
               DO 20 I = J + 2, N
                  CALL DAXPY( I, X(J,I-1), H(1,I-1), 1, P(1,J), 1 )
   20          CONTINUE
C
               CALL DAXPY( N, X(J,N), H(1,N), 1, P(1,J), 1 )
   30       CONTINUE
C
            CALL DCOPY( N, X(1,N), 1, P(1,N), 1 )
            CALL DTRMV( UPLO, 'NoTran', 'NoDiag', N, H, LDH, P(1,N), 1 )
C
            DO 40 I = 2, N
               P(I,N) = P(I,N) + H(I,I-1)*X(I-1,N)
   40       CONTINUE
C
         ELSE
C
C           Compute  P := H*L + H*sL'.
C           There is no contribution from sL' for the first column.
C
            CALL DCOPY( N, X, 1, P, 1 )
            CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', N, H, LDH, P, 1 )
C
            DO 50 I = 2, N
               P(I,1) = P(I,1 ) + H(I,I-1)*X(I-1,1)
   50       CONTINUE
C
            DO 80 J = 2, N
C
C              Compute the contribution from H*sL'.
C
               CALL DCOPY( J-1, X(J,1), LDX, P(1,J), 1 )
               CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', J-1, H, LDH,
     $                     P(1,J), 1 )
               P(J,J) = ZERO
C
               DO 60 I = 2, J
                  P(I,J) = P(I,J ) + H(I,I-1)*X(J,I-1)
   60          CONTINUE
C
C              Compute the contribution from H*L.
C
               TEMP = P(J,J)
               CALL DGEMV( 'NoTran', J-1, N-J+1, ONE, H(1,J), LDH,
     $                     X(J,J), 1, ONE, P(1,J), 1 )
               CALL DCOPY( N-J+1, X(J,J), 1, P(J,J), 1 )
               CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', N-J+1, H(J,J),
     $                     LDH, P(J,J), 1 )
               P(J,J) = P(J,J) + TEMP
C
               DO 70 I = J+1, N
                  P(I,J) = P(I,J ) + H(I,I-1)*X(I-1,J)
   70          CONTINUE
C
   80       CONTINUE
C
         END IF
C
      ELSE
C
         IF ( LUPLO ) THEN
C
C           Compute  P := U*H + sU'*H.
C
            DO 90 J = 1, N - 2
               J3 = MIN( J+3, N )
               CALL DCOPY( J+1, H(1,J), 1, P(1,J), 1 )
               CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J+1, X, LDX,
     $                     P(1,J), 1 )
               CALL DCOPY( J+1, H(1,J), 1, P(2,J+1), 1 )
               CALL DTRMV( UPLO, 'Tran', 'NoDiag', J+1, X(1,2), LDX,
     $                     P(2,J+1), 1 )
               CALL DAXPY( J, ONE, P(2,J+1), 1, P(2,J), 1 )
               P(J+2,J) = DDOT( J+1, X(1,J+2), 1, H(1,J), 1 )
               CALL DGEMV( 'Tran', J+1, N-J3, ONE, X(1,J3), LDX,
     $                     H(1,J), 1, ONE, P(J3,J), 1 )
               P(N,J) = DDOT( J+1, X(1,N), 1, H(1,J), 1 )
   90       CONTINUE
C
            IF ( N.EQ.1 ) THEN
               P(1,1) = X(1,1)*H(1,1)
            ELSE
               CALL DCOPY( N, H(1,N-1), 1, P(1,N-1), 1 )
               CALL DCOPY( N, H(1,N), 1, P(1,N), 1 )
               CALL DTRMM( 'Left', UPLO, 'NoTran', 'NoDiag', N, 2, ONE,
     $                     X, LDX, P(1,N-1), LDP )
C
               DO 100 I = 2, N
                  CALL DGEMV( 'Tran', I-1, 2, ONE, H(1,N-1), LDH,
     $                        X(1,I), 1, ONE, P(I,N-1), LDP )
  100          CONTINUE
C
            END IF
C
         ELSE
C
C           Compute  P := L*H + sL'*H.
C
            DO 110 J = 1, N - 1
               CALL DCOPY( J, H(1,J), 1, P(1,J), 1 )
               CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J, X, LDX, P(1,J),
     $                     1 )
               CALL DCOPY( J, H(2,J), 1, P(1,J+1), 1 )
               CALL DTRMV( UPLO, 'Tran', 'NoDiag', J, X(2,1), LDX,
     $                     P(1,J+1), 1 )
               CALL DAXPY( J, ONE, P(1,J+1), 1, P(1,J), 1 )
               CALL DGEMV( 'NoTran', N-J, J+1, ONE, X(J+1,1), LDX,
     $                     H(1,J), 1, ZERO, P(J+1,J), 1 )
  110       CONTINUE
C
            CALL DCOPY( N, H(1,N), 1, P(1,N), 1 )
            CALL DTRMV( UPLO, 'NoTran', 'NoDiag', N, X, LDX, P(1,N), 1 )
C
            DO 120 I = 1, N - 1
               P(I,N) = P(I,N) + DDOT( N-I, X(I+1,I), 1, H(I+1,N), 1 )
  120       CONTINUE
C
         END IF
C
      END IF
C
      RETURN
C *** Last line of MB01OS ***
      END


! this does the jbb algorithm for rk4
subroutine timeinterprk4_jbb(stage, lo, hi, &
     phi,  phi_lo, phi_hi, &
     old, old_lo, old_hi, &
     k1 , k1_lo, k1_hi, &
     k2 , k2_lo, k2_hi, &
     k3 , k3_lo, k3_hi, &
     k4 , k4_lo, k4_hi, &
     tf, tc_old, dt_c, dt_f, iter, nref &
     ) bind(C, name="timeinterprk4_jbb")

  use amrex_fort_module, only : amrex_real, dim=>bl_spacedim
  implicit none
  integer, intent(in) :: lo(3), hi(3), iter, nref
  integer, intent(in) :: phi_lo(3), phi_hi(3)
  integer, intent(in) :: old_lo(3), old_hi(3)
  integer, intent(in) :: k1_lo(3), k1_hi(3)
  integer, intent(in) :: k2_lo(3), k2_hi(3)
  integer, intent(in) :: k3_lo(3), k3_hi(3)
  integer, intent(in) :: k4_lo(3), k4_hi(3), stage

  double precision, intent(in)    :: tf, tc_old, dt_c, dt_f
  double precision, intent(inout) :: phi(phi_lo(1):phi_hi(1), &
                                         phi_lo(2):phi_hi(2), &
                                         phi_lo(3):phi_hi(3))

  double precision, intent(in)    :: old(old_lo(1):old_hi(1), &
                                         old_lo(2):old_hi(2), &
                                         old_lo(3):old_hi(3))

  double precision, intent(in)    :: k1(k1_lo(1):k1_hi(1), &
                                        k1_lo(2):k1_hi(2), &
                                        k1_lo(3):k1_hi(3))
  double precision, intent(in)    :: k2(k2_lo(1):k2_hi(1), &
                                        k2_lo(2):k2_hi(2), &
                                        k2_lo(3):k2_hi(3))
  double precision, intent(in)    :: k3(k3_lo(1):k3_hi(1), &
                                        k3_lo(2):k3_hi(2), &
                                        k3_lo(3):k3_hi(3))
  double precision, intent(in)    :: k4(k4_lo(1):k4_hi(1), &
                                        k4_lo(2):k4_hi(2), &
                                        k4_lo(3):k4_hi(3))

  integer          :: i,j,k
  double precision :: k_1, k_2, k_3, k_4, squcoef, cubcoef, u0,  utemp(0:3)
  double precision  :: xi, fn, fnfprime, fnsqfdouble, dtc2, dtc3, dtf2, dtf3, fprimsqfn

  !this gets us to un
  xi = (tf - tc_old)/dt_c

  !print*, "*************IN JBB VERSION****************"
  dtf2 = dt_f*dt_f
  dtf3 = dt_f*dt_f*dt_f
  dtc2 = dt_c*dt_c
  dtc3 = dt_c*dt_c*dt_c
  !$omp parallel do private(i,j,k,x,y,z,r2) collapse(2)
  do k=lo(3),hi(3)
     do j=lo(2),hi(2)
        do i=lo(1),hi(1)

           !the ks get multiplied by dtc in the code
           k_1 = k1(i,j,k)
           k_2 = k2(i,j,k)
           k_3 = k3(i,j,k)
           k_4 = k4(i,j,k)
           !straight outta mccorquodale
           squcoef = 0.5d0*(-3.0d0*k_1 + 2.0d0*k_2 + 2.0d0*k_3 - k_4)
           cubcoef = (2.0d0/3.0d0)*(k_1 - k_2 - k_3 + k_4)

           u0 = old(i,j,k) + xi*k_1 + xi*xi*squcoef + xi*xi*xi*cubcoef

           fn = k_1/dt_c
           fnfprime    = (1.0d0/dtc2)*(4.0d0*k_3 - k_4 - 3.0d0*k_1)
           fnsqfdouble = (1.0d0/dtc3)*(4.0d0*k_4 + 4.0d0*k_1 + 8.0d0*k_2 - 16.0d0*k_3)
           fprimsqfn   = (4.0d0/dtc3)*(k_3 - k_2)

           utemp(0) =  u0
           utemp(1) =  u0 + 0.5d0*dt_f*fn
           utemp(2) =  u0 + 0.5d0*dt_f*fn + 0.25d0*dtf2*fnfprime + 0.0625d0*dtf3*fnsqfdouble
           utemp(3) =  u0 +       dt_f*fn +  0.5d0*dtf2*fnfprime + 0.1250d0*dtf3*fnsqfdouble + 0.25d0*dtf3*fprimsqfn

           phi(i,j,k) = utemp(stage)

!debug set to old method
!           phi(i,j,k) = u0
!end debug

        end do
     end do
  end do

end subroutine timeinterprk4_jbb

! this does the jbb algorithm for rk3
subroutine timeinterprk3_jbb(stage, lo, hi, &
     phi,  phi_lo, phi_hi, &
     old, old_lo, old_hi, &
     k1 , k1_lo, k1_hi, &
     k2 , k2_lo, k2_hi, &
     tf, tc_old, dt_c, dt_f, iter, nref  &
     ) bind(C, name="timeinterprk3_jbb")

  use amrex_fort_module, only : amrex_real, dim=>bl_spacedim
  implicit none
  double precision, intent(in)    :: tf, tc_old, dt_c, dt_f
  integer, intent(in) :: lo(3), hi(3),stage, iter, nref
  integer, intent(in) :: phi_lo(3), phi_hi(3)
  integer, intent(in) :: old_lo(3), old_hi(3)
  integer, intent(in) :: k1_lo(3), k1_hi(3)
  integer, intent(in) :: k2_lo(3), k2_hi(3)

  double precision, intent(inout) :: phi(phi_lo(1):phi_hi(1), &
                                         phi_lo(2):phi_hi(2), &
                                         phi_lo(3):phi_hi(3))

  double precision, intent(in)    :: old(old_lo(1):old_hi(1), &
                                         old_lo(2):old_hi(2), &
                                         old_lo(3):old_hi(3))

  double precision, intent(in)    :: k1(k1_lo(1):k1_hi(1), &
                                        k1_lo(2):k1_hi(2), &
                                        k1_lo(3):k1_hi(3))
  double precision, intent(in)    :: k2(k2_lo(1):k2_hi(1), &
                                        k2_lo(2):k2_hi(2), &
                                        k2_lo(3):k2_hi(3))

  integer          :: i,j,k
  double precision :: k_1, k_2,  squcoef, u0, fn, fnfprime, utemp(0:2)
  double precision :: xi

  xi = (tf              - tc_old)/dt_c

  !$omp parallel do private(i,j,k,x,y,z,r2) collapse(2)
  do k=lo(3),hi(3)
     do j=lo(2),hi(2)
        do i=lo(1),hi(1)

           k_1 = k1(i,j,k)
           k_2 = k2(i,j,k)

           !straight outta fok and rosales
           squcoef = 0.5d0*(k_2 - k_1)

           u0 = old(i,j,k) + xi*k_1 + xi*xi*squcoef

           fn       = k_1/dt_c
           fnfprime = (k_2 - k_1)/(dt_c*dt_c)

           utemp(0) = u0
           utemp(1) = u0 +       dt_f*fn
           utemp(2) = u0 + 0.5d0*dt_f*fn + 0.25d0*dt_f*dt_f*fnfprime

           phi(i,j,k) = utemp(stage)

        end do
     end do
  end do

end subroutine timeinterprk3_jbb

!this is the simply polynomial algorithm introduced by mccorquodale for rk4
!      if(a_stage == 0)
!      {
!        xi = (tf - tc_old)/dt_c;
!      }
!      else if(a_stage == 1)
!      {
!        xi = (tf + 0.5*dt_f - tc_old)/dt_c;
!      }
!      else if(a_stage == 2)
!      {
!        xi = (tf + 0.5*dt_f - tc_old)/dt_c; //why, yes, this *is* the same as stage 1
!      }
!      else
!      {
!        xi = (tf + dt_f - tc_old)/dt_c;
!      }
subroutine timeinterprk4_simplepoly(stage, lo, hi, &
     phi,  phi_lo, phi_hi, &
     old, old_lo, old_hi, &
     k1 , k1_lo, k1_hi, &
     k2 , k2_lo, k2_hi, &
     k3 , k3_lo, k3_hi, &
     k4 , k4_lo, k4_hi, &
     tf, tc_old, dt_c, dt_f, iter, nref  &
     ) bind(C, name="timeinterprk4_simplepoly")

  use amrex_fort_module, only : amrex_real, dim=>bl_spacedim
  implicit none
  integer, intent(in) :: lo(3), hi(3), stage, iter, nref
  integer, intent(in) :: phi_lo(3), phi_hi(3)
  integer, intent(in) :: old_lo(3), old_hi(3)
  integer, intent(in) :: k1_lo(3), k1_hi(3)
  integer, intent(in) :: k2_lo(3), k2_hi(3)
  integer, intent(in) :: k3_lo(3), k3_hi(3)
  integer, intent(in) :: k4_lo(3), k4_hi(3)

  double precision, intent(in) ::  tf, tc_old, dt_f, dt_c
  double precision, intent(inout) :: phi(phi_lo(1):phi_hi(1), &
                                         phi_lo(2):phi_hi(2), &
                                         phi_lo(3):phi_hi(3))

  double precision, intent(in)    :: old(old_lo(1):old_hi(1), &
                                         old_lo(2):old_hi(2), &
                                         old_lo(3):old_hi(3))

  double precision, intent(in)    :: k1(k1_lo(1):k1_hi(1), &
                                        k1_lo(2):k1_hi(2), &
                                        k1_lo(3):k1_hi(3))
  double precision, intent(in)    :: k2(k2_lo(1):k2_hi(1), &
                                        k2_lo(2):k2_hi(2), &
                                        k2_lo(3):k2_hi(3))
  double precision, intent(in)    :: k3(k3_lo(1):k3_hi(1), &
                                        k3_lo(2):k3_hi(2), &
                                        k3_lo(3):k3_hi(3))
  double precision, intent(in)    :: k4(k4_lo(1):k4_hi(1), &
                                        k4_lo(2):k4_hi(2), &
                                        k4_lo(3):k4_hi(3))

  integer          :: i,j,k
  double precision :: k_1, k_2, k_3, k_4, squcoef, cubcoef, phival,xi

  if(stage .eq. 0) then
     xi = (tf - tc_old)/dt_c
  else if(stage .eq. 1) then
     xi = (tf + 0.5*dt_f - tc_old)/dt_c
  else if(stage .eq. 2) then
     xi = (tf + 0.5*dt_f - tc_old)/dt_c !why, yes, this *is* the same as stage 1
  else
     xi = (tf + dt_f - tc_old)/dt_c;
  endif

  !$omp parallel do private(i,j,k,x,y,z,r2) collapse(2)
  do k=lo(3),hi(3)
     do j=lo(2),hi(2)
        do i=lo(1),hi(1)

           k_1 = k1(i,j,k)
           k_2 = k2(i,j,k)
           k_3 = k3(i,j,k)
           k_4 = k4(i,j,k)
           !straight outta  mccorquodale
           squcoef = 0.5d0*(-3.0d0*k_1 + 2.0d0*k_2 + 2.0d0*k_3 - k_4)
           cubcoef = (2.0d0/3.0d0)*(k_1 - k_2 - k_3 + k_4)

           phival = old(i,j,k) + xi*k_1 + xi*xi*squcoef + xi*xi*xi*cubcoef
           phi(i,j,k) = phival

        end do
     end do
  end do

end subroutine timeinterprk4_simplepoly

!this is the simply polynomial algorithm introduced by mccorquodale for rk3
!      if(a_stage == 0)
!      {
!        xi = (tf - tc_old)/dt_c;
!      }
!      else if(a_stage == 1)
!      {
!        xi = (tf + dt_f - tc_old)/dt_c;
!      }
!      else if(a_stage == 2)
!      {
!        xi = (tf + 0.5*dt_f - tc_old)/dt_c;
!      }
subroutine timeinterprk3_simplepoly(stage, lo, hi, &
     phi,  phi_lo, phi_hi, &
     old, old_lo, old_hi, &
     k1 , k1_lo, k1_hi, &
     k2 , k2_lo, k2_hi, &
     tf, tc_old, dt_c, dt_f, iter, nref  &
     ) bind(C, name="timeinterprk3_simplepoly")

  use amrex_fort_module, only : amrex_real, dim=>bl_spacedim
  implicit none
  integer, intent(in) :: lo(3), hi(3), stage, iter, nref
  integer, intent(in) :: phi_lo(3), phi_hi(3)
  integer, intent(in) :: old_lo(3), old_hi(3)
  integer, intent(in) :: k1_lo(3), k1_hi(3)
  integer, intent(in) :: k2_lo(3), k2_hi(3)

  double precision, intent(in) :: tf, tc_old, dt_c, dt_f
  double precision, intent(inout) :: phi(phi_lo(1):phi_hi(1), &
                                         phi_lo(2):phi_hi(2), &
                                         phi_lo(3):phi_hi(3))

  double precision, intent(in)    :: old(old_lo(1):old_hi(1), &
                                         old_lo(2):old_hi(2), &
                                         old_lo(3):old_hi(3))

  double precision, intent(in)    :: k1(k1_lo(1):k1_hi(1), &
                                        k1_lo(2):k1_hi(2), &
                                        k1_lo(3):k1_hi(3))
  double precision, intent(in)    :: k2(k2_lo(1):k2_hi(1), &
                                        k2_lo(2):k2_hi(2), &
                                        k2_lo(3):k2_hi(3))

  integer          :: i,j,k
  double precision :: k_1, k_2,  squcoef,  phival, xi

  if(stage .eq. 0) then
     xi = (tf              - tc_old)/dt_c
  else if(stage .eq. 1) then
     xi = (tf +       dt_f - tc_old)/dt_c
  else
     xi = (tf + 0.5d0*dt_f - tc_old)/dt_c;
  endif

  !$omp parallel do private(i,j,k,x,y,z,r2) collapse(2)
  do k=lo(3),hi(3)
     do j=lo(2),hi(2)
        do i=lo(1),hi(1)

           k_1 = k1(i,j,k)
           k_2 = k2(i,j,k)
           !straight outta fok and rosales
           squcoef = 0.5d0*(k_2 - k_1)

           phival = old(i,j,k) + xi*k_1 + xi*xi*squcoef
           phi(i,j,k) = phival

        end do
     end do
  end do

end subroutine timeinterprk3_simplepoly


c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c        This is the end of the debugging code and the beginning of the
c        code for the evaluation of eigenvalues and eigenvectors
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
        subroutine jaceig(a,n,eps,ifvect,uout,nelems)
        implicit real *8 (a-h,o-z)
        save
        dimension a(n,n),b(2,2),u(2,2),rlam(4),uout(n,n)
c
c        This subroutine uses Jacobi iterations to find the
c        spectrum of a real symmetric matrix. It is a primitive
c        and robust code. It is also mercifully short.
c        IMPORTANT! The dimensionality of the matrix must be
c        .ge. 3. Otherwise, a terrible bomb will happen!
c
c                 Input parameters:
c
c  a - the matrix whose spectrum is to be found; destroyed by the
c        subroutine
c  n - the dimensionality of a; must be .ge. 3
c  eps - the accuracy (relative) to which the calculations are to
c        be conducted
c  ifvect - the integer parameter telling the subroutine whether it
c        should compute the eigenvectors (or only the eigenvalues)
c        ifvect=1 will cause the eigenvectors to be computed
c        ifvect=0 will suppress the computation of the eigenvectors
c
c                 Output parameters:
c
c  a - the first n elements of a contain the (ordered) spectrum of a
c  uout - the eigenvectors of a corresponding to the eigenvalues
c        returned in the first column of a. These are only returned if
c        on input, ifvect was set to 1
c  nelems - the number of jacobi rotations performed by the subroutine;
c        provided solely for the amusement of a sophisticated reader
c
c        . . . if the user so requested, initialized the matrix u
c
        if(ifvect .eq. 0) goto 1150
c
        do 1120 i=1,n
        do 1110 j=1,n
        uout(j,i)=0
 1110 continue
c
        uout(i,i)=1
 1120 continue
c
 1150 continue
c
        maxiter=1000
        d=0
        do 1400 i=1,n
        do 1200 j=1,i
        if(abs(a(j,i)) .gt. d) d=abs(a(j,i))
 1200 continue
 1400 continue
        throut=eps*d
c
c       one pair of off-diagonal elements after another, use
c       Jacobi rotations to diagonalize the matrix a
c
        nelems=0
        do 4000 ijk=1,maxiter
c
c       find the threshold after which the elements of the matrix
c       will be considered to be zero
c
        d=0
        do 1500 i=2,n
        do 1450 j=1,i-1
        if(abs(a(j,i)) .gt. d) d=abs(a(j,i))
 1450 continue
 1500 continue
c
cccc        thresh=d/10
        thresh=d/2
c
        ifdone=1
        do 2800 i=2,n
        do 2600 j=1,i-1
c
        if(abs(a(i,j)) .gt. throut) ifdone=0
        if(abs(a(j,i)) .lt. thresh) goto 2600
c
        nelems=nelems+1
c
        b(1,1)=a(j,j)
        b(2,2)=a(i,i)
        b(1,2)=a(j,i)
        b(2,1)=b(1,2)
c
c       diagonalize this 2 \times 2 - matrix
c
        call oneu(b,rlam,u)
c
c       apply matrix u to the rows i,j of the matrix a
c
        do 1600 k=1,n
c
        dj=u(1,1)*a(j,k)+u(1,2)*a(i,k)
        di=u(2,1)*a(j,k)+u(2,2)*a(i,k)
c
        a(j,k)=dj
        a(i,k)=di
 1600 continue
c
c       apply matrix u^* to the columns i,j of the matrix a
c
        do 1800 k=1,n
c
        dj=u(1,1)*a(k,j)+u(1,2)*a(k,i)
        di=u(2,1)*a(k,j)+u(2,2)*a(k,i)
c
        a(k,j)=dj
        a(k,i)=di
 1800 continue
c
        if(ifvect .eq. 0) goto 2200
c
c       if the user so requested, apply matrix u^* to the
c       columns i,j of the matrix u
c
        do 2000 k=1,n
c
        dj=u(1,1)*uout(k,j)+u(1,2)*uout(k,i)
        di=u(2,1)*uout(k,j)+u(2,2)*uout(k,i)
c
        uout(k,j)=dj
        uout(k,i)=di
 2000 continue
c
 2200 continue
c
 2600 continue
 2800 continue
ccccccccccccc        call prinf('in jaceig, ijk=*',ijk,1)
c
        do 3400 i=2,n
        do 3200 j=1,n-1
        a(i,j)=a(j,i)
 3200 continue
 3400 continue
c
        if(ifdone .eq. 1) goto 4200
c
 4000 continue
c
 4200 continue
c
c      copy the eigenvalues into the first column of a and sort them
c
        do 4400 i=1,n
        a(i,1)=a(i,i)
 4400 continue
c
c        put the first three largest eigenvalues in the first three
c        positions
c

         do 5200 i=1,3
c
         d=-1.0d30
         do 4600 j=i,n
c
         if(a(j,1) .lt. d) goto 4600
         jmax=j
         d=a(j,1)
 4600 continue
c
         if(ifvect .eq. 0) goto 5000
         do 4800 j=1,n

        d=uout(j,jmax)
        uout(j,jmax)=uout(j,i)
        uout(j,i)=d
 4800 continue
c
 5000 continue
c
        d=a(i,1)
        a(i,1)=a(jmax,1)
        a(jmax,1)=d
c
 5200 continue
c
c       sort the remaining eigenvalues
c
        do 5600 i=4,n
        a(i,2)=i
 5600 continue
c
ccccccccccccccccc        call prin2('before sorting, a(1)=*',a(1,1),n)
c
        do 6000 i=1,n
c
        do 5800 j=4,n-1
        if(a(j,1) .gt. a(j+1,1)) goto 5800
c
        d=a(j,1)
        a(j,1)=a(j+1,1)
        a(j+1,1)=d
c
        d=a(j,2)
        a(j,2)=a(j+1,2)
        a(j+1,2)=d
 5800 continue
 6000 continue
c
c        if the user so requested, reorder the eigenvectors to corresponfd
c        to the reordered eigenvalues
c
        if(ifvect .eq. 0) return
        do 6400 i=4,n
c
        i1=i
        i2=a(i,2) +0.1
c
        do 6200 j=1,n
        a(j,i1)=uout(j,i2)
 6200 continue
c
 6400 continue
c
        do 6800 i=4,n
        do 6600 j=1,n
        uout(j,i)=a(j,i)
 6600 continue
c
 6800 continue
c
        return
        end
c
c
c
c
c
        subroutine oneu(b,rlam,u)
        implicit real *8 (a-h,o-z)
        save
        dimension u(2,2),v(2,2),rlam(2),
     1      b(2,2),z(2,2),rlams(2,2)
        data eps/1.0d-10/,done/1.0d0/
c
c       this subroutine produces the eigendecomposition
c       of a 2 * 2 real symmetric matrix b, so that on exit,
c
c       a = u^* d u
c
c       with u orthogonal, and d a diagonal matrix with the
c       vector rlam=(rlam(1),rlam(2)) on the diagonal.
c
c       now, diagonalize the simmetrized matrix
c
        den=b(2,2)-b(1,1)
        rnum=b(1,2)*2
c
c       if denominator is not too small, use exact formulae
c
        if(dabs(den) .lt. eps*dabs(rnum)) goto 1600
        tg2phi=-rnum/den
        if(dabs(tg2phi) .lt. 1.0d-3) goto 1500
c
        dd=dsqrt(4/tg2phi**2+4)
        if(tg2phi .lt. 0) tgphi=(-2/tg2phi-dd)/2
        if(tg2phi .gt. 0) tgphi=(-2/tg2phi+dd)/2
c
        phi=datan(tgphi)
        alpha=dcos(phi)
        beta=dsin(phi)
        goto 1800
 1500 continue
c
        beta=tg2phi/2
        alpha=dsqrt(done-beta**2)
c
        goto 1800
 1600 continue
c
c       denominator is too small. use taylor expansion
c
        alpha=dsqrt((1-den/rnum)/2)
        beta=dsqrt((1+den/rnum)/2)
 1800 continue
c
c       construct the diagonalizing matrix
c       and the resulting diagonal
c
        v(1,1)=alpha
        v(1,2)=beta
        v(2,1)=-beta
        v(2,2)=alpha
c
        u(1,1)=alpha
        u(1,2)=-beta
        u(2,1)=beta
        u(2,2)=alpha
c
c       finally, compute the resulting diagonal elements
c
        call jac_prod2(v,b,z)
        call jac_prod2(z,u,rlams)
        rlam(1)=rlams(1,1)
        rlam(2)=rlams(2,2)
c
        u(1,2)=-u(1,2)
        u(2,1)=-u(2,1)
        return
        end
c
c
c
c
c
        subroutine jac_prod2(a,b,c)
        implicit real *8 (a-h,o-z)
        save
        dimension a(2,2),b(2,2),c(2,2)
c
        c(1,1)=a(1,1)*b(1,1)+a(1,2)*b(2,1)
        c(1,2)=a(1,1)*b(1,2)+a(1,2)*b(2,2)
        c(2,1)=a(2,1)*b(1,1)+a(2,2)*b(2,1)
        c(2,2)=a(2,1)*b(1,2)+a(2,2)*b(2,2)
        return
        end


program isotherm_fig

  use isotherm

  ! Computes equilibrium isotherms
  ! for a number of figures.

  implicit none

  ! Binary fluid parameters
  real (dp), parameter :: A = -0.00625
  real (dp), parameter :: B = -A
  real (dp), parameter :: kappa = 0.016
  real (dp), parameter :: xi0sq = -2.0*kappa/A
  real (dp)            :: xi0

  ! Diamant and Andelman parameters
  real (dp), parameter :: da_alpha = 12.0
  real (dp), parameter :: da_beta  =  0.0
  real (dp), parameter :: da_kt    =  1.0
  real (dp)            :: psi_b = 5.0e-06

  ! Diffuse interface surfactant parameters
  real (dp), parameter :: epsilon = kappa
  real (dp), parameter :: beta = (0.0/24.0)*epsilon
  real (dp), parameter :: kT = epsilon/(24.0*xi0sq)

  real (dp)          :: W = 0.00
  real (dp)          :: psi, psi_c_langmuir
  real (dp)          :: psi_0
  real (dp)          :: sigma0
  real (dp)          :: phi

  real (dp)          :: z0 = 9.0
  real (dp)          :: z

  xi0 = sqrt(xi0sq)
  sigma0 = (4.0/3.0)*kappa/xi0
  psi_c_langmuir = exp((1.0/kT)*(-0.5*epsilon/xi0sq - 0.5*W))

  write (unit = 0, fmt = '(a,e12.6)') 'Interfactial width = ', &
       sqrt(-2.0*kappa/A)

  write (unit = 0, fmt = '(a,e12.6)') 'psi_c (langmuir) ', psi_c_langmuir
  write (unit = 0, fmt = '(a,e12.6)') 'psi0 diamant andelman ', &
       psi_0_diamant(psi_b, da_alpha, da_beta, da_kt)

  phi = psi_frumkin(psi_b, beta, epsilon, W, kT, 0.0d0, 0.0d0, xi0)
  write (unit = 0, '(a,e12.6)') 'psi0 diffuse ', phi

  !call figx()
  !call fig3()

contains

  !---------------------------------------------------------------------------
  ! Isotherms
  ! beta != 0, ie., general case of Frumpkin adsorption
  !---------------------------------------------------------------------------

  subroutine fig2()

    integer   :: n
    real (dp) :: y
    real (dp) :: psi0_langmuir

    do n = 1, 190
       psi_b = exp(log(0.00001) - log(0.00001)*n/190.)
       psi0_langmuir = psi_b / (psi_b + psi_c_langmuir)

       write (unit = *, fmt = '(3(1x,e14.7))') psi_b, psi0_langmuir, &
            psi_frumkin(psi_b, beta, epsilon, W, kT, 0.0_dp, 0.0_dp, xi0)
    end do

  end subroutine fig2

  !---------------------------------------------------------------------------
  ! Change in surface tension vs psi_0
  !---------------------------------------------------------------------------

  subroutine fig3()

    integer   :: n
    real (dp) :: psi0, psi0_eq
    real (dp) :: sigma
    real (dp) :: psi_c_frumkin

    psi0_eq = psi_frumkin(psi_b, beta, epsilon, W, kT, 0.0d0, 0.0d0, xi0)

    do n = 1, 100
       psi0 = 0.01*n

       if (psi0 < psi0_eq) then

          ! set phi_b to get desired psi0
          psi_c_frumkin = exp((1.0/kT)*(-0.5*epsilon/xi0sq - beta*psi0/xi0sq))
          psi_b = psi_c_frumkin*psi0/(1.0 - psi0)
          call free_energy(sigma, .false.)

          write (unit = *, fmt = '(2(1x,e12.6))') psi0, (sigma - sigma0)/sigma0
       end if
    end do

  end subroutine fig3

  !---------------------------------------------------------------------------
  !  Diamant & Andelman \delta\gamma
  !---------------------------------------------------------------------------

  subroutine fig3a()

    integer   :: n
    real (dp) :: psi0, psi0_eq
    real (dp) :: dsigma_theory

    psi0_eq = psi_0_diamant(psi_b, da_alpha, da_beta, da_kt)

    do n = 1, 100
       psi0 = 0.01*n
       if (psi0 < psi0_eq) then
          dsigma_theory = log(1.0-psi0) + 0.5*(da_beta/da_kt)*psi0*psi0
          write (unit = *, fmt = '(2(1x,e12.6))') psi0, dsigma_theory
       end if
    end do

    return

  end subroutine fig3a

  !---------------------------------------------------------------------------
  ! Equilibrium profiles of various terms in the free energy
  ! We also integrate the excess free energy to get the surface
  ! tension (sigma is returned).
  !---------------------------------------------------------------------------

  subroutine free_energy(sigma, verbose)

    real (dp), intent(out)  :: sigma
    logical, intent(in)     :: verbose

    integer :: n
    real (dp) :: phi_bulk, psi_bulk
    real (dp) :: phi_surf, psi_surf, psi_w
    real (dp) :: delta
    real (dp) :: psi_background
    real (dp) :: ktlocal

    ! Take epsilon = 0 to mean no surfactant, in which case, we
    ! must also set kT = 0 for the energy calculations (only).

    ktlocal = kT
    !if (epsilon < tiny(epsilon)) ktlocal = 0.0

    psi_background = ktlocal*(psi_b*log(psi_b) + (1.0-psi_b)*log(1.0-psi_b))
    sigma = 0.0

    do n = 0, 1900
       z = 0.01*n
       phi = tanh((z0-z)/xi0)
       psi = psi_frumkin(psi_b, beta, epsilon, W, kT, z, z0, xi0)

       delta = 1.0/(xi0sq*cosh((z-z0)/xi0)**4)

       phi_bulk = 0.5*A*phi*phi + 0.25*B*phi*phi*phi*phi
       phi_surf = 0.5*kappa*delta
       psi_bulk = ktlocal*(psi*log(psi) + (1.0 - psi)*log(1.0 - psi))
       psi_surf = -0.5*epsilon*psi*delta -0.5*beta*psi*psi*delta
       psi_w    = 0.5*W*psi*phi*phi

       if (verbose) then
          write (unit = *, fmt = '(9(1x,e12.5))') (z-z0)/xi0, phi, psi, &
               phi_bulk, phi_surf, psi_bulk, psi_surf, psi_w, &
               phi_bulk + phi_surf + psi_bulk + psi_surf
       end if

       sigma = sigma + 0.01*(phi_surf + phi_bulk - (0.5*A + 0.25*B))
       sigma = sigma + 0.01*(psi_surf + psi_bulk - psi_background)
       sigma = sigma + 0.01*(psi_w - 0.5*W*psi_b*1.0*1.0)
    end do

    if (verbose) then
       write (unit = 0, fmt = '(a,e12.6)') 'Interfactial width = ', &
            sqrt(-2.0*kappa/A)
       write (unit = 0, fmt = '(a,e12.6,1xe12.6)') 'Surface tension = ', &
            sigma, sigma0
       write (unit = 0, fmt = '(a,e12.6)') 'Surfactant bulk background = ', &
            psi_background
    end if

  end subroutine free_energy

end program isotherm_fig


!> Testing determinant evaluation via getrf
program test_pdet
  use, intrinsic :: iso_fortran_env, stdout => output_unit
  use test_common_module
  use libscalapackfx_module
  implicit none

  ! Block size (using an extremely small value for test purposes)
  integer, parameter :: bsize = 1

  call main()

contains

  subroutine main()
    type(blacsgrid) :: mygrid
    real(dp), allocatable :: xx(:,:)
    complex(dp), allocatable :: xxc(:,:)
    real(dp) :: det
    integer :: exponent
    complex(dp) :: detc
    integer :: descx(DLEN_)
    integer :: nprow, npcol, mm, nn, iproc, nproc, ii, jj, iLoc, jLoc
    integer, allocatable :: ipiv(:)
    logical :: tLocal

    ! Initialize blas and create a square processor grid
    call blacsfx_pinfo(iproc, nproc)
    do nprow = int(sqrt(real(nproc, dp))), nproc
      if (mod(nproc, nprow) == 0) then
        exit
      end if
    end do
    npcol = nproc / nprow
    call mygrid%initgrid(nprow, npcol)
    if (mygrid%master) then
      write(stdout, "(A,2(1X,I0))") "# processor grid:", nprow, npcol
      write(stdout, "(A,1X,I0)") "# block size:", bsize
    end if

    ! Set up matrix
    if (mygrid%master) then
      write(stdout, "(A)") "Matrix read from file 'hamsqr1.dat'."
    end if
    call readfromfile(mygrid, "hamsqr1.dat", bsize, bsize, xx, descx)
    mm = descx(M_)
    nn = descx(N_)

    allocate(ipiv(min(mm,nn)))
    ipiv = 0

    if (mygrid%master) then
      write(stdout, "(A,2(1X,I0))") "# global matrix size:", mm, nn
      write(stdout, "(A,2(1X,I0))") "# local matrix size on master:",&
          & size(xx, dim=1), size(xx, dim=2)
    end if

    call scalafx_pgetrf(xx,descx,ipiv)

    ! note, this includes under-/over-flow protection similar to LINPACK routine dgedi.f
    det = 1.0_dp
    exponent = 0
    do ii = 1, size(xx,dim=2)
      jj = scalafx_indxl2g(ii, descx(NB_), mygrid%mycol, descx(CSRC_), mygrid%ncol)
      call scalafx_islocal(mygrid, descx, jj, jj, tLocal, iLoc, jLoc)
      if (tLocal) then
        if (jj /= ipiv(ii)) then
          det = -det * xx(iLoc,jLoc)
        else
          det = det * xx(iLoc,jLoc)
        end if
        do while (abs(det) > 2)
          det = det / 2.0_dp
          exponent = exponent + 1
        end do
        do while (abs(det) < 0.5_dp)
          det = det * 2.0_dp
          exponent = exponent - 1
        end do
      end if
    end do
    det = det * 2.0_dp ** exponent

    ! Would normally accumulate product via mpi calls, but messy to do via blacs operations only
    write(stdout,*)'Det part from process', mygrid%iproc, ' : ', det

    ! Finish blacs.
    call blacsfx_exit()

  end subroutine main

end program test_pdet


!
!   FnVFFRet.f90
!
!
!   Created by Kurt Mitman on 10/10/14.
!
!

DOUBLE PRECISION FUNCTION FnVFFRet(bsav)

USE Params
USE Globals
USE funcs
USE Procedures

IMPLICIT NONE

DOUBLE PRECISION, INTENT(IN) :: bsav
DOUBLE PRECISION             :: cons
DOUBLE PRECISION             :: vals(2)
INTEGER                      :: inds(2)

cons=gliq-FnQb(bsav,0.0d0)*bsav

if(cons .GT. cmin) then

    call basefun(GridB,nb,bsav,vals,inds)

!    FnVFFRet = -1.0d0*(ufore(cons,ghouse,gij)-xi+bet*(vals(1)*EVrentRet(inds(1),gij)+vals(2)*EVrentRet(inds(2),gij)))
    FnVFFRet = -1.0d0*(urent(cons,GridHR(1),gij)-xi+bet*(vals(1)*EVrentRet(inds(1),gij)+vals(2)*EVrentRet(inds(2),gij)))

else

FnVFFRet = 1.0d10+10.0d0*(cmin-cons)

endif

END FUNCTION FnVFFRet


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c Compute the residuals from the model:
c          s = snom + e
c          l = lnom + f

      subroutine compute_eps(l,s,lnom,snom,e,f,tres,eps)
      implicit none
c Inputs...
      real*4 l(3,202),s(3,202)		!3 best locations
      real*4 lnom(202),snom(202)		!nominal locations
      real e,f
      integer*4 tres
c Outputs...
      real*4 eps(3,202)

c Local variables..
      integer i,k
      real dl,ds
      character*132 msg

      do 50 k=1,202
      do 40 i=1,3
      if (l(i,k).ne.-999) then
         dl = l(i,k) - lnom(k) - f
         ds = s(i,k) - snom(k) - e
         eps(i,k) = sqrt(dl**2+ds**2)
      else
         eps(i,k) = -999
      endif
   40 continue
   50 continue

      if (tres.eq.0) return
      k = tres
      write(msg,101) lnom(k),snom(k),e,f
      call xvmessage(msg,0)
      do i=1,3
         write(msg,102) i,l(i,k),s(i,k),eps(i,k)
         call xvmessage(msg,0)
      enddo
      return

  101 format('(lnom,snom)=(',f5.1,',',f5.1,') e=',f5.2,' f=',f5.2)
  102 format(i1,': (l,s)=(', f6.1,',',f6.1,') eps=',f6.1)
      end


module compute_flux_module

  use amrex_fort_module, only : amrex_real
  implicit none

  private

  public :: compute_flux_3d

contains

  subroutine compute_flux_3d(lo, hi, dt, dx, &
                             phi,ph_lo,ph_hi, &
                             umac,  u_lo,  u_hi, &
                             vmac,  v_lo,  v_hi, &
                             wmac,  w_lo,  w_hi, &
                             flxx, fx_lo, fx_hi, &
                             flxy, fy_lo, fy_hi, &
                             flxz, fz_lo, fz_hi, &
                             phix, phix_y, phix_z, &
                             phiy, phiy_x, phiy_z, &
                             phiz, phiz_x, phiz_y, &
                             slope, glo, ghi)

    use slope_module, only: slopex, slopey, slopez

    integer, intent(in) :: lo(3), hi(3), glo(3), ghi(3)
    real(amrex_real), intent(in) :: dt, dx(3)
    integer, intent(in) :: ph_lo(3), ph_hi(3)
    integer, intent(in) ::  u_lo(3),  u_hi(3)
    integer, intent(in) ::  v_lo(3),  v_hi(3)
    integer, intent(in) ::  w_lo(3),  w_hi(3)
    integer, intent(in) :: fx_lo(3), fx_hi(3)
    integer, intent(in) :: fy_lo(3), fy_hi(3)
    integer, intent(in) :: fz_lo(3), fz_hi(3)
    real(amrex_real), intent(in   ) :: phi (ph_lo(1):ph_hi(1),ph_lo(2):ph_hi(2),ph_lo(3):ph_hi(3))
    real(amrex_real), intent(in   ) :: umac( u_lo(1): u_hi(1), u_lo(2): u_hi(2), u_lo(3): u_hi(3))
    real(amrex_real), intent(in   ) :: vmac( v_lo(1): v_hi(1), v_lo(2): v_hi(2), v_lo(3): v_hi(3))
    real(amrex_real), intent(in   ) :: wmac( w_lo(1): w_hi(1), w_lo(2): w_hi(2), w_lo(3): w_hi(3))
    real(amrex_real), intent(  out) :: flxx(fx_lo(1):fx_hi(1),fx_lo(2):fx_hi(2),fx_lo(3):fx_hi(3))
    real(amrex_real), intent(  out) :: flxy(fy_lo(1):fy_hi(1),fy_lo(2):fy_hi(2),fy_lo(3):fy_hi(3))
    real(amrex_real), intent(  out) :: flxz(fz_lo(1):fz_hi(1),fz_lo(2):fz_hi(2),fz_lo(3):fz_hi(3))
    real(amrex_real), dimension(glo(1):ghi(1),glo(2):ghi(2),glo(3):ghi(3)) :: &
         phix, phix_y, phix_z, phiy, phiy_x, phiy_z, phiz, phiz_x, phiz_y, slope

    integer :: i, j, k
    real(amrex_real) :: hdtdx(3), tdtdx(3)

    hdtdx = 0.5*(dt/dx)
    tdtdx = (1.d0/3.d0)*(dt/dx)

    call slopex(glo, ghi, &
                phi, ph_lo, ph_hi, &
                slope, glo, ghi)

    ! compute phi on x faces using umac to upwind; ignore transverse terms
    do       k = lo(3)-1, hi(3)+1
       do    j = lo(2)-1, hi(2)+1
          do i = lo(1)  , hi(1)+1

             if (umac(i,j,k) .lt. 0.d0) then
                phix(i,j,k) = phi(i  ,j,k) - (0.5d0 + hdtdx(1)*umac(i,j,k))*slope(i  ,j,k)
             else
                phix(i,j,k) = phi(i-1,j,k) + (0.5d0 - hdtdx(1)*umac(i,j,k))*slope(i-1,j,k)
             end if

          end do
       end do
    end do

    call slopey(glo, ghi, &
                phi, ph_lo, ph_hi, &
                slope, glo, ghi)

    ! compute phi on y faces using vmac to upwind; ignore transverse terms
    do       k = lo(3)-1, hi(3)+1
       do    j = lo(2)  , hi(2)+1
          do i = lo(1)-1, hi(1)+1

             if (vmac(i,j,k) .lt. 0.d0) then
                phiy(i,j,k) = phi(i,j  ,k) - (0.5d0 + hdtdx(2)*vmac(i,j,k))*slope(i,j  ,k)
             else
                phiy(i,j,k) = phi(i,j-1,k) + (0.5d0 - hdtdx(2)*vmac(i,j,k))*slope(i,j-1,k)
             end if

          end do
       end do
    end do

    call slopez(glo, ghi, &
                phi, ph_lo, ph_hi, &
                slope, glo, ghi)

    ! compute phi on z faces using wmac to upwind; ignore transverse terms
    do       k = lo(3)  , hi(3)+1
       do    j = lo(2)-1, hi(2)+1
          do i = lo(1)-1, hi(1)+1

             if (wmac(i,j,k) .lt. 0.d0) then
                phiz(i,j,k) = phi(i,j,k  ) - (0.5d0 + hdtdx(3)*wmac(i,j,k))*slope(i,j,k  )
             else
                phiz(i,j,k) = phi(i,j,k-1) + (0.5d0 - hdtdx(3)*wmac(i,j,k))*slope(i,j,k-1)
             end if

          end do
       end do
    end do

    !!!!!!!!!!!!!!!!!!!!
    ! transverse terms
    !!!!!!!!!!!!!!!!!!!!

    ! update phi on x faces by adding in y-transverse terms
    do       k=lo(3)-1, hi(3)+1
       do    j=lo(2)  , hi(2)
          do i=lo(1)  , hi(1)+1

             if (umac(i,j,k) .lt. 0.d0) then
                phix_y(i,j,k) = phix(i,j,k) &
                     - tdtdx(2) * (0.5d0*(vmac(i  ,j+1,k)+vmac(i  ,j,k)) * (phiy(i  ,j+1,k)-phiy(i  ,j,k)) )
             else
                phix_y(i,j,k) = phix(i,j,k) &
                     - tdtdx(2) * (0.5d0*(vmac(i-1,j+1,k)+vmac(i-1,j,k)) * (phiy(i-1,j+1,k)-phiy(i-1,j,k)) )
             end if

          end do
       end do
    end do

    ! update phi on x faces by adding in z-transverse terms
    do       k=lo(3)  , hi(3)
       do    j=lo(2)-1, hi(2)+1
          do i=lo(1)  , hi(1)+1

             if (umac(i,j,k) .lt. 0.d0) then
                phix_z(i,j,k) = phix(i,j,k) &
                     - tdtdx(3) * (0.5d0*(wmac(i  ,j,k+1)+wmac(i  ,j,k)) * (phiz(i  ,j,k+1)-phiz(i  ,j,k)) )
             else
                phix_z(i,j,k) = phix(i,j,k) &
                     - tdtdx(3) * (0.5d0*(wmac(i-1,j,k+1)+wmac(i-1,j,k)) * (phiz(i-1,j,k+1)-phiz(i-1,j,k)) )
             end if

          end do
       end do
    end do

    ! update phi on y faces by adding in x-transverse terms
    do       k = lo(3)-1, hi(3)+1
       do    j = lo(2)  , hi(2)+1
          do i = lo(1)  , hi(1)

             if (vmac(i,j,k) .lt. 0.d0) then
                phiy_x(i,j,k) = phiy(i,j,k) &
                     - tdtdx(1) * (0.5d0*(umac(i+1,j  ,k)+umac(i,j  ,k)) * (phix(i+1,j  ,k)-phix(i,j  ,k)) )
             else
                phiy_x(i,j,k) = phiy(i,j,k) &
                     - tdtdx(1) * (0.5d0*(umac(i+1,j-1,k)+umac(i,j-1,k)) * (phix(i+1,j-1,k)-phix(i,j-1,k)) )
             end if

          end do
       end do
    end do

    ! update phi on y faces by adding in z-transverse terms
    do       k = lo(3)  , hi(3)
       do    j = lo(2)  , hi(2)+1
          do i = lo(1)-1, hi(1)+1

             if (vmac(i,j,k) .lt. 0.d0) then
                phiy_z(i,j,k) = phiy(i,j,k) &
                     - tdtdx(3) * (0.5d0*(wmac(i,j  ,k+1)+wmac(i,j  ,k)) * (phiz(i,j  ,k+1)-phiz(i,j  ,k)) )
             else
                phiy_z(i,j,k) = phiy(i,j,k) &
                     - tdtdx(3) * (0.5d0*(wmac(i,j-1,k+1)+wmac(i,j-1,k)) * (phiz(i,j-1,k+1)-phiz(i,j-1,k)) )
             end if

          end do
       end do
    end do

    ! update phi on z faces by adding in x-transverse terms
    do       k = lo(3)  , hi(3)+1
       do    j = lo(2)-1, hi(2)+1
          do i = lo(1)  , hi(1)

             if (wmac(i,j,k) .lt. 0.d0) then
                phiz_x(i,j,k) = phiz(i,j,k) &
                     - tdtdx(1) * (0.5d0*(umac(i+1,j,k  )+umac(i,j,k  )) * (phix(i+1,j,k  )-phix(i,j,k  )) )
             else
                phiz_x(i,j,k) = phiz(i,j,k) &
                     - tdtdx(1) * (0.5d0*(umac(i+1,j,k-1)+umac(i,j,k-1)) * (phix(i+1,j,k-1)-phix(i,j,k-1)) )
             end if

          end do
       end do
    end do

    ! update phi on z faces by adding in y-transverse terms
    do       k = lo(3)  , hi(3)+1
       do    j = lo(2)  , hi(2)
          do i = lo(1)-1, hi(1)+1

             if (wmac(i,j,k) .lt. 0.d0) then
                phiz_y(i,j,k) = phiz(i,j,k) &
                     - tdtdx(2) * (0.5d0*(vmac(i,j+1,k  )+vmac(i,j,k  )) * (phiy(i,j+1,k  )-phiy(i,j,k  )) )
             else
                phiz_y(i,j,k) = phiz(i,j,k) &
                     - tdtdx(2) * (0.5d0*(vmac(i,j+1,k-1)+vmac(i,j,k-1)) * (phiy(i,j+1,k-1)-phiy(i,j,k-1)) )
             end if

          end do
       end do
    end do

    !!!!!!!!!!!!!!!!!!!!
    ! final edge states
    !!!!!!!!!!!!!!!!!!!!

    ! update phi on x faces by adding in yz and zy transverse terms
    do       k = lo(3), hi(3)
       do    j = lo(2), hi(2)
          do i = lo(1), hi(1)+1

             if (umac(i,j,k) .lt. 0.d0) then
                phix(i,j,k) = phix(i,j,k) &
                     - hdtdx(2)*( 0.5d0*(vmac(i  ,j+1,k  )+vmac(i  ,j,k)) * (phiy_z(i  ,j+1,k  )-phiy_z(i  ,j,k)) ) &
                     - hdtdx(3)*( 0.5d0*(wmac(i  ,j  ,k+1)+wmac(i  ,j,k)) * (phiz_y(i  ,j  ,k+1)-phiz_y(i  ,j,k)) )
             else
                phix(i,j,k) = phix(i,j,k) &
                     - hdtdx(2)*( 0.5d0*(vmac(i-1,j+1,k  )+vmac(i-1,j,k)) * (phiy_z(i-1,j+1,k  )-phiy_z(i-1,j,k)) ) &
                     - hdtdx(3)*( 0.5d0*(wmac(i-1,j  ,k+1)+wmac(i-1,j,k)) * (phiz_y(i-1,j  ,k+1)-phiz_y(i-1,j,k)) )
             end if

             ! compute final x-fluxes
             flxx(i,j,k) = umac(i,j,k)*phix(i,j,k)

          end do
       end do
    end do

    ! update phi on y faces by adding in xz and zx transverse terms
    do       k = lo(3), hi(3)
       do    j = lo(2), hi(2)+1
          do i = lo(1), hi(1)

             if (vmac(i,j,k) .lt. 0.d0) then
                phiy(i,j,k) = phiy(i,j,k) &
                     - hdtdx(1)*( 0.5d0*(umac(i+1,j  ,k  )+umac(i,j  ,k)) * (phix_z(i+1,j  ,k  )-phix_z(i,j  ,k)) ) &
                     - hdtdx(3)*( 0.5d0*(wmac(i  ,j  ,k+1)+wmac(i,j  ,k)) * (phiz_x(i  ,j  ,k+1)-phiz_x(i,j  ,k)) )
             else
                phiy(i,j,k) = phiy(i,j,k) &
                     - hdtdx(1)*( 0.5d0*(umac(i+1,j-1,k  )+umac(i,j-1,k)) * (phix_z(i+1,j-1,k  )-phix_z(i,j-1,k)) ) &
                     - hdtdx(3)*( 0.5d0*(wmac(i  ,j-1,k+1)+wmac(i,j-1,k)) * (phiz_x(i  ,j-1,k+1)-phiz_x(i,j-1,k)) )
             end if

             ! compute final y-fluxes
             flxy(i,j,k) = vmac(i,j,k)*phiy(i,j,k)

          end do
       end do
    end do

    ! update phi on z faces by adding in xy and yx transverse terms
    do       k = lo(3), hi(3)+1
       do    j = lo(2), hi(2)
          do i = lo(1), hi(1)

             if (wmac(i,j,k) .lt. 0.d0) then
                phiz(i,j,k) = phiz(i,j,k) &
                     - hdtdx(1)*( 0.5d0*(umac(i+1,j  ,k  )+umac(i  ,j,k)) * (phix_y(i+1,j  ,k  )-phix_y(i,j,k  )) ) &
                     - hdtdx(2)*( 0.5d0*(vmac(i  ,j+1,k  )+vmac(i  ,j,k)) * (phiy_x(i  ,j+1,k  )-phiy_x(i,j,k  )) )
             else
                phiz(i,j,k) = phiz(i,j,k) &
                     - hdtdx(1)*( 0.5d0*(umac(i+1,j  ,k-1)+umac(i,j,k-1)) * (phix_y(i+1,j  ,k-1)-phix_y(i,j,k-1)) ) &
                     - hdtdx(2)*( 0.5d0*(vmac(i  ,j+1,k-1)+vmac(i,j,k-1)) * (phiy_x(i  ,j+1,k-1)-phiy_x(i,j,k-1)) )
             end if

             ! compute final z-fluxes
             flxz(i,j,k) = wmac(i,j,k)*phiz(i,j,k)

          end do
       end do
    end do

  end subroutine compute_flux_3d

end module compute_flux_module


! **************************************************************************
! ... nudging.f90
! ... Quim Ballabrera, February 2013
! ...
! ... System Dynamics
! ... Nudging applied to the Lorenz model
! ...
! **************************************************************************

program nudging

use sysdyn

implicit none

integer, parameter                          :: NVE = lorenz_n
type(obs_type)                              :: obs

logical default,Zexist

integer i,ii,step,nstep,iu,k,kk
real(dp) T,Jc,a,b,tt,apply

integer,  dimension(NVE)                    :: Iobs
real(dp), dimension(NVE)                    :: Xo,X,Xn,Xm
real(dp), dimension(NVE)                    :: Yo
character(len=180) nfile,ifile,ofile,rpath,rfile,bfile

! ... Lorenz model parameters
! ...
real(dp)                                    :: to,tf,dt
real(dp)                                    :: sigma
real(dp)                                    :: rho
real(dp)                                    :: beta

! ... Nudging parameters
! ...
real(dp) mux,muy,muz
real(dp) Tx,Ty,Tz

NAMELIST/namnudging/ifile,ofile,          &
                    rpath,rfile,          &
                    bfile,                &
                    mux,muy,muz,          &
                    Tx,Ty,Tz,             &
                    Iobs,                 &
                    sigma,rho,beta,       &
                    to,dt,tf

to    = lorenz_to
dt    = lorenz_dt
tf    = lorenz_tf
sigma = lorenz_sigma
rho   = lorenz_rho
beta  = lorenz_beta

nfile = ''
CALL getarg(1,nfile)
inquire(file=nfile,exist=Zexist)

if (len_trim(nfile).gt.0) then
  if (.not.Zexist) stop 'Namelist file not found'
endif

if (Zexist) then
  write(*,*) 'Reading ', trim(nfile)
  open(10,FILE=nfile,STATUS='old')
  rewind(10)
  read(10,namnudging)
  close(10)
  default = .false.
else
  default = .true.
endif

IF (default) THEN
  write(*,*) 'Default nudging parameters'

  ! ... Starting model value:
  ! ...
  ifile = 'nudging.ini'
  to    =  0.0D0
  Xo(:) = (/ -1.483,  6.517, 30.774 /)

  iu = unitfree()
  open(iu,file=trim(ifile),status='unknown')
  write(iu,*) to, Xo(:)
  close(iu)

  ! ... Observation file
  ofile = './obs_noise_02_sampl_010.dat'

  ! ... Output file
  rpath = './'
  rfile = './forward.dat'
  bfile = './backward.dat'

  ! ... Nudging coefficient:
  ! ...
  mux =  100D0
  muy =  100D0
  muz =  100D0
  Tx  =  0.10
  Ty  =  0.10
  Tz  =  0.10

  ! ... Model parameters:
  ! ...
  sigma = lorenz_sigma
  rho   = lorenz_rho
  beta  = lorenz_beta

  ! ... Model simulation time
  ! ...
  tf = 20.0D0
  dt = lorenz_dt

  ! ... What do we assimilate
  ! ...
  Iobs(:) = 1   ! All obs are assimilated
  !Iobs(:) = (/1, 1, 0/)

  ! ... If file nudging.namelist does not exist, we
  ! ... create a copy that can be later modified ....
  ! ...
  inquire(file='bfn.namelist',exist=Zexist)
  if (.not.Zexist) then
    open(20,file='bfn.namelist',status='new')
    write(20,nml=namnudging)
    close(20)
  endif

endif

lorenz_sigma = sigma
lorenz_rho   = rho
lorenz_beta  = beta

! ... Read the intial solution
! ...
write(*,*) 'Reading initial solution from ', trim(ifile)
iu = unitfree()
open(iu,file=trim(ifile),status='old')
rewind(iu)
read(iu,*) tt, Xo(:)
close(iu)

! ... Read the observations
! ...
obs = obs_read (ofile)

write(*,*)
write(*,*) 'Nobs                   = ', obs%Nobs
write(*,*) 'First time record      = ', obs%time(1)
write(*,*) 'Last time record       = ', obs%time(obs%Nobs)
write(*,*) 'Iobs                   = ', Iobs(:)
write(*,*) 'X nudging coefficient  = ', mux
write(*,*) 'Y nudging coefficient  = ', muy
write(*,*) 'Z nudging coefficient  = ', muz
write(*,*) 'Tx                     = ', Tx
write(*,*) 'Ty                     = ', Ty
write(*,*) 'Tz                     = ', Tz

! ... Fill the h vector:
! ...
obs%h(:) = .false.
where (Iobs(:).ge.1) obs%h = .true.

nstep = NINT((tf-to)/dt)

write(*,*)
write(*,*) 'Model initial time = ', to
write(*,*) 'Model final time   = ', tf
write(*,*) 'Model time step    = ', dt
write(*,*) 'Number time steps  = ', nstep + 1
write(*,*) 'Model parameters'
write(*,*) 'sigma              = ', lorenz_sigma
write(*,*) 'rho                = ', lorenz_rho
write(*,*) 'beta               = ', lorenz_beta

! ... Fill the step vector:
! ...
obs%step(:) = -1
kk = 1
do i=1,nstep+1
 tt = to + (i-1)*dt
 if (abs(obs%time(kk)-tt).le.0.1*dt) then
   obs%step(kk) = i
   kk = kk + 1
   if (kk.gt.obs%Nobs) exit
 endif
enddo
do i=1,obs%Nobs
  print*, i, obs%time(i), obs%step(i)
enddo

! ... Make sure that the observation index
! ... points to the first observation
do i=1,obs%Nobs
  if (obs%time(i).ge.to) then
    obs%p = i
    exit
  endif
enddo
write(*,*)
write(*,*) 'First observation ', obs%p, obs%time(obs%p)
write(*,*)

! ... Nudging data assimilation:
! ...
write(*,*) 'Output file ', trim(filename_append(rpath,rfile))
open(77,file=trim(filename_append(rpath,rfile)),status='unknown')
rewind(77)

t = to
X = Xo
write(77,'(4F10.4)') t, X

do step=1,nstep

  ! ... Assimilation is performed all the time:
  ! ... dx/dt = Physics + mu*SUM (w(t'-t)*(y(t')-x(t))
  ! ...
  CALL rk4 (lorenz_n,X,t,dt,XN,rhwnud)

  X = XN
  t = t + dt
  write(77,'(4F10.4)') t, X
ENDDO
write(*,*) 'closing file ', trim(filename_append(rpath,rfile))
CLOSE(77)

! ... Backward simulation:
! ...
dt = -dt

write(*,*) 'Output file ', trim(filename_append(rpath,bfile))
open(77,file=trim(filename_append(rpath,bfile)),status='unknown')
rewind(77)

write(77,'(4F10.4)') t, X
do step=1,nstep

  ! ... Assimilation is performed all the time:
  ! ... dx/dt = Physics + mu*SUM (w(t'-t)*(y(t')-x(t))
  ! ...
  CALL rk4 (lorenz_n,X,t,dt,XN,back_rhwnud)

  X = XN
  t = t + dt
  write(77,'(4F10.4)') t, X
ENDDO
write(*,*) 'closing file ', trim(filename_append(rpath,bfile))
close(77)

open(77,file='bfn.out',status='unknown')
write(77,'(4F10.4)') t, X
close(77)

call stop_error(0,'Nudging Ok')

contains
! ...
! ==========================================================================
! ...
  subroutine rhnud (n,t,x,dxdt)

  implicit none

  integer, intent(in)     :: n
  real(dp), intent(in)    :: t
  real(dp), intent(in)    :: x(n)
  real(dp), intent(out)   :: dxdt(n)

  ! ... Local variables
  ! ...
  real(dp), dimension(n)  :: nr

  ! ... Lorenz model equations
  ! ...
  dxdt(1) = lorenz_sigma*(X(2)-X(1))
  dxdt(2) = (lorenz_rho-X(3))*X(1) - X(2)
  dxdt(3) = X(1)*X(2) - lorenz_beta*X(3)

  ! ... Newtonian Relaxation:
  ! ... apply : is 0 or 1 depending if obs is available at that time
  ! ... obs%h : is True for the variables being assimilated, false otherwise
  ! ...
  nr(:) = zero
  if (obs%h(1)) nr(1) = apply*mux*(Yo(1)-X(1))
  if (obs%h(2)) nr(2) = apply*muy*(Yo(2)-X(2))
  if (obs%h(3)) nr(3) = apply*muz*(Yo(3)-X(3))

  dxdt(:) = dxdt(:) + nr(:)

  return
  end subroutine rhnud
! ...
! ==========================================================================
! ...
  subroutine rhwnud (n,t,x,dxdt)

  implicit none

  integer, intent(in)     :: n
  real(dp), intent(in)    :: t
  real(dp), intent(in)    :: x(n)
  real(dp), intent(out)   :: dxdt(n)

  ! ... Local variables
  ! ...
  real(dp) xsum,ysum,zsum
  real(dp), dimension(n)  :: nr

  ! ... Lorenz model equations
  ! ...
  dxdt(1) = sigma*(X(2)-X(1))
  dxdt(2) = (rho-X(3))*X(1) - X(2)
  dxdt(3) = X(1)*X(2) - beta*X(3)

  ! ... Newtonian Relaxation:
  ! ... obs%h : is True for the variables being assimilated, false otherwise
  ! ...
  call weight_innov (t,x,xsum,ysum,zsum)

  nr(:) = zero
  if (obs%h(1)) nr(1) = mux*xsum
  if (obs%h(2)) nr(2) = muy*ysum
  if (obs%h(3)) nr(3) = muz*zsum

  dxdt(:) = dxdt(:) + nr(:)

  return
  end subroutine rhwnud
! ...
! ========================================================================
! ...
  subroutine weight_innov (Time,X,xsum,ysum,zsum)

  implicit none

  real(dp), intent(in)                   :: Time
  real(dp), dimension(NVE), intent(in)   :: X
  real(dp), intent(out)                  :: xsum,ysum,zsum

  integer i
  real(dp) TT,argx,argy,argz,wx,wy,wz

  xsum = 0.0D0
  ysum = 0.0D0
  zsum = 0.0D0
  do i=1,obs%Nobs
    TT   = ABS(Time - obs%time(i))
    argx = TT/Tx
    argy = TT/Ty
    argz = TT/Tz
    wx = 0D0
    wy = 0D0
    wz = 0D0
    IF (argx.LT.10) wx = exp(-argx*argx)
    IF (argy.LT.10) wy = exp(-argy*argy)
    IF (argz.LT.10) wz = exp(-argz*argz)

    if (Time.gt.obs%time(i)+0.001D0) then
      wx = 0D0
      wy = 0D0
      wz = 0D0
    endif

    !print*, Time, i, obs%time(i), wx
    xsum = xsum + wx*(obs%y(1,i)-X(1))
    ysum = ysum + wy*(obs%y(2,i)-X(2))
    zsum = zsum + wz*(obs%y(3,i)-X(3))
  enddo

  return
  end subroutine weight_innov
! ...
! ==========================================================================
! ...
  subroutine back_rhwnud (n,t,x,dxdt)

  implicit none

  integer, intent(in)     :: n
  real(dp), intent(in)    :: t
  real(dp), intent(in)    :: x(n)
  real(dp), intent(out)   :: dxdt(n)

  ! ... Local variables
  ! ...
  real(dp) xsum,ysum,zsum
  real(dp), dimension(n)  :: nr

  ! ... Lorenz model equations
  ! ...
  dxdt(1) = sigma*(X(2)-X(1))
  dxdt(2) = (rho-X(3))*X(1) - X(2)
  dxdt(3) = X(1)*X(2) - beta*X(3)

  ! ... Newtonian Relaxation:
  ! ... obs%h : is True for the variables being assimilated, false otherwise
  ! ...
  call back_weight_innov (t,x,xsum,ysum,zsum)

  nr(:) = zero
  if (obs%h(1)) nr(1) = mux*xsum
  if (obs%h(2)) nr(2) = muy*ysum
  if (obs%h(3)) nr(3) = muz*zsum

  dxdt(:) = dxdt(:) - nr(:)

  return
  end subroutine back_rhwnud
! ...
! ========================================================================
! ...
  subroutine back_weight_innov (Time,X,xsum,ysum,zsum)

  implicit none

  real(dp), intent(in)                   :: Time
  real(dp), dimension(NVE), intent(in)   :: X
  real(dp), intent(out)                  :: xsum,ysum,zsum

  integer i
  real(dp) TT,argx,argy,argz,wx,wy,wz

  xsum = 0.0D0
  ysum = 0.0D0
  zsum = 0.0D0
  do i=1,obs%Nobs
    TT   = ABS(Time - obs%time(i))
    argx = TT/Tx
    argy = TT/Ty
    argz = TT/Tz
    wx = 0D0
    wy = 0D0
    wz = 0D0
    IF (argx.LT.10) wx = exp(-argx*argx)
    IF (argy.LT.10) wy = exp(-argy*argy)
    IF (argz.LT.10) wz = exp(-argz*argz)

    !if (Time.lt.obs%time(i)+0.001D0) then
    !  wx = 0D0
    !  wy = 0D0
    !  wz = 0D0
    !endif

    !print*, Time, i, obs%time(i), wx
    xsum = xsum + wx*(obs%y(1,i)-X(1))
    ysum = ysum + wy*(obs%y(2,i)-X(2))
    zsum = zsum + wz*(obs%y(3,i)-X(3))
  enddo

  return
  end subroutine back_weight_innov

end program nudging


      integer(4) function i4elsum(ivec,nelmnt)
*
* Sum of elements of integer vector IVEC
* Explicit integer(4) version
*
      implicit none

      integer(4), intent(in) ::
     &   nelmnt, ivec(nelmnt)

      integer(4) ::
     &   isum, ielmnt
*
      isum = 0
      do ielmnt = 1, nelmnt
        isum = isum + ivec(ielmnt)
      end do
*
      i4elsum = isum
*
      return
      end


    program demo_aimag
    implicit none
    integer,parameter :: dp=kind(0.0d0)
    complex          :: z4
    complex(kind=dp) :: z8
       z4 = cmplx(1.23456789, 1.23456789)
       print *, 'Z4=',z4
       ! using kind=dp makes it keep DOUBLEPRECISION precision
       z8 = cmplx(1.2345678901234567d0, 1.2345678901234567d0,kind=dp)
       print *, 'Z8=',z8
       ! NOTE:
       ! The following is intuitive and works without calling cmplx(3)
       ! but does not work for variables just constants
       z8 = (1.2345678901234567d0 , 1.2345678901234567d0 )
       print *, 'Z8 defined with constants=',z8
    end program demo_aimag


let Char :* = Int;;
let GTInt (lo:Int) :* = (x:Int.(x>lo));;
let GTEInt (lo:Int) :* = (x:Int.(lo<=x));;
let LTInt (hi:Int) :* = (x:Int.(x<hi));;
let RInt (lo:Int) (hi:Int) :* = (x:Int. (and (lo<=x)  (x<hi)));;

datatype String =
  SNull of (u:Unit)
| SCons of (x:Char) (r:String)
;;

   let rec concat (s1:String) (s2:String) : String=
     caseString s1 String
       (fn u => s2)
       (fn x r => (SCons x (concat r s2)));;

let chomp (s:String) : String =
      caseString s String
      (fn u => s)
      (fn c r => r);;

let stringify (c:Char) :String = (SCons c (SNull unit));;

let chareq (x:Char) (y:Char) :Bool = inteq x y;;

let rec stringeq (s1:String) (s2:String) :Bool =
  caseString s1 Bool
    (fn u1 =>
     (caseString s2 Bool
        (fn u => true)
        (fn c r => false)))
    (fn c1 r1 =>
     (caseString s2 Bool
        (fn u2 => false)
        (fn c2 r2 =>
         (if [Bool] (chareq c1 c2)
         then (stringeq r1 r2)
         else false))))
;;

/*--------------Constant Strings and Chars--------------------------*/

let charPercent = 37 as Char;;

let charZero = 48 as Char;;
let charOne = 49 as Char;;
let charTwo = 50 as Char;;
let charThree = 51 as Char;;
let charFour = 52 as Char;;
let charFive = 53 as Char;;
let charSix = 54 as Char;;
let charSeven = 55 as Char;;
let charEight = 56 as Char;;
let charNine = 57 as Char;;

let charA = 65 as Char;; /*unicode decimal number for 'A'*/
let charB = 66 as Char;; /*unicode decimal number for 'B'*/
let charD = 68 as Char;; /*unicode decimal number for 'D'*/
let charE = 69 as Char;; /*unicode decimal number for 'E'*/
let charF = 70 as Char;; /*unicode decimal number for 'F'*/
let charL = 76 as Char;; /*unicode decimal number for 'L'*/
let charR = 82 as Char;; /*unicode decimal number for 'R'*/
let charS = 83 as Char;; /*unicode decimal number for 'S'*/
let charT = 84 as Char;; /*unicode decimal number for 'T'*/
let charU = 85 as Char;; /*unicode decimal number for 'U'*/
let charDash = 45 as Char;; /*unicode decimal number for '-'*/

let strPerD = (SCons charPercent (SCons charD (SNull unit)));;
let strPerB = (SCons charPercent (SCons charB (SNull unit)));;
let strPerS = (SCons charPercent (SCons charS (SNull unit)));;
/*
let stringTrue = SCons charT (SCons charR (SCons charU (SCons charE
      (SNull unit))));;

let stringFalse =  SCons charF  (SCons charA  (SCons charL
      (SCons charS  (SCons charE (SNull unit)))));;

/*-------------------INT->STRING---------------------------*/

let numeral_to_char (i:(RInt 0 10)) : Char =
      if [Char] (inteq i 0)
      then charZero
      else (if [Char] (inteq i 1)
         then charOne
         else (if [Char] (inteq i 2)
            then charTwo
            else (if [Char] (inteq i 3)
               then charThree
               else (if [Char] (inteq i 4)
                  then charFour
                  else (if [Char] (inteq i 5)
                     then charFive
                     else (if [Char] (inteq i 6)
                        then charSix
                        else (if [Char] (inteq i 7)
                           then charSeven
                           else (if [Char] (inteq i 8)
                              then charEight
                              else charNine
                                 ))))))));;

let rec mod (i:(GTEInt 0)) (d:(GTInt 0)) : (RInt 0 d) =
      if [RInt 0 d] (i < d)
      then i
      else (mod (i-d) d);;

let rec fd_helper (i:(GTEInt 0)) (d:(GTInt 0)) (res:(GTEInt 0)) : (GTEInt 0) =
      if [GTEInt 0] (i < d)
      then res
      else (fd_helper (i-d) d (res+1));;

let floor_divide (i:(GTEInt 0)) (d:(GTInt 0)): (GTEInt 1) = /* BUG: 0 -> 1 */
      fd_helper i d 0;;

let rec helper_int_to_string (i:(GTEInt 0)) (s:String) : String =
      if [String] (inteq i 0)
      then s
      else (let new_s = (SCons (numeral_to_char (mod i 10)) s) in
             (helper_int_to_string (floor_divide i 10) new_s));;

let int_to_string (i:Int) (ret:String) : String =
      if [String] (inteq i 0)
      then (stringify charZero)
      else (if [String] (i < 0)
         then (concat
           (SCons charDash (helper_int_to_string (0 - i) (SNull unit)))
           ret)
         else (concat (helper_int_to_string i (SNull unit)) ret));;

/*------------BOOL->STRING -------------*/

let bool_to_string (b:Bool) (ret:String) : String =
      if [String] b
      then (concat stringTrue ret)
      else (concat stringFalse ret)
   ;;
*/

/*------------THE TYPE --------------*/

let rec Data (fmt:String) : * =
  (caseString fmt *
    (fn u => Unit)
    (fn x1 r1 =>
     if[*] (chareq x1 charPercent)
     then
       (caseString r1 *
         (fn u => Unit)
         (fn x2 r2 =>
          if[*] (chareq x2 charD)
          then (Int -> (Data r2))
          else if[*] (chareq x2 charB)
          then (Bool -> (Data r2))
          else Data r2))
     else Data r1))
;;

/*---------PRINTF----------------*/

let rec printf (fmt:String) : Data fmt =
  let t = (Data fmt) in
  (caseString fmt (Data fmt)
        (fn u => unit)
        (fn x1 r1 =>
         if[Data fmt] (chareq x1 charPercent)
         then
           (caseString r1 (Data fmt)
             (fn u => unit)
             (fn x2 r2 =>
              if[Data fmt] (chareq x2 charD)
              then
                (fn (i:Int) =>
                  let dummy = print i in
                  printf r2)
              else if[Data fmt] (chareq x2 charB)
              then
                (fn (b:Bool) =>
                  let dummy = print b in
                  printf r2)
              else
                (let d = print x1 in
                let d = print x2 in
                printf r2)))
         else
           let d = print x1 in
           printf r1))
;;

/*---------PRINTF----------------

let rec printf (fmt:String) =
  let t = Dynamic in
  (caseString fmt t
        (fn u => unit)
        (fn x1 r1 =>
         if[t] (chareq x1 charPercent)
         then
           (caseString r1 t
             (fn u => unit)
             (fn x2 r2 =>
              if[t] (chareq x2 charD)
              then
                (fn (i:Int) =>
                  let dummy = print i in
                  printf r2)
              else if[t] (chareq x2 charB)
              then
                (fn (b:Bool) =>
                  let dummy = print b in
                  printf r2)
              else
                (let d = print x1 in
                let d = print x2 in
                printf r2)))
         else
           let d = print x1 in
           printf r1))
;;

*/

printf (SCons charPercent (SCons charB (SCons charPercent (SCons charB (SNull unit)))));;


!>
module integrate

#include "debug.h"

  ! debug compilation
  ! - <DEBUG_INTEGRATE>: verbosity of debug statements, local to this file.
#define DEBUG_INTEGRATE 1

  ! local debug verbosity cannot be lower than the global debug verbosity
#if ((defined DEBUG) && (defined DEBUG_INTEGRATE) && (DEBUG > DEBUG_INTEGRATE))
#undef DEBUG_INTEGRATE
#define DEBUG_INTEGRATE DEBUG
#endif

  use parameters

  implicit none

contains

  function integrate_trapezoid (n, x, f) result (integral)
    integer , intent(in) :: n
    double precision , intent(in) :: x(n), f(n)
    double precision :: w(n)
    double precision :: integral
    integer :: ii
    integer :: i_err

#if (DEBUG_INTEGRATE >= 1)
    write (STDERR, *) DBG, "function integrate_trapezoid()"
#endif

    ! check if arguments are valid
    i_err = 0

    if (n < 2) then
      i_err = 1
#if (DEBUG_INTEGRATE >= 2)
      write (STDERR, *) DBG, ERR, "<n> < 2"
#endif
    end if

    ! handle invalid arguments
    if (i_err /= 0) then
#if (DEBUG_INTEGRATE >= 2)
      write (STDERR, *) DBG, ERR, "<i_err> = ", i_err
#endif

      integral = 0.0d0

#if (DEBUG_INTEGRATE >= 1)
      write (STDERR, *) DBG, ERR, "arguments are invalid"
      write (STDERR, *) DBG, ERR, "returning <integral> = 0"
      write (STDERR, *) DBG, ERR, "exiting function integrate_trapezoid()"
#endif
      return
    end if

#if (DEBUG_INTEGRATE >= 2)
    write (STDERR, *) DBG, "arguments are valid"
#endif

#if (DEBUG_INTEGRATE >= 5)
    write (STDERR, *) DBG, "<index>, <w>"
#endif

    ! calculate weights
    w(1) = (x(2) - x(1)) / 2.0d0

#if (DEBUG_INTEGRATE >= 5)
    write (STDERR, *) DBG, 1, w(1)
#endif

    do ii = 2, n-1
      w(ii) = (x(ii+1) - x(ii-1)) / 2.0d0

#if (DEBUG_INTEGRATE >= 5)
      write (STDERR, *) DBG, ii, w(ii)
#endif

    end do

    w(n) = (x(n) - x(n-1)) / 2.0d0

#if (DEBUG_INTEGRATE >= 5)
    write (STDERR, *) DBG, n, w(n)
#endif

    ! calculate integral
    integral = 0.0d0

    do ii = 1, n
      integral = integral + (w(ii) * f(ii))
    end do

#if (DEBUG_INTEGRATE >= 2)
    write (STDERR, *) DBG, "<integral> = ", integral
#endif

#if (DEBUG_INTEGRATE >= 1)
    write (STDERR, *) DBG, "end function integrate_trapezoid()"
#endif
    return

  end function integrate_trapezoid

end module integrate


      SUBROUTINE qrdcmp(a,n,np,c,d,sing)
      INTEGER n,np
      DOUBLE PRECISION a(np,np),c(n),d(n)
      LOGICAL sing
      INTEGER i,j,k
      DOUBLE PRECISION scale,sigma,sum,tau
      sing=.false.
      scale=0.d0
      do 17 k=1,n-1
        do 11 i=k,n
          scale=max(scale,abs(a(i,k)))
11      continue
        if(scale.eq.0.d0)then
          sing=.true.
          c(k)=0.d0
          d(k)=0.d0
        else
          do 12 i=k,n
            a(i,k)=a(i,k)/scale
12        continue
          sum=0.d0
          do 13 i=k,n
            sum=sum+a(i,k)**2
13        continue
          sigma=sign(sqrt(sum),a(k,k))
          a(k,k)=a(k,k)+sigma
          c(k)=sigma*a(k,k)
          d(k)=-scale*sigma
          do 16 j=k+1,n
            sum=0.d0
            do 14 i=k,n
              sum=sum+a(i,k)*a(i,j)
14          continue
            tau=sum/c(k)
            do 15 i=k,n
              a(i,j)=a(i,j)-tau*a(i,k)
15          continue
16        continue
        endif
17    continue
      d(n)=a(n,n)
      if(d(n).eq.0.d0)sing=.true.
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software 0!5,.


C    Copyright(C) 1988-2017 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    Redistribution and use in source and binary forms, with or without
C    modification, are permitted provided that the following conditions are
C    met:
C
C    * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C    * Redistributions in binary form must reproduce the above
C      copyright notice, this list of conditions and the following
C      disclaimer in the documentation and/or other materials provided
C      with the distribution.
C
C    * Neither the name of NTESS nor the names of its
C      contributors may be used to endorse or promote products derived
C      from this software without specific prior written permission.
C
C    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C    A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C    OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

      subroutine jacob(x1,x2,x3,x4,x5,x6,x7,x8,
     *                 y1,y2,y3,y4,y5,y6,y7,y8,
     *                 z1,z2,z3,z4,z5,z6,z7,z8, JACMN)
      REAL JACOBI, JACMN
      REAL XXI(3), XET(3), XZE(3)

      JACMN = 1.0e38

C... Jacobian at mid-point:

      xxi(1) = x2 + x3 + x6 + x7 - x1 - x4 - x5 - x8
      xet(1) = x3 + x4 + x7 + x8 - x1 - x2 - x5 - x6
      xze(1) = x5 + x6 + x7 + x8 - x1 - x2 - x3 - x4

      xxi(2) = y2 + y3 + y6 + y7 - y1 - y4 - y5 - y8
      xet(2) = y3 + y4 + y7 + y8 - y1 - y2 - y5 - y6
      xze(2) = y5 + y6 + y7 + y8 - y1 - y2 - y3 - y4

      xxi(3) = z2 + z3 + z6 + z7 - z1 - z4 - z5 - z8
      xet(3) = z3 + z4 + z7 + z8 - z1 - z2 - z5 - z6
      xze(3) = z5 + z6 + z7 + z8 - z1 - z2 - z3 - z4

      jacobi = CRSDOT(xxi,xet,xze)/64.0
      jacmn = min(jacobi, jacmn)
C... J(0,0,0):

      xxi(1) = x2 - x1
      xet(1) = x4 - x1
      xze(1) = x5 - x1

      xxi(2) = y2 - y1
      xet(2) = y4 - y1
      xze(2) = y5 - y1

      xxi(3) = z2 - z1
      xet(3) = z4 - z1
      xze(3) = z5 - z1

      jacobi = CRSDOT(xxi,xet,xze)
      jacmn = min(jacobi, jacmn)

C... J(1,0,0):

      xxi(1) = x2 - x1
      xet(1) = x3 - x2
      xze(1) = x6 - x2

      xxi(2) = y2 - y1
      xet(2) = y3 - y2
      xze(2) = y6 - y2

      xxi(3) = z2 - z1
      xet(3) = z3 - z2
      xze(3) = z6 - z2

      jacobi = CRSDOT(xxi,xet,xze)
      jacmn = min(jacobi, jacmn)

C... J(0,1,0):

      xxi(1) = x3 - x4
      xet(1) = x4 - x1
      xze(1) = x8 - x4

      xxi(2) = y3 - y4
      xet(2) = y4 - y1
      xze(2) = y8 - y4

      xxi(3) = z3 - z4
      xet(3) = z4 - z1
      xze(3) = z8 - z4

      jacobi = CRSDOT(xxi,xet,xze)
      jacmn = min(jacobi, jacmn)

C... J(0,0,1):

      xxi(1) = x6 - x5
      xet(1) = x8 - x5
      xze(1) = x5 - x1

      xxi(2) = y6 - y5
      xet(2) = y8 - y5
      xze(2) = y5 - y1

      xxi(3) = z6 - z5
      xet(3) = z8 - z5
      xze(3) = z5 - z1

      jacobi = CRSDOT(xxi,xet,xze)
      jacmn = min(jacobi, jacmn)

C... J(1,1,0):

      xxi(1) = x3 - x4
      xet(1) = x3 - x2
      xze(1) = x7 - x3

      xxi(2) = y3 - y4
      xet(2) = y3 - y2
      xze(2) = y7 - y3

      xxi(3) = z3 - z4
      xet(3) = z3 - z2
      xze(3) = z7 - z3

      jacobi = CRSDOT(xxi,xet,xze)
      jacmn = min(jacobi, jacmn)

C... J(1,0,1):

      xxi(1) = x6 - x5
      xet(1) = x7 - x6
      xze(1) = x6 - x2

      xxi(2) = y6 - y5
      xet(2) = y7 - y6
      xze(2) = y6 - y2

      xxi(3) = z6 - z5
      xet(3) = z7 - z6
      xze(3) = z6 - z2

      jacobi = CRSDOT(xxi,xet,xze)
      jacmn = min(jacobi, jacmn)

C... J(0,1,1):

      xxi(1) = x7 - x8
      xet(1) = x8 - x5
      xze(1) = x8 - x4

      xxi(2) = y7 - y8
      xet(2) = y8 - y5
      xze(2) = y8 - y4

      xxi(3) = z7 - z8
      xet(3) = z8 - z5
      xze(3) = z8 - z4

      jacobi = CRSDOT(xxi,xet,xze)
      jacmn = min(jacobi, jacmn)

C... J(1,1,1):

      xxi(1) = x7 - x8
      xet(1) = x7 - x6
      xze(1) = x7 - x3

      xxi(2) = y7 - y8
      xet(2) = y7 - y6
      xze(2) = y7 - y3

      xxi(3) = z7 - z8
      xet(3) = z7 - z6
      xze(3) = z7 - z3

      jacobi = CRSDOT(xxi,xet,xze)
      jacmn = min(jacobi, jacmn)

      return
      end

      REAL FUNCTION CRSDOT(a, b, c)
      REAL a(3), b(3), c(3)
C ... Compute d = a dot (b cross c)

      REAL xcross, ycross, zcross

      xcross = b(2) * c(3) - b(3) * c(2)
      ycross = b(3) * c(1) - b(1) * c(3)
      zcross = b(1) * c(2) - b(2) * c(1)

      crsdot = (a(1) * xcross + a(2) * ycross + a(3) * zcross)
      return
      end


	FUNCTION FFTAMP(CHANNEL,F)
C
C	THIS IS THE GAIN OF A CIRCUIT JUST BEFORE THE FFT D/A CONVERTER
C
	INTEGER*4 CHANNEL
	COMPLEX Z1,Y2,GAIN
	REAL RSW(6),C2MUF(6),F
	COMMON /GAINBLK/ PHASE,GAIN
	DATA RSW /50.,400.,400.,0.,0.,0./
	DATA C2MUF /1.961,1.896,1.949,1.981,2.011,1.943/
	DATA C1,R2,C2 /2.E-6,1.E4,1.E-9/
	DATA TWOPI /6.2831853/
C
	GAIN = CMPLX(1.,0.)
	PHASE = 0.
	FFTAMP = 1.
	IF(CHANNEL.GT.6) RETURN
	W = TWOPI*F
	C1 = C2MUF(CHANNEL)*1.E-6
	RSWT = RSW(CHANNEL)
	Z1 = CMPLX(RSWT,-1./W/C1)
	Y2 = CMPLX(1./R2,W*C2)
	GAIN = 1./(1. + Y2*Z1)

C
	GNIP = AIMAG(GAIN)
	GNRP = GAIN
	PHASE = ATAN2(GNIP,GNRP)
	FFTAMP = CABS(GAIN)
	RETURN
	END


!==========================================================================
elemental subroutine gsw_rho_second_derivatives (sa, ct, p, rho_sa_sa, &
                                  rho_sa_ct, rho_ct_ct, rho_sa_p, rho_ct_p)
!==========================================================================
!
!  Calculates five second-order derivatives of rho. Note that this function
!  uses the using the computationally-efficient expression for specific
!  volume (Roquet et al., 2014).
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  rho_SA_SA = The second-order derivative of rho with respect to
!              Absolute Salinity at constant CT & p.    [ J/(kg (g/kg)^2) ]
!  rho_SA_CT = The second-order derivative of rho with respect to
!              SA and CT at constant p.                  [ J/(kg K(g/kg)) ]
!  rho_CT_CT = The second-order derivative of rho with respect to CT at
!              constant SA & p
!  rho_SA_P  = The second-order derivative with respect to SA & P at
!              constant CT.
!  rho_CT_P  = The second-order derivative with respect to CT & P at
!              constant SA.
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_specvol, gsw_specvol_first_derivatives
use gsw_mod_toolbox, only : gsw_specvol_second_derivatives

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p
real (r8), intent(out), optional :: rho_sa_sa, rho_sa_ct, rho_ct_ct
real (r8), intent(out), optional :: rho_sa_p, rho_ct_p

integer :: iflag1, iflag2
real (r8) :: rec_v, rec_v2, rec_v3, v_ct, v_ct_ct, v_ct_p, v_p, v_sa, v_sa_ct
real (r8) :: v_sa_p, v_sa_sa

iflag1 = 0
if (present(rho_sa_sa) .or. present(rho_sa_ct) &
                       .or. present(rho_sa_p)) iflag1 = ibset(iflag1,1)
if (present(rho_sa_ct) .or. present(rho_ct_ct) &
                       .or. present(rho_ct_p)) iflag1 = ibset(iflag1,2)
if (present(rho_sa_p) .or. present(rho_ct_p)) iflag1 = ibset(iflag1,3)

call gsw_specvol_first_derivatives(sa,ct,p,v_sa,v_ct,v_p,iflag=iflag1)

iflag2 = 0
if (present(rho_sa_sa)) iflag2 = ibset(iflag2,1)
if (present(rho_sa_ct)) iflag2 = ibset(iflag2,2)
if (present(rho_ct_ct)) iflag2 = ibset(iflag2,3)
if (present(rho_sa_p)) iflag2 = ibset(iflag2,4)
if (present(rho_ct_p)) iflag2 = ibset(iflag2,5)

call gsw_specvol_second_derivatives(sa,ct,p,v_sa_sa,v_sa_ct,v_ct_ct, &
                                    v_sa_p,v_ct_p,iflag=iflag2)

rec_v = 1.0_r8/gsw_specvol(sa,ct,p)
rec_v2 = rec_v**2
rec_v3 = rec_v2*rec_v

if (present(rho_sa_sa)) rho_sa_sa = -v_sa_sa*rec_v2 + 2.0_r8*v_sa*v_sa*rec_v3

if (present(rho_sa_ct)) rho_sa_ct = -v_sa_ct*rec_v2 + 2.0_r8*v_sa*v_ct*rec_v3

if (present(rho_ct_ct)) rho_ct_ct = -v_ct_ct*rec_v2 + 2.0_r8*v_ct*v_ct*rec_v3

if (present(rho_sa_p)) rho_sa_p = -v_sa_p*rec_v2 + 2.0_r8*v_sa*v_p*rec_v3

if (present(rho_ct_p)) rho_ct_p = -v_ct_p*rec_v2 + 2.0_r8*v_ct*v_p*rec_v3

return
end subroutine

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


FUNCTION CSNDZEQ(IOPT,SNDDIA,GPDIASED,TAUR,TAUB,SNDDMX,DEP,SSG,WS)

  ! *** CALCULATES NEAR BED REFERENCE CONCENTRATION REFERENCE HEIGHT (DIMENSIONLESS)
  !
  ! CHANGE RECORD
  ! DATE MODIFIED     BY               DESCRIPTION
  !----------------------------------------------------------------------!
  ! 2011-03           PAUL M. CRAIG    REWRITTEN TO F90
  ! 2011-03-02        PAUL M. CRAIG    FIXED CASE WHEN WS <= 0

  IMPLICIT NONE

  INTEGER :: IOPT
  REAL    :: CSNDZEQ,SNDDIA,GPDIASED,TAUR,TAUB,SNDDMX,DEP,SSG,WS,TMPVAL,REY,TAURS,VAL,VAL1,ZEQ1

  IF( IOPT == 1 )THEN
    ! *** IOPT=1  BASED ON
    ! ***
    ! *** GARCIA, M., AND G. PARKER, 1991: ENTRAINMENT OF BED SEDIMENT
    ! *** INTO SUSPENSION, J. HYDRAULIC ENGINEERING, 117, 414-435.

    CSNDZEQ=0.05

  ELSEIF( IOPT == 2 )THEN
    !
    ! *** IOPT=2  BASED ON
    ! ***
    ! *** SMITH, J. D., AND S. R. MCLEAN, 1977: SPATIALLY AVERAGED FLOW
    ! *** OVER A WAVY SURFACE, J. GEOPHYSICAL RESEARCH, 82, 1735-1746.

    TMPVAL=26.3*SNDDMX*(TAUB-TAUR)/GPDIASED
    TMPVAL=TMPVAL*SNDDIA/SNDDMX
    TMPVAL=TMPVAL/DEP
    CSNDZEQ=MAX(TMPVAL,0.01)

  ELSEIF( IOPT == 3 )THEN
    ! *** IOPT=3  BASED ON
    ! ***
    ! *** VAN RIJN, L. C., 1984: SEDIMENT TRANSPORT, PART II: SUSPENDED
    ! *** LOAD TRANSPORT, J. HYDRAULIC ENGINEERING, 110, 1623-1641.
    IF( WS > 0. )THEN
      REY=1.E4*SNDDIA*( (9.8*(SSG-1.))**0.333 )
      IF( REY <= 10.) TAURS=(4.*WS/REY)**2
      IF( REY > 10.) TAURS=0.016*WS*WS
      VAL=(TAUB/TAURS)-1.
      VAL=MIN(MAX(VAL,0.),100.)
      VAL1=1.-EXP(-0.5*VAL)
      VAL1=0.11*VAL1*(25.-VAL)
      ZEQ1=0.5*VAL1*(DEP**0.7)*(SNDDMX**0.3)
      ZEQ1=ZEQ1/DEP
      CSNDZEQ=MAX(ZEQ1,0.01)
    ELSE
      CSNDZEQ=0.01
    ENDIF

  ELSEIF( IOPT  ==  4 .OR. IOPT == 5 )THEN
    ! *** HAMRICK'S SEDFLUME OPTION
    CSNDZEQ=0.01

  ELSE
    ! *** BAD OPTION
    STOP ' BAD CSNDZEQ OPTION'

  ENDIF

  RETURN

END


C --- ------------------------- CHECK_STEPWIDTH_CRIT ---------------------------
      LOGICAL*4 FUNCTION CHECK_STEPWIDTH_CRIT(wsp,fsp,sw_crit)
C     Stepwidth control checking curvature of profile
      REAL*8    as(4),bs(4),cs(4)               ! Buffer for Spline Coefficients
      REAL*8    fsp(4)                          ! Fluxpoints
      REAL*8    wsp(4)                          ! wavelengthpoints
      REAL*8    z,dz
      REAL*8    f1,f2                           ! 1. and 2. derivation
      REAL*8    sw_crit                         ! stepwidth-criterium
      REAL*8    xbuf
      REAL*8    hex

      CALL DSPLINE(wsp,fsp,as,bs,cs,4)

c      dz = (wsp(4)-wsp(3))*0.5
c      f1 = (as(3) + dz*(2.D0*bs(3) + 3.D0*cs(3)*dz)) * 1.D-8
c      f2 = (2.D0*bs(3) + 6.D0*cs(3) * dz) * 1.D-16

      f1 = as(3) * 1.D-8
      f2 = bs(3) * 2.D-16
      hex= DABS(f2/dsqrt(1.D0+f1*f1)**3.D0)
      xbuf = DABS(f1) + hex
C      write(*,100) wsp(3)*1.D8,fsp(3),f1,f2,xbuf,hex
C100   FORMAT(' ',f8.3,' ',f7.4,' ',4(G13.4,' '))
      CHECK_STEPWIDTH_CRIT = sw_crit.LT.xbuf

      RETURN
      END


C
C
      SUBROUTINE ANSMFT(R,S,R1,R2,S1,S2,C,U,PUX,PUY,PUXX,PUXY,PUYY)
C
C***********************************************************************
C
C     This routine does 2d smooth surface interpolation for
C     the temperature dependent parts of THOMAS-FERMI eos.
C     Original method and routines by D. J. McCloskey
C     Modified for aneos by S. L. Thompson  10/88
C
C     TWO-DIMENSIONAL SMOOTH SURFACE FIT.
C     REF. - BIRKHOFF AND GARABEDIAN, SMOOTH SURFACE INTERPOLATION,
C            JOUR. OF MATH. AND PHYSICS, VOL. XXXIX, 1960, P. 258-268.
C
C**************************************************** slt 10/88 ********
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION C(12)
      PARAMETER (ZERO=0.D0)
      PARAMETER (AHALF=0.5D0)
      PARAMETER (TWO=2.D0)
      PARAMETER (THREE=3.D0)
      PARAMETER (FIVE=5.D0)
      PARAMETER (SIX=6.D0)
      PARAMETER (ANINE=9.D0)
      PARAMETER (EIGTEN=18.D0)
      PARAMETER (TWENTY=20.D0)
      DX=TWO/(R2-R1)
      DY=TWO/(S2-S1)
      X=(R-AHALF*(R2+R1))*DX
      Y=(S-AHALF*(S2+S1))*DY
      Y2=Y*Y
      X2=X*X
      Y3=Y2*Y
      X3=X2*X
      U=(((C(12)+C(11))*THREE*Y-C(11)*Y3+C(5))*X+C(2))*X2+((C(11)-C(12))
     & *THREE*Y3+C(10)*Y+C(4))*X+((C(8)*Y+C(3))*Y+C(7))*Y+C(1)
      PUX=((C(11)-C(11)*X2-C(12))*THREE*Y2+(C(11)+C(12))*ANINE*X2+C(10))
     & *Y+(THREE*C(5)*X+TWO*C(2))*X+C(4)
      PUY=((C(11)-C(11)*Y2+C(12))*THREE*X2+((C(11)-C(12))*ANINE*Y2+
     & C(10)))*X+(THREE*C(8)*Y+TWO*C(3))*Y+C(7)
      PUXX=(((EIGTEN-SIX*Y2)*C(11)+EIGTEN*C(12))*Y+SIX*C(5))*X+TWO*C(2)
      PUXY=(C(11)-C(11)*Y2+C(12))*ANINE*X2+(C(11)-C(12))*ANINE*Y2+C(10)
      PUYY=(((EIGTEN-SIX*X2)*C(11)-EIGTEN*C(12))*X+SIX*C(8))*Y+TWO*C(3)
      IF (X2.LT.Y2) GO TO 10
C     NOW IN A OR C
      TU=C(12)*X3*Y*(Y2-X2)
      TPUX=C(12)*X2*Y*(THREE*Y2-FIVE*X2)
      TPUY=C(12)*X3*(THREE*Y2-X2)
      TPUXX=C(12)*X*Y*(SIX*Y2-TWENTY*X2)
      TPUXY=C(12)*X2*(ANINE*Y2-FIVE*X2)
      TPUYY=C(12)*SIX*X3*Y
      TU1=C(6)*(X2+Y2)+TWO*C(9)*X*Y
      TPUX1=TWO*(C(6)*X+C(9)*Y)
      TPUY1=TWO*(C(6)*Y+C(9)*X)
      TPUXX1=TWO*C(6)
      TPUXY1=TWO*C(9)
      TPUYY1=TPUXX1
      IF (X.LT.ZERO) GO TO 30
      GO TO 20
C     NOW IN B OR D
   10 TU=C(12)*X*Y3*(Y2-X2)
      TPUX=C(12)*Y3*(Y2-THREE*X2)
      TPUY=C(12)*X*Y2*(FIVE*Y2-THREE*X2)
      TPUXX=-C(12)*SIX*X*Y3
      TPUXY=C(12)*Y2*(FIVE*Y2-ANINE*X2)
      TPUYY=C(12)*X*Y*(TWENTY*Y2-SIX*X2)
      TU1=TWO*C(6)*X*Y+C(9)*(X2+Y2)
      TPUX1=TWO*(C(6)*Y+C(9)*X)
      TPUY1=TWO*(C(6)*X+C(9)*Y)
      TPUXX1=TWO*C(9)
      TPUXY1=TWO*C(6)
      TPUYY1=TPUXX1
      IF (Y.LT.ZERO) GO TO 30
C     NOW IN A OR B
   20 U=TU+TU1+U
      PUX=(TPUX+TPUX1+PUX)*DX
      PUY=(TPUY+TPUY1+PUY)*DY
      PUXX=(TPUXX+TPUXX1+PUXX)*DX*DX
      PUXY=(TPUXY+TPUXY1+PUXY)*DX*DY
      PUYY=(TPUYY+TPUYY1+PUYY)*DY*DY
      GO TO 40
C     NOW IN C OR D
   30 U=TU-TU1+U
      PUX=(TPUX-TPUX1+PUX)*DX
      PUY=(TPUY-TPUY1+PUY)*DY
      PUXX=(TPUXX-TPUXX1+PUXX)*DX*DX
      PUXY=(TPUXY-TPUXY1+PUXY)*DX*DY
      PUYY=(TPUYY-TPUYY1+PUYY)*DY*DY
   40 CONTINUE
      RETURN
      END


      subroutine ch_watqual4

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine performs in-stream nutrient transformations and water
!!    quality calculations

      use channel_module
      use hydrograph_module
      use climate_module
      use channel_data_module

      real :: tday, wtmp, fll, gra
      real :: lambda, fnn, fpp, algi, fl_1, xx, yy, zz, ww
      real :: uu, vv, cordo, f1, algcon
      real :: thgra = 1.047, thrho = 1.047, thrs1 = 1.024
      real :: thrs2 = 1.074, thrs3 = 1.074, thrs4 = 1.024, thrs5 = 1.024
      real :: thbc1 = 1.083, thbc2 = 1.047, thbc3 = 1.047, thbc4 = 1.047
      real :: thrk1 = 1.047, thrk2 = 1.024, thrk3 = 1.024, thrk4 = 1.060
      real :: soxy             !mg O2/L       |saturation concetration of dissolved oxygen

      !! calculate flow duration
      tday = rttime / 24.0
      tday = amin1 (1., tday)

      !! calculate temperature in stream Stefan and Preudhomme. 1993.  Stream temperature estimation
      !! from air temperature.  Water Res. Bull. p. 27-45 SWAT manual equation 2.3.13
      wtmp = 5.0 + 0.75 * wst(iwst)%weat%tave
      if (wtmp <= 0.) wtmp = 0.1
      ht2%temp = wtmp

      !! benthic sources/losses in mg
      rs2_s =  Theta(ch_nut(jnut)%rs2,thrs2,wtmp) * ben_area    !ch_hyd(jhyd)%l *ch_hyd(jhyd)%w * rt_delt
      rs3_s =  Theta(ch_nut(jnut)%rs3,thrs3,wtmp) * ben_area    !ch_hyd(jhyd)%l *ch_hyd(jhyd)%w * rt_delt
      rk4_s =  Theta(ch_nut(jnut)%rk4,thrk4,wtmp) * ben_area    !ch_hyd(jhyd)%l *ch_hyd(jhyd)%w * rt_delt

      !! ht3 = concentration of incoming nutrients
      if (ht3%flo > 0.) then
        disoxin = ht3%dox - rk4_s / ht3%flo
        disoxin = amax1 (0., disoxin)
        dispin = ht3%solp + rs2_s / ht3%flo
        ammoin = ht3%nh3 + rs3_s / ht3%flo

        !! calculate effective concentration of available nitrogen QUAL2E equation III-15
        cinn = ch_stor(jrch)%nh3 + ch_stor(jrch)%no3

        !! calculate saturation concentration for dissolved oxygen
        !! QUAL2E section 3.6.1 equation III-29
        ww = -139.34410 + (1.575701e05 / (wtmp + 273.15))
        xx = 6.642308e07 / ((wtmp + 273.15)**2)
        yy = 1.243800e10 / ((wtmp + 273.15)**3)
        zz = 8.621949e11 / ((wtmp + 273.15)**4)
        soxy = Exp(ww - xx + yy - zz)
        if (soxy < 1.e-6) soxy = 0.
        !! end initialize concentrations

        !! O2 impact calculations
        !! calculate nitrification rate correction factor for low oxygen QUAL2E equation III-21
	    if (ht3%dox < 0.001) ht3%dox = 0.001
	    if (ht3%dox > 30.) ht3%dox = 30.
        cordo = 1.0 - Exp(-0.6 * ht3%dox)
        !! end O2 impact calculations

        !! algal growth
        !! calculate chlorophyll-a concentration at end of day QUAL2E equation III-1
        algcon = 1000. * ch_stor(jrch)%chla / ch_nut(jnut)%ai0
        algin = 1000. * ht3%chla / ch_nut(jnut)%ai0

        !! calculate light extinction coefficient (algal self shading) QUAL2E equation III-12
        if (ch_nut(jnut)%ai0 * algcon > 1.e-6) then
          lambda = ch_nut(jnut)%lambda0 + (ch_nut(jnut)%lambda1 * ch_nut(jnut)%ai0 * algcon)   &
              + ch_nut(jnut)%lambda2 * (ch_nut(jnut)%ai0 * algcon) ** (.66667)
        else
          lambda = ch_nut(jnut)%lambda0
        endif

	    if (lambda > ch_nut(jnut)%lambda0) lambda = ch_nut(jnut)%lambda0
        !! calculate algal growth limitation factors for nitrogen
        !! and phosphorus QUAL2E equations III-13 & III-14
        fnn = cinn / (cinn + ch_nut(jnut)%k_n)
        fpp = ch_stor(jrch)%solp / (ch_stor(jrch)%solp + ch_nut(jnut)%k_p)

        !! calculate daylight average, photosynthetically active, light intensity QUAL2E equation III-8
        !! Light Averaging Option # 2
        iwgn = wst(iwst)%wco%wgn
        if (wgn_pms(iwgn)%daylth > 0.) then
          algi = wst(iwst)%weat%solrad * ch_nut(jnut)%tfact /  wgn_pms(iwgn)%daylth
        else
          algi = 0.00001
        end if

        !! calculate growth attenuation factor for light, based on
        !! daylight average light intensity QUAL2E equation III-7b
        fl_1 = (1. / (lambda * rchdep)) * Log((ch_nut(jnut)%k_l + algi) /     &
                (ch_nut(jnut)%k_l + algi *  (Exp(-lambda * rchdep))))
        fll = 0.92 * (wgn_pms(iwgn)%daylth / 24.) * fl_1

        !! calculcate local algal growth rate
        if (algcon < 5000.) then
          select case (ch_nut(jnut)%igropt)
          case (1)
            !! multiplicative QUAL2E equation III-3a
            gra = ch_nut(jnut)%mumax * fll * fnn * fpp
          case (2)
            !! limiting nutrient QUAL2E equation III-3b
            gra = ch_nut(jnut)%mumax * fll * Min(fnn, fpp)
          case (3)
            !! harmonic mean QUAL2E equation III-3c
            if (fnn > 1.e-6 .and. fpp > 1.e-6) then
              gra = ch_nut(jnut)%mumax * fll * 2. / ((1. / fnn) + (1. / fpp))
            else
              gra = 0.
            endif
          end select
        end if

        !! calculate algal biomass concentration at end of day (phytoplanktonic algae) QUAL2E equation III-2
        factk = Theta(gra,thgra,wtmp) - Theta(ch_nut(jnut)%rhoq, thrho, wtmp)
        algcon = 1000. * ht3%cla / ch_nut(jnut)%ai0
        alg_m1 = wq_semianalyt (tday, rt_delt, 0., factk, algcon, algin)

        alg_m = wq_semianalyt (tday, rt_delt, 0., factk, algcon, algin)
        alg_m2 = alg_m - alg_m1
        !! calculate fraction of algal nitrogen uptake from ammonia pool QUAL2E equation III-18
        f1 = ch_nut(jnut)%p_n * ch_stor(jrch)%nh3 / (ch_nut(jnut)%p_n * ch_stor(jrch)%nh3 +       &
                          (1. - ch_nut(jnut)%p_n) * ch_stor(jrch)%no3 + 1.e-6)
        alg_no3_m = -alg_m * (1. - f1) * ch_nut(jnut)%ai1
        alg_nh4_m = -alg_m * f1 * ch_nut(jnut)%ai1
        alg_P_m = -alg_m * ch_nut(jnut)%ai2
        alg_set = 0.
        if (rchdep > 0.001) alg_set = Theta (ch_nut(jnut)%rs1, thrs1, wtmp) / rchdep

        algcon_out = wq_semianalyt (tday, rt_delt, alg_m, -alg_set, algcon, algin)

        if (algcon_out < 1.e-6) algcon_out = 0.
        if (algcon_out > 5000.) algcon_out = 5000.

        !! calculate chlorophyll-a concentration at end of day QUAL2E equation III-1
        ht2%chla = algcon_out * ch_nut(jnut)%ai0 / 1000.

        !! end algal growth

        !! oxygen calculations
        !! calculate carbonaceous biological oxygen demand at end of day QUAL2E section 3.5 equation III-26
        !! adjust rk1 to m-term and BOD & O2 mass availability

        cbodo = min (ch_stor(jrch)%cbod, ch_stor(jrch)%dox)
        cbodoin = min (ht3%cbod, ht3%dox)
        rk1_k = -Theta (ch_nut(jnut)%rk1, thrk1,wtmp)
        rk1_m = wq_k2m (tday, rt_delt, rk1_k, ch_stor(jrch)%cbod, ht3%cbod)
        !! calculate corresponding m-term
        rk3_k=0.
        if (rchdep > 0.001)  rk3_k = -Theta (ch_nut(jnut)%rk3, thrk3, wtmp) / rchdep
        factm = rk1_m
        factk = rk3_k
        ht2%cbod = wq_semianalyt (tday, rt_delt, factm, factk, ch_stor(jrch)%cbod, ht3%cbod)

        !! nitrogen calculations
        !! calculate organic N concentration at end of day
        !! QUAL2E section 3.3.1 equation III-16
        bc1_k = Theta(ch_nut(jnut)%bc1,thbc1,wtmp)
        bc3_k = Theta(ch_nut(jnut)%bc3,thbc3,wtmp)
        bc1_k = bc1_k * 2.
        bc3_k = bc3_k * 2.
        rs4_k = 0.
        if (rchdep > 0.001)  rs4_k = Theta (ch_nut(jnut)%rs4, thrs4, wtmp) / rchdep

        bc3_m = wq_k2m (tday, rt_delt, -bc3_k, ch_stor(jrch)%orgn, ht3%orgn)
        factk = -rs4_k
        factm = bc3_m
        ht2%orgn = wq_semianalyt (tday, rt_delt, factm, factk, ch_stor(jrch)%orgn, ht3%orgn)
        if (ht2%orgn <0.) ht2%orgn = 0.

        !! calculate dissolved oxygen concentration if reach at end of day QUAL2E section 3.6 equation III-28

        rk2_m = Theta (ch_nut(jnut)%rk2, thrk2, wtmp) * soxy
        rk2_k = Theta (ch_nut(jnut)%rk2, thrk2, wtmp)

        alg_m_o2 = ch_nut(jnut)%ai4 * alg_m2 + ch_nut(jnut)%ai3 * alg_m1

        factk = - rk2_k
        bc2_k = -Theta (ch_nut(jnut)%bc2, thbc2, wtmp)
        bc1_m = wq_k2m (tday, rt_delt, factk, ch_stor(jrch)%nh3, ht3%nh3)
        bc2_m = wq_k2m (tday, rt_delt, bc2_k, ch_stor(jrch)%no2, ht3%no2)
        factm = rk1_m + rk2_m - rs4_k + bc1_m * ch_nut(jnut)%ai5 + bc2_m * ch_nut(jnut)%ai6
        ht2%dox = wq_semianalyt (tday, rt_delt, factm, factk, ch_stor(jrch)%dox, ht3%dox)
        if (ht2%dox <0.) ht2%dox = 0.

        !! end oxygen calculations

        !! calculate ammonia nitrogen concentration at end of day QUAL2E section 3.3.2 equation III-17
        factk = -bc1_k
        factm = bc1_m - bc3_m
        ht2%nh3 = wq_semianalyt (tday, rt_delt, factm, 0., ch_stor(jrch)%nh3, ht3%nh3)
        if (ht2%nh3 < 1.e-6) ht2%nh3 = 0.

        !! calculate concentration of nitrite at end of day QUAL2E section 3.3.3 equation III-19
        factm = -bc1_m + bc2_m
        ht2%no2 = wq_semianalyt (tday, rt_delt, factm, 0., ch_stor(jrch)%no2, ht3%no2)
        if (ht2%no2 < 1.e-6) ht2%no2 = 0.

        !! calculate nitrate concentration at end of day QUAL2E section 3.3.4 equation III-20
        factk = 0.
        factm = -bc2_m + ht3%no3

        ht2%no3 = wq_semianalyt (tday, rt_delt, factm, 0., ch_stor(jrch)%no3, ht3%no3)
        if (ht2%no3 < 1.e-6) ht2%no3 = 0.
        !! end nitrogen calculations

        !! phosphorus calculations
        !! calculate organic phosphorus concentration at end of day QUAL2E section 3.3.6 equation III-24
        bc4_k = Theta (ch_nut(jnut)%bc4, thbc4,wtmp)
        bc4_m = wq_k2m (tday, rt_delt, -bc4_k, ch_stor(jrch)%sedp, ht3%sedp)
        rs5_k = 0.
        if (rchdep > 0.001) rs5_k = Theta (ch_nut(jnut)%rs5, thrs5, wtmp) / rchdep

        factk = -rs5_k
        factm = bc4_m

        ht2%sedp = wq_semianalyt (tday, rt_delt, factm, factk, ch_stor(jrch)%sedp, ht3%sedp)
        if (ht2%sedp < 1.e-6) ht2%sedp = 0.

        !! calculate dissolved phosphorus concentration at end of day QUAL2E section 3.4.2 equation III-25
        factk = 0.
        factm = -bc4_m + ch_nut(jnut)%ai2 * alg_m
        ht2%solp = wq_semianalyt (tday, rt_delt, factm, 0., ch_stor(jrch)%solp, ht3%solp)
        if (ht2%solp < 1.e-6) ht2%solp = 0.
        !! end phosphorus calculations

      else
        !! all water quality variables set to zero when no flow
        ht2 = hz
        ch_stor(jrch) = hz
      endif

      return
      end subroutine ch_watqual4