subroutine z_tratur(dischy    ,nubnd     ,j         ,nmmaxj    ,nmmax     , &
                  & nmax      ,mmax      ,kmax      ,ltur      ,nto       , &
                  & icx       ,icy       ,kfs       ,kfu       ,kfv       , &
                  & kcs       ,mnbnd     ,s1        ,dps       ,u1        , &
                  & v1        ,w1        ,rtur0     ,rtur1     ,thick     , &
                  & sig       ,guu       ,gvv       ,guv       ,gvu       , &
                  & vicww     ,dicww     ,cfurou    ,cfvrou    ,z0urou    , &
                  & z0vrou    ,windsu    ,windsv    ,bruvai    ,dudz      , &
                  & dvdz      ,tkepro    ,tkedis    ,deltau    ,deltav    ,dfu       , &
                  & dfv       ,dis       ,hrms      ,uorb      ,tp        , &
                  & aak       ,bbk       ,cck       ,ddk       ,bdx       , &
                  & bux       ,bdy       ,buy       ,umea      ,vmea      , &
                  & ubnd      ,kdismx    , &
                  & hsurft    ,pkwav     ,kfsmin    ,kfsmn0    ,kfsmax    , &
                  & kfsmx0    ,kfuz1     ,kfvz1     ,dzs1      ,ueul      , &
                  & veul      ,gdp       )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: z_tratur.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/kernel/src/compute/z_tratur.f90 $
!!--description-----------------------------------------------------------------
!
! Computes transport in the u, v and w-direction of the turbulent kinetic energy
! and dissipation.
! The time integration is fully implicit. Timesplitting is used.
! In the first stage the horizontal advection and diffusion terms are
! implicitly. The systems of equations are decoupled in the vertical.
! A Gauss Seidel iterative solution method is used.
! In the second stage the vertical transport terms are integrated implicitly in
! combination with the source and sink terms.
!
! Sinks are treated implicitly and sources explicitly. The systems of equations
! are decoupled in the horizontal. In the vertical the tridiagonal systems
! of equations are solved by a double sweep.
!
! - Horizontal Advection in U-direction : implicit, first order upwind
! - Horizontal Advection in V-direction : implicit, first order upwind
! - Horizontal Diffusion                : not implemented,
!                                         dominated by numerical diffusion
! - Vertical Advection                  : implicit, first order upwind
! - Vertical Diffusion                  : implicit
! - Sources are integrated explicitly
! - Sinks are integrated implicitly
! - Production term contains only vertical gradients
! - Dissipation term is linearised to improve stability
! - Gauss Seidel iteration in the horizontal
!
! Comment:
! At the open boundaries a vertical equation is used to compute TKE and epsilon
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    use dfparall
    !
    use globaldata
    !
    implicit none
    !
    type(globdat),target :: gdp
    !
    ! The following list of pointer parameters is used to point inside the gdp structure
    !
    real(fp)               , pointer :: hdt
    real(fp)               , pointer :: rhow
    real(fp)               , pointer :: z0
    real(fp)               , pointer :: z0v
    real(fp)               , pointer :: vonkar
    real(fp)               , pointer :: vicmol
    integer                , pointer :: iro
    integer                , pointer :: irov
    integer                , pointer :: lundia
    real(fp)               , pointer :: cde
    real(fp)               , pointer :: cmukep
    real(fp)               , pointer :: cep1
    real(fp)               , pointer :: cep2
    real(fp)               , pointer :: cep3
    real(fp)               , pointer :: sigrho
    real(fp)               , pointer :: cewall
    real(fp)               , pointer :: ck
    logical                , pointer :: wave
!
! Global variables
!
    integer                                                      , intent(in)  :: icx    !  Increment in the X-dir., if ICX= NMAX then computation proceeds in the X-dir. If icx=1 then computation proceeds in the Y-dir.
    integer                                                      , intent(in)  :: icy    !  Increment in the Y-dir. (see ICX)
    integer                                                                    :: j      !  Begin pointer for arrays which have been transformed into 1D arrays. Due to the shift in the 2nd (M-) index, J = -2*NMAX + 1
    integer                                                      , intent(in)  :: kmax   !  Description and declaration in esm_alloc_int.f90
    integer                                                      , intent(in)  :: ltur   !  Description and declaration in esm_alloc_int.f90
    integer                                                      , intent(in)  :: mmax   !  Description and declaration in esm_alloc_int.f90
    integer                                                      , intent(in)  :: nmax   !  Description and declaration in esm_alloc_int.f90
    integer                                                      , intent(in)  :: nmmax  !  Description and declaration in dimens.igs
    integer                                                                    :: nmmaxj !  Description and declaration in dimens.igs
    integer                                                      , intent(in)  :: nto    !  Description and declaration in esm_alloc_int.f90
    integer                                                                    :: nubnd  !  Description and declaration in trisol.igs
    integer      , dimension(7, nto)                                           :: mnbnd  !  Description and declaration in esm_alloc_int.f90
    integer      , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: kcs    !  Description and declaration in esm_alloc_int.f90
    integer      , dimension(gdp%d%nmlb:gdp%d%nmub)                            :: kdismx
    integer      , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: kfs    !  Description and declaration in esm_alloc_int.f90
    integer      , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: kfsmax !  Description and declaration in esm_alloc_int.f90
    integer      , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: kfsmin !  Description and declaration in esm_alloc_int.f90
    integer      , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: kfsmn0 !  Description and declaration in iidim.f90
    integer      , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: kfsmx0 !  Description and declaration in esm_alloc_int.f90
    integer      , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: kfu    !  Description and declaration in esm_alloc_int.f90
    integer      , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: kfv    !  Description and declaration in esm_alloc_int.f90
    integer      , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)        , intent(in)  :: kfuz1  !  Description and declaration in esm_alloc_int.f90
    integer      , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)        , intent(in)  :: kfvz1  !  Description and declaration in esm_alloc_int.f90
    real(fp)     , dimension(2, ltur, 0:kmax, 2, nto)                          :: ubnd   !  Description and declaration in trisol.igs
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub,3)                          :: cfurou !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub,3)                          :: cfvrou !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)                            :: deltau !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)                            :: deltav !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)                            :: dfu    !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)                            :: dfv    !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub,4)                          :: dis    !  Description and declaration in esm_alloc_real.f90
    real(prec)   , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: dps    !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: guu    !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: guv    !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: gvu    !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: gvv    !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)                            :: hrms   !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)                            :: hsurft
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: s1     !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)                            :: tp     !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)                            :: uorb   !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: windsu !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: windsv !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: z0urou !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: z0vrou !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax)                    :: aak    !  Internal work array
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax)                    :: bbk    !  Internal work array
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax)      , intent(in)  :: bruvai !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax)                    :: cck    !  Internal work array
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax)                    :: ddk    !  Internal work array, diagonal space at (N,M,K)
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax)      , intent(in)  :: dicww  !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax)      , intent(in)  :: dudz   !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax)      , intent(in)  :: dvdz   !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax)                    :: pkwav
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax)      , intent(in)  :: vicww  !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax)      , intent(in)  :: w1     !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax, ltur), intent(in)  :: rtur0  !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax, ltur)              :: rtur1  !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: bdx    !  Internal work array, implicit coupling of concentration in (N,M,K)
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: bdy
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: bux    !  Internal work array, implicit coupling of concentration in (N,M,K) with layer concentration in (N,M+1,K)
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: buy
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)        , intent(in)  :: dzs1   !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: tkedis !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: tkepro !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)        , intent(in)  :: u1     !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)        , intent(in)  :: ueul   !  Eulerian velocity in X-direction (including Stokes drift)
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: umea   !  Mean horizontal velocity
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)        , intent(in)  :: v1     !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)        , intent(in)  :: veul   !  Eulerian velocity in Y-direction (including Stokes drift)
    real(fp)     , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: vmea   !  Mean horizontal velocity
    real(fp)     , dimension(kmax)                                             :: sig    !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(kmax)                                             :: thick  !  Description and declaration in esm_alloc_real.f90
    character(8)                                                               :: dischy !  Description and declaration in tricom.igs
