Module DecayFunctions
! comments
!This module is a collection of subroutines with general formulas for the
!calculation of 2-body decays.

! load modules
Use Control
! load modules

! interfaces
 Interface VectorBosonToTwoFermions
  Module Procedure VectorBosonToTwoFermionsC, VectorBosonToTwoFermionsR
 End Interface

Contains

  Subroutine FermionToFermionPi(mF,mF1,mS,f_pi, G_F, kL,kR,width)
  !-----------------------------------------------------------------------
  ! FermionToFermionPi(mF,mF1,kL,kR,width) calculates the two body decay
  ! width of fermion decaying to another fermion and a pion. mF is the mass
  ! of the decaying fermion, mF1 the mass of the fermion in the
  ! final state and mS the mass of the pion.
  ! kL and kR are the left and right couplings, respectively. All
  ! couplings are complex.
  ! written by Werner Porod, 12.06.2013
  !-----------------------------------------------------------------------
  implicit none
  Real(dp), Intent(in) :: mF, mF1, mS, f_pi, G_F
  real(dp), intent(out) :: width
  complex(dp), intent(in) :: kL,kR

  Real(dp) :: mFsq,mF1sq,mSsq,kappa

  if ( abs(mF).le.( abs(mF1) + mS ) ) then
   width = 0._dp

  elseif ((Abs(kL).eq.0._dp).and.(Abs(kR).eq.0._dp)) then
   width = 0._dp

  else
   mFsq = mF * mF
   mF1sq = mF1 * mF1
   mSsq = mS * mS
   kappa = Sqrt( (mFsq-mF1sq-mSsq)**2 - 4._dp * mF1sq*mSsq )
   If (kL.eq.0._dp) Then
    width = oo32Pi * kappa * Abs(kR)**2 * (mFsq + mF1sq - mSsq) / Abs(mF)**3
   Else If (kR.eq.0._dp) Then
    width = oo32Pi * kappa * Abs(kL)**2 * (mFsq + mF1sq - mSsq) / Abs(mF)**3
   Else
    width = oo4Pi * kappa * (f_pi * G_F)**2                      &
      & * ( Abs(kL+Conjg(kR))**2 * ( (mFsq - mF1sq)**2 - mSsq * (mF-mF1)**2 ) &
      &   + Abs(kL-Conjg(kR))**2 * ( (mFsq - mF1sq)**2 - mSsq * (mF+mF1)**2 ) &
      &   )    / Abs(mF)**3
   End If

  endif

  End Subroutine FermionToFermionPi

  Subroutine FermionToFermionScalar(mF,mF1,mS,kL,kR,width)
  !-----------------------------------------------------------------------
  ! FermionToFermionScalar(mF,mF1,mS,kL,kR,width) calculates the two body decay
  ! width of fermion decaying to another fermion and a scalar. mF is the mass
  ! of the decaying fermion, mF1 (mS) the mass of the fermion (scalar) in the
  ! final state. kL and kR are the left and right couplings respectively. All
  ! couplings are complex.
  ! written by Werner Porod, 3.11.1999
  ! 23.10.2000: porting to f90
  !-----------------------------------------------------------------------
  implicit none
  real(dp), intent(in) :: mF,mF1,mS
  real(dp), intent(out) :: width
  complex(dp), intent(in) :: kL,kR

  real(dp) :: mFsq,mF1sq,mSsq,kappa

  if ( abs(mF).le.( abs(mF1) + mS ) ) then
   width = 0._dp

  elseif ((Abs(kL).eq.0._dp).and.(Abs(kR).eq.0._dp)) then
   width = 0._dp

  elseif ((mF1.eq.0._dp).and.(mS.eq.0._dp)) then
   If (kL.eq.0._dp) Then
    width = Abs(kR)**2 * mF * oo32Pi
   Else If (kR.eq.0._dp) Then
    width = Abs(kL)**2 * mF * oo32Pi
   Else
    width = (Abs(kL)**2 + Abs(kR)**2) * mF * oo32Pi
   End If

  elseif (mF1.eq.0._dp) then
   mFsq = mF * mF
   mSsq = mS * mS
   If (kL.eq.0._dp) Then
    width =  oo32pi * Abs(kR)**2 * (mFsq - mSsq)**2 /Abs(mF)**3
   Else If (kR.eq.0._dp) Then
    width =  oo32pi * Abs(kL)**2 * (mFsq - mSsq)**2 /Abs(mF)**3
   Else
    width =  oo32pi * (Abs(kL)**2 + Abs(kR)**2) * (mFsq - mSsq)**2 /Abs(mF)**3
   End If

  elseif (mS.eq.0._dp) then
   mFsq = mF * mF
   mF1sq = mF1 * mF1
   If (kL.eq.0._dp) Then
    width = oo32Pi * (mFsq - mF1sq) * Abs(kR)**2 * (mFsq + mF1sq) / Abs(mF)**3
   Else If (kR.eq.0._dp) Then
    width = oo32Pi * (mFsq - mF1sq) * Abs(kL)**2 * (mFsq + mF1sq) / Abs(mF)**3
   Else
    width = oo32Pi * (mFsq - mF1sq)                         &
         & * ( (Abs(kL)**2 + Abs(kR)**2) * (mFsq + mF1sq)  &
         &   + 4._dp * Real( Conjg(kL) * kR,dp ) * mF * mF1 ) / Abs(mF)**3
   End If

  else
   mFsq = mF * mF
   mF1sq = mF1 * mF1
   mSsq = mS * mS
   kappa = Sqrt( (mFsq-mF1sq-mSsq)**2 - 4._dp * mF1sq*mSsq )
   If (kL.eq.0._dp) Then
    width = oo32Pi * kappa * Abs(kR)**2 * (mFsq + mF1sq - mSsq) / Abs(mF)**3
   Else If (kR.eq.0._dp) Then
    width = oo32Pi * kappa * Abs(kL)**2 * (mFsq + mF1sq - mSsq) / Abs(mF)**3
   Else
    width = oo32Pi * kappa                                       &
         & * ( (Abs(kL)**2 + Abs(kR)**2) * (mFsq + mF1sq - mSsq) &
         &   + 4._dp * Real( Conjg(kL) * kR,dp ) * mF * mF1 )    / Abs(mF)**3
   End If

  endif

  End Subroutine FermionToFermionScalar

  Subroutine FermionToFermionVectorBoson(mF,mF1,mV,kL,kR,width)
  !-----------------------------------------------------------------------
  ! FermionToFermionVectorBoson calculates the two body decay
  ! width of fermion decaying to another fermion and a vectorboson. mF is the
  ! mass of the decaying fermion, mF1 (mV) the mass of the fermion
  ! (vector boson) in the final state. kL and kR are the left and right
  ! couplings respectively. All couplings are complex.
  ! written by Werner Porod, 3.11.1999
  ! 23.10.2000: porting to f90
  !-----------------------------------------------------------------------
  implicit none
   real(dp), intent(in) :: mF,mF1,mV
   real(dp), intent(out) :: width
   complex(dp), intent(in) :: kL,kR

   real(dp) :: mFsq,mF1sq,mVsq,kappa

   if ( abs(mF).le.( abs(mF1) + mV ) ) then
    width = 0._dp

   elseif (mV.eq.0._dp) then
    write(ErrCan,*) 'Warning from subroutine FermionToFermionVectorBoson.'
    write(ErrCan,*) ' Vectorboson mass = 0 has occured, setting width to 0!!!'
    width = 0._dp

   elseif ((Abs(kL).eq.0._dp).and.(Abs(kR).eq.0._dp)) then
    width = 0._dp

   elseif (mF1.eq.0._dp) then
    mFsq = mF * mF
    mVsq = mV * mV
    width =  oo16pi * (Abs(kL)**2 + Abs(kR)**2) * (mFsq - mVsq)         &
          & * ( 0.5_dp * ( mFsq**2 /  mVsq + mFsq ) - mVsq ) / Abs(mF)**3

   else
    mFsq = mF * mF
    mF1sq = mF1 * mF1
    mVsq = mV * mV
    kappa = Sqrt( (mFsq-mF1sq-mVsq)**2 - 4._dp * mF1sq*mVsq )
    width = oo16Pi * kappa                                                   &
        & * ( (Abs(kL)**2 + Abs(kR)**2)                                      &
        &     * ( 0.5_dp * ( (mFsq-mF1sq)**2 / mVsq + mFsq + mF1sq) - mVsq )  &
        &   - 6._dp * Real( Conjg(kL) * kR,dp ) * mF * mF1 )  / Abs(mF)**3

   endif

  End Subroutine FermionToFermionVectorBoson

  Subroutine ScalarToScalarVectorBoson(mS,mS1,mV,coup,width)
  !-----------------------------------------------------------------------
  ! ScalarToScalarVectorBoson calculates the two body decay
  ! width of a scalar decaying to another scalar and a vectorboson. mS is the
  ! mass of the decaying scalar, mS1 (mV) the mass of the scalar (vectorboson)
  ! in the final state. coup is a complex coupling.
  ! written by Werner Porod, 3.11.1999
  ! 23.10.2000: porting to f90
  !-----------------------------------------------------------------------
  implicit none
   real(dp), intent(in) :: mS,mS1,mV
   real(dp), intent(out) :: width
   complex(dp), intent(in) :: coup

   real(dp) :: mSsq,mS1sq,mVsq,kappa

   if ( abs(mS).le.( abs(mS1) + mV ) ) then
    width = 0._dp

   elseif (mV.eq.0._dp) then
    write(ErrCan,*) 'Warning from subroutine ScalarToScalarVectorBoson.'
    write(ErrCan,*) 'Vectorboson mass = 0 has occured, setting width to 0!!!'
    width = 0._dp

  elseif (Abs(coup).eq.0._dp) then
   width = 0._dp

   elseif (mS1.eq.0._dp) then
    mSsq = mS * mS
    mVsq = mV * mV
    width = oo16pi * Abs(coup)**2  * (mSsq - mVsq)**3 / ( mS**3 * mVsq )

   else
    mSsq = mS * mS
    mS1sq = mS1 * mS1
    mVsq = mV * mV
    kappa = Sqrt( (mSsq-mS1sq-mVsq)**2 - 4._dp * mS1sq*mVsq )
    width = oo16Pi * Abs(coup)**2 * kappa**3 / ( mS**3 * mVsq )

   endif

  End Subroutine ScalarToScalarVectorBoson

 Subroutine ScalarToTwoFermions(mS,mF1,mF2,kL,kR,width)
 !-----------------------------------------------------------------------
 ! ScalarToTwoFermions calculates the two body decay width of a scalar
 ! decaying to 2 fermions. mS is the mass of the decaying scalar and
 ! mF1 (mF2) are the masses of the fermions.
 ! kL and kR are the left and right couplings respectively. All
 ! couplings can be complex.
 ! written by Werner Porod, 3.11.1999
 ! 9.10.2000: porting to f90
 !-----------------------------------------------------------------------
 implicit none
  real(dp), intent(in) :: mS,mF1,mF2
  real(dp), intent(out) ::width
  complex(dp), intent(in) :: kL,kR

  real(dp) :: mSsq,mF1sq,mF2sq,kappa

  if ( abs(mS).le.( abs(mF1) + abs(mF2) ) ) then
   width = 0._dp

  elseif ((Abs(kL).eq.0._dp).and.(Abs(kR).eq.0._dp)) then
   width = 0._dp

  elseif ((mF1.eq.0._dp).and.(mF2.eq.0._dp)) then
   width = (Abs(kL)**2 + Abs(kR)**2) * mS * oo16Pi

  elseif ((mF1.eq.0._dp).or.(mF2.eq.0._dp)) then
   mSsq = mS * mS
   if (mF1.eq.0._dp) mF1sq = mF2 * mF2
   if (mF2.eq.0._dp) mF1sq = mF1 * mF1
   width = (Abs(kL)**2 + Abs(kR)**2) * (mSsq - mF1sq)**2 * oo16pi / mS**3

  elseif (mF1.eq.mF2) then
   mSsq = mS * mS
   mF1sq = mF1 * mF1
   kappa = Sqrt( mSsq**2 - 4._dp * mSsq * mF1sq )
   width = oo16Pi * kappa                                        &
     &   *  ( (Abs(kL)**2 + Abs(kR)**2) * (mSsq - 2._dp * mF1sq)  &
     &      - 4._dp * Real( Conjg(kL) * kR,dp ) * mF1sq )  / mS**3

  else
   mSsq = mS * mS
   mF1sq = mF1 * mF1
   mF2sq = mF2 * mF2
   kappa = Sqrt( (mSsq-mF1sq-mF2sq)**2 - 4._dp * mF1sq*mF2sq )
   width = oo16Pi * kappa                                            &
     &   * ( (Abs(kL)**2 + Abs(kR)**2) * (mSsq - mF1sq - mF2sq)      &
     &     - 4._dp * Real( Conjg(kL) * kR,dp ) * mF2 * mF1 ) / mS**3

  endif

 End Subroutine ScalarToTwoFermions

 Subroutine ScalarToFermionGravitino(mS,mF1,m32,F,kL,kR,width)
 !-----------------------------------------------------------------------
 ! using the formula of
 ! ScalarToTwoFermions calculates the two body decay width of a scalar
 ! decaying to 2 fermions. mS is the mass of the decaying scalar and
 ! mF1 (m32) are the masses of the fermion (gravitino).
 ! F is the SUSY breaking F-term.
 ! kL and kR are the left and right couplings respectively. All
 ! couplings can be complex.
 ! written by Werner Porod, 3.11.1999
 !-----------------------------------------------------------------------
 Implicit None
  Real(dp), Intent(in) :: mS,mF1,m32,F
  Real(dp), Intent(out) ::width
  Complex(dp), Intent(in) :: kL,kR

  Real(dp) :: mSsq,mF1sq,m32sq,kappa

  width = 0._dp
  If ( Abs(mS).Le.( Abs(mF1) + Abs(m32) ) ) Then
   Return

  Elseif ((Abs(kL).Eq.0._dp).And.(Abs(kR).Eq.0._dp)) Then
   Return

  Elseif (mF1.Eq.0._dp) Then
   mSsq = mS * mS
   m32sq = m32 * m32
   width = (Abs(kL)**2 + Abs(kR)**2) * (mSsq - m32sq)**4 / mSsq**2

  Elseif (mF1.Eq.m32) Then
   mSsq = mS * mS
   mF1sq = mF1 * mF1
   kappa = Sqrt( mSsq**2 - 4._dp * mSsq * mF1sq )
   width = kappa**3                                               &
     &   *  ( (Abs(kL)**2 + Abs(kR)**2) * (mSsq - 2._dp * mF1sq)  &
     &      - 4._dp * Real( Conjg(kL) * kR,dp ) * mF1sq )  / mSsq**2

  Else
   mSsq = mS * mS
   mF1sq = mF1 * mF1
   m32sq = m32 * m32
   kappa = Sqrt( (mSsq-mF1sq-m32sq)**2 - 4._dp * mF1sq*m32sq )
   width = kappa**3                                                  &
     &   * ( (Abs(kL)**2 + Abs(kR)**2) * (mSsq - mF1sq - m32sq)      &
     &     - 4._dp * Real( Conjg(kL) * kR,dp ) * m32 * mF1 ) / mSsq**2

  Endif

  width = oo16Pi * mS * width / F**2

 End Subroutine ScalarToFermionGravitino

 Subroutine ScalarToTwoScalars(mS,mS1,mS2,coup,width)
 !-----------------------------------------------------------------------
 ! ScalarToTwoFermions calculates the two body decay width of a scalar
 ! decaying to 2 scalars. mS is the mass of the decaying scalar and
 ! mS1 (mS2) are the masses of the scalars in the final state.
 ! coup is a complex coupling.
 ! written by Werner Porod, 3.11.1999
 ! 23.10.2000: porting to f90
 !-----------------------------------------------------------------------
 implicit none
  real(dp), intent(in) :: mS,mS1,mS2
  real(dp), intent(out) ::width
  complex(dp), intent(in) :: coup

  real(dp) :: mSsq,mS1sq,mS2sq,kappa

  if ( abs(mS).le.( abs(mS1) + abs(mS2) ) ) then
   width = 0._dp

  elseif (Abs(coup).eq.0._dp) then
   width = 0._dp

  elseif ((mS1.eq.0._dp).and.(mS2.eq.0._dp)) then
   width = Abs(coup)**2 * oo16Pi / mS

  elseif ((mS1.eq.0._dp).or.(mS2.eq.0._dp)) then
   mSsq = mS * mS
   if (mS1.eq.0._dp) mS1sq = mS2 * mS2
   if (mS2.eq.0._dp) mS1sq = mS1 * mS1
   width = Abs(coup)**2 * (mSsq - mS1sq) * oo16pi / mS**3

  else
   mSsq = mS * mS
   mS1sq = mS1 * mS1
   mS2sq = mS2 * mS2
   kappa = Sqrt( (mSsq-mS1sq-mS2sq)**2 - 4._dp * mS1sq*mS2sq )
   width = oo16Pi * Abs(coup)**2 * kappa / mS**3

  endif

  End Subroutine ScalarToTwoScalars