!
! Local variables
!
    integer      :: ddb
    integer      :: icxy
    integer      :: k
    integer      :: kd
    integer      :: ken
    integer      :: kmaxx
    integer      :: kmin
    integer      :: kmmx
    integer      :: kminmax
    integer      :: kminmin
    integer      :: kmaxmax
    integer      :: kmaxmin
    integer      :: knd
    integer      :: knu
    integer      :: ku
    integer      :: kz
    integer      :: l
    integer      :: m
    integer      :: maxk
    integer      :: n
    integer      :: ndm
    integer      :: ndmd
    integer      :: nm
    integer      :: nmd
    integer      :: nmu
    integer      :: num
    integer      :: nm_pos     ! indicating the array to be exchanged has nm index at the 2nd place, e.g., dbodsd(lsedtot,nm)
    real(fp)     :: alfa
    real(fp)     :: bi
    real(fp)     :: buoflu
    real(fp)     :: cu
    real(fp)     :: cv
    real(fp)     :: deltas
    real(fp)     :: dfus
    real(fp)     :: dfvs
    real(fp)     :: dfdis
    real(fp)     :: difd
    real(fp)     :: difu
    real(fp)     :: du
    real(fp)     :: dv
    real(fp)     :: dx
    real(fp)     :: dy
    real(fp)     :: dz
    real(fp)     :: ee
    real(fp)     :: epsd
    real(fp)     :: epswav
    real(fp)     :: epswin
    real(fp)     :: fact
    real(fp)     :: h0
    real(fp)     :: hsurf
    real(fp)     :: laydep
    real(fp)     :: pransm
    real(fp)     :: rz
    real(fp)     :: s
    real(fp)     :: timest
    real(fp)     :: tkebot
    real(fp)     :: tkewin
    real(fp)     :: tkewav
    real(fp)     :: us
    real(fp)     :: utot
    real(fp)     :: uu
    real(fp)     :: vs
    real(fp)     :: vv
    real(fp)     :: uuu
    real(fp)     :: vcc
    real(fp)     :: viww
    real(fp)     :: vvv
    real(fp)     :: wdo
    real(fp)     :: wup
    real(fp)     :: www
    real(fp)     :: z0s
    real(fp)     :: zlev
    real(fp)     :: zw
!
    data epsd/1.E-20/
!
!! executable statements -------------------------------------------------------
!
    lundia      => gdp%gdinout%lundia
    cde         => gdp%gdturcoe%cde
    cmukep      => gdp%gdturcoe%cmukep
    cep1        => gdp%gdturcoe%cep1
    cep2        => gdp%gdturcoe%cep2
    cep3        => gdp%gdturcoe%cep3
    sigrho      => gdp%gdturcoe%sigrho
    cewall      => gdp%gdturcoe%cewall
    ck          => gdp%gdturcoe%ck
    rhow        => gdp%gdphysco%rhow
    z0          => gdp%gdphysco%z0
    z0v         => gdp%gdphysco%z0v
    vonkar      => gdp%gdphysco%vonkar
    vicmol      => gdp%gdphysco%vicmol
    iro         => gdp%gdphysco%iro
    irov        => gdp%gdphysco%irov
    hdt         => gdp%gdnumeco%hdt
    wave        => gdp%gdprocs%wave
    !
    ddb    = gdp%d%ddbound
    icxy   = max(icx, icy)
    timest = 2.0 * hdt
    ee     = exp(1.0)
    nm_pos = 1
    !
    ! first step : advection
    !
    do n = 1, nmax, 1
       do m = 1, mmax, 1
          nm = (n + ddb)*icy + (m + ddb)*icx - icxy
          if (kfs(nm) == 1) then
             nmd = nm - icx
             ndm = nm - icy
             do k = kfsmin(nm), kfsmax(nm) - 1
                umea(nm, k) = 0.25 * (u1(nm, k) + u1(nmd, k) + u1(nm, k + 1) + u1(nmd, k + 1))
                vmea(nm, k) = 0.25 * (v1(nm, k) + v1(ndm, k) + v1(nm, k + 1) + v1(ndm, k + 1))
             enddo
          endif
       enddo
    enddo
    !
    ! initialisation turbulent variables for new layers or resetting for dry layers
    !
    do nm = 1, nmmax
       if (kfs(nm) == 1) then
          kmaxmax = max(kfsmax(nm), kfsmx0(nm))
          kmaxmin = min(kfsmax(nm), kfsmx0(nm))
          kminmax = max(kfsmin(nm), kfsmn0(nm))
          kminmin = min(kfsmin(nm), kfsmn0(nm))
          do k = kfsmin(nm), kfsmax(nm)
             rtur1(nm, k, 1) = rtur0(nm, k, 1)
             if (ltur == 2) rtur1(nm, k, 2) = rtur0(nm, k, 2)
          enddo
          do k = kminmin, kfsmin(nm)-1
             rtur1(nm, k, 1) = 0.0
             if (ltur == 2) rtur1(nm, k, 2) = 0
          enddo
          do k = kfsmin(nm), kminmax-1
             rtur1(nm, k, 1) = rtur1(nm, kminmax, 1)
             if (ltur == 2) rtur1(nm, k, 2) = rtur1(nm, kminmax, 2)
          enddo
          do k = kfsmax(nm)+1, kmaxmax
             rtur1(nm, k, 1) = 0.0
             if (ltur == 2) rtur1(nm, k, 2) = 0
          enddo
          do k = kmaxmin+1, kfsmax(nm)
             rtur1(nm, k, 1) = rtur1(nm, kmaxmin, 1)
             if (ltur == 2) rtur1(nm, k, 2) = rtur1(nm, kmaxmin, 2)
          enddo
       endif
    enddo
    !
    ! user defined boundary conditions if nubnd <> 0
    ! in two directions
    !
    if (nubnd /= 0) then
       do l=1,ltur
          call usrbcc(j         ,nmmaxj    ,kmax      ,l         , &
                    & icx       ,icy       ,nto       ,ltur      , &
                    & mnbnd     ,ubnd      ,aak       ,bbk       ,cck       , &
                    & ddk       ,rtur0     ,rtur1    , gdp       )
       enddo
    endif
    !
    ! Delft3D-16494: NOT NECESSARY?
    !
    ! exchange rtur1 with neighbours for parallel runs
    !
    call dfexchg ( rtur1(:, :, 1), 1, kmax-1, dfloat, nm_pos, gdp )
    call dfexchg ( rtur1(:, :, 2), 1, kmax-1, dfloat, nm_pos, gdp )
    !
    ! advective transport
    !
    do n = 1, nmax, 1
       do m = 1, mmax, 1
          nm = (n + ddb)*icy + (m + ddb)*icx - icxy
          if (kcs(nm)*kfs(nm) == 1) then
             nmd = nm - icx
             ndm = nm - icy
             do k = kfsmin(nm), kfsmax(nm) - 1
                !
                ! mean horizontal velocities at layer interfaces
                !
                if (umea(nm, k) >= 0.0 .and. vmea(nm, k) >= 0.0) then
                   cu = real(kfuz1(nmd, k),fp) * umea(nm, k)                         &
                      & * timest / (gvu(nmd) + 1.0 - real(kfuz1(nmd, k),fp))
                   cv = real(kfvz1(ndm, k),fp) * vmea(nm, k)                         &
                      & * timest / (guv(ndm) + 1.0 - real(kfvz1(ndm, k),fp))
                   rtur1(nm, k, 1) = (rtur0(nm, k, 1) + cu*rtur1(nmd, k, 1)     &
                                   & + cv*rtur1(ndm, k, 1)) / (1.0 + cu + cv)
                   if (ltur == 2) then
                      rtur1(nm, k, 2) = (rtur0(nm, k, 2) + cu*rtur1(nmd, k, 2)  &
                                      & + cv*rtur1(ndm, k, 2)) / (1.0 + cu + cv)
                   endif
                endif
             enddo
          endif
       enddo
    enddo
    !
    ! exchange rtur1 with neighbours for parallel runs
    !
    call dfexchg ( rtur1(:, :, 1), 1, kmax-1, dfloat, nm_pos, gdp )
    call dfexchg ( rtur1(:, :, 2), 1, kmax-1, dfloat, nm_pos, gdp )
    !
    do n = nmax, 1, -1
       do m = mmax, 1, -1
          nm = (n + ddb)*icy + (m + ddb)*icx - icxy
          if (kcs(nm)*kfs(nm) == 1) then
             nmu = nm + icx
             num = nm + icy
             do k = kfsmin(nm), kfsmax(nm) - 1
                if (umea(nm, k) <= 0.0 .and. vmea(nm, k) <= 0.0) then
                   cu = real(kfuz1(nm, k),fp) * umea(nm, k)                          &
                      & * timest / (gvu(nm) + 1.0 - real(kfuz1(nm, k),fp))
                   cv = real(kfvz1(nm, k),fp) * vmea(nm, k)                          &
                      & * timest / (guv(nm) + 1.0 - real(kfvz1(nm, k),fp))
                   rtur1(nm, k, 1) = (rtur0(nm, k, 1) - cu*rtur1(nmu, k, 1)     &
                                   & - cv*rtur1(num, k, 1)) / (1.0 - cu - cv)
                   if (ltur == 2) then
                      rtur1(nm, k, 2) = (rtur0(nm, k, 2) - cu*rtur1(nmu, k, 2)  &
                                      & - cv*rtur1(num, k, 2)) / (1.0 - cu - cv)
                   endif
                endif
             enddo
          endif
       enddo
    enddo
    !
    ! exchange rtur1 with neighbours for parallel runs
    !
    call dfexchg ( rtur1(:, :, 1), 1, kmax-1, dfloat, nm_pos, gdp )
    call dfexchg ( rtur1(:, :, 2), 1, kmax-1, dfloat, nm_pos, gdp )
    !
    do n = 1, nmax, 1
       do m = mmax, 1, -1
          nm = (n + ddb)*icy + (m + ddb)*icx - icxy
          if (kcs(nm)*kfs(nm) == 1) then
             nmu = nm + icx
             ndm = nm - icy
             do k = kfsmin(nm), kfsmax(nm) - 1
                if (umea(nm, k) <= 0.0 .and. vmea(nm, k) >= 0.0) then
                   cu = real(kfuz1(nm, k),fp) * umea(nm, k)                          &
                      & * timest / (gvu(nm) + 1.0 - real(kfuz1(nm, k),fp))
                   cv = real(kfvz1(ndm, k),fp) * vmea(nm, k)                         &
                      & * timest / (guv(ndm) + 1.0 - real(kfvz1(ndm, k),fp))
                   rtur1(nm, k, 1) = (rtur0(nm, k, 1) - cu*rtur1(nmu, k, 1)     &
                                   & + cv*rtur1(ndm, k, 1)) / (1.0 - cu + cv)
                   if (ltur == 2) then
                      rtur1(nm, k, 2) = (rtur0(nm, k, 2) - cu*rtur1(nmu, k, 2)  &
                                      & + cv*rtur1(ndm, k, 2)) / (1.0 - cu + cv)
                   endif
                endif
             enddo
          endif
       enddo
    enddo
    !
    ! exchange rtur1 with neighbours for parallel runs
    !
    call dfexchg ( rtur1(:, :, 1), 1, kmax-1, dfloat, nm_pos, gdp )
    call dfexchg ( rtur1(:, :, 2), 1, kmax-1, dfloat, nm_pos, gdp )
    !
    do n = nmax, 1, -1
       do m = 1, mmax, 1
          nm = (n + ddb)*icy + (m + ddb)*icx - icxy
          if (kcs(nm)*kfs(nm) == 1) then
             nmd = nm - icx
             num = nm + icy
             do k = kfsmin(nm), kfsmax(nm) - 1
                if (umea(nm, k) >= 0.0 .and. vmea(nm, k) <= 0.0) then
                   cu = real(kfuz1(nmd, k),fp) * umea(nm, k)                         &
                      & * timest / (gvu(nmd) + 1.0 - real(kfuz1(nmd, k),fp))
                   cv = real(kfvz1(nm, k),fp) * vmea(nm, k)                          &
                      & * timest / (guv(nm) + 1.0 - real(kfvz1(nm, k),fp))
                   rtur1(nm, k, 1) = (rtur0(nm, k, 1) + cu*rtur1(nmd, k, 1)     &
                                   & - cv*rtur1(num, k, 1)) / (1.0 + cu - cv)
                   if (ltur == 2) then
                      rtur1(nm, k, 2) = (rtur0(nm, k, 2) + cu*rtur1(nmd, k, 2)  &
                                      & - cv*rtur1(num, k, 2)) / (1.0 + cu - cv)
                   endif
                endif
             enddo
          endif
       enddo
    enddo
    !
    ! exchange rtur1 with neighbours for parallel runs
    !
    call dfexchg ( rtur1(:, :, 1), 1, kmax-1, dfloat, nm_pos, gdp )
    call dfexchg ( rtur1(:, :, 2), 1, kmax-1, dfloat, nm_pos, gdp )
    !
    ! production term (only vertical gradients)
    !
    do nm = 1, nmmax
       if (kfs(nm) == 1) then
          nmd = nm - icx
          ndm = nm - icy
          do k = kfsmin(nm), kfsmax(nm) - 1
             bdy(nm, k) =   0.5 * (dudz(nm, k)**2 + dudz(nmd, k)**2)              &
                        & / max(1, kfuz1(nmd, k) + kfuz1(nm, k))                  &
                        & + 0.5 * (dvdz(nm, k)**2 + dvdz(ndm, k)**2)              &
                        & / max(1, kfvz1(ndm, k) + kfvz1(nm, k))
          enddo
       endif
    enddo
    !
    ! production term (only horizontal gradients if IROV=1)
    !
    if (irov > 0) then
       do nm = 1, nmmax
          if (kfs(nm)*kcs(nm) == 1) then
             nmu = nm + icx
             num = nm + icy
             nmd = nm - icx
             ndm = nm - icy
             dx  = 0.5 * (gvv(nm) + gvv(ndm))
             dy  = 0.5 * (guu(nm) + guu(nmd))
             do k = kfsmin(nm), kfsmax(nm)
                bdx(nm, k) =   ((u1(nm, k) - u1(nmd, k))/dx)**2       &
                           & + ((v1(nm, k) - v1(ndm, k))/dy)**2
             enddo
          else
             do k = kfsmin(nm), kfsmax(nm)
                bdx(nm, k) = 0.0
             enddo
          endif
       enddo
       do nm = 1, nmmax
          nmu = nm + icx
          num = nm + icy
          nmd = nm - icx
          ndm = nm - icy
          kz  = kfv(nm) * kfv(nmu) * kfu(nm) * kfu(num)
          if (kz == 1) then
             dx = 0.5 * (gvv(nm) + gvv(nmu))
             dy = 0.5 * (guu(nm) + guu(num))
             do k = kfsmin(nm), kfsmax(nm)
                bux(nm, k) = ((u1(num, k) - u1(nm, k))/dy + (v1(nmu, k) - v1(nm,k))/dx)**2
             enddo
          else
             do k = kfsmin(nm), kfsmax(nm)
                bux(nm, k) = 0.0
             enddo
          endif
       enddo
       do nm = 1, nmmax
          if (kcs(nm)*kfs(nm) == 1) then
             nmd  = nm - icx
             ndm  = nm - icy
             ndmd = nm - icx - icy
             do k = kfsmin(nm), kfsmax(nm) - 1
                bdy(nm, k) = bdy(nm, k) + 0.5*(bdx(nm, k) + bdx(nm, k + 1))            &
                           & + ((bux(nm  , k    ) + bux(nmd , k    ) + bux(ndm, k    ) &
                           & +   bux(ndmd, k    ) + bux(nm  , k + 1) + bux(nmd, k + 1) &
                           & +   bux(ndm , k + 1) + bux(ndmd, k + 1))/16.0)
             enddo
          endif
       enddo
    endif
    do l = 1, ltur
       !
       ! Second step : vertical advection, diffusion, production and diffusion
       !
       if (l == 1) pransm = 1.0
       if (l == 2) pransm = 1.3
       !
       do nm = 1, nmmax
          if (kfs(nm) /= 0) then
             do k = kfsmin(nm) - 1, kfsmax(nm)
                aak(nm, k) = 0.0
                bbk(nm, k) = 1.0 / timest
                cck(nm, k) = 0.0
             enddo
          endif
       enddo
       do nm = 1, nmmax
          do k = kfsmin(nm), kfsmax(nm) - 1
             ddk(nm, k) = rtur1(nm, k, l) / timest
          enddo
       enddo
       do nm = 1, nmmax
          do k = kfsmin(nm), kfsmax(nm) - 1
             ku = k + 1
             !
             ! ADVECTION IN VERTICAL DIRECTION
             !
             if (kfs(nm)*kcs(nm) == 1) then
                h0  = max(0.01_fp, s1(nm) + real(dps(nm),fp))
                www = w1(nm, k)
                wdo = 0.5 * (www + abs(www)) / dzs1(nm, k)
                wup = 0.5 * (www - abs(www)) / dzs1(nm, ku)
                if (k == kfsmin(nm)) wdo = 0.0
                aak(nm, k) = -wdo
                bbk(nm, k) = 1.0/timest + wdo - wup
                cck(nm, k) = wup
                ddk(nm, k) = rtur1(nm, k, l) / timest
             endif
          enddo
       enddo
       !
       do nm = 1, nmmax
          do k = kfsmin(nm), kfsmax(nm) - 1
             ku = k + 1
             kd = k - 1
             if (l == 2 .and. k == kfsmin(nm)) then
                knd = kd
                vcc = 0.0
             else
                knd = k
                vcc = vicmol
             endif
             if (l == 2 .and. k == kfsmax(nm) - 1) then
                knu = ku
             else
                knu = k
             endif
             !
             ! DIFFUSION IN VERTICAL DIRECTION
             !
             if (kfs(nm) == 1) then
                dz         = 0.5 * (dzs1(nm, k) + dzs1(nm, k + 1))
                difu       = (vicmol + 0.5*(vicww(nm, knu) + vicww(nm, ku ))/pransm) / (dzs1(nm, ku)*dz)
                difd       = (vcc    + 0.5*(vicww(nm, kd ) + vicww(nm, knd))/pransm) / (dzs1(nm, k )*dz)
                aak(nm, k) = aak(nm, k)        - difd
                bbk(nm, k) = bbk(nm, k) + difu + difd
                cck(nm, k) = cck(nm, k) - difu
             endif
          enddo
       enddo
       !
       ! source and sink terms
       !
       if (l == 1) then
          !
          ! buoyancy term
          !
          do nm = 1, nmmax
             do k = kfsmin(nm), kfsmax(nm) - 1
                if (kfs(nm) == 1) then
                   buoflu     = vicww(nm, k) * bruvai(nm, k) / sigrho
                   ddk(nm, k) = ddk(nm, k) - min(0.0_fp, buoflu)
                   bbk(nm, k) = bbk(nm, k) + max(0.0_fp, buoflu)/max(rtur0(nm, k, 1), epsd)
                endif
             enddo
          enddo
          !
          ! production term horizontal and vertical gradients
          !
          do nm = 1, nmmax
             if (kfs(nm) == 1) then
                pkwav(nm, kfsmin(nm)) = 0.
                pkwav(nm, kfsmax(nm)) = 0.
                !
                do k = kfsmin(nm)+1, kfsmax(nm)-1
                   !
                   ! Reset pkwav tke sources due to waves
                   !
                   pkwav(nm, k   )       = 0.
                   !
                   ddk(nm, k) = ddk(nm, k) + 2*(vicmol + vicww(nm, k))*bdy(nm, k)
                enddo
             endif
          enddo
          !
          ! production term due to breaking of waves
          !
          ! first: determine length (vertical) of distribution of
          !        turbulent energy and fill production term in right hand side
          !
          if (wave) then
             do nm = 1, nmmax
                if (kfs(nm) == 1) then
                   h0                    = max(0.01_fp, s1(nm) + real(dps(nm),fp))
                   pkwav(nm, kfsmax(nm)) =  2.0_fp*(dis(nm,2)+dis(nm,3))/(rhow*max(hrms(nm),0.01_fp))
                   zw  = 0.0_fp
                   do k = kfsmax(nm)-1, kfsmin(nm), -1
                      zw  = zw  + dzs1(nm,k+1)
                      if (hrms(nm) > zw) then
                         pkwav(nm,k) = pkwav(nm,kfsmax(nm))*(1.0_fp - zw/(hrms(nm)))
                         ddk(nm,k)   = ddk(nm,k) + pkwav(nm, k)
                      else
                         kdismx(nm)=k+1
                         exit
                      endif
                   enddo
                endif
             enddo
          endif
          !
          ! Addition of wall production due to slip on vertical walls
          !
          ! !!!! Must still be changed from SIGMA implementation to Z !!!!
          !
          !if (irov == 1) then
          !   do k = 1, kmax - 1
          !      ku = k + 1
          !      do nm = 1, nmmax
          !         if (kfs(nm)*kcs(nm) == 1) then
          !            nmd = nm - icx
          !            ndm = nm - icy
          !            nmu = nm + icx
          !            num = nm + icy
          !            if (kcs(num) == 0) then
          !               uu = 0.25 * (u1(nm, k) + u1(nmd, k) + u1(nm, ku) + u1(nmd, ku))
          !               us = vonkar * uu / log((0.25*(guu(nm) + guu(nmd)) + z0v)/z0v)
          !               du = abs(us) / (0.25*(guu(nm) + guu(nmd)) + z0v)
          !               ddk(nm, k) = ddk(nm, k) + 0.5*du*us*us
          !               bdy(nm, k) = bdy(nm, k) + 0.5*du*du
          !            endif
          !            if (kcs(ndm) == 0) then
          !               uu = 0.25 * (u1(nm, k) + u1(nmd, k) + u1(nm, ku) + u1(nmd, ku))
          !               us = vonkar * uu / log((0.25*(guu(nm) + guu(nmd)) + z0v)/z0v)
          !               du = abs(us) / (0.25*(guu(nm) + guu(nmd)) + z0v)
          !               ddk(nm, k) = ddk(nm, k) + 0.5*du*us*us
          !               bdy(nm, k) = bdy(nm, k) + 0.5*du*du
          !            endif
          !            if (kcs(nmu) == 0) then
          !               vv = 0.25 * (v1(nm, k) + v1(ndm, k) + v1(nm, ku) + v1(ndm, ku))
          !               vs = vonkar * vv / log((0.25*(gvv(nm) + gvv(nmd)) + z0v)/z0v)
          !               dv = abs(vs) / (0.25*(guu(nm) + guu(nmd)) + z0v)
          !               ddk(nm, k) = ddk(nm, k) + 0.5*dv*vs*vs
          !               bdy(nm, k) = bdy(nm, k) + 0.5*dv*dv
          !            endif
          !            if (kcs(nmd) == 0) then
          !               vv = 0.25 * (v1(nm, k) + v1(ndm, k) + v1(nm, ku) + v1(ndm, ku))
          !               vs = vonkar * vv / log((0.25*(gvv(nm) + gvv(nmd)) + z0v)/z0v)
          !               dv = abs(vs) / (0.25*(guu(nm) + guu(nmd)) + z0v)
          !               ddk(nm, k) = ddk(nm, k) + 0.5*dv*vs*vs
          !               bdy(nm, k) = bdy(nm, k) + 0.5*dv*dv
          !            endif
          !         endif
          !      enddo
          !   enddo
          !endif
       else
          !
          ! EPSILON equation
          ! buoyancy term
          !
          do nm = 1, nmmax
             do k = kfsmin(nm), kfsmax(nm) - 1
                if (kfs(nm) == 1) then
                   if (bruvai(nm, k) < 0.0) then
                      !
                      ! in case of an unstable stratification CEP3 is set to zero
                      ! this means that the buoyancy flux is switched on
                      !
                      buoflu  = - vicww(nm, k) * bruvai(nm, k) / sigrho
                   else
                      !
                      ! in case of a stable stratification CEP3 is set to one
                      ! this means that the buoyancy flux is switched off
                      !
                      buoflu  = 0.0_fp
                   endif
                   ddk(nm, k) = ddk(nm, k) + cep1*buoflu*rtur0(nm, k, 2)/max(rtur0(nm, k, 1), epsd)
                endif
             enddo
          enddo
          !
          ! production term horizontal and vertical gradients
          !
          do nm = 1, nmmax
             nmd = nm - icx
             ndm = nm - icy
             do k = kfsmin(nm), kfsmax(nm) - 1
                if (kfs(nm) == 1) then
                   ddk(nm, k) = ddk(nm, k) + 2*cmukep*cep1*rtur1(nm, k, 1)*bdy(nm, k)
                endif
             enddo
          enddo
          if (wave) then
             do nm = 1, nmmax
                if (kfs(nm) == 1) then
                   !
                   ! production term breaking waves in epsilon
                   !
                   do k = kdismx(nm),kfsmax(nm)
                      ddk(nm, k) = ddk(nm, k) + cep1*pkwav(nm, k)*rtur0(nm, k, 2)/max(rtur0(nm, k, 1), epsd)
                   enddo
                   !
                   ! production term wave dissipation in bottom boundary layer
                   ! is switched off just as in the production of turb. kinetic energy
                   ! Already accounted for in increased z0 (in subroutine TAUBOT)
                   !
                endif
             enddo
          endif
       endif
       if (ltur == 1) then
          !
          ! dissipation in k-L model    (Newton linearisation)
          !
          do nm = 1, nmmax
             do k = kfsmin(nm), kfsmax(nm) - 1
                if (kfs(nm) == 1) then
                   viww       = vicmol + vicww(nm, k)
                   ddk(nm, k) = ddk(nm, k) +   cmukep*(rtur1(nm, k, 1)**2)/viww
                   bbk(nm, k) = bbk(nm, k) + 2*cmukep* rtur1(nm, k, 1)    /viww
                endif
             enddo
          enddo
       !
       ! dissipation k-epsilon model (Newton linearisation)
       !
       elseif (l == 1) then
          do nm = 1, nmmax
             do k = kfsmin(nm), kfsmax(nm) - 1
                if (kfs(nm) == 1) then
                   ddk(nm, k) = ddk(nm, k) +   rtur0(nm, k, 2)
                   bbk(nm, k) = bbk(nm, k) + 2*rtur0(nm, k, 2)/max(rtur0(nm, k, 1), epsd)
                endif
             enddo
          enddo
       else
          do nm = 1, nmmax
             do k = kfsmin(nm), kfsmax(nm) - 1
                if (kfs(nm) == 1) then
                   ddk(nm, k) = ddk(nm, k) +   cep2*(rtur0(nm, k, 2)**2) &
                              & /max(rtur0(nm, k, 1), epsd)
                   bbk(nm, k) = bbk(nm, k) + 2*cep2* rtur0(nm, k, 2)     &
                              & /max(rtur0(nm, k, 1), epsd)
                endif
             enddo
          enddo
       endif
       !
       ! vertical boundary conditions
       !
       if (l == 1) then
          !
          ! tke at free surface and bottom
          !
          do nm = 1, nmmax
             nmd = nm - icx
             ndm = nm - icy
             !
             ! at free surface
             !
             if (kfs(nm) == 1) then
                tkewin = sqrt((windsu(nm)**2 + windsv(nm)**2)/cmukep)/rhow
                aak(nm, kfsmax(nm)) = 0.0
                bbk(nm, kfsmax(nm)) = 1.0
                cck(nm, kfsmax(nm)) = 0.0
                ddk(nm, kfsmax(nm)) = tkewin
                !
                ! Added production due to waves
                !
                if (wave) then
                   !
                   ! Flux boundary type
                   !
                   h0     = max(0.01_fp, s1(nm) + real(dps(nm),fp))
                   !
                   epswav = 4.0_fp * (dis(nm,2)+dis(nm,3)) / (rhow*max(hrms(nm),0.01_fp))
                   !
                   ! Hrms/2 is the characteristic length scale for the wave dissipation
                   ! which can be compared to a Nikuradse length scale near the bottom
                   ! The roughness height due to wave breaking, needed in the boundary
                   ! condition for k is assumed to scale in the same fashion as z0 = ks/30:
                   ! (zw = 0.5_fp*hrms(nm)/30.0_fp)
                   !
                   tkewav = (epswav*vonkar*0.5*hrms(nm)/(30.0*cde))**(2.0/3.0)
                   !
                   ddk(nm, kfsmax(nm)) = ddk(nm, kfsmax(nm)) + tkewav
                endif
                !
                ! at bottom
                !
                aak(nm, kfsmin(nm) - 1) = 0.0
                bbk(nm, kfsmin(nm) - 1) = 1.0
                cck(nm, kfsmin(nm) - 1) = 0.0
                !
                ! ustar determined 1.5 grid space above bed
                !
                kmin = kfsmin(nm)
                if (kfsmin(nm) /= kfsmax(nm)) then
                   uuu = (ueul(nmd, kmin + 1) + ueul(nm, kmin + 1))                 &
                       & /max(1, kfuz1(nmd, kmin + 1) + kfuz1(nm, kmin + 1))
                   vvv = (veul(ndm, kmin + 1) + veul(nm, kmin + 1))                 &
                       & /max(1, kfvz1(ndm, kmin + 1) + kfvz1(nm, kmin + 1))
                   dz  = dzs1(nm, kmin) + 0.5*dzs1(nm, kmin + 1)
                else
                   uuu = (ueul(nmd, kmin) + ueul(nm, kmin))                         &
                       & /max(1, kfuz1(nmd, kmin) + kfuz1(nm, kmin))
                   vvv = (veul(ndm, kmin) + veul(nm, kmin))                         &
                       & /max(1, kfvz1(ndm, kmin) + kfvz1(nm, kmin))
                   dz  = dzs1(nm, kmin)/ee
                endif
                utot = sqrt(uuu*uuu + vvv*vvv)
                h0   = max(0.01_fp, s1(nm) + real(dps(nm),fp))
                ken  = kfu(nm) + kfu(nmd) + kfv(nm) + kfv(ndm)
                if (ken /= 0) then
                   z0s = ( kfu(nmd)*z0urou(nmd) + kfu(nm)*z0urou(nm) + kfv(ndm)*z0vrou(ndm)  &
                       & + kfv(nm )*z0vrou(nm ) ) / ken
                   !
                   rz                      = 1.0 + 1.0/z0s*dz
                   s                       = log(rz)/vonkar
                   ddk(nm, kfsmin(nm) - 1) = utot*utot/(s*s*sqrt(cmukep))
                   if (kfsmax(nm)/=kfsmin(nm)) then
                      aak(nm, kmin) = 0.0
                      bbk(nm, kmin) = 1.0
                      cck(nm, kmin) = 0.0
                      ddk(nm, kmin) = (1.0 - dzs1(nm, kmin)/h0)*ddk(nm, kmin - 1)
                   endif
                endif
             endif
          enddo
       endif
       !
       ! dissipation at free surface and bottom
       !
       if (l == 2) then
          do nm = 1, nmmax
             nmd = nm - icx
             ndm = nm - icy
             if (kfs(nm) /= 0 .and. kfsmax(nm) >= kfsmin(nm)) then
                !
                ! at free surface
                !
                h0                  = max(0.01_fp, s1(nm) + real(dps(nm),fp))
                zw                  = 0.5 * dzs1(nm, kfsmax(nm))
                tkewin              = sqrt((windsu(nm)**2 + windsv(nm)**2)/cmukep) / rhow
                epswin              = cewall * (tkewin**1.5) / zw
                aak(nm, kfsmax(nm)) = 0.0
                bbk(nm, kfsmax(nm)) = 1.0
                cck(nm, kfsmax(nm)) = 0.0
                ddk(nm, kfsmax(nm)) = epswin
                !
                ! Added production due to waves
                !
                if (wave) then
                   h0 = max(0.01_fp, s1(nm) + real(dps(nm),fp))
                   !
                   ! need to calculate tkewav in same manner as above
                   ! (note, for this pransm should = 1)
                   ! and then adjust for differences between k flux and epsilon flux
                   ! this should include the difference in pransm
                   !
                   epswav = 4.0_fp * (dis(nm,2)+dis(nm,3)) /(rhow*max(hrms(nm),0.01_fp))
                   !
                   ddk(nm, kfsmax(nm)) = ddk(nm, kfsmax(nm)) + epswav
                endif
                !
                ! at bottom
                !
                ! Neumann BC for Epsilon
                !
                kmin = kfsmin(nm)
                if (kfsmin(nm) /= kfsmax(nm)) then
                   uuu = (ueul(nmd, kmin + 1) + ueul(nm, kmin + 1))                 &
                       & /max(1, kfuz1(nmd, kmin + 1) + kfuz1(nm, kmin + 1))
                   vvv = (veul(ndm, kmin + 1) + veul(nm, kmin + 1))                 &
                       & /max(1, kfvz1(ndm, kmin + 1) + kfvz1(nm, kmin + 1))
                   dz = dzs1(nm, kmin) + 0.5*dzs1(nm, kmin + 1)
                else
                   uuu = (ueul(nmd, kmin) + ueul(nm, kmin))                         &
                       & /max(1, kfuz1(nmd, kmin) + kfuz1(nm, kmin))
                   vvv = (veul(ndm, kmin) + veul(nm, kmin))                         &
                       & /max(1, kfvz1(ndm, kmin) + kfvz1(nm, kmin))
                   dz = dzs1(nm, kmin) / ee
                endif
                utot  = sqrt(uuu*uuu + vvv*vvv)
                h0    = max(0.01_fp, s1(nm) + real(dps(nm),fp))
                ken   = kfu(nm) + kfu(nmd) + kfv(nm) + kfv(ndm)
                if (ken /= 0) then
                   z0s    = ( kfu(nmd)*z0urou(nmd) + kfu(nm)*z0urou(nm) + kfv(ndm)*z0vrou(ndm)  &
                          & + kfv(nm )*z0vrou(nm ) ) / ken
                   rz     = 1.0 + dz/z0s
                   s      = log(rz) / vonkar
                   tkebot = utot*utot/(s*s*sqrt(cmukep))
                   aak(nm, kmin - 1) = 0.0
                   bbk(nm, kmin - 1) = 1.0
                   cck(nm, kmin - 1) = 0.0
                   ddk(nm, kmin - 1) = cewall*tkebot**1.5/z0s
                   !
                   ! Only perform additional specification of boundary flux for epsilon
                   ! when more than 1 layer is active
                   !
                   if (kfsmax(nm) > kmin) then
                      aak(nm, kmin)     = 0.0
                      bbk(nm, kmin)     = 1.0
                      cck(nm, kmin)     = 0.0
                      ddk(nm, kmin)     = z0s * ddk(nm, kmin - 1) / (dzs1(nm, kmin)+z0s)
                   endif
                else
                   aak(nm, kmin - 1) = 0.0
                   bbk(nm, kmin - 1) = 1.0
                   cck(nm, kmin - 1) = 0.0
                   ddk(nm, kmin - 1) = 0.0
                endif
             endif
          enddo
       endif
       !
       ! Reset the system of equations in the Open Boundary Points
       ! with User Defined Boundary Conditions
       !
       if (nubnd /= 0) then
          call usrbcc(j         ,nmmaxj    ,kmax      ,l         , &
                    & icx       ,icy       ,nto       ,ltur      , &
                    & mnbnd     ,ubnd      ,aak       ,bbk       ,cck       , &
                    & ddk       ,rtur0     ,rtur1    , gdp       )
       endif
       !
       ! SOLUTION PROCEDURE SYSTEM OF EQUATIONS
       !
       do nm = 1, nmmax
          if (kfs(nm) /= 0) then
             maxk          = kfsmin(nm) - 1
             bi            = 1. / bbk(nm, maxk)
             bbk(nm, maxk) = bi
             cck(nm, maxk) = cck(nm, maxk) * bi
             ddk(nm, maxk) = ddk(nm, maxk) * bi
          endif
       enddo
       do nm = 1, nmmax
          do k = kfsmin(nm), kfsmax(nm)
             if (kfs(nm) == 1) then
                bi         = 1./(bbk(nm, k) - aak(nm, k)*cck(nm, k - 1))
                bbk(nm, k) = bi
                cck(nm, k) = cck(nm, k) * bi
                ddk(nm, k) = (ddk(nm, k) - aak(nm, k)*ddk(nm, k - 1)) * bi
             endif
          enddo
       enddo
       do nm = 1, nmmax
          if (kfsmax(nm) >= kfsmin(nm) .and. kfs(nm) == 1) then
             rtur1(nm, kfsmax(nm), l) = ddk(nm, kfsmax(nm))
          endif
       enddo
       do nm = 1, nmmax
          do k = kfsmax(nm) - 1, kfsmin(nm) - 1, -1
             if (kfs(nm) == 1) then
                rtur1(nm, k, l) = ddk(nm, k) - cck(nm, k)*rtur1(nm, k + 1, l)
             endif
          enddo
       enddo
       !
       ! Delft3D-16494: NOT NECESSARY? no implicit solve took place
       !
       ! exchange rtur1 with neighbours for parallel runs
       !
       call dfexchg ( rtur1(:, :, l), 0, kmax, dfloat, nm_pos, gdp )
    enddo