Subroutine ScalarToTwoVectorbosons(mS,mV1,mV2,coup,width)
 !-----------------------------------------------------------------------
 ! ScalarToTwoFermions calculates the two body decay width of a scalar
 ! decaying to 2 Vectorbosons. mS is the mass of the decaying scalar and
 ! mV are the mass of the vectorboson, coup is a real coupling.
 ! written by Werner Porod, 5.11.1999
 ! 23.10.2000: porting to f90
 !-----------------------------------------------------------------------
  Implicit None
   Real(dp), Intent(in) :: mS,mV1,mV2
   Real(dp), Intent(out) :: width
   Complex(dp), Intent(in) :: coup

   Real(dp) :: mSsq,mV1sq, mV2sq,kappa, x

   If ( Abs(mS).Le.( Abs(mV1)+Abs(mV2) ) ) Then
    width = 0._dp

   Elseif (mV1.Eq.0._dp) Then
    Write(ErrCan,*) 'Warning, in subroutine ScalarToTwoVectorbosons'
    Write(ErrCan,*) 'm_V1 = 0, setting width to 0'
    width = 0._dp

   Elseif (mV2.Eq.0._dp) Then
    Write(ErrCan,*) 'Warning, in subroutine ScalarToTwoVectorbosons'
    Write(ErrCan,*) 'm_V2 = 0, setting width to 0'
    width = 0._dp

   Elseif (Abs(coup).Eq.0._dp) Then
    width = 0._dp

   Elseif (mV1.Eq.mV2) Then
    mSsq = mS * mS
    mV1sq = mV1**2
    x = mSsq / mV1sq
    kappa = Sqrt( 1._dp - 4._dp / x )
    width = oo64Pi * Abs(coup)**2 * kappa * (x*x - 4._dp*x + 12._dp) / mS

   Else
    mSsq = mS * mS
    mV1sq = mV1**2
    mV2sq = mV2**2
    kappa = Sqrt( (mSsq-mV1sq-mV2sq)**2 - 4._dp * mV1sq*mV2sq )/(mS**3)
    width = Abs(coup)**2/(mV1sq*mV2sq)*(mV1sq**2 + 10._dp*mV1sq*mV2sq - &
             & 2._dp*(mV1sq+mV2sq)*mSsq + mV2sq**2 +mSsq**2)
    width = oo64Pi*width*kappa

   Endif

  End Subroutine ScalarToTwoVectorbosons

 Subroutine ScalarToVectorbosonsVR(mS,mV,coup,width)
 !-----------------------------------------------------------------------
 ! ScalarToTwoFermions calculates the two body decay width of a scalar
 ! decaying to 2 Vectorbosons, where on of them is real and the other is
 ! virtuell. mS is the mass of the decaying scalar and
 ! mV are the mass of the vectorboson. coup is an effective real coupling,
 ! which is the scalar-vectorboson coupling times g times a correction
 ! factor for the Z-boson. This correction factor squared reads:
 ! (m_Z/m_W)**2 * (3.5-20.*sinw2/3.+80.*sinw4/9.) * cosW2
 ! written by Werner Porod, 5.11.1999
 ! 23.10.2000: porting to f90
 !-----------------------------------------------------------------------
 implicit none
  real(dp), intent(in) :: mS,mV,coup
  real(dp), intent(out) :: width

  real(dp) :: RHiggs,x,x2,sum1,sum2,sum3

  width = 0._dp

  if ((mS.lt.mV).or.(Abs(coup).eq.0._dp) ) return
  If (mS.Gt.(2._dp*mV-0.1_dp)) return ! in this case a refined calculation
                                      ! is necessary

  x = (mV / mS )**2
  x2 = x*x
  sum1 = 3._dp * (1._dp-8._dp*x+20._dp*x2) / sqrt(4._dp*x-1._dp)   &
     & * acos( (3._dp*x-1._dp) / (2._dp*sqrt(x**3)) )
  sum2 = -0.5_dp * (1._dp-x) * (2._dp-13._dp*x+47._dp*x2) / x
  sum3 = - 1.5_dp * (1._dp-6._dp*x+4._dp*x2) * log(x)

  Rhiggs = sum1 + sum2 + sum3

  width = 3._dp * oo128pi3 * coup**2 * mS * Rhiggs

 End Subroutine ScalarToVectorbosonsVR

  Subroutine VectorBosonToTwoFermionsC(mV,mF1,mF2,Nc,cL,cR,width)
  !-----------------------------------------------------------------------
  ! VectorBosonToTwoScalars calculates the two body decay
  ! width of a vector poson decaying to two fermionss. mV is the
  ! mass of the decaying vector boson, mF2 and mF2 are the masses of the fermions
  ! in the final state. cL and cR are complex couplings and Nc a color factor
  ! written by Werner Porod, 03.09.2010
  !-----------------------------------------------------------------------
  Implicit None
   Integer :: Nc ! color factor
   Real(dp), Intent(in) :: mF2,mF1,mV
   Real(dp), Intent(out) :: width
   Complex(dp), Intent(in) :: cL, cR

   Real(dp) :: mF1sq, mF2sq, mVsq, kappa, r

   If (     ( mV.Le.( Abs(mF1) + Abs(mF2) ) ) &
      & .Or.((Abs(cL)+Abs(cR)).Eq.0._dp) ) Then
    width = 0._dp
    Return

   Else If ((mF1.Eq.0._dp).And.(mF2.Eq.0._dp)) Then
    width = 2._dp * (Abs(cL)**2 + Abs(cR)**2)

   Else If (mF1.Eq.0._dp) Then
    r = (mF2 / mV)**2
    width = (Abs(cL)**2 + Abs(cR)**2) * (1._dp-r) * (2._dp - r**2 - r)

   Else If (mF2.Eq.0._dp) Then
    r = (mF1 / mV)**2
    width = (Abs(cL)**2 + Abs(cR)**2) * (1._dp-r) * (2._dp - r**2 - r)

   Else If (mF1.Eq.mF2) Then
    r = (mF1 / mV)**2
    width = ( (Abs(cL)**2 + Abs(cR)**2) * (1._dp-r)   &
        &   + 6._dp * Real(cL*Conjg(cR),dp) * r )            &
        &   * 2._dp * Sqrt(1._dp - 4._dp * r)

   Else
    mF1sq = mF1 * mF1
    mF2sq = mF2 * mF2
    mVsq = mV * mV
    kappa = (mVsq-mF1sq-mF2sq)**2 - 4._dp * mF1sq*mF2sq
    width = (Abs(cL)**2 + Abs(cR)**2)                                    &
        &   * (2._dp * mVsq - mF1sq - mF2sq - (mF1sq-mF2sq)**2 / mVsq )  &
        & + 12._dp * Real(cL*Conjg(cR),dp) * mF1 * mF2
    width = width * Sqrt(kappa) / mVsq**2

   End If

   width = Nc * oo48Pi * width * mV

  End Subroutine VectorBosonToTwoFermionsC

  Subroutine VectorBosonToTwoFermionsR(mV,mF1,mF2,Nc,cL,cR,width)
  !-----------------------------------------------------------------------
  ! VectorBosonToTwoScalars calculates the two body decay
  ! width of a vector poson decaying to two fermionss. mV is the
  ! mass of the decaying vector boson, mF2 and mF2 are the masses of the fermions
  ! in the final state. cL and cR are complex couplings and Nc a color factor
  ! written by Werner Porod, 03.09.2010
  !-----------------------------------------------------------------------
  Implicit None
   Integer :: Nc ! color factor
   Real(dp), Intent(in) :: mF2,mF1,mV, cL, cR
   Real(dp), Intent(out) :: width

   Real(dp) :: mF1sq, mF2sq, mVsq, kappa, r

   If (( mV.Le.( mF1 + mF2 ) ).Or.((Abs(cL)+Abs(cR)).Eq.0._dp) ) Then
    width = 0._dp
    Return

   Else If ((mF1.Eq.0._dp).And.(mF2.Eq.0._dp)) Then
    width = 2._dp * (cL**2 + cR**2)

   Elseif (mF1.Eq.0._dp) Then
    r = (mF2 / mV)**2
    width = (cL**2 + cR**2) * (1._dp-r) * (2._dp - r**2 - r)

   Elseif (mF2.Eq.0._dp) Then
    r = (mF1 / mV)**2
    width = (cL**2 + cR**2) * (1._dp-r) * (2._dp - r**2 - r)

   Elseif (mF1.Eq.mF2) Then
    r = (mF1 / mV)**2
    width = ( (cL**2 + cR**2) * (1._dp-r) + 6._dp * cL * cR * r )   &
        &   * 2._dp * Sqrt(1._dp - 4._dp * r)

   Else
    mF1sq = mF1 * mF1
    mF2sq = mF2 * mF2
    mVsq = mV * mV
    kappa = (mVsq-mF1sq-mF2sq)**2 - 4._dp * mF1sq*mF2sq
    width = (cL**2 + cR**2)                                              &
        &   * (2._dp * mVsq - mF1sq - mF2sq - (mF1sq-mF2sq)**2 / mVsq )  &
        & + 12._dp * cL * cR  * mF1 * mF2
    width = width * Sqrt(kappa) / mVsq**2

   Endif

   width = Nc * oo48Pi * width * mV

  End Subroutine VectorBosonToTwoFermionsR

  Subroutine VectorBosonToTwoScalars(mV,mS1,mS2,Nc,coup,width)
  !-----------------------------------------------------------------------
  ! ScalarToScalarVectorBoson calculates the two body decay
  ! width of a vector poson decaying to two scalars. mV is the
  ! mass of the decaying vector boson, mS and mS1 are the masses of the scalars
  ! in the final state. coup is a complex coupling and Nc a color factor
  ! written by Werner Porod, 03.09.2010
  !-----------------------------------------------------------------------
  Implicit None
   Integer :: Nc ! color factor
   Real(dp), Intent(in) :: mS2,mS1,mV
   Real(dp), Intent(out) :: width
   Complex(dp), Intent(in) :: coup

   Real(dp) :: r, r2

   If (( mV.Le.( mS1 + mS2 ) ).Or.(Abs(coup).Eq.0._dp) ) Then
    width = 0._dp
    Return

   Else If (mS1.Eq.0._dp) Then
    r = (mS2/mV)**2
    width = (1._dp - r )**3

   Else If (mS2.Eq.0._dp) Then
    r = (mS1/mV)**2
    width = (1._dp - r )**3

   Else If (mS1.Eq.mS2) Then
    r = (mS1/mV)**2
    width = (1._dp - 4._dp * r )**1.5_dp

   Else
    r = (mS1/mV)**2
    r2 = (mS2/mV)**2
    width = ( 1._dp - 2._dp*(r+r2) + (r-r2)**2 )**1.5_dp

   End If

   width = Nc * oo48Pi * Abs(coup)**2  * width * mV

  End Subroutine VectorBosonToTwoScalars

 Subroutine VectorBosonToTwoVectorBosons(mV,mV1,mV2,c,width)
  !-----------------------------------------------------------------------
  ! Two Body decay of a vector boson into two other vector boson
  ! Florian Staub. 25.08.2011
  !-----------------------------------------------------------------------
  Implicit None
   Real(dp), Intent(in) :: mV2,mV1,mV
   Real(dp), Intent(out) :: width
   Complex(dp) :: c

   Real(dp) :: mV1sq, mV2sq, mVsq, kappa

   If (( mV.Le.( mV1 + mV2 ) ).Or.(c.Eq.0._dp) ) Then
    width = 0._dp
    Return

   Else If ((mV1.Eq.0._dp).Or.(mV2.Eq.0._dp)) Then
    width = 0._dp

   Else
    mV1sq = mV1 * mV1
    mV2sq = mV2 * mV2
    mVsq = mV * mV
    kappa = (mVsq-mV1sq-mV2sq)**2 - 4._dp * mV1sq*mV2sq
    width = ((mV1-mV2-mV)*(mV1+mV2-mV)*(mV1-mV2+mV)*(mV1+mV2+mV)     &
          &   * (mV1sq*mV1sq + 10._dp*mV1sq*mV2sq + mV2sq*mV2sq      &
          &     + 10._dp*mV1sq*mVsq + 10._dp*mV2sq*mVsq + mVsq*mVsq) &
          & ) / (4._dp*mV1sq*mV2sq*mVsq)
    width = width * Sqrt(kappa) / mV**3

   Endif

   width = Abs(c)**2 *oo48Pi * width

 End Subroutine VectorBosonToTwoVectorBosons

 Subroutine VectorBosonToScalarAndVectorBoson(mV,mS,mV2,c,width)
  !-----------------------------------------------------------------------
  ! Two Body decay of a vector boson into a scalar and a vector boson
  ! Florian Staub. 25.08.2011
  !-----------------------------------------------------------------------
  Implicit None
   Real(dp), Intent(in) :: mV2,mS,mV
   Real(dp), Intent(out) :: width
   Complex(dp) :: c

   Real(dp) :: mSsq, mV2sq, mVsq, kappa

   If (( mV.Le.( mS + mV2 ) ).Or.(c.Eq.0._dp) ) Then
    width = 0._dp
    Return

   Else If (mV2.Eq.0._dp) Then
    width = 0._dp

   Else
    mSsq = mS * mS
    mV2sq = mV2 * mV2
    mVsq = mV * mV
    kappa = (mVsq-mSsq-mV2sq)**2 - 4._dp * mSsq*mV2sq
    width = 2._dp + (mSsq-mVsq-mV2sq)**2/(4._dp*mVsq*mV2sq)
    width = width * Sqrt(kappa) / mV**3

   Endif

   width = Abs(c)**2 * oo48Pi * width

  End Subroutine VectorBosonToScalarAndVectorBoson

End Module DecayFunctions