end subroutine z_tratur


      DOUBLE PRECISION FUNCTION DGAMLN(Z,IERR)
C***BEGIN PROLOGUE  DGAMLN
C***DATE WRITTEN   830501   (YYMMDD)
C***REVISION DATE  830501   (YYMMDD)
C***CATEGORY NO.  B5F
C***KEYWORDS  GAMMA FUNCTION,LOGARITHM OF GAMMA FUNCTION
C***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
C***PURPOSE  TO COMPUTE THE LOGARITHM OF THE GAMMA FUNCTION
C***DESCRIPTION
C
C               **** A DOUBLE PRECISION ROUTINE ****
C         DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR
C         Z.GT.0.  THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES
C         GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION
C         G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN.  THE FUNCTION WAS MADE AS
C         PORTABLE AS POSSIBLE BY COMPUTIMG ZMIN FROM THE NUMBER OF BASE
C         10 DIGITS IN A WORD, RLN=AMAX1(-ALOG10(R1MACH(4)),0.5E-18)
C         LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY.
C
C         SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100
C         VALUES IS USED FOR SPEED OF EXECUTION.
C
C     DESCRIPTION OF ARGUMENTS
C
C         INPUT      Z IS D0UBLE PRECISION
C           Z      - ARGUMENT, Z.GT.0.0D0
C
C         OUTPUT      DGAMLN IS DOUBLE PRECISION
C           DGAMLN  - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0
C           IERR    - ERROR FLAG
C                     IERR=0, NORMAL RETURN, COMPUTATION COMPLETED
C                     IERR=1, Z.LE.0.0D0,    NO COMPUTATION
C
C
C***REFERENCES  COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C                 BY D. E. AMOS, SAND83-0083, MAY, 1983.
C***ROUTINES CALLED  I1MACH,D1MACH
C***END PROLOGUE  DGAMLN
      DOUBLE PRECISION CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST,
     * T1, WDTOL, Z, ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ, D1MACH
      INTEGER I, IERR, I1M, K, MZ, NZ, I1MACH
      DIMENSION CF(22), GLN(100)
C           LNGAMMA(N), N=1,100
      DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7),
     1     GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14),
     2     GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20),
     3     GLN(21), GLN(22)/
     4     0.00000000000000000D+00,     0.00000000000000000D+00,
     5     6.93147180559945309D-01,     1.79175946922805500D+00,
     6     3.17805383034794562D+00,     4.78749174278204599D+00,
     7     6.57925121201010100D+00,     8.52516136106541430D+00,
     8     1.06046029027452502D+01,     1.28018274800814696D+01,
     9     1.51044125730755153D+01,     1.75023078458738858D+01,
     A     1.99872144956618861D+01,     2.25521638531234229D+01,
     B     2.51912211827386815D+01,     2.78992713838408916D+01,
     C     3.06718601060806728D+01,     3.35050734501368889D+01,
     D     3.63954452080330536D+01,     3.93398841871994940D+01,
     E     4.23356164607534850D+01,     4.53801388984769080D+01/
      DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28),
     1     GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34),
     2     GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40),
     3     GLN(41), GLN(42), GLN(43), GLN(44)/
     4     4.84711813518352239D+01,     5.16066755677643736D+01,
     5     5.47847293981123192D+01,     5.80036052229805199D+01,
     6     6.12617017610020020D+01,     6.45575386270063311D+01,
     7     6.78897431371815350D+01,     7.12570389671680090D+01,
     8     7.46582363488301644D+01,     7.80922235533153106D+01,
     9     8.15579594561150372D+01,     8.50544670175815174D+01,
     A     8.85808275421976788D+01,     9.21361756036870925D+01,
     B     9.57196945421432025D+01,     9.93306124547874269D+01,
     C     1.02968198614513813D+02,     1.06631760260643459D+02,
     D     1.10320639714757395D+02,     1.14034211781461703D+02,
     E     1.17771881399745072D+02,     1.21533081515438634D+02/
      DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50),
     1     GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56),
     2     GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62),
     3     GLN(63), GLN(64), GLN(65), GLN(66)/
     4     1.25317271149356895D+02,     1.29123933639127215D+02,
     5     1.32952575035616310D+02,     1.36802722637326368D+02,
     6     1.40673923648234259D+02,     1.44565743946344886D+02,
     7     1.48477766951773032D+02,     1.52409592584497358D+02,
     8     1.56360836303078785D+02,     1.60331128216630907D+02,
     9     1.64320112263195181D+02,     1.68327445448427652D+02,
     A     1.72352797139162802D+02,     1.76395848406997352D+02,
     B     1.80456291417543771D+02,     1.84533828861449491D+02,
     C     1.88628173423671591D+02,     1.92739047287844902D+02,
     D     1.96866181672889994D+02,     2.01009316399281527D+02,
     E     2.05168199482641199D+02,     2.09342586752536836D+02/
      DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72),
     1     GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78),
     2     GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84),
     3     GLN(85), GLN(86), GLN(87), GLN(88)/
     4     2.13532241494563261D+02,     2.17736934113954227D+02,
     5     2.21956441819130334D+02,     2.26190548323727593D+02,
     6     2.30439043565776952D+02,     2.34701723442818268D+02,
     7     2.38978389561834323D+02,     2.43268849002982714D+02,
     8     2.47572914096186884D+02,     2.51890402209723194D+02,
     9     2.56221135550009525D+02,     2.60564940971863209D+02,
     A     2.64921649798552801D+02,     2.69291097651019823D+02,
     B     2.73673124285693704D+02,     2.78067573440366143D+02,
     C     2.82474292687630396D+02,     2.86893133295426994D+02,
     D     2.91323950094270308D+02,     2.95766601350760624D+02,
     E     3.00220948647014132D+02,     3.04686856765668715D+02/
      DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94),
     1     GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/
     2     3.09164193580146922D+02,     3.13652829949879062D+02,
     3     3.18152639620209327D+02,     3.22663499126726177D+02,
     4     3.27185287703775217D+02,     3.31717887196928473D+02,
     5     3.36261181979198477D+02,     3.40815058870799018D+02,
     6     3.45379407062266854D+02,     3.49954118040770237D+02,
     7     3.54539085519440809D+02,     3.59134205369575399D+02/