subroutine momentum_interpolation(u, v, p, aw, ae, as, an, ap, su, sv, f_uf, f_vf, s_uf, s_vf, res_uf, res_vf, auf_bar, avf_bar, uf, vf, dx, dy, imax, jmax, xi, xf)
use parameters
use kind_parameters
implicit none
include "mpif.h"

!! Input variables

integer, intent(in):: imax, jmax, xi, xf
real(kind=dp), intent(in), dimension(imax,xi-1:xf+1):: u, v, p, aw, ae, as, an, ap, su, sv
real(kind=dp), intent(inout), dimension(imax-1, xi-1:xf+1):: uf, auf_bar, f_uf, res_uf, s_uf
real(kind=dp), intent(inout), dimension(imax, xi-1:xf+1):: vf, avf_bar, f_vf, res_vf, s_vf
real(kind=dp):: dx(imax), dy(jmax)
!real(kind=dp):: alphau, alphav

!! Other local variables
real(kind=dp), dimension(imax, xi-1:xf+1):: Hu, Hv
real(kind=dp), dimension(imax-1,xi-1:xf+1):: Huf_bar
real(kind=dp), dimension(imax,xi-1:xf+1):: Hvf_bar
real(kind=dp):: fe_area, fn_area
integer:: iu, ju, iv, jv
!real(kind=dp):: temp_fu, temp_fv

do ju = xi,xf

 do iu = 2, imax-1

  Hu(iu,ju) = aw(iu,ju)*u(iu-1,ju) + ae(iu,ju)*u(iu+1,ju) + as(iu,ju)*u(iu,ju-1) + an(iu,ju)*u(iu,ju+1) + su(iu,ju)

 end do

end do

do jv = xi,xf

 do iv = 2, imax-1

  Hv(iv,jv) = aw(iv,jv)*v(iv-1,jv) + ae(iv,jv)*v(iv+1,jv) + as(iv,jv)*v(iv,jv-1) + an(iv,jv)*v(iv,jv+1) + sv(iv,jv)

 end do

end do

call exchange_data(Hu, imax, xi, xf)
call exchange_data(Hv, imax, xi, xf)

! Internal u control volumes

do ju=xi,xf
      do iu=2,imax-2

            fe_area = dx(iu+1)/(dx(iu+1)+dx(iu))
            auf_bar(iu,ju) = 1.0d0/(fe_area/ap(iu,ju) + (1.0d0-fe_area)/ap(iu+1,ju))
            Huf_bar(iu,ju) = fe_area*Hu(iu,ju) + (1.0d0-fe_area)*Hu(iu+1,ju)
            uf(iu,ju) = (1.0d0-alphau)*uf(iu,ju) + (alphau)/auf_bar(iu,ju)*(Huf_bar(iu,ju) + (p(iu,ju) - p(iu+1,ju))*dy(ju) + f_uf(iu,ju))

      end do

end do

do ju=xi,xf

      do iu=2,imax-2

            res_uf(iu,ju) = auf_bar(iu,ju)*uf(iu,ju) - Huf_bar(iu,ju) - (p(iu,ju) - p(iu+1,ju))*dy(ju) - f_uf(iu,ju)

      end do
end do

! Internal v control volumes

do jv = xi,xf

      do iv = 2,imax-1

            fn_area = dy(jv+1)/(dy(jv+1)+dy(jv))
            avf_bar(iv,jv) = 1.0d0/(fn_area/ap(iv,jv) + (1.0d0-fn_area)/ap(iv,jv+1))
            Hvf_bar(iv,jv) = fn_area*Hv(iv,jv) + (1.0d0-fn_area)*Hv(iv,jv+1)
            vf(iv,jv) = (1.0d0-alphav)*vf(iv,jv) + (alphav)/avf_bar(iv,jv)*(Hvf_bar(iv,jv) + (p(iv,jv) - p(iv,jv+1))*dx(iv)+ f_vf(iv,jv))
      end do

end do

if (xf .eq. jmax-1) then

      do iv = 2,imax-1

           vf(iv,jmax-1) = v(iv,jmax)

      end do

end if

!vf(1,xi-1:xf+1) = vf(2,xi-1:xf+1)
!vf(imax,xi-1:xf+1) = vf(imax-1,xi-1:xf+1)
!
!uf(1,xi-1:xf+1) = uf(2,xi-1:xf+1)
!uf(imax-1,xi-1:xf+1) = uf(imax-2,xi-1:xf+1)

do jv=xi,xf

      do iv=2,imax-1

            res_vf(iv,jv) = avf_bar(iv,jv)*vf(iv,jv) - Hvf_bar(iv,jv) - (p(iv,jv) - p(iv,jv+1))*dx(iv) - f_vf(iv,jv)

      end do
end do

call exchange_data(auf_bar, imax-1, xi, xf)
call exchange_data(avf_bar, imax, xi, xf)
call exchange_data(uf, imax-1, xi, xf)
call exchange_data(vf, imax, xi, xf)
call exchange_data(res_uf, imax-1, xi, xf)
call exchange_data(res_vf, imax, xi, xf)

end subroutine


subroutine amrex_probinit (init, name, namlen, problo, probhi) bind(c)

      use probdata_module
      use prob_params_module, only : center
      use amrex_constants_module, only: M_PI, FOUR3RD
      use amrex_fort_module, only : rt => amrex_real
      implicit none

      integer :: init, namlen
      integer :: name(namlen)
      real(rt)      :: problo(1), probhi(1)

      integer :: untin,i

      namelist /fortin/ m_0, r_0, v_0, &
                        eta, beta, delt, tau, &
                        f_a, TT_0, &
                        M_csm, M_ej, dR_csm, kap, &
                        t_0, rho_0, E_0, h_csm, &
                        filter_rhomax, filter_timemax, v_max, &
                        n, d, s, f_r, tau_a, pl_ej, use_Trec, Trec, dT_rec, &
                        dR_w, rho_w, eps, p, fm_bo, ft_bo, xi_bo

      integer, parameter :: maxlen = 256
      character :: probin*(maxlen)

      do i = 1, namlen
        probin(i:i) = char(name(i))
      end do

      !namelist defaults

      m_0 = 1.98e33_rt ! characteristic mass in g (M_csm)
      r_0 = 1.e14_rt   ! characteristic radius in cm (R_csm)
      !v_0 = 1.e9_rt   ! characteristic velocity in cm/s (v_ej)

      kap = 0.2e0_rt ! characteristic opacity (cm^2/g)
      eps = 1.e-3_rt ! planck mean (thermalization frac)
      M_ej = 3.e0_rt*1.989e33_rt ! ejecta mass (g)

      use_Trec = -1.e0_rt ! whether or not to use a recombination opacity
      Trec = 5.5e3_rt ! recombination temperature
      dT_rec = 0.1e0_rt*Trec ! smoothing length

      eta = 1.e-2_rt ! ratio M_csm/M_ej
      beta = 3.333333e-2_rt ! = v_ej/c
      delt = 1.e0_rt ! ratio dR/R_csm
      tau = 1.e1_rt ! csm optical depth

      f_a = 1.e-4_rt ! ratio of maximum possible ambient to csm density
                     ! this is only set if the optical depth param is too large
                     ! to make sure the ambient density doesn't contribute to
                     ! late-time LC in cases of small kappa
      TT_0 = 1.e2_rt ! ambient temperature

      rho_w = 1.e-15_rt !interface wind density
      dR_w = 2e15_rt !wind width

      h_csm = 1.e-1_rt ! smoothing length ratio h/R_csm

      d = 0.e0_rt ! inner ejecta density profile power law
      n = 10.e0_rt ! outer ejecta density profile power law
      pl_ej = -1.e0_rt ! whether or not to use power law ejecta prescription
      s = 0.e0_rt ! CSM density profile power law

      f_r = 0.1e0_rt ! ejecta transition velocity coordinate

      tau_a = 1.e-3_rt ! ambient density optical depth

      p = 10.e0_rt ! breakout layer power law index
      fm_bo = -1.e0_rt ! fractional mass of breakout layer
      ft_bo = -1.e0_rt ! fractional optical depth of breakout layer

      filter_rhomax = 1.e-99_rt
      filter_timemax = 0.e0_rt

      xi_bo = 0.e0_rt

      v_max = 3.e9_rt

      open(newunit=untin,file=probin(1:namlen),form='formatted',status='old')
      read(untin,fortin)
      close(unit=untin)

      v_0 = beta*2.998e10_rt
      M_csm = eta*M_ej
      m_0 = M_csm

      !r_0 = sqrt(kap*eta*M_ej/tau)*sqrt((3.e0_rt-s)/(4.e0_rt*M_PI*abs(1.e0_rt-s)))
      !r_0 = r_0*sqrt(abs((1.e0_rt+delt)**(1.e0_rt-s)-1.e0_rt)/abs((1.e0_rt+delt)**(3.e0_rt-s)-1.e0_rt))
      t_0 = r_0/v_0 !characteristic time
      rho_0 = M_ej/(FOUR3RD*M_PI*r_0*r_0*r_0) !characteristic density
      E_0 = m_0*v_0*v_0 ! characteristic energy

      dR_csm = delt*r_0
      !kap = tau*r_0*r_0/m_0
      !kap = FOUR3RD*M_PI*tau*r_0*r_0/m_0/delt*((1.e0_rt+delt)**3.e0_rt-1.e0_rt)
      !kap = tau*r_0*r_0/m_0*4.e0_rt*M_PI*(1.e0_rt-s)/(3.e0_rt-s)
      !kap = kap*((1.e0_rt+delt)**(3.e0_rt-s)-1.e0_rt)/((1.e0_rt+delt)**(1.e0_rt-s)-1.e0_rt)

      t_d = sqrt(kap*m_0/(v_0*2.998e10_rt))

      center(1) = 0.e0_rt

end subroutine amrex_probinit

subroutine ca_initdata(level,time,lo,hi,nscal, &
                       state,state_l1,state_h1, &
                       delta,xlo,xhi)

    use probdata_module
    use eos_module
    use network, only : nspec,naux
    use eos_type_module
    use amrex_constants_module, only: M_PI, FOUR3RD
    use meth_params_module, only: NVAR, URHO, UTEMP, UMX, UMZ, UEDEN, UEINT, UFS, UFX
    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: level, nscal
    integer, parameter :: nsub = 1
    integer :: lo(1), hi(1)
    integer :: state_l1, state_h1
    real(rt)        :: xlo(1), xhi(1), time, delta(1)
    real(rt)        :: state(state_l1:state_h1,NVAR)

    real(rt)        :: xx, xxs, vol, dx_sub, vol_sub
!    real(rt)        :: R_s, eta_r, eta_v, v_t, M_ch, rho_w
    real(rt)        :: rho_ej, rho_csm, rho_o, rho_a, R_t, rho_wa, rho_cw,rho_ca,rho_ww
    real(rt)        :: rho, vel, T, rho_sub, vel_sub, T_sub
    real(rt)        :: rho0_ej, rho0_csm, xi, R_bo, rho_bo
!    real(rt)		:: h_c, h_ej
    integer :: i, ii

    type(eos_t)  :: eos_state

    dx_sub = delta(1)/dble(nsub)

    R_t = f_r*r_0

    ! eta_r = (n-3.e0_rt)*(3.e0_rt-d)/(n-d)/(4.e0_rt*M_PI)
    ! eta_v = sqrt(2.e0_rt*(5.e0_rt-d)*(n-5.e0_rt) &
    !             /((3.e0_rt-d)*(n-3.e0_rt)))
    !
    ! M_ch = M_ej / 1.4e0_rt
    ! v_t = 6.e8_rt*eta_v*sqrt(E_ej/M_ch)
    ! R_s = v_t*R_c/v_ej
    !
    !
    ! h_ej = 0.1e0_rt*R_s
    ! h_c = 0.02e0_rt*R_x1
    ! rho_w = Mdot_w*2.e33_rt/(3.154e7_rt)/(4.*M_PI*R_c**2*v_w)
    !
    !
    ! rho_sh = M_sh*2.e33_rt/(4.e0_rt*M_PI*(f_sh*R_sh)**3)
    ! rho_sh = rho_sh/(sqrt(M_PI)/2.e0_rt*(1.e0_rt+2.e0_rt/f_sh**2)-N_sh*exp(-N_sh*N_sh))
    !
    ! rho_x = M_x*2.e33_rt/(4.e0_rt*M_PI*R_x0*R_x0*(R_x1-R_x0))

    xi = xi_bo