C             COEFFICIENTS OF ASYMPTOTIC EXPANSION
      DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8),
     1     CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15),
     2     CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/
     3     8.33333333333333333D-02,    -2.77777777777777778D-03,
     4     7.93650793650793651D-04,    -5.95238095238095238D-04,
     5     8.41750841750841751D-04,    -1.91752691752691753D-03,
     6     6.41025641025641026D-03,    -2.95506535947712418D-02,
     7     1.79644372368830573D-01,    -1.39243221690590112D+00,
     8     1.34028640441683920D+01,    -1.56848284626002017D+02,
     9     2.19310333333333333D+03,    -3.61087712537249894D+04,
     A     6.91472268851313067D+05,    -1.52382215394074162D+07,
     B     3.82900751391414141D+08,    -1.08822660357843911D+10,
     C     3.47320283765002252D+11,    -1.23696021422692745D+13,
     D     4.88788064793079335D+14,    -2.13203339609193739D+16/
C
C             LN(2*PI)
      DATA CON                    /     1.83787706640934548D+00/
C
C***FIRST EXECUTABLE STATEMENT  DGAMLN
      IERR=0
      IF (Z.LE.0.0D0) GO TO 70
      IF (Z.GT.101.0D0) GO TO 10
      NZ = INT(SNGL(Z))
      FZ = Z - FLOAT(NZ)
      IF (FZ.GT.0.0D0) GO TO 10
      IF (NZ.GT.100) GO TO 10
      DGAMLN = GLN(NZ)
      RETURN
   10 CONTINUE
      WDTOL = D1MACH(4)
      WDTOL = DMAX1(WDTOL,0.5D-18)
      I1M = I1MACH(14)
      RLN = D1MACH(5)*FLOAT(I1M)
      FLN = DMIN1(RLN,20.0D0)
      FLN = DMAX1(FLN,3.0D0)
      FLN = FLN - 3.0D0
      ZM = 1.8000D0 + 0.3875D0*FLN
      MZ = INT(SNGL(ZM)) + 1
      ZMIN = FLOAT(MZ)
      ZDMY = Z
      ZINC = 0.0D0
      IF (Z.GE.ZMIN) GO TO 20
      ZINC = ZMIN - FLOAT(NZ)
      ZDMY = Z + ZINC
   20 CONTINUE
      ZP = 1.0D0/ZDMY
      T1 = CF(1)*ZP
      S = T1
      IF (ZP.LT.WDTOL) GO TO 40
      ZSQ = ZP*ZP
      TST = T1*WDTOL
      DO 30 K=2,22
        ZP = ZP*ZSQ
        TRM = CF(K)*ZP
        IF (DABS(TRM).LT.TST) GO TO 40
        S = S + TRM
   30 CONTINUE
   40 CONTINUE
      IF (ZINC.NE.0.0D0) GO TO 50
      TLG = DLOG(Z)
      DGAMLN = Z*(TLG-1.0D0) + 0.5D0*(CON-TLG) + S
      RETURN
   50 CONTINUE
      ZP = 1.0D0
      NZ = INT(SNGL(ZINC))
      DO 60 I=1,NZ
        ZP = ZP*(Z+FLOAT(I-1))
   60 CONTINUE
      TLG = DLOG(ZDMY)
      DGAMLN = ZDMY*(TLG-1.0D0) - DLOG(ZP) + 0.5D0*(CON-TLG) + S
      RETURN
C
C
   70 CONTINUE
      IERR=1
      RETURN
      END


*> \brief \b SROTMG
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM)
*
*       .. Scalar Arguments ..
*       REAL SD1,SD2,SX1,SY1
*       ..
*       .. Array Arguments ..
*       REAL SPARAM(5)
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
*>    THE SECOND COMPONENT OF THE 2-VECTOR  (SQRT(SD1)*SX1,SQRT(SD2)*>    SY2)**T.
*>    WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
*>
*>    SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0
*>
*>      (SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0)
*>    H=(          )    (          )    (          )    (          )
*>      (SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0).
*>    LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
*>    RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
*>    VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
*>
*>    THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
*>    INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
*>    OF SD1 AND SD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
*>
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in,out] SD1
*> \verbatim
*>          SD1 is REAL
*> \endverbatim
*>
*> \param[in,out] SD2
*> \verbatim
*>          SD2 is REAL
*> \endverbatim
*>
*> \param[in,out] SX1
*> \verbatim
*>          SX1 is REAL
*> \endverbatim
*>
*> \param[in] SY1
*> \verbatim
*>          SY1 is REAL
*> \endverbatim
*>
*> \param[out] SPARAM
*> \verbatim
*>          SPARAM is REAL array, dimension (5)
*>     SPARAM(1)=SFLAG
*>     SPARAM(2)=SH11
*>     SPARAM(3)=SH21
*>     SPARAM(4)=SH12
*>     SPARAM(5)=SH22
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_blas_level1
*
*  =====================================================================
      SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM)
*
*  -- Reference BLAS level1 routine --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      REAL SD1,SD2,SX1,SY1
*     ..
*     .. Array Arguments ..
      REAL SPARAM(5)
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1,
     $     SQ2,STEMP,SU,TWO,ZERO
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC ABS
*     ..
*     .. Data statements ..
*
      DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/
      DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
*     ..

      IF (SD1.LT.ZERO) THEN
*        GO ZERO-H-D-AND-SX1..
         SFLAG = -ONE
         SH11 = ZERO
         SH12 = ZERO
         SH21 = ZERO
         SH22 = ZERO
*
         SD1 = ZERO
         SD2 = ZERO
         SX1 = ZERO
      ELSE
*        CASE-SD1-NONNEGATIVE
         SP2 = SD2*SY1
         IF (SP2.EQ.ZERO) THEN
            SFLAG = -TWO
            SPARAM(1) = SFLAG
            RETURN
         END IF
*        REGULAR-CASE..
         SP1 = SD1*SX1
         SQ2 = SP2*SY1
         SQ1 = SP1*SX1
*
         IF (ABS(SQ1).GT.ABS(SQ2)) THEN
            SH21 = -SY1/SX1
            SH12 = SP2/SP1
*
            SU = ONE - SH12*SH21
*
           IF (SU.GT.ZERO) THEN
             SFLAG = ZERO
             SD1 = SD1/SU
             SD2 = SD2/SU
             SX1 = SX1*SU
           ELSE
*            This code path if here for safety. We do not expect this
*            condition to ever hold except in edge cases with rounding
*            errors. See DOI: 10.1145/355841.355847
             SFLAG = -ONE
             SH11 = ZERO
             SH12 = ZERO
             SH21 = ZERO
             SH22 = ZERO
*
             SD1 = ZERO
             SD2 = ZERO
             SX1 = ZERO
           END IF
         ELSE

            IF (SQ2.LT.ZERO) THEN
*              GO ZERO-H-D-AND-SX1..
               SFLAG = -ONE
               SH11 = ZERO
               SH12 = ZERO
               SH21 = ZERO
               SH22 = ZERO
*
               SD1 = ZERO
               SD2 = ZERO
               SX1 = ZERO
            ELSE
               SFLAG = ONE
               SH11 = SP1/SP2
               SH22 = SX1/SY1
               SU = ONE + SH11*SH22
               STEMP = SD2/SU
               SD2 = SD1/SU
               SD1 = STEMP
               SX1 = SY1*SU
            END IF
         END IF