!    if (fm_bo .gt. 0) then
!        xi = 1.e0_rt+(1.e0_rt-p/3.e0_rt)*(1.e0_rt-(1.e0_rt+delt)**(-3))*fm_bo
!        xi = xi**(1.e0_rt/(3.e0_rt-p))
!    else if (ft_bo .gt. 0) then
!        xi = 1.e0_rt - (p-1.e0_rt)/(1.e0_rt+1.e0_rt/delt)*ft_bo
!        xi = xi**(1.e0_rt/(1.e0_rt-p))
!    endif

    R_bo = r_0+dR_csm+xi*dR_csm

    do i = lo(1), hi(1)

     xx = xlo(1)+delta(1)*(dble(i-lo(1)+0.5e0_rt))

     state(i,UMX:UMZ) = 0.0e0_rt

     vol  = 0.e0_rt
     rho     = 0.e0_rt
     T       = 0.e0_rt
     vel       = 0.e0_rt

     do ii=0,nsub-1

      xxs = xx + (dble(ii)+0.5e0_rt)*dx_sub

      vol_sub = xxs*xxs
      vol = vol + vol_sub

      ! rho0 = eta_r*M_ej*2.e33_rt/(R_s)**3*(R_s/xxs)**d
      ! rho1 = eta_r*M_ej*2.e33_rt/(R_s)**3*(R_s/xxs)**n
      ! rhow = rho_w*(R_c/xxs)**s

      ! rhoej = rho0 + 0.5e0_rt*(rho1-rho0)*(1.e0_rt+tanh((xxs-R_s)/h_ej))

      if (pl_ej .gt. 0 ) then
        rho0_ej = (n-3.e0_rt)*(3.e0_rt-d)/(4.e0_rt*M_PI*(n-d))*M_ej/(f_r*r_0)**3
      else
        rho0_ej = 3.e0_rt/(4.e0_rt*M_PI)*M_ej/r_0**3
      endif

      rho0_csm = (3.e0_rt-s)/(4.e0_rt*M_PI)/((1.e0_rt+delt)**(3.e0_rt-s)-1.e0_rt)*M_csm/r_0**3

      rho_csm = rho0_csm*(xxs/r_0)**(-s)
      rho_ww = rho_w*(xxs/(r_0+dR_csm))**(-2.e0_rt)
      rho_a = min(tau_a/(kap*xhi(1)),f_a*rho_csm)
      rho_bo = rho0_csm*((r_0+dR_csm)/r_0)**(-s)*(xxs/(r_0+dR_csm))**(-p)
      if (dR_w .gt. 0.e0_rt) then
          rho_cw = rho_csm + 0.5e0_rt*(rho_ww-rho_csm)*(1.e0_rt+tanh((xxs-(r_0+dR_csm))/(h_csm*r_0)))
          rho_wa = rho_ww + 0.5e0_rt*(rho_a-rho_ww)*(1.e0_rt+tanh((xxs-(r_0+dR_csm+dR_w))/(h_csm*(r_0+dR_csm+dR_w))))
          else
              rho_ca = rho_csm + 0.5e0_rt*(rho_a-rho_csm)*(1.e0_rt+tanh((xxs-(r_0+dR_csm))/(h_csm*r_0)))
          endif
      if (xxs .lt. R_t) then
          rho_sub = rho0_ej!*(xxs/R_t)**(-d)
          if (pl_ej .gt. 0) then
            rho_sub = rho_sub*(xxs/R_t)**(-d)
          endif
          vel_sub = v_0*(xxs/r_0)
          T_sub = TT_0
      else if (xxs .lt. r_0) then
          rho_sub = rho0_ej!*(xxs/R_t)**(-n)
          if (pl_ej .gt. 0) then
            rho_sub = rho_sub*(xxs/R_t)**(-n)
          endif
          vel_sub = v_0*(xxs/r_0)
          T_sub = TT_0
      else if (xxs .lt. r_0+dR_csm) then
      !    if (dR_w .gt. 0.e0_rt) then
      !        rho_sub = rho_cw
      !    else
      !        rho_sub = rho_ca
      !    endif
          rho_sub = rho_csm
          vel_sub = 0.e0_rt
          T_sub = TT_0
      else if (xxs .lt. R_bo) then
          rho_sub =  rho_bo
          vel_sub = 0.e0_rt
          T_sub = TT_0
      else
        !if (dR_w .gt. 0.e0_rt) then
        !    rho_sub = rho_wa
        !else
        !    rho_sub = rho_ca
        !endif
          rho_sub = rho_a
          vel_sub = 0.e0_rt
          T_sub =TT_0
      endif
     ! rho_sub = rhoej + 0.5e0_rt*(rhow-rhoej)*(1.e0_rt+tanh((xxs-R_c)/h_c))

     ! rho_sub = rho_sub !+ rho_sh*exp(-(xxs/R_sh-1)**2/(f_sh*f_sh))

      rho = rho + rho_sub*vol_sub
      T = T + T_sub*vol_sub
      vel = vel + vel_sub*vol_sub

     enddo

     rho = rho / vol
     T = T / vol
     vel = vel / vol
     state(i,URHO) = rho
     state(i,UTEMP) = T
     state(i,UMX) = state(i,URHO)*vel

     eos_state % rho = state(i,URHO)
     eos_state % T   = state(i,UTEMP)

     call eos(eos_input_rt, eos_state)

     state(i,UEINT) = state(i,URHO) * eos_state % e

     state(i,UEDEN) = state(i,UEINT) + 0.5e0_rt*state(i,UMX)**2/state(i,URHO)
     !state(i,UFS:UFS-1+nspec) = 0.e0_rt

     if (xx .lt. r_0) then
        state(i,UFX) = 1.e0_rt*rho
        state(i,UFX+1)= 0.e0_rt
        state(i,UFX+2) = 0.e0_rt
    else if (xx .lt. r_0+dR_csm) then
      state(i,UFX) = 0.e0_rt
      state(i,UFX+1) = 1.e0_rt*rho
      state(i,UFX+2) = 0.e0_rt
    else
      state(i,UFX) = 0.e0_rt
      state(i,UFX+1) = 0.e0_rt
      state(i,UFX+2) = 1.e0_rt*rho
    endif
     state(i,UFS) = state(i,URHO)
     !state(i,UFX) = state(i,URHO)
     !state(i,UFX+1) = state(i,URHO)

    enddo

end subroutine ca_initdata

subroutine ca_initrad(level,time,lo,hi,nrad, &
                      rad_state,rad_state_l1, &
                      rad_state_h1, &
                      delta,xlo,xhi)

    use probdata_module
    use meth_params_module, ONLY : UTEMP
    use fundamental_constants_module, only: a_rad
    use amrex_fort_module, only : rt => amrex_real
    use rad_params_module, only : xnu
    use blackbody_module, only : BGroup
    implicit none

    integer :: level, nrad
    integer :: lo(1), hi(1)
    integer :: rad_state_l1, rad_state_h1
    real(rt)    :: xlo(1), xhi(1), time, delta(1)
    real(rt)    :: rad_state(rad_state_l1:rad_state_h1, 0:nrad-1)
    integer :: i, igroup
    real(rt) :: xx, T

    do i = lo(1),hi(1)

    	xx = xlo(1)+delta(1)*(dble(i-lo(1)+0.5e0_rt))
      T = TT_0

      if (nrad .eq. 1) then
        rad_state(i,0) = a_rad*T**4
      else
        do igroup=0,nrad-1
          rad_state(i,igroup) = BGroup(T,xnu(igroup),xnu(igroup+1))
        enddo
      endif

    enddo

end subroutine ca_initrad


!
!	Find the Gilula-Haberman correction.
!	eacov is the estimated asymptotic covariance matrix under the model.
!	inform is the estimated information obtained by the Louis approach.
!	loglik is the log likelihood.
!	totalitems is the total weighted number of presented items.
!
!
real(kind=8) function gh(eacov,inform,loglik,totalitems)
implicit none
real(kind=8),intent(in)::eacov(:,:),inform(:,:),loglik,totalitems
!	col counts columns.
!	obs is an observation counter.
!	row counts rows.
integer::col,obs,row
gh=-loglik
do row=1,size(eacov,1)
	do col=1,row
		if(col<row)then
			gh=gh+2.0_8*eacov(row,col)*inform(col,row)
		else
			gh=gh+eacov(row,row)*inform(row,row)
		end if
	end do
end do
gh=gh/totalitems
return
end function gh


      SUBROUTINE CSYMMF ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB,
     $                   BETA, C, LDC )
*     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO
      INTEGER            M, N, LDA, LDB, LDC
      COMPLEX            ALPHA, BETA
*     .. Array Arguments ..
      COMPLEX            A( LDA, * ), B( LDB, * ), C( LDC, * )
*     ..
*
*  Purpose
*  =======
*
*  CSYMM  performs one of the matrix-matrix operations
*
*     C := alpha*A*B + beta*C,
*
*  or
*
*     C := alpha*B*A + beta*C,
*
*  where  alpha and beta are scalars, A is a symmetric matrix and  B and
*  C are m by n matrices.
*
*  Parameters
*  ==========
*
*  SIDE   - CHARACTER*1.
*           On entry,  SIDE  specifies whether  the  symmetric matrix  A
*           appears on the  left or right  in the  operation as follows:
*
*              SIDE = 'L' or 'l'   C := alpha*A*B + beta*C,
*
*              SIDE = 'R' or 'r'   C := alpha*B*A + beta*C,
*
*           Unchanged on exit.
*
*  UPLO   - CHARACTER*1.
*           On  entry,   UPLO  specifies  whether  the  upper  or  lower
*           triangular  part  of  the  symmetric  matrix   A  is  to  be
*           referenced as follows:
*
*              UPLO = 'U' or 'u'   Only the upper triangular part of the
*                                  symmetric matrix is to be referenced.
*
*              UPLO = 'L' or 'l'   Only the lower triangular part of the
*                                  symmetric matrix is to be referenced.
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry,  M  specifies the number of rows of the matrix  C.
*           M  must be at least zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the number of columns of the matrix C.
*           N  must be at least zero.
*           Unchanged on exit.
*
*  ALPHA  - COMPLEX         .
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  A      - COMPLEX          array of DIMENSION ( LDA, ka ), where ka is
*           m  when  SIDE = 'L' or 'l'  and is n  otherwise.
*           Before entry  with  SIDE = 'L' or 'l',  the  m by m  part of
*           the array  A  must contain the  symmetric matrix,  such that
*           when  UPLO = 'U' or 'u', the leading m by m upper triangular
*           part of the array  A  must contain the upper triangular part
*           of the  symmetric matrix and the  strictly  lower triangular
*           part of  A  is not referenced,  and when  UPLO = 'L' or 'l',
*           the leading  m by m  lower triangular part  of the  array  A
*           must  contain  the  lower triangular part  of the  symmetric
*           matrix and the  strictly upper triangular part of  A  is not
*           referenced.
*           Before entry  with  SIDE = 'R' or 'r',  the  n by n  part of
*           the array  A  must contain the  symmetric matrix,  such that
*           when  UPLO = 'U' or 'u', the leading n by n upper triangular
*           part of the array  A  must contain the upper triangular part
*           of the  symmetric matrix and the  strictly  lower triangular
*           part of  A  is not referenced,  and when  UPLO = 'L' or 'l',
*           the leading  n by n  lower triangular part  of the  array  A
*           must  contain  the  lower triangular part  of the  symmetric
*           matrix and the  strictly upper triangular part of  A  is not
*           referenced.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the  calling (sub) program. When  SIDE = 'L' or 'l'  then
*           LDA must be at least  max( 1, m ), otherwise  LDA must be at
*           least max( 1, n ).
*           Unchanged on exit.
*
*  B      - COMPLEX          array of DIMENSION ( LDB, n ).
*           Before entry, the leading  m by n part of the array  B  must
*           contain the matrix B.
*           Unchanged on exit.
*
*  LDB    - INTEGER.
*           On entry, LDB specifies the first dimension of B as declared
*           in  the  calling  (sub)  program.   LDB  must  be  at  least
*           max( 1, m ).
*           Unchanged on exit.
*
*  BETA   - COMPLEX         .
*           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
*           supplied as zero then C need not be set on input.
*           Unchanged on exit.
*
*  C      - COMPLEX          array of DIMENSION ( LDC, n ).
*           Before entry, the leading  m by n  part of the array  C must
*           contain the matrix  C,  except when  beta  is zero, in which
*           case C need not be set on entry.
*           On exit, the array  C  is overwritten by the  m by n updated
*           matrix.
*
*  LDC    - INTEGER.
*           On entry, LDC specifies the first dimension of C as declared
*           in  the  calling  (sub)  program.   LDC  must  be  at  least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 3 Blas routine.
*
*  -- Written on 8-February-1989.
*     Jack Dongarra, Argonne National Laboratory.
*     Iain Duff, AERE Harwell.
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*     Sven Hammarling, Numerical Algorithms Group Ltd.
*
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, INFO, J, K, NROWA
      COMPLEX            TEMP1, TEMP2
*     .. Parameters ..
      COMPLEX            ONE
      PARAMETER        ( ONE  = ( 1.0E+0, 0.0E+0 ) )
      COMPLEX            ZERO
      PARAMETER        ( ZERO = ( 0.0E+0, 0.0E+0 ) )
*     ..
*     .. Executable Statements ..
*
*     Set NROWA as the number of rows of A.
*
      IF( LSAME( SIDE, 'L' ) )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      UPPER = LSAME( UPLO, 'U' )