*     PROCEDURE..SCALE-CHECK
         IF (SD1.NE.ZERO) THEN
            DO WHILE ((SD1.LE.RGAMSQ) .OR. (SD1.GE.GAMSQ))
               IF (SFLAG.EQ.ZERO) THEN
                  SH11 = ONE
                  SH22 = ONE
                  SFLAG = -ONE
               ELSE
                  SH21 = -ONE
                  SH12 = ONE
                  SFLAG = -ONE
               END IF
               IF (SD1.LE.RGAMSQ) THEN
                  SD1 = SD1*GAM**2
                  SX1 = SX1/GAM
                  SH11 = SH11/GAM
                  SH12 = SH12/GAM
               ELSE
                  SD1 = SD1/GAM**2
                  SX1 = SX1*GAM
                  SH11 = SH11*GAM
                  SH12 = SH12*GAM
               END IF
            ENDDO
         END IF

         IF (SD2.NE.ZERO) THEN
            DO WHILE ( (ABS(SD2).LE.RGAMSQ) .OR. (ABS(SD2).GE.GAMSQ) )
               IF (SFLAG.EQ.ZERO) THEN
                  SH11 = ONE
                  SH22 = ONE
                  SFLAG = -ONE
               ELSE
                  SH21 = -ONE
                  SH12 = ONE
                  SFLAG = -ONE
               END IF
               IF (ABS(SD2).LE.RGAMSQ) THEN
                  SD2 = SD2*GAM**2
                  SH21 = SH21/GAM
                  SH22 = SH22/GAM
               ELSE
                  SD2 = SD2/GAM**2
                  SH21 = SH21*GAM
                  SH22 = SH22*GAM
               END IF
            END DO
         END IF

      END IF

      IF (SFLAG.LT.ZERO) THEN
         SPARAM(2) = SH11
         SPARAM(3) = SH21
         SPARAM(4) = SH12
         SPARAM(5) = SH22
      ELSE IF (SFLAG.EQ.ZERO) THEN
         SPARAM(3) = SH21
         SPARAM(4) = SH12
      ELSE
         SPARAM(2) = SH11
         SPARAM(5) = SH22
      END IF

      SPARAM(1) = SFLAG
      RETURN
*
*     End of SROTMG
*
      END


!*****************************************************************************80
!
!! Assemble the elemental to solve for coefficients the transient
!  Discussion:
!             As the elemental matrices are created we add them to the global
!
!  Input: n - element number
!
!  Output:
!

subroutine assemble_matrix_transient (isotope,delay_group,n)

    USE flags_M
    USE element_matrices_M
    USE global_parameters_M
    USE material_info_M
    USE mesh_info_M
    USE solution_vectors_M
    USE mesh_info_M
    USE time_info_M
    Use parameters_fe

    use Mod_GlobalConstants
    use Mod_SetupOutputFiles

    implicit none
!---Dummy variables
    integer,intent(in) :: isotope
    integer,intent(in) :: delay_group
    integer,intent(in) :: n

!---Local variables
    integer :: i, j, length
    real(dp), dimension(3) ::  beta_lambda_times_q_vec, &
                              W_left_times_prev_elem_soln_vec
    ! H_times_soln_vec,

    elem_matrix_H = 0.0_dp
!---Calculate [U - lambda*A - W_r]
    H_times_soln_vec = matmul(elem_matrix_U,precursor_soln_prev(isotope,delay_group,n,:)) - &
        matmul(allPrecursorData(isotope) % decayConst(delay_group)*elem_matrix_A,precursor_soln_prev(isotope,delay_group,n,:)) - &
        matmul(matrix_W_right_face,precursor_soln_prev(isotope,delay_group,n,:))

    beta_lambda_times_q_vec = 0.0_dp
!---Calculate Beta/Gen Time * {q}
    do i = 1, nodes_per_elem
        beta_lambda_times_q_vec(i) = power_amplitude_prev*&
                                    total_power_initial*spatial_power_frac_fcn(n,i)*&
                           (allPrecursorData(isotope) % groupBeta(delay_group)/gen_time)*elem_vec_q(i)
    end do

    W_left_times_prev_elem_soln_vec = 0.0_dp
!---Calculate W_l*c_e-l
    if ( n > 1) then
        do i = 1, nodes_per_elem
            do j = 1, nodes_per_elem
                W_left_times_prev_elem_soln_vec(i) = W_left_times_prev_elem_soln_vec(i) + &
                                                 matrix_W_left_face(i,j)*&
                             precursor_soln_new(isotope,delay_group,n-1,3)
            end do
        end do
    else
        do i = 1, nodes_per_elem
            do j = 1, nodes_per_elem
                W_left_times_prev_elem_soln_vec(i) = W_left_times_prev_elem_soln_vec(i) + &
                                                 matrix_W_left_face(i,j)*&
                             precursor_soln_new(isotope,delay_group,num_elem,3)
            end do
        end do
    end if

!---RHS final
    do i = 1, nodes_per_elem
        RHS_transient_final_vec(i) = H_times_soln_vec(i) + &
                                     beta_lambda_times_q_vec(i) +&
                                     W_left_times_prev_elem_soln_vec(i)
    end do

!    DEBUG = .TRUE.
    if (DEBUG .eqv. .TRUE.) then

       write(outfile_unit,fmt='(a)'),' '
       write(outfile_unit,fmt='(a,4I6)'),'[U] element Matrix gaussian integration &
                                          | element --> ',n
       do j=1,nodes_per_elem
              write(outfile_unit,fmt='(12es14.3)') &
                   (elem_matrix_U(j,i),i=1,nodes_per_elem)
       end do

       write(outfile_unit,fmt='(a)'), ' '
       write(outfile_unit,fmt='(a,I6)'),'[W] right Matrix | element --> ',n
       do j=1,nodes_per_elem
             write(outfile_unit,fmt='(12es14.3)') &
                  (matrix_W_right_face(j,i),i=1,nodes_per_elem)
       end do

       write(outfile_unit,fmt='(a)'), ' '
       write(outfile_unit,fmt='(a,4I6)'),'[W] left Matrix | element --> ',n
       do j=1,nodes_per_elem
             write(outfile_unit,fmt='(12es14.3)') &
                  (matrix_W_left_face(j,i),i=1,nodes_per_elem)
       end do
       write(outfile_unit,fmt='(a,4I6)'),'{q} vector  --> ',n
             write(outfile_unit,fmt='(12es14.3)') &
                  (elem_vec_q(i),i=1,nodes_per_elem)

        write(outfile_unit,fmt='(a,12es14.3)'), '@ time = ', t0

        write(outfile_unit,fmt='(a)'), ' '
        write(outfile_unit,fmt='(a,1I2)'),'H Matrix | element --> ',n
        do i=1,nodes_per_elem
              write(outfile_unit,fmt='(12es14.3)') &
                   (elem_matrix_H(i,j),j=1,nodes_per_elem)
        end do

        write(outfile_unit,fmt='(a)'), ' '
        write(outfile_unit,fmt='(a,1I3)'),' [H]*{c_e} | element --> ', n
        do j=1,nodes_per_elem
              write(outfile_unit,fmt='(12es14.3)')H_times_soln_vec(j)
        end do

        write(outfile_unit,fmt='(a)'), ' '
        write(outfile_unit,fmt='(a,1I3)'),' [W_l]*{c_e-1} | element --> ', n
        do j=1,nodes_per_elem
              write(outfile_unit,fmt='(12es14.3)')W_left_times_prev_elem_soln_vec(j)
        end do

        write(outfile_unit,fmt='(a)'),' '
        write(outfile_unit,fmt='(a,1I2)'),'{q} element source vector | element --> ',n
        write(outfile_unit,fmt='(12es14.3)') (beta_lambda_times_q_vec(i),i=1,nodes_per_elem)

        write(outfile_unit,fmt='(a)'),' '
        write(outfile_unit,fmt='(a,1I2)'),'RHS vector | element --> ',n
        write(outfile_unit,fmt='(12es14.3)') (RHS_transient_final_vec(i),i=1,nodes_per_elem)

        write(outfile_unit,fmt='(a)'),'*****************************************'

    end if
!DEBUG = .FALSE.

end


      double complex function BSYA1fqqppmp(e1,p2,p3,e4,za,zb,zab,zba)
      implicit none
C-----Authors: John Campbell and Keith Ellis, November 2011
C---- taken from arXiv:1101.5947 [hep-ph], limit of Eq. (102)
C---- (These are twiddle functions, c.f.arXiv:1101.5947[hep-ph],Eq.(91))
      include 'constants.f'
      include 'zprods_decl.f'
      include 'zabprods_decl.f'
      include 'massiveintegrals.f'
      double complex BSYA0qqppmp
      integer e1,p2,p3,e4

      BSYA1fqqppmp=2d0/3d0*BSYA0qqppmp(e1,p2,p3,e4,za,zb,zab,zba)
     & *(I23-1d0/3d0)

      return
      end


module random_integer

  implicit none

contains

  function randint(a, b)

    integer, intent(in)::a
    integer, intent(in), optional::b
    integer::rangemin
    integer::rangemax
    real::r
    integer::randint

    if (present(b)) then
      rangemin = a
      rangemax = b
    else
      rangemin = 1
      rangemax = a
    end if

    call random_number(r)

    randint = int(r*(rangemax - rangemin - 1)) + rangemin

  end function randint
end module random_integer