*
*     Test the input parameters.
*
      INFO = 0
      IF(      ( .NOT.LSAME( SIDE, 'L' ) ).AND.
     $         ( .NOT.LSAME( SIDE, 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER              ).AND.
     $         ( .NOT.LSAME( UPLO, 'L' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 7
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 9
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 12
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'CSYMM ', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
     $    ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
*
*     And when  alpha.eq.zero.
*
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
*
*     Start the operations.
*
      IF( LSAME( SIDE, 'L' ) )THEN
*
*        Form  C := alpha*A*B + beta*C.
*
         IF( UPPER )THEN
            DO 70, J = 1, N
               DO 60, I = 1, M
                  TEMP1 = ALPHA*B( I, J )
                  TEMP2 = ZERO
                  DO 50, K = 1, I - 1
                     C( K, J ) = C( K, J ) + TEMP1    *A( K, I )
                     TEMP2     = TEMP2     + B( K, J )*A( K, I )
   50             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2
                  ELSE
                     C( I, J ) = BETA *C( I, J ) +
     $                           TEMP1*A( I, I ) + ALPHA*TEMP2
                  END IF
   60          CONTINUE
   70       CONTINUE
         ELSE
            DO 100, J = 1, N
               DO 90, I = M, 1, -1
                  TEMP1 = ALPHA*B( I, J )
                  TEMP2 = ZERO
                  DO 80, K = I + 1, M
                     C( K, J ) = C( K, J ) + TEMP1    *A( K, I )
                     TEMP2     = TEMP2     + B( K, J )*A( K, I )
   80             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2
                  ELSE
                     C( I, J ) = BETA *C( I, J ) +
     $                           TEMP1*A( I, I ) + ALPHA*TEMP2
                  END IF
   90          CONTINUE
  100       CONTINUE
         END IF
      ELSE
*
*        Form  C := alpha*B*A + beta*C.
*
         DO 170, J = 1, N
            TEMP1 = ALPHA*A( J, J )
            IF( BETA.EQ.ZERO )THEN
               DO 110, I = 1, M
                  C( I, J ) = TEMP1*B( I, J )
  110          CONTINUE
            ELSE
               DO 120, I = 1, M
                  C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J )
  120          CONTINUE
            END IF
            DO 140, K = 1, J - 1
               IF( UPPER )THEN
                  TEMP1 = ALPHA*A( K, J )
               ELSE
                  TEMP1 = ALPHA*A( J, K )
               END IF
               DO 130, I = 1, M
                  C( I, J ) = C( I, J ) + TEMP1*B( I, K )
  130          CONTINUE
  140       CONTINUE
            DO 160, K = J + 1, N
               IF( UPPER )THEN
                  TEMP1 = ALPHA*A( J, K )
               ELSE
                  TEMP1 = ALPHA*A( K, J )
               END IF
               DO 150, I = 1, M
                  C( I, J ) = C( I, J ) + TEMP1*B( I, K )
  150          CONTINUE
  160       CONTINUE
  170    CONTINUE
      END IF
*
      RETURN
*
*     End of CSYMM .
*
      END


      SUBROUTINE CALSND
C
C CHANGE RECORD
C **  SUBROUTINE CALSND CALCULATES NONCOHESIVER SEDIMENT SETTLING,
C **  DEPOSITION AND RESUSPENSION AND IS CALLED FOR SSEDTOX
C
      USE GLOBAL

	IMPLICIT NONE
	REAL::TIME,GRADSED,SIGP,CRNUM,DUM1,DUM3,DUM4,DIASED3
	REAL::FSEDMODE,CSNDZEQ,ZEQMIN,CSNDEQC,CSHIELDS,TMPVAL
	REAL::CSNDSET,SHIELDS,TOP,BOT,WSFAC,WESE,WESEMX
	REAL::PROBDEP,WSETMP,WVEL,CLEFT,CRIGHT,SNDBTMP,SEDAVG
	REAL::AA11,AA12,AA21,AA22,BB11,BB22,DETI,FLUXFAC
	INTEGER::NX,NS,K,L,ISGPFLAG,ISEHFLAG,KTOP,NXX,NSS,IFLAG,LN
C
C**********************************************************************C
C
      IF(ISDYNSTP.EQ.0)THEN
        TIME=(DT*FLOAT(N)+TCON*TBEGIN)/TCON
      ELSE
        TIME=TIMESEC/TCON
      ENDIF
C
C**********************************************************************C
C
C **  SET MAXIMUM NONCOHESIVE SEDIMENT DIAMETER
C
      SNDDMX=0.
      IF(ISTRAN(7).GE.1)THEN
        DO NX=1,NSND
          NS=NSED+NX
          SNDDMX=MAX(SNDDMX,SEDDIA(NS))
        ENDDO
      ENDIF
C
C**********************************************************************C
C
C **  SET NONCOHESIVE ARMORING PARAMETERS
C
      IF(ISTRAN(7).GE.1)THEN
C
        IF(ISNDAL.EQ.0)THEN
C
          DO K=1,KB
            DO L=2,LA
              SIGPHI(L,K)=0.
            ENDDO
          ENDDO
C
          DO NX=1,NSND
            DO L=2,LA
              PEXP(L,NX)=1.
              PHID(L,NX)=1.
            ENDDO
          ENDDO
C
        ENDIF
C
        IF(ISNDAL.GE.1)THEN
C
          ISGPFLAG=0
          ISEHFLAG=0
          DO NX=1,NSND
            NS=NX+NSED
            IF(ISNDEQ(NS).EQ.1)ISGPFLAG=1
            IF(ISBDLD(NS).GE.2)ISEHFLAG=1
          ENDDO
C
C **  SET SIGPHI FOR GARCIA AND PARKER (1991) EQS 46 AND 47
C
          IF(ISGPFLAG.EQ.1)THEN
C
C **  GP - CONVERT SEDIMENT DIAMETERS IN M TO MM AND SET PHI SIZE
C
            DO NX=1,NSND
              NS=NSED+NX
              SEDPHI(NS)=-LOG(1000.*SEDDIA(NS))/LOG(2.)
            ENDDO
C
C **  GP - SET MEAN PHI FOR TOP LAYER OF BED
C
            DO L=2,LA
              TVAR3W(L)=0.
              TVAR3E(L)=0.
              SIGPHI(L,KBT(L))=0.
            ENDDO
C
            DO NX=1,NSND
              NS=NSED+NX
              DO L=2,LA
                KTOP=KBT(L)
                TVAR3W(L)=TVAR3W(L)+SEDPHI(NS)*VFRBED(L,KTOP,NS)
                TVAR3E(L)=TVAR3E(L)+VFRBED(L,KTOP,NS)
              ENDDO
            ENDDO
C
            DO L=2,LA
              IF(TVAR3E(L).LE.0.) TVAR3E(L)=1.
              TVAR3W(L)=TVAR3W(L)/TVAR3E(L)
            ENDDO
C
            DO NX=1,NSND
              NS=NSED+NX
              DO K=1,KB
                DO L=2,LA
                  KTOP=KBT(L)
                  SIGPHI(L,KTOP)=SIGPHI(L,K)+((SEDPHI(NS)-TVAR3W(L))**2)
     &                *VFRBED(L,KTOP,NS)/TVAR3E(L)
                ENDDO
              ENDDO
            ENDDO
C
            DO L=2,LA
              KTOP=KBT(L)
              IF(SIGPHI(L,KTOP).LT.0.)THEN
                SIGPHI(L,KTOP)=-SQRT(ABS(SIGPHI(L,KTOP)))   ! *** PMC TEMP PATCH
              ELSE
                SIGPHI(L,KTOP)=SQRT(SIGPHI(L,KTOP))
              ENDIF
            ENDDO
C
          ENDIF
C
C **  END CALCULATION OF SIGPHI FOR GARCIA AND PARKER (1991)
C
C **  SET EXPOSURE AND HIDING FUNCTIONS FOR ENGULAND-HANSEN AND WU,WANG,
C
          IF(ISEHFLAG.EQ.1.OR.ISGPFLAG.EQ.1)THEN
C
            DO NX=1,NSND
              DO L=2,LA
                PEXP(L,NX)=0.0
                PHID(L,NX)=0.0
              ENDDO
            ENDDO
C
            DO L=2,LA
              SNDBT(L,KBT(L))=0.0
            ENDDO
C
            DO NX=1,NSND
              NS=NSED+NX
              DO L=2,LA
                K=KBT(L)
                SNDBT(L,K)=SNDBT(L,K)+SNDB(L,K,NX)
                DO NXX=1,NSND
                  NSS=NSED+NXX
                  PEXP(L,NX)=PEXP(L,NX)+SNDB(L,K,NXX)*SEDDIA(NS)
     &                /(SEDDIA(NS)+SEDDIA(NSS))
                  PHID(L,NX)=PHID(L,NX)+SNDB(L,K,NXX)*SEDDIA(NSS)
     &                /(SEDDIA(NS)+SEDDIA(NSS))
                ENDDO
              ENDDO
            ENDDO
C
            DO NX=1,NSND
              DO L=2,LA
                K=KBT(L)
                IF(SNDBT(L,K).GT.0.0) THEN
                  PEXP(L,NX)=PEXP(L,NX)/SNDBT(L,K)
                  PHID(L,NX)=PHID(L,NX)/SNDBT(L,K)
                ELSE
                  PEXP(L,NX)=1.0
                  PHID(L,NX)=1.0
                END IF
              ENDDO
            ENDDO

C          DO L=2,LA
C            WRITE(8,888)IL(L),JL(L),(PEXP(L,NX),NX=1,NSND),
C     &                  (PHID(L,NX),NX=1,NSND)
C          ENDDO
C
          ENDIF
C
C **  END SET EXPOSURE AND HIDING FUNCTIONS FOR ENGULAND-HANSEN
C

        ENDIF
C
      ENDIF
C
  888 FORMAT(2I5,6E12.4)
C
C**********************************************************************C
C
C **   SET CRITICAL SHILED'S PARAMETER FOR D50
C
      DO L=2,LA
        CALL SETSHLD(DUM1,CSHIELDS50(L),SEDDIA50(L,KBT(L)),
     &      SSG(NSED+1),DUM3,DUM4)
      ENDDO
C
C**********************************************************************C
C
C **  NONCOHESIVE SEDIMENT, KC=1 (SINGLE LAYER IN VERTICAL)
C
      IF(ISTRAN(7).GE.1.AND.KC.EQ.1)THEN
        DO NX=1,NSND
          NS=NX+NSED
          DSEDGMM=1./(1.E6*SSG(NS))
          DIASED=SEDDIA(NS)
          DIASED3=3.*DIASED
          GPDIASED=G*(SSG(NS)-1.)*DIASED
C
C----------------------------------------------------------------------C
C
C **  SET SETTLING VELOCITIES
C
          K=0
C
          IF(ISNDVW.EQ.0)THEN
            DO L=2,LA
              WSETA(L,K,NS)=WSEDO(NS)
            ENDDO
          ENDIF
C
          IF(ISNDVW.GE.1)THEN
            DO L=2,LA
              WSETA(L,K,NS)=WSEDO(NS)*
     &            CSNDSET(SNDT(L,K+1),SDEN(NS),ISNDVW)
            ENDDO
          ENDIF
C
          IF(IROUSE(NX).EQ.0)THEN
            DO L=2,LA
              IF(USTAR(L).GT.0.0) THEN
                ROUSE(L)=WSETA(L,0,NS)/(VKC*USTAR(L))
              ELSE
                ROUSE(L)=250000.*WSETA(L,0,NS)
              END IF
            ENDDO
          ELSE
            DO L=2,LA
              IF(USTARSND(L).GT.0.0) THEN
                ROUSE(L)=WSETA(L,0,NS)/(VKC*USTARSND(L))
              ELSE
                ROUSE(L)=250000.*WSETA(L,0,NS)
              END IF
            ENDDO
          ENDIF
C
C----------------------------------------------------------------------C
C
          DO L=1,LC
            QSBDLDP(L)=0.
            QSBDLDX(L,NX)=0.
            QSBDLDY(L,NX)=0.
            QSBDLDOT(L,NX)=0.
            QSBDLDIN(L,NX)=0.
            SNDFBL(L,NX)=0.
            RBPSBL(L)=1.0
          ENDDO
C
          CALL BEDLOAD(NX,NS)
C
C----------------------------------------------------------------------C
C
C **  SUSPENDED TRANSPORT HORIZONTAL LOOP
C
          DO L=2,LA
            FACSUSL(L)=FSEDMODE(WSETA(L,0,NS),USTAR(L),USTARSND(L),
     &          RSNDM(NX),ISNDM1(NX),ISNDM2(NX),2)
          ENDDO
C
C **  SET EQUILIBRUIM CONCENTRATION HEIGHT & INVERSE
          DO L=2,LA
            ZEQ(L)=CSNDZEQ(DIASED,GPDIASED,TAUR(NS),TAUBSND(L),
     &        SEDDIA50(L,KBT(L)),HP(L),ISNDEQ(NS),SSG(NS),WSETA(L,0,NS))
            ZEQMIN=0.5*DZC(1)
            ZEQ(L)=MIN(ZEQ(L),ZEQMIN)
            ZEQI(L)=1./ZEQ(L)
          ENDDO
C
C **  SET EQUILIBRUIM CONCENTRATION
          DO L=2,LA
            SNDEQB(L)=CSNDEQC(DIASED,SSG(NS),WSETA(L,0,NS),TAUR(NS),
     &          TAUBSND(L),SEDDIA50(L,KBT(L)),SIGPHI(L,KBT(L)),ZEQ(L),
     &          ISNDEQ(NS),ISNDAL)
          ENDDO
C
C **  APPLIED LIMITOR TO GARCIA AND PARKER
C
          IF(ISNDEQ(NS).EQ.1)THEN
            IF(ISLTAUC(NS).EQ.1)THEN
              CSHIELDS=TCSHIELDS(NS)
              DO L=2,LA
                IF(ISEDEFF.EQ.2)THEN
                  TMPVAL=1.+(COEHEFF2-1.)
     &                *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
                  CSHIELDS=TMPVAL*CSHIELDS
                ENDIF
                SHIELDS=TAUBSND(L)/GPDIASED
                IF(SHIELDS.LT.CSHIELDS) SNDEQB(L)=0.
              ENDDO
            ENDIF
            IF(ISLTAUC(NS).EQ.2)THEN
              DO L=2,LA
                CSHIELDS=SEDDIA50(L,KBT(L))*CSHIELDS50(L)/DIASED
                IF(ISEDEFF.EQ.2)THEN
                  TMPVAL=1.+(COEHEFF2-1.)
     &                *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
                  CSHIELDS=TMPVAL*CSHIELDS
                ENDIF
                SHIELDS=TAUBSND(L)/GPDIASED
                IF(SHIELDS.LT.CSHIELDS) SNDEQB(L)=0.
              ENDDO
            ENDIF
            IF(ISLTAUC(NS).EQ.3)THEN
              DO L=2,LA
                CSHIELDS=0.03*((PHID(L,NX)/PEXP(L,NX))**0.6)
                IF(ISEDEFF.EQ.2)THEN
                  TMPVAL=1.+(COEHEFF2-1.)
     &                *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
                  CSHIELDS=TMPVAL*CSHIELDS
                ENDIF
                SHIELDS=TAUBSND(L)/GPDIASED
                IF(SHIELDS.LT.CSHIELDS) SNDEQB(L)=0.
              ENDDO
            ENDIF
          ENDIF
C
          IF(ISEDEFF.EQ.1)THEN
            DO L=2,LA
              SNDEQB(L)=SNDEQB(L)*EXP(-COEHEFF*FRACCOH(L,KBT(L)))
            ENDDO
          ENDIF
C

          DO L=2,LA
            IF(ROUSE(L).LT.0.999.OR.ROUSE(L).GT.1.001)THEN
              TOP=(ZEQ(L)**(ROUSE(L)-1.))-1.
              BOT=(1.-ROUSE(L))*(ZEQI(L)-1.)
              SNDEQ(L)=SNDEQB(L)*TOP/BOT
              SNDEQ(L)=FACSUSL(L)*VFRBED(L,KBT(L),NS)*MAX(SNDEQ(L),0.)
              SNDEQSAV(L,NX)=SNDEQ(L)
            ELSE
              TOP=LOG(ZEQI(L))
              BOT=(ZEQI(L)-1.)
              SNDEQ(L)=SNDEQB(L)*TOP/BOT
              SNDEQ(L)=FACSUSL(L)*VFRBED(L,KBT(L),NS)*MAX(SNDEQ(L),0.)
              SNDEQSAV(L,NX)=SNDEQ(L)
            ENDIF
          ENDDO
C
          DO L=2,LA
            SNDF(L,1,NX)=0.
            PROBDEP=0.
            WESE=0.
C **  SET MAXIMUM EROSION RATE
            WESEMX=DELTI*CTMPDRY(L)*SNDB(L,KBT(L),NX)-SNDFBL(L,NX)
            WESEMX=MAX(WESEMX,0.)
C **  SET RESUSPENSION FLUX
            WSFAC=2.*(1.+ROUSE(L))/(2.+ROUSE(L)*(1.-ZEQ(L)))
            WESE=WSFAC*CTMPDRY(L)*WSETA(L,0,NS)*SNDEQ(L)
C **  SET DEPOSITION VELOCITY
            WSETMP=WSFAC*WSETA(L,0,NS)
            WVEL=DELT*HPI(L)*DZIC(1)
            CLEFT=1.+WSETMP*WVEL
            CRIGHT=MAX(SND(L,1,NX),0.)+(WESE-SNDF(L,1,NX))*WVEL
            SND(L,1,NX)=CRIGHT/CLEFT
            SNDF(L,0,NX)=-WSETMP*SND(L,1,NX)+WESE
            SNDBTMP=SNDB(L,KBT(L),NX)-DELT*SNDF(L,0,NX)
     &          -DELT*SNDFBL(L,NX)
C **  ADDED BED LOAD FLUX TO SUSPENDED LOAD FLUX WITH ABOVE LINE
            IF(SNDBTMP.LT.0.0)THEN
              ! *** PMC Begin Block
              ! *** Adjust bedload flux, trying to keep suspended load flux constant
              SNDBTMP=SNDB(L,KBT(L),NX)-DELT*SNDF(L,0,NX)
              LN=LNC(L)
              IF(SNDBTMP.LT.0.0)THEN
                ! *** Zero Bedload Outflux
                QSBDLDX(L,NX)=MAX(QSBDLDX(L,NX),0.0)
                QSBDLDY(L,NX)=MAX(QSBDLDY(L,NX),0.0)
                QSBDLDX(LEAST(L),NX)=MIN(QSBDLDX(LEAST(L),NX),0.0)
                QSBDLDY(LN,NX)=MIN(QSBDLDY(LN,NX),0.0)
                QSBDLDOT(L ,NX)=0.
                SNDFBL(L,NX)=DXYIP(L)*(QSBDLDX(LEAST(L),NX)
     &              -QSBDLDX(L,NX)+QSBDLDY(LN,NX)-QSBDLDY(L,NX)
     &              +QSBDLDOT(L,NX)-QSBDLDIN(L,NX))

                ! *** Reduce Suspended Load Flux
                SNDF(L,0,NX)=DELTI*SNDB(L,KBT(L),NX)
                SND(L,1,NX)=SNDS(L,1,NX)+(SNDF(L,0,NX)-
     &                                    SNDF(L,1,NX))*WVEL
              ELSE
                ! *** Reduce Bedload Flux
                SNDBTMP=SNDBTMP/DELT
                FLUXFAC=SNDBTMP/SNDFBL(L,NX)

                IF(QSBDLDX(L,NX).LT.0.)
     &                 QSBDLDX(L,NX)=FLUXFAC*QSBDLDX(L,NX)
                IF(QSBDLDY(L,NX).LT.0.)
     &                 QSBDLDY(L,NX)=FLUXFAC*QSBDLDY(L,NX)
                QSBDLDOT(L ,NX)=FLUXFAC*QSBDLDOT(L ,NX)

                ! *** Update final Bedload Flux
                SNDFBL(L,NX)=SNDBTMP-QSBDLDIN(L ,NX)
              ENDIF
              SNDBTMP=0.0
              ! *** PMC End Block
            ENDIF
            SNDB1(L,KBT(L),NX)=S3TL*SNDB(L,KBT(L),NX)
     &          +S2TL*SNDB1(L,KBT(L),NX)
            SNDB(L,KBT(L),NX)=SNDBTMP
            SNDF(L,0,NX)=SNDF(L,0,NX)+SNDFBL(L,NX)
            QSBDTOP(L)=QSBDTOP(L)+DSEDGMM*SNDF(L,0,NX)
            QWBDTOP(L)=QWBDTOP(L)+DSEDGMM*
     &          ( VDRBED(L,KBT(L))*MAX(SNDF(L,0,NX),0.)
     &          +VDRDEPO(NS)*MIN(SNDF(L,0,NX),0.) )
          ENDDO
C
C----------------------------------------------------------------------C
C
        ENDDO
      ENDIF
C
C**********************************************************************C
C
C **  NONCOHESIVE SEDIMENT, KC=2 (TWO LAYERS IN VERTICAL)
C
      IF(ISTRAN(7).GE.1.AND.KC.EQ.2)THEN
        DO NX=1,NSND
          NS=NX+NSED
          DSEDGMM=1./(1.E6*SSG(NS))
          DIASED=SEDDIA(NS)
          DIASED3=3.*DIASED
          GPDIASED=G*(SSG(NS)-1.)*DIASED
C
C----------------------------------------------------------------------C
C
C **  SET SETTLING VELOCITIES
C
          IF(ISNDVW.EQ.0)THEN
            DO K=0,KS
              DO L=2,LA
                WSETA(L,K,NS)=WSEDO(NS)
              ENDDO
            ENDDO
          ENDIF
C
          IF(ISNDVW.GE.1)THEN
            DO K=0,KS
              DO L=2,LA
                WSETA(L,K,NS)=WSEDO(NS)*
     &              CSNDSET(SNDT(L,K+1),SDEN(NS),ISNDVW)
              ENDDO
            ENDDO
          ENDIF
C
          IF(IROUSE(NX).EQ.0)THEN
            DO L=2,LA
              IF(USTAR(L).GT.0.0) THEN
                ROUSE(L)=WSETA(L,0,NS)/(VKC*USTAR(L))
              ELSE
                ROUSE(L)=250000.*WSETA(L,0,NS)
              END IF
            ENDDO
          ELSE
            DO L=2,LA
              IF(USTARSND(L).GT.0.0) THEN
                ROUSE(L)=WSETA(L,0,NS)/(VKC*USTARSND(L))
              ELSE
                ROUSE(L)=250000.*WSETA(L,0,NS)
              END IF
            ENDDO
          ENDIF
C
C----------------------------------------------------------------------C
C
          DO L=1,LC
            QSBDLDP(L)=0.
            QSBDLDX(L,NX)=0.
            QSBDLDY(L,NX)=0.
            QSBDLDOT(L,NX)=0.
            QSBDLDIN(L,NX)=0.
            SNDFBL(L,NX)=0.
            RBPSBL(L)=1.0
          ENDDO
C
          CALL BEDLOAD(NX,NS)
C
C----------------------------------------------------------------------C
C
C **  HORIZONTAL LOOPS
C
          K=2
          DO L=2,LA
            SNDF(L,K,NX)=0.
            WVEL=DELT*HPI(L)*DZIC(K)
            CLEFT=1.+WSETA(L,K-1,NS)*WVEL
            CRIGHT=MAX(SND(L,K,NX),0.)
            SND(L,K,NX)=CRIGHT/CLEFT
            SNDF(L,K-1,NX)=-WSETA(L,K-1,NS)*SND(L,K,NX)
          ENDDO
C
          DO L=2,LA
            FACSUSL(L)=FSEDMODE(WSETA(L,0,NS),USTAR(L),USTARSND(L),
     &          RSNDM(NX),ISNDM1(NX),ISNDM2(NX),2)
          ENDDO
C
          DO L=2,LA
            PROBDEP=0.
            WESE=0.
C **  SET MAXIMUM EROSION RATE
            WESEMX=DELTI*CTMPDRY(L)*SNDB(L,KBT(L),NX)-SNDFBL(L,NX)
            WESEMX=MAX(WESEMX,0.)
C **  SET ROUSE PARAMETER AND EQUILIBRUIM CONCENTRATION
            ZEQ(L)=CSNDZEQ(DIASED,GPDIASED,TAUR(NS),TAUBSND(L),
     &        SEDDIA50(L,KBT(L)),HP(L),ISNDEQ(NS),SSG(NS),WSETA(L,0,NS))
            ZEQMIN=0.5*DZC(1)
            ZEQ(L)=MIN(ZEQ(L),ZEQMIN)
            ZEQD(L)=ZEQ(L)/DZC(1)
            ZEQDI(L)=1./ZEQD(L)
            WSFAC=1.
            SIGP=SIGPHI(L,KBT(L))
            SNDEQB(L)=CSNDEQC(DIASED,SSG(NS),WSETA(L,0,NS),TAUR(NS),
     &          TAUBSND(L),SEDDIA50(L,KBT(L)),SIGP,ZEQ(L),ISNDEQ(NS)
     &          ,ISNDAL)
C
C **  APPLIED LIMITOR TO GARCIA AND PARKER
C
            IF(ISNDEQ(NS).EQ.1)THEN
              IF(ISLTAUC(NS).EQ.1)THEN
                CSHIELDS=TCSHIELDS(NS)
                IF(ISEDEFF.EQ.2)THEN
                  TMPVAL=1.+(COEHEFF2-1.)
     &                *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
                  CSHIELDS=TMPVAL*CSHIELDS
                ENDIF
                SHIELDS=TAUBSND(L)/GPDIASED
                IF(SHIELDS.LT.CSHIELDS) SNDEQB(L)=0.
              ENDIF
              IF(ISLTAUC(NS).EQ.2)THEN
                CSHIELDS=SEDDIA50(L,KBT(L))*CSHIELDS50(L)/DIASED
                IF(ISEDEFF.EQ.2)THEN
                  TMPVAL=1.+(COEHEFF2-1.)
     &                *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
                  CSHIELDS=TMPVAL*CSHIELDS
                ENDIF
                SHIELDS=TAUBSND(L)/GPDIASED
                IF(SHIELDS.LT.CSHIELDS) SNDEQB(L)=0.
              ENDIF
              IF(ISLTAUC(NS).EQ.3)THEN
                CSHIELDS=0.03*((PHID(L,NX)/PEXP(L,NX))**0.6)
                IF(ISEDEFF.EQ.2)THEN
                  TMPVAL=1.+(COEHEFF2-1.)
     &                *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
                  CSHIELDS=TMPVAL*CSHIELDS
                ENDIF
                SHIELDS=TAUBSND(L)/GPDIASED
                IF(SHIELDS.LT.CSHIELDS) SNDEQB(L)=0.
              ENDIF
            ENDIF
C
            IF(ISEDEFF.EQ.1)
     &          SNDEQB(L)=SNDEQB(L)*EXP(-COEHEFF*FRACCOH(L,KBT(L)))
C
            IF(ROUSE(L).LT.0.999.OR.ROUSE(L).GT.1.001)THEN
              TOP=(ZEQD(L)**(ROUSE(L)-1.))-1.
              BOT=(1.-ROUSE(L))*(ZEQDI(L)-1.)
              SNDEQ(L)=SNDEQB(L)*TOP/BOT
              SNDEQ(L)=FACSUSL(L)*VFRBED(L,KBT(L),NS)*MAX(SNDEQ(L),0.)
            ELSE
              TOP=LOG(ZEQDI(L))
              BOT=(ZEQDI(L)-1.)
              SNDEQ(L)=SNDEQB(L)*TOP/BOT
              SNDEQ(L)=FACSUSL(L)*VFRBED(L,KBT(L),NS)*MAX(SNDEQ(L),0.)
            ENDIF
C **  SET RESUSPENSION FLUX
            WESE=WSFAC*CTMPDRY(L)*WSETA(L,0,NS)*SNDEQ(L)
C **  SET DEPOSITION VELOCITY
            WSETMP=WSFAC*WSETA(L,0,NS)
            WVEL=DELT*HPI(L)*DZIC(1)
            CLEFT=1.+WSETMP*WVEL
            CRIGHT=MAX(SND(L,1,NX),0.)+(WESE-SNDF(L,1,NX))*WVEL
            SND(L,1,NX)=CRIGHT/CLEFT
            SNDF(L,0,NX)=-WSETMP*SND(L,1,NX)+WESE
            SNDBTMP=SNDB(L,KBT(L),NX)-DELT*SNDF(L,0,NX)
     &          -DELT*SNDFBL(L,NX)
C **  ADDED BED LOAD FLUX TO SUSPENDED LOAD FLUX WITH ABOVE LINE
            IF(SNDBTMP.LT.0.0)THEN
              ! *** PMC Begin Block
              ! *** Adjust bedload flux, trying to keep suspended load flux constant
              SNDBTMP=SNDB(L,KBT(L),NX)-DELT*SNDF(L,0,NX)
              LN=LNC(L)
              IF(SNDBTMP.LT.0.0)THEN
                ! *** Zero Bedload Outflux
                QSBDLDX(L,NX)=MAX(QSBDLDX(L,NX),0.0)
                QSBDLDY(L,NX)=MAX(QSBDLDY(L,NX),0.0)
                QSBDLDX(LEAST(L),NX)=MIN(QSBDLDX(LEAST(L),NX),0.0)
                QSBDLDY(LN,NX)=MIN(QSBDLDY(LN,NX),0.0)
                QSBDLDOT(L ,NX)=0.
                SNDFBL(L,NX)=DXYIP(L)*(QSBDLDX(LEAST(L),NX)
     &              -QSBDLDX(L,NX)+QSBDLDY(LN,NX)-QSBDLDY(L,NX)
     &              +QSBDLDOT(L,NX)-QSBDLDIN(L,NX))

                ! *** Reduce Suspended Load Flux
                SNDF(L,0,NX)=DELTI*SNDB(L,KBT(L),NX)
                SND(L,1,NX)=SNDS(L,1,NX)+(SNDF(L,0,NX)-
     &                                    SNDF(L,1,NX))*WVEL
              ELSE
                ! *** Reduce Bedload Flux
                SNDBTMP=SNDBTMP/DELT
                FLUXFAC=SNDBTMP/SNDFBL(L,NX)

                IF(QSBDLDX(L,NX).LT.0.)
     &                 QSBDLDX(L,NX)=FLUXFAC*QSBDLDX(L,NX)
                IF(QSBDLDY(L,NX).LT.0.)
     &                 QSBDLDY(L,NX)=FLUXFAC*QSBDLDY(L,NX)
                QSBDLDOT(L ,NX)=FLUXFAC*QSBDLDOT(L ,NX)

                ! *** Update final Bedload Flux
                SNDFBL(L,NX)=SNDBTMP-QSBDLDIN(L ,NX)
              ENDIF
              SNDBTMP=0.0
              ! *** PMC End Block
            ENDIF
            SNDB1(L,KBT(L),NX)=S3TL*SNDB(L,KBT(L),NX)
     &          +S2TL*SNDB1(L,KBT(L),NX)
            SNDB(L,KBT(L),NX)=SNDBTMP
            SNDF(L,0,NX)=SNDF(L,0,NX)+SNDFBL(L,NX)
            QSBDTOP(L)=QSBDTOP(L)+DSEDGMM*SNDF(L,0,NX)
            QWBDTOP(L)=QWBDTOP(L)+DSEDGMM*
     &          ( VDRBED(L,KBT(L))*MAX(SNDF(L,0,NX),0.)
     &          +VDRDEPO(NS)*MIN(SNDF(L,0,NX),0.) )
          ENDDO
C
C----------------------------------------------------------------------C
C
C **  ANTI-DIFFUSION OF NONCOHESIVE SEDIMENT  KC.EQ.2
C
          IF(ISTOPT(7).EQ.1)THEN
C
            DO L=2,LA
              CRNUM=1.+DELT*WSETA(L,1,NS)*HPI(L)*DZIC(KC)
              GRADSED=(SND(L,KC,NX)-SND(L,1,NX))/(DZC(KC)+DZC(1))
              SEDAVG=0.5*(SND(L,KC,NX)+SND(L,KC,NX)+1.E-16)
              WSETA(L,1,NS)=-CRNUM*DZC(KC)*WSETA(L,1,NS)*GRADSED/SEDAVG
            ENDDO
C
            DO L=2,LA
              AA11=DELTI*DZC(1)*HP(L)-MIN(WSETA(L,1,NS),0.)
              AA12=-MAX(WSETA(L,1,NS),0.)
              AA21=MIN(WSETA(L,1,NS),0.)
              AA22=DELTI*DZC(KC)*HP(L)+MAX(WSETA(L,1,NS),0.)
              BB11=DELTI*DZC(1)*HP(L)*SND(L,1,NX)
              BB22=DELTI*DZC(KC)*HP(L)*SND(L,KC,NX)
              DETI=1./(AA11*AA22-AA12*AA21)
              SND(L,1,NX)=DETI*( BB11*AA22-BB22*AA12 )
              SND(L,KC,NX)=DETI*( AA11*BB22-AA21*BB11 )
            ENDDO
C
          ENDIF
C
C----------------------------------------------------------------------C
C
C **  FINAL FLUX KC=2
C
          DO L=2,LA
            SNDF(L,1,NX)=DELTI*DZC(KC)*HP(L)*(SND(L,KC,NX)
     &          -SNDS(L,KC,NX))
          ENDDO
C
C----------------------------------------------------------------------C
C
        ENDDO
      ENDIF
C
C**********************************************************************C
C
C **  NONCOHESIVE SEDIMENT, KC=3 (THREE LAYERS IN VERTICAL)
C
      IF(ISTRAN(7).GE.1.AND.KC.EQ.3)THEN
        DO NX=1,NSND
          NS=NX+NSED
          DSEDGMM=1./(1.E6*SSG(NS))
          DIASED=SEDDIA(NS)
          DIASED3=3.*DIASED
          GPDIASED=G*(SSG(NS)-1.)*DIASED
C
C----------------------------------------------------------------------C
C
C **  SET SETTLING VELOCITIES
C
          IF(ISNDVW.EQ.0)THEN
            DO K=0,KS
              DO L=2,LA
                WSETA(L,K,NS)=WSEDO(NS)
              ENDDO
            ENDDO
          ENDIF
C
          IF(ISNDVW.GE.1)THEN
            DO K=0,KS
              DO L=2,LA
                WSETA(L,K,NS)=WSEDO(NS)*
     &              CSNDSET(SNDT(L,K+1),SDEN(NS),ISNDVW)
              ENDDO
            ENDDO
          ENDIF
C
          IF(IROUSE(NX).EQ.0)THEN
            DO L=2,LA
              IF(USTAR(L).GT.0.0) THEN
                ROUSE(L)=WSETA(L,0,NS)/(VKC*USTAR(L))
              ELSE
                ROUSE(L)=250000.*WSETA(L,0,NS)
              END IF
            ENDDO
          ELSE
            DO L=2,LA
              IF(USTARSND(L).GT.0.0) THEN
                ROUSE(L)=WSETA(L,0,NS)/(VKC*USTARSND(L))
              ELSE
                ROUSE(L)=250000.*WSETA(L,0,NS)
              END IF
            ENDDO
          ENDIF
C
C----------------------------------------------------------------------C
C
          DO L=1,LC
            QSBDLDP(L)=0.
            QSBDLDX(L,NX)=0.
            QSBDLDY(L,NX)=0.
            QSBDLDOT(L,NX)=0.
            QSBDLDIN(L,NX)=0.
            SNDFBL(L,NX)=0.
            RBPSBL(L)=1.0
          ENDDO
C
          CALL BEDLOAD(NX,NS)
C
C----------------------------------------------------------------------C
C
C **  HORIZONTAL LOOPS
C
          K=3
          DO L=2,LA
            SNDF(L,K,NX)=0.
            WVEL=DELT*HPI(L)*DZIC(K)
            CLEFT=1.+WSETA(L,K-1,NS)*WVEL
            CRIGHT=MAX(SND(L,K,NX),0.)
            SND(L,K,NX)=CRIGHT/CLEFT
            SNDF(L,K-1,NX)=-WSETA(L,K-1,NS)*SND(L,K,NX)
          ENDDO
C
          K=2
          DO L=2,LA
            WVEL=DELT*HPI(L)*DZIC(K)
            CLEFT=1.+WSETA(L,K-1,NS)*WVEL
            CRIGHT=MAX(SND(L,K,NX),0.)-SNDF(L,K,NX)*WVEL
            SND(L,K,NX)=CRIGHT/CLEFT
            SNDF(L,K-1,NX)=-WSETA(L,K-1,NS)*SND(L,K,NX)
          ENDDO
C
          DO L=2,LA
            FACSUSL(L)=FSEDMODE(WSETA(L,0,NS),USTAR(L),USTARSND(L),
     &          RSNDM(NX),ISNDM1(NX),ISNDM2(NX),2)
          ENDDO
C
          DO L=2,LA
            PROBDEP=0.
            WESE=0.
C **  SET MAXIMUM EROSION RATE
            WESEMX=DELTI*CTMPDRY(L)*SNDB(L,KBT(L),NX)-SNDFBL(L,NX)
            WESEMX=MAX(WESEMX,0.)
C **  SET ROUSE PARAMETER AND EQUILIBRUIM CONCENTRATION
            ZEQ(L)=CSNDZEQ(DIASED,GPDIASED,TAUR(NS),TAUBSND(L),
     &        SEDDIA50(L,KBT(L)),HP(L),ISNDEQ(NS),SSG(NS),WSETA(L,0,NS))
            ZEQMIN=0.5*DZC(1)
            ZEQ(L)=MIN(ZEQ(L),ZEQMIN)
            ZEQD(L)=ZEQ(L)/DZC(1)
            ZEQDI(L)=1./ZEQD(L)
            WSFAC=1.
            SIGP=SIGPHI(L,KBT(L))
            SNDEQB(L)=CSNDEQC(DIASED,SSG(NS),WSETA(L,0,NS),TAUR(NS),
     &          TAUBSND(L),SEDDIA50(L,KBT(L)),SIGP,ZEQ(L),ISNDEQ(NS)
     &          ,ISNDAL)
C
C **  APPLIED LIMITOR TO GARCIA AND PARKER
C
            IF(ISNDEQ(NS).EQ.1)THEN
              IF(ISLTAUC(NS).EQ.1)THEN
                CSHIELDS=TCSHIELDS(NS)
                IF(ISEDEFF.EQ.2)THEN
                  TMPVAL=1.+(COEHEFF2-1.)
     &                *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
                  CSHIELDS=TMPVAL*CSHIELDS
                ENDIF
                SHIELDS=TAUBSND(L)/GPDIASED
                IF(SHIELDS.LT.CSHIELDS) SNDEQB(L)=0.
              ENDIF
              IF(ISLTAUC(NS).EQ.2)THEN
                CSHIELDS=SEDDIA50(L,KBT(L))*CSHIELDS50(L)/DIASED
                IF(ISEDEFF.EQ.2)THEN
                  TMPVAL=1.+(COEHEFF2-1.)
     &                *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
                  CSHIELDS=TMPVAL*CSHIELDS
                ENDIF
                SHIELDS=TAUBSND(L)/GPDIASED
                IF(SHIELDS.LT.CSHIELDS) SNDEQB(L)=0.
              ENDIF
              IF(ISLTAUC(NS).EQ.3)THEN
                CSHIELDS=0.03*((PHID(L,NX)/PEXP(L,NX))**0.6)
                IF(ISEDEFF.EQ.2)THEN
                  TMPVAL=1.+(COEHEFF2-1.)
     &                *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
                  CSHIELDS=TMPVAL*CSHIELDS
                ENDIF
                SHIELDS=TAUBSND(L)/GPDIASED
                IF(SHIELDS.LT.CSHIELDS) SNDEQB(L)=0.
              ENDIF
            ENDIF
C
            IF(ISEDEFF.EQ.1)
     &          SNDEQB(L)=SNDEQB(L)*EXP(-COEHEFF*FRACCOH(L,KBT(L)))
C
            IF(ROUSE(L).LT.0.999.OR.ROUSE(L).GT.1.001)THEN
              TOP=(ZEQD(L)**(ROUSE(L)-1.))-1.
              BOT=(1.-ROUSE(L))*(ZEQDI(L)-1.)
              SNDEQ(L)=SNDEQB(L)*TOP/BOT
              SNDEQ(L)=FACSUSL(L)*VFRBED(L,KBT(L),NS)*MAX(SNDEQ(L),0.)
            ELSE
              TOP=LOG(ZEQDI(L))
              BOT=(ZEQDI(L)-1.)
              SNDEQ(L)=SNDEQB(L)*TOP/BOT
              SNDEQ(L)=FACSUSL(L)*VFRBED(L,KBT(L),NS)*MAX(SNDEQ(L),0.)
            ENDIF
C **  SET RESUSPENSION FLUX
            WESE=WSFAC*CTMPDRY(L)*WSETA(L,0,NS)*SNDEQ(L)
C **  SET DEPOSITION VELOCITY
            WSETMP=WSFAC*WSETA(L,0,NS)
            WVEL=DELT*HPI(L)*DZIC(1)
            CLEFT=1.+WSETMP*WVEL
            CRIGHT=MAX(SND(L,1,NX),0.)+(WESE-SNDF(L,1,NX))*WVEL
            SND(L,1,NX)=CRIGHT/CLEFT
            SNDF(L,0,NX)=-WSETMP*SND(L,1,NX)+WESE
            SNDBTMP=SNDB(L,KBT(L),NX)-DELT*SNDF(L,0,NX)
     &          -DELT*SNDFBL(L,NX)
C **  ADDED BED LOAD FLUX TO SUSPENDED LOAD FLUX WITH ABOVE LINE
            IF(SNDBTMP.LT.0.0)THEN
              ! *** PMC Begin Block
              ! *** Adjust bedload flux, trying to keep suspended load flux constant
              SNDBTMP=SNDB(L,KBT(L),NX)-DELT*SNDF(L,0,NX)
              LN=LNC(L)
              IF(SNDBTMP.LT.0.0)THEN
                ! *** Zero Bedload Outflux
                QSBDLDX(L,NX)=MAX(QSBDLDX(L,NX),0.0)
                QSBDLDY(L,NX)=MAX(QSBDLDY(L,NX),0.0)
                QSBDLDX(LEAST(L),NX)=MIN(QSBDLDX(LEAST(L),NX),0.0)
                QSBDLDY(LN,NX)=MIN(QSBDLDY(LN,NX),0.0)
                QSBDLDOT(L ,NX)=0.
                SNDFBL(L,NX)=DXYIP(L)*(QSBDLDX(LEAST(L),NX)
     &              -QSBDLDX(L,NX)+QSBDLDY(LN,NX)-QSBDLDY(L,NX)
     &              +QSBDLDOT(L,NX)-QSBDLDIN(L,NX))

                ! *** Reduce Suspended Load Flux
                SNDF(L,0,NX)=DELTI*SNDB(L,KBT(L),NX)
                SND(L,1,NX)=SNDS(L,1,NX)+(SNDF(L,0,NX)-
     &                                    SNDF(L,1,NX))*WVEL
              ELSE
                ! *** Reduce Bedload Flux
                SNDBTMP=SNDBTMP/DELT
                FLUXFAC=SNDBTMP/SNDFBL(L,NX)

                IF(QSBDLDX(L,NX).LT.0.)
     &                 QSBDLDX(L,NX)=FLUXFAC*QSBDLDX(L,NX)
                IF(QSBDLDY(L,NX).LT.0.)
     &                 QSBDLDY(L,NX)=FLUXFAC*QSBDLDY(L,NX)
                QSBDLDOT(L ,NX)=FLUXFAC*QSBDLDOT(L ,NX)

                ! *** Update final Bedload Flux
                SNDFBL(L,NX)=SNDBTMP-QSBDLDIN(L ,NX)
              ENDIF
              SNDBTMP=0.0
              ! *** PMC End Block
            ENDIF
            SNDB1(L,KBT(L),NX)=S3TL*SNDB(L,KBT(L),NX)
     &          +S2TL*SNDB1(L,KBT(L),NX)
            SNDB(L,KBT(L),NX)=SNDBTMP
            SNDF(L,0,NX)=SNDF(L,0,NX)+SNDFBL(L,NX)
            QSBDTOP(L)=QSBDTOP(L)+DSEDGMM*SNDF(L,0,NX)
            QWBDTOP(L)=QWBDTOP(L)+DSEDGMM*
     &          ( VDRBED(L,KBT(L))*MAX(SNDF(L,0,NX),0.)
     &          +VDRDEPO(NS)*MIN(SNDF(L,0,NX),0.) )
          ENDDO
C
C----------------------------------------------------------------------C
C
C **  ANTI-DIFFUSION OF NONCOHESIVE SEDIMENT  KC.EQ.3
C
          IF(ISTOPT(7).EQ.1)THEN
C
            DO K=1,2
              DO L=2,LA
                CRNUM=1.+DELT*WSETA(L,K,NS)*HPI(L)*DZIC(K+1)
                GRADSED=(SND(L,K+1,NX)-SND(L,K,NX))/(DZC(K+1)+DZC(K))
                SEDAVG=0.5*(SND(L,K+1,NX)-SND(L,K,NX)+1.E-16)
                WSETA(L,K,NS)=-CRNUM*DZC(K+1)*WSETA(L,K,NS)*GRADSED/
     &              SEDAVG
              ENDDO
            ENDDO
C
C     TVAR1S=LOWER DIAGONAL
            DO L=2,LA
              TVAR1S(L,1)=0
            ENDDO
            DO K=2,KC
              DO L=2,LA
                TVAR1S(L,K)=MIN(WSETA(L,K-1,NS),0.)
              ENDDO
            ENDDO
C     TVAR1N=UPPER DIAGONAL
            DO L=2,LA
              TVAR1N(L,KC)=0
            ENDDO
            DO K=1,KS
              DO L=2,LA
                TVAR1N(L,K)=-MAX(WSETA(L,K,NS),0.)
              ENDDO
            ENDDO
C     TVAR1W=MAIN DIAGONAL
            DO L=2,LA
              TVAR1W(L,1)=DELTI*DZC(1)*HP(L)-MIN(WSETA(L,1,NS),0.)
              TVAR1W(L,KC)=DELTI*DZC(KC)*HP(L)+MAX(WSETA(L,KC-1,NS),0.)
            ENDDO
            DO K=2,KS
              DO L=2,LA
                TVAR1W(L,K)=DELTI*DZC(KC)*HP(L)+MAX(WSETA(L,K-1,NS),0.)
     &              -MIN(WSETA(L,K,NS),0.)
              ENDDO
            ENDDO
C     TVAR1E=RIGHT HAND SIDE
            DO K=1,KC
              DO L=2,LA
                TVAR1E(L,K)=DELTI*DZC(KC)*HP(L)*SND(L,K,NX)
              ENDDO
            ENDDO
C
C     TVAR3S=BET,TVAR2N=U,TVAR2S=GAM ARE WORKING ARRAYS
            DO L=2,LA
              TVAR3S(L)=TVAR1W(L,1)
            ENDDO
            DO L=2,LA
              TVAR2N(L,1)=TVAR1E(L,1)/TVAR3S(L)
            ENDDO
            DO K=2,KC
              DO L=2,LA
                TVAR2S(L,K)=TVAR1N(L,K-1)/TVAR3S(L)
                TVAR3S(L)=TVAR1W(L,K)-TVAR1S(L,K)*TVAR2S(L,K)
                TVAR2N(L,K)=(TVAR1E(L,K)-TVAR1S(L,K)*TVAR2N(L,K-1))/
     &              TVAR3S(L)
              ENDDO
            ENDDO
            DO K=KS,1,-1
              DO L=2,LA
                TVAR2N(L,K)=TVAR2N(L,K)-TVAR2S(L,K+1)*TVAR2N(L,K+1)
              ENDDO
            ENDDO
            DO K=1,KC
              DO L=2,LA
                SND(L,K,NX)=TVAR2N(L,K)
              ENDDO
            ENDDO
C
          ENDIF
C
C----------------------------------------------------------------------C
C
C **  FINAL FLUX KC=3
C
          DO L=2,LA
            SNDF(L,KC-1,NX)=DELTI*DZC(KC)*HP(L)*(SND(L,KC,NX)
     &          -SNDS(L,KC,NX))
          ENDDO
          DO L=2,LA
            SNDF(L,1,NX)=DELTI*DZC(KC-1)*HP(L)*(SND(L,KC-1,NX)
     &          -SNDS(L,KC-1,NX))+SNDF(L,KC-1,NX)
          ENDDO
C
C----------------------------------------------------------------------C
C
        ENDDO
      ENDIF
C
C**********************************************************************C
C
C **  NONCOHESIVE SEDIMENT, KC.GT.3 (THREE OR MORE LAYERS IN VERTICAL)
C
      IF(ISTRAN(7).GE.1.AND.KC.GT.3)THEN
        DO NX=1,NSND
          NS=NX+NSED
          DSEDGMM=1./(1.E6*SSG(NS))
          DIASED=SEDDIA(NS)
          DIASED3=3.*DIASED
          GPDIASED=G*(SSG(NS)-1.)*DIASED
C
C----------------------------------------------------------------------C
C
C **  SET SETTLING VELOCITIES
C
          IF(ISNDVW.EQ.0)THEN
            DO K=0,KS
              DO L=2,LA
                WSETA(L,K,NS)=WSEDO(NS)
              ENDDO
            ENDDO
          ENDIF
C
          IF(ISNDVW.GE.1)THEN
            DO K=0,KS
              DO L=2,LA
                WSETA(L,K,NS)=WSEDO(NS)*
     &              CSNDSET(SNDT(L,K+1),SDEN(NS),ISNDVW)
              ENDDO
            ENDDO
          ENDIF
C
          IF(IROUSE(NX).EQ.0)THEN
            DO L=2,LA
              IF(USTAR(L).GT.0.0) THEN
                ROUSE(L)=WSETA(L,0,NS)/(VKC*USTAR(L))
              ELSE
                ROUSE(L)=250000.*WSETA(L,0,NS)
              END IF
            ENDDO
          ELSE
            DO L=2,LA
              IF(USTARSND(L).GT.0.0) THEN
                ROUSE(L)=WSETA(L,0,NS)/(VKC*USTARSND(L))
              ELSE
                ROUSE(L)=250000.*WSETA(L,0,NS)
              END IF
            ENDDO
          ENDIF
C
C----------------------------------------------------------------------C
C
          DO L=1,LC
            QSBDLDP(L)=0.
            QSBDLDX(L,NX)=0.
            QSBDLDY(L,NX)=0.
            QSBDLDOT(L,NX)=0.
            QSBDLDIN(L,NX)=0.
            SNDFBL(L,NX)=0.
            RBPSBL(L)=1.0
          ENDDO
C
          CALL BEDLOAD(NX,NS)
C
C----------------------------------------------------------------------C
C
C **  HORIZONTAL LOOP
C
          K=KC
          DO L=2,LA
            SNDF(L,K,NX)=0.
            WVEL=DELT*HPI(L)*DZIC(K)
            CLEFT=1.+WSETA(L,K-1,NS)*WVEL
            CRIGHT=MAX(SND(L,K,NX),0.)
            SND(L,K,NX)=CRIGHT/CLEFT
            SNDF(L,K-1,NX)=-WSETA(L,K-1,NS)*SND(L,K,NX)
          ENDDO
C
          DO K=KS,2,-1
            DO L=2,LA
              WVEL=DELT*HPI(L)*DZIC(K)
              CLEFT=1.+WSETA(L,K-1,NS)*WVEL
              CRIGHT=MAX(SND(L,K,NX),0.)-SNDF(L,K,NX)*WVEL
              SND(L,K,NX)=CRIGHT/CLEFT
              SNDF(L,K-1,NX)=-WSETA(L,K-1,NS)*SND(L,K,NX)
            ENDDO
          ENDDO
C
          DO L=2,LA
            FACSUSL(L)=FSEDMODE(WSETA(L,0,NS),USTAR(L),USTARSND(L),
     &          RSNDM(NX),ISNDM1(NX),ISNDM2(NX),2)
          ENDDO
C
          DO L=2,LA
c            SNDF(L,1,NX)=0.
            PROBDEP=0.
            WESE=0.
C **  SET MAXIMUM EROSION RATE
            WESEMX=DELTI*CTMPDRY(L)*SNDB(L,KBT(L),NX)-SNDFBL(L,NX)
            WESEMX=MAX(WESEMX,0.)
C **  SET ROUSE PARAMETER AND EQUILIBRUIM CONCENTRATION
            ZEQ(L)=CSNDZEQ(DIASED,GPDIASED,TAUR(NS),TAUBSND(L),
     &        SEDDIA50(L,KBT(L)),HP(L),ISNDEQ(NS),SSG(NS),WSETA(L,0,NS))
            ZEQMIN=0.5*DZC(1)
            ZEQ(L)=MIN(ZEQ(L),ZEQMIN)
            ZEQD(L)=ZEQ(L)/DZC(1)
            ZEQDI(L)=1./ZEQD(L)
            WSFAC=1.
            SIGP=SIGPHI(L,KBT(L))
            SNDEQB(L)=CSNDEQC(DIASED,SSG(NS),WSETA(L,0,NS),TAUR(NS),
     &          TAUBSND(L),SEDDIA50(L,KBT(L)),SIGP,ZEQ(L),ISNDEQ(NS)
     &          ,ISNDAL)
C
C **  APPLIED LIMITOR TO GARCIA AND PARKER
C
            IF(ISNDEQ(NS).EQ.1)THEN
              IF(ISLTAUC(NS).EQ.1)THEN
                CSHIELDS=TCSHIELDS(NS)
                IF(ISEDEFF.EQ.2)THEN
                  TMPVAL=1.+(COEHEFF2-1.)
     &                *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
                  CSHIELDS=TMPVAL*CSHIELDS
                ENDIF
                SHIELDS=TAUBSND(L)/GPDIASED
                IF(SHIELDS.LT.CSHIELDS) SNDEQB(L)=0.
              ENDIF
              IF(ISLTAUC(NS).EQ.2)THEN
                CSHIELDS=SEDDIA50(L,KBT(L))*CSHIELDS50(L)/DIASED
                IF(ISEDEFF.EQ.2)THEN
                  TMPVAL=1.+(COEHEFF2-1.)
     &                *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
                  CSHIELDS=TMPVAL*CSHIELDS
                ENDIF
                SHIELDS=TAUBSND(L)/GPDIASED
                IF(SHIELDS.LT.CSHIELDS) SNDEQB(L)=0.
              ENDIF
              IF(ISLTAUC(NS).EQ.3)THEN
                CSHIELDS=0.03*((PHID(L,NX)/PEXP(L,NX))**0.6)
                IF(ISEDEFF.EQ.2)THEN
                  TMPVAL=1.+(COEHEFF2-1.)
     &                *( 1.-EXP(-COEHEFF*FRACCOH(L,KBT(L))) )
                  CSHIELDS=TMPVAL*CSHIELDS
                ENDIF
                SHIELDS=TAUBSND(L)/GPDIASED
                IF(SHIELDS.LT.CSHIELDS) SNDEQB(L)=0.
              ENDIF
            ENDIF
C
            IF(ISEDEFF.EQ.1)
     &          SNDEQB(L)=SNDEQB(L)*EXP(-COEHEFF*FRACCOH(L,KBT(L)))
C
            IF(ROUSE(L).LT.0.999.OR.ROUSE(L).GT.1.001)THEN
              TOP=(ZEQD(L)**(ROUSE(L)-1.))-1.
              BOT=(1.-ROUSE(L))*(ZEQDI(L)-1.)
              SNDEQ(L)=SNDEQB(L)*TOP/BOT
              SNDEQ(L)=FACSUSL(L)*VFRBED(L,KBT(L),NS)*MAX(SNDEQ(L),0.)
            ELSE
              TOP=LOG(ZEQDI(L))
              BOT=(ZEQDI(L)-1.)
              SNDEQ(L)=SNDEQB(L)*TOP/BOT
              SNDEQ(L)=FACSUSL(L)*VFRBED(L,KBT(L),NS)*MAX(SNDEQ(L),0.)
            ENDIF
C **  SET RESUSPENSION FLUX
            WESE=WSFAC*CTMPDRY(L)*WSETA(L,0,NS)*SNDEQ(L)
C **  SET DEPOSITION VELOCITY
            WSETMP=WSFAC*WSETA(L,0,NS)
            WVEL=DELT*HPI(L)*DZIC(1)
            CLEFT=1.+WSETMP*WVEL
            CRIGHT=MAX(SND(L,1,NX),0.)+(WESE-SNDF(L,1,NX))*WVEL
            SND(L,1,NX)=CRIGHT/CLEFT
            SNDF(L,0,NX)=-WSETMP*SND(L,1,NX)+WESE
            SNDBTMP=SNDB(L,KBT(L),NX)-DELT*SNDF(L,0,NX)
     &          -DELT*SNDFBL(L,NX)
C **  ADDED BED LOAD FLUX TO SUSPENDED LOAD FLUX WITH ABOVE LINE
            IF(SNDBTMP.LT.0.0)THEN
              ! *** PMC Begin Block
              ! *** Adjust bedload flux, trying to keep suspended load flux constant
              SNDBTMP=SNDB(L,KBT(L),NX)-DELT*SNDF(L,0,NX)
              LN=LNC(L)
              IF(SNDBTMP.LT.0.0)THEN
                ! *** Zero Bedload Outflux
                QSBDLDX(L,NX)=MAX(QSBDLDX(L,NX),0.0)
                QSBDLDY(L,NX)=MAX(QSBDLDY(L,NX),0.0)
                QSBDLDX(LEAST(L),NX)=MIN(QSBDLDX(LEAST(L),NX),0.0)
                QSBDLDY(LN,NX)=MIN(QSBDLDY(LN,NX),0.0)
                QSBDLDOT(L ,NX)=0.
                SNDFBL(L,NX)=DXYIP(L)*(QSBDLDX(LEAST(L),NX)
     &              -QSBDLDX(L,NX)+QSBDLDY(LN,NX)-QSBDLDY(L,NX)
     &              +QSBDLDOT(L,NX)-QSBDLDIN(L,NX))

                ! *** Reduce Suspended Load Flux
                SNDF(L,0,NX)=DELTI*SNDB(L,KBT(L),NX)
                SND(L,1,NX)=SNDS(L,1,NX)+(SNDF(L,0,NX)-
     &                                    SNDF(L,1,NX))*WVEL
              ELSE
                ! *** Reduce Bedload Flux
                SNDBTMP=SNDBTMP/DELT
                FLUXFAC=SNDBTMP/SNDFBL(L,NX)

                IF(QSBDLDX(L,NX).LT.0.)
     &                 QSBDLDX(L,NX)=FLUXFAC*QSBDLDX(L,NX)
                IF(QSBDLDY(L,NX).LT.0.)
     &                 QSBDLDY(L,NX)=FLUXFAC*QSBDLDY(L,NX)
                QSBDLDOT(L ,NX)=FLUXFAC*QSBDLDOT(L ,NX)

                ! *** Update final Bedload Flux
                SNDFBL(L,NX)=SNDBTMP-QSBDLDIN(L ,NX)
              ENDIF
              SNDBTMP=0.0
              ! *** PMC End Block
            ENDIF
            SNDB1(L,KBT(L),NX)=S3TL*SNDB(L,KBT(L),NX)
     &          +S2TL*SNDB1(L,KBT(L),NX)
            SNDB(L,KBT(L),NX)=SNDBTMP
            SNDF(L,0,NX)=SNDF(L,0,NX)+SNDFBL(L,NX)
            QSBDTOP(L)=QSBDTOP(L)+DSEDGMM*SNDF(L,0,NX)
            QWBDTOP(L)=QWBDTOP(L)+DSEDGMM*
     &          ( VDRBED(L,KBT(L))*MAX(SNDF(L,0,NX),0.)
     &          +VDRDEPO(NS)*MIN(SNDF(L,0,NX),0.) )
          ENDDO
C
C----------------------------------------------------------------------C
C
C **  ANTI-DIFFUSION OF NONCOHESIVE SEDIMENT  KC.GT.3
C
          IF(ISTOPT(7).EQ.1)THEN
C
            DO K=1,KS
              DO L=2,LA
                CRNUM=1.+DELT*WSETA(L,K,NS)*HPI(L)*DZIC(K+1)
                GRADSED=(SND(L,K+1,NX)-SND(L,K,NX))/(DZC(K+1)+DZC(K))
                SEDAVG=0.5*(SND(L,K+1,NX)-SND(L,K,NX)+1.E-16)
                WSETA(L,K,NS)=-CRNUM*DZC(K+1)*WSETA(L,K,NS)*GRADSED/
     &              SEDAVG
              ENDDO
            ENDDO
C
C     TVAR1S=LOWER DIAGONAL
            DO L=2,LA
              TVAR1S(L,1)=0
            ENDDO
            DO K=2,KC
              DO L=2,LA
                TVAR1S(L,K)=MIN(WSETA(L,K-1,NS),0.)
              ENDDO
            ENDDO
C     TVAR1N=UPPER DIAGONAL
            DO L=2,LA
              TVAR1N(L,KC)=0
            ENDDO
            DO K=1,KS
              DO L=2,LA
                TVAR1N(L,K)=-MAX(WSETA(L,K,NS),0.)
              ENDDO
            ENDDO
C     TVAR1W=MAIN DIAGONAL
            DO L=2,LA
              TVAR1W(L,1)=DELTI*DZC(1)*HP(L)-MIN(WSETA(L,1,NS),0.)
              TVAR1W(L,KC)=DELTI*DZC(KC)*HP(L)+MAX(WSETA(L,KC-1,NS),0.)
            ENDDO
            DO K=2,KS
              DO L=2,LA
                TVAR1W(L,K)=DELTI*DZC(KC)*HP(L)+MAX(WSETA(L,K-1,NS),0.)
     &              -MIN(WSETA(L,K,NS),0.)
              ENDDO
            ENDDO
C     TVAR1E=RIGHT HAND SIDE
            DO K=1,KC
              DO L=2,LA
                TVAR1E(L,K)=DELTI*DZC(KC)*HP(L)*SND(L,K,NX)
              ENDDO
            ENDDO
C
C     TVAR3S=BET,TVAR2N=U,TVAR2S=GAM ARE WORKING ARRAYS
            DO L=2,LA
              TVAR3S(L)=TVAR1W(L,1)
            ENDDO
            DO L=2,LA
              TVAR2N(L,1)=TVAR1E(L,1)/TVAR3S(L)
            ENDDO
            DO K=2,KC
              DO L=2,LA
                TVAR2S(L,K)=TVAR1N(L,K-1)/TVAR3S(L)
                TVAR3S(L)=TVAR1W(L,K)-TVAR1S(L,K)*TVAR2S(L,K)
                TVAR2N(L,K)=(TVAR1E(L,K)-TVAR1S(L,K)*TVAR2N(L,K-1))/
     &              TVAR3S(L)
              ENDDO
            ENDDO
            DO K=KS,1,-1
              DO L=2,LA
                TVAR2N(L,K)=TVAR2N(L,K)-TVAR2S(L,K+1)*TVAR2N(L,K+1)
              ENDDO
            ENDDO
            DO K=1,KC
              DO L=2,LA
                SND(L,K,NX)=TVAR2N(L,K)
              ENDDO
            ENDDO
C
          ENDIF
C
C----------------------------------------------------------------------C
C
C **  FINAL FLUX KC.GE.3
C
          DO L=2,LA
            SNDF(L,KS,NX)=DELTI*DZC(KC)*HP(L)*
     &          (SND(L,KC,NX)-SNDS(L,KC,NX))
          ENDDO
C
          DO K=KS-1,1,-1
            DO L=2,LA
              SNDF(L,K,NX)=DELTI*DZC(K+1)*HP(L)*
     &            (SND(L,K+1,NX)-SNDS(L,K+1,NX))+SNDF(L,K+1,NX)
            ENDDO
          ENDDO
C
C----------------------------------------------------------------------C
C
        ENDDO
      ENDIF
C
C**********************************************************************C
C
      IF(DEBUG)THEN
        IFLAG=0
        DO NS=1,NSND
          DO K=1,KC
            DO L=2,LA
              IF(SND(L,K,NS).LT.0.)THEN
                IF(IFLAG.EQ.0)THEN
                  OPEN(1,FILE='NEGSEDSND.OUT',POSITION='APPEND')
                  IFLAG=1
                ENDIF
                WRITE(1,107)TIME,NS,IL(L),JL(L),K,SND(L,K,NS)
              ENDIF
            ENDDO
          ENDDO
        ENDDO
C
        DO NS=1,NSND
          DO L=2,LA
            IF(SNDB(L,KBT(L),NS).LT.0.)THEN
              IF(IFLAG.EQ.0)THEN
                OPEN(1,FILE='NEGSEDSND.OUT',POSITION='APPEND')
                IFLAG=1
              ENDIF
              WRITE(1,108)TIME,NS,IL(L),JL(L),KBT(L),SNDB(L,KBT(L),NS),
     &          SNDF(L,0,NS)

              SNDB(L,KBT(L),NS)=0.0

            ENDIF
          ENDDO
        ENDDO
C
        IF(IFLAG.EQ.1)CLOSE(1)
      ENDIF
C
C **  ACCUMULATE NET POSTIVE AND NEGATIVE NONCOHESIVE SEDIMENT FLUXES
C
      DO NS=1,NSND
        DO L=2,LA
          SNDFDTAP(L,NS)=SNDFDTAP(L,NS)+DELT*MAX(SNDF(L,0,NS),0.0)
          SNDFDTAN(L,NS)=SNDFDTAN(L,NS)+DELT*MIN(SNDF(L,0,NS),0.0)
        ENDDO
      ENDDO
C
  107 FORMAT(' TIME,NS,I,J,K,NEGSND = ',F12.4,4I5,4E13.4)
  108 FORMAT(' TIME,NS,I,J,NEGSNDB,SNDF = ',F12.4,4I5,4E13.4)
C
C**********************************************************************C
C
      RETURN
      END