subroutine tur2d(dischy    ,j         ,nmmaxj    ,nmmax     ,nmax      , &
               & mmax      ,kmax      ,icx       ,icy       ,kfs       , &
               & kfu       ,kfv       ,kcs       ,kfd       ,dp        , &
               & dps       ,s1        ,umean     ,vmean     ,rtu2d0    , &
               & rtu2d1    ,rtubnd    ,thick     ,guu       ,gvv       , &
               & guv       ,gvu       ,vicww     ,dicww     ,vicuv     , &
               & vnu2d     ,vnu3d     ,cfurou    ,cfvrou    ,dddksi    , &
               & dddeta    ,z0urou    ,z0vrou    ,windu     ,windv     , &
               & tkepro    ,tkedis    ,bbk       ,ddk       ,bdx       , &
               & bux       ,bdy       ,buy       ,wrka1     ,wrka2     , &
               & wrka3     ,dep2      ,umea      ,vmea      ,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: tur2d.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/tur2d.f90 $
!!--description-----------------------------------------------------------------
!
!    Function: Computes transport in the u and v -direction of
!              the turbulent kinetic energy and enstrophy and
!              determines the 2D eddy viscosity at depth points.
!              The time integration is fully implicit.
!              Timesplitting is used. In the first stage
!              the horizontal advection terms
!              are integrated implicitly.
!              A Gauss Seidel iterative solution method is used.
!              In the second stage the diffusive transport terms
!              are integrated implicitly in combination with
!              the source and sink terms.
!              Sinks are treated implicitly and sources explicit-
!              ly. The systems of equations are decoupled in
!              the ksi- and eta-horizontal direction. The
!              resulting tridiagonal systems of equations are
!              solved by a double sweep.
!              The production of turbulence is due to horizontal
!              shear and wall friction (slip) on vertical
!              walls. The wall friction term may be switched on
!              or off with the parameter IROV.
!
! Method used: Reference : Theoretical foundation of eddy
!              diffusivity (R.E. Uittenbogaard).
!              Barotropic turbulence model, q2-eta2-model.
!              q2 and eta2 defined at depth points.
!              - Horizontal Advection in U-direction :
!                implicit, first order upwind
!              - Horizontal Advection in V-direction :
!                implicit, first order upwind
!              - Horizontal Diffusion : implicit
!              - Sources are integrated explicitly
!              - Sinks are integrated implicitly
!              - Production term contains horizontal gradients
!              - Dissipation term is linearised to improve
!                stability
!              - Gauss Seidel iteration in the horizontal
!     Comment: At the open boundaries the TKE and enstrophy.
!              have to be prescribed by the user
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    use globaldata
    use dfparall
    !
    implicit none
    !
    type(globdat),target :: gdp
    !
    ! The following list of pointer parameters is used to point inside the gdp structure
    !
    integer                , pointer :: lundia
    real(fp)               , pointer :: hdt
    real(fp)               , pointer :: ag
    real(fp)               , pointer :: vonkar
    real(fp)               , pointer :: vicmol
    real(fp)               , pointer :: ceta
    real(fp)               , pointer :: ck
    real(fp)               , pointer :: sigq2e
!
! 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                                                     :: mmax   !  Description and declaration in esm_alloc_int.f90
    integer                                                     :: nmax   !  Description and declaration in esm_alloc_int.f90
    integer                                                     :: nmmax  !  Description and declaration in dimens.igs
    integer                                                     :: nmmaxj !  Description and declaration in dimens.igs
    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)                       :: kfd    !!  Mask array for the depth points (time dependent) =0 corner of dry point =1 corner of wet points
    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) :: 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
    real(fp)                                                    :: vicuv  !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub,3)      , intent(in)  :: cfurou !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub,3)      , intent(in)  :: cfvrou !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)        , intent(in)  :: dddeta !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)        , intent(in)  :: dddksi !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)                      :: dep2   !!  Internal work array, for square of total water depth at (N,M)
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)        , intent(in)  :: dp     !  Description and declaration in esm_alloc_real.f90
    real(prec), dimension(gdp%d%nmlb:gdp%d%nmub)                      :: 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)                      :: guv    !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)                      :: 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)        , intent(in)  :: s1     !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)        , intent(in)  :: umean  !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)        , intent(in)  :: vmean  !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)                      :: vnu2d  !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)                      :: vnu3d  !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)                      :: windu  !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)                      :: windv  !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)                      :: z0urou !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)                      :: z0vrou !  Description and declaration in esm_alloc_real.f90
    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)              :: ddk    !!  Internal work array, diagonal space at (N,M,K)
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax)              :: dicww  !  Description and declaration in esm_alloc_real.f90
    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)              :: wrka1  !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax)              :: wrka2  !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax)              :: wrka3  !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, 2)                   :: rtu2d0 !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, 2)                   :: rtu2d1 !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, 2)     , intent(in)  :: rtubnd !  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)                :: 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)                :: umea
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                :: vmea
    real(fp), dimension(kmax)                         , intent(in)  :: thick  !  Description and declaration in esm_alloc_real.f90
    character(8)                                  , intent(in)  :: dischy !  Description and declaration in tricom.igs
!
! Local variables
!
    integer :: icxy
    integer :: ij
    integer :: iter
    integer :: itmax
    integer :: k
    integer :: kcd
    integer :: kd
    integer :: l
    integer :: mmaxddb
    integer :: n
    integer :: ndm
    integer :: nm
    integer :: nmaxddb
    integer :: nmd
    integer :: nmu
    integer :: num
    integer :: numu
    real(fp):: chezy
    real(fp):: d2udx2
    real(fp):: d2udy2
    real(fp):: d2vdx2
    real(fp):: d2vdy2
    real(fp):: dddx
    real(fp):: dddy
    real(fp):: dep
    real(fp):: dx
    real(fp):: dxd
    real(fp):: dxu
    real(fp):: dy
    real(fp):: dyd
    real(fp):: dyu
    real(fp):: ermax
    real(fp):: fac
    real(fp):: omegaz
    real(fp):: prod
    real(fp):: s
    real(fp):: timest
    real(fp):: udo
    real(fp):: umod
    real(fp):: uup
    real(fp):: uuu
    real(fp):: vdo
    real(fp):: vicd
    real(fp):: vicu
    real(fp):: vup
    real(fp):: vvv
    integer :: nm_pos ! indicating the array to be exchanged has nm index at the 2nd place, e.g., dbodsd(lsedtot,nm)
!
!! executable statements -------------------------------------------------------
!
    ceta        => gdp%gdturcoe%ceta
    ck          => gdp%gdturcoe%ck
    sigq2e      => gdp%gdturcoe%sigq2e
    ag          => gdp%gdphysco%ag
    vonkar      => gdp%gdphysco%vonkar
    vicmol      => gdp%gdphysco%vicmol
    hdt         => gdp%gdnumeco%hdt
    lundia      => gdp%gdinout%lundia
    !
    nmaxddb = nmax + 2*gdp%d%ddbound
    mmaxddb = mmax + 2*gdp%d%ddbound
    nm_pos  = 1
    !
    icxy = max(icx, icy)
    if (dischy=='cn') then
       timest = hdt
    else
       timest = 2*hdt
    endif
    !
    ! set identification array in depth points
    !
    do nm = 1, nmmax
       num  = nm + icy
       numu = nm + icy + icx
       nmu  = nm + icx
       !
       !                 +  - +
       !        cell:
       !                 |  o |
       !
       !                 +  - +
       !
       kfd(nm) = kfu(nm)*kfu(num)*kfv(nmu)*kfv(nm)
    enddo
    call dfexchg ( kfd, 1, 1, dfint, nm_pos, gdp )
    !
    !  mean horizontal velocities at depth point and
    !  depth-averaged vertical viscosity and
    !  total waterdepth at depth point
    !
    if (kmax>1) then
       do nm = 1, nmmax
          if (kfd(nm)==1) then
             nmu         = nm + icx
             num         = nm + icy
             numu        = nm + icy + icx
             vnu3d(nm)   = 0.
             umea(nm, 1) = 0.25*(umean(nm) + umean(num))
             vmea(nm, 1) = 0.25*(vmean(nm) + vmean(nmu))
             do k = 1, kmax
                kd = k - 1
                vnu3d(nm) = vnu3d(nm) + thick(k)                                &
                          & *.125*(vicww(nm, k) + vicww(nmu, k) + vicww(num, k) &
                          & + vicww(numu, k) + vicww(nm, kd) + vicww(nmu, kd)   &
                          & + vicww(num, kd) + vicww(numu, kd))
             enddo
          endif
       enddo
    else
       !
       ! logarithmic velocity profile without wind
       !
       do nm = 1, nmmax
          if (kfd(nm)==1) then
             nmu       = nm + icx
             num       = nm + icy
             numu      = nm + icy + icx
             uuu       = .5*(umean(nm) + umean(num))
             vvv       = .5*(vmean(nm) + vmean(nmu))
             s         = 0.25*(s1(nm) + s1(num) + s1(nmu) + s1(numu))
             dep       = max(dp(nm) + s, 0.01_fp)
             umod      = sqrt(uuu*uuu + vvv*vvv)
             chezy     = .25*(cfurou(nm,1) + cfurou(num,1) + cfvrou(nm,1) + cfvrou(nmu,1))
             fac       = ag/(chezy*chezy*dep)
             vnu3d(nm) = vonkar*sqrt(fac*umod*umod)*dep/6.
          endif
       enddo
    endif
    do nm = 1, nmmax
       if (kfd(nm)/=1) then
          nmu         = nm + icx
          num         = nm + icy
          umea(nm, 1) = 0.25*(umean(nm) + umean(num))
          vmea(nm, 1) = 0.25*(vmean(nm) + vmean(nmu))
       endif
    enddo
    !
    !  Loop for transport q2 and eta2
    !
    do l = 1, 2
       do nm = 1, nmmax
          nmu  = nm + icx
          num  = nm + icy
          numu = nm + icy + icx
          if (kfd(nm)==1) then
             s          = 0.25*(s1(nm) + s1(num) + s1(nmu) + s1(numu))
             dep        = max(dp(nm) + s, 0.01_fp)
             dep2(nm)   = 1.
             if (l==2) dep2(nm) = dep*dep
             bux(nm, 1) = 0.0
             bdx(nm, 1) = 0.0
             buy(nm, 1) = 0.0
             bdy(nm, 1) = 0.0
             bbk(nm, 1) = 1.0/(timest*dep2(nm))
             ddk(nm, 1) = rtu2d0(nm, l)/(timest*dep2(nm))
          endif
       enddo
       !
       ! advection in horizontal U-direction
       !
       do nm = 1, nmmax
          nmd = nm - icx
          nmu = nm + icx
          if (kfd(nm)==1) then
             uuu        = umea(nm, 1)
             udo        = 0.5*(uuu + abs(uuu))*kfd(nmd)/gvv(nm)
             uup        = 0.5*(uuu - abs(uuu))*kfd(nmu)/gvv(nmu)
             bux(nm, 1) = bux(nm, 1) + uup*dep2(nmu)
             bbk(nm, 1) = bbk(nm, 1) - uup*dep2(nm) + udo*dep2(nm)
             bdx(nm, 1) = bdx(nm, 1) - udo*dep2(nmd)
          endif
       enddo
       !
       ! advection in horizontal V-direction
       !
       do nm = 1, nmmax
          ndm = nm - icy
          num = nm + icy
          if (kfd(nm)==1) then
             vvv        = vmea(nm, 1)
             vdo        = 0.5*(vvv + abs(vvv))*kfd(ndm)/guu(nm)
             vup        = 0.5*(vvv - abs(vvv))*kfd(num)/guu(num)
             buy(nm, 1) = buy(nm, 1) + vup*dep2(num)
             bbk(nm, 1) = bbk(nm, 1) - vup*dep2(nm) + vdo*dep2(nm)
             bdy(nm, 1) = bdy(nm, 1) - vdo*dep2(ndm)
          endif
       enddo
       !
       ! Boundary conditions for advection part
       ! For TKE
       !
       if (l==1) then
          do nm = 1, nmmax
             nmu  = nm + icx
             num  = nm + icy
             numu = nm + icx + icy
             kcd  = kcs(nm)*kcs(num)*kcs(nmu)*kcs(numu)
             if (kcd==4) then
                !
                ! Open boundary only. At closed boundary all values are zero
                !
                bux(nm, 1) = 0.0
                bdx(nm, 1) = 0.0
                buy(nm, 1) = 0.0
                bdy(nm, 1) = 0.0
                bbk(nm, 1) = 1.0
                ddk(nm, 1) = rtubnd(nm, l)
             endif
          enddo
       else
          !
          ! Enstrophy
          !
          do nm = 1, nmmax
             nmu  = nm + icx
             num  = nm + icy
             nmd  = nm - icx
             ndm  = nm - icy
             numu = nm + icx + icy
             kcd  = kcs(nm)*kcs(num)*kcs(nmu)*kcs(numu)
             if (kfd(nm)==0) then
                !
                ! Closed boundary
                !
                if (kfd(num)==1) then
                   bux(nm, 1) =  0.0
                   bdx(nm, 1) =  0.0
                   buy(nm, 1) =  1.0
                   bdy(nm, 1) =  0.0
                   bbk(nm, 1) = -1.0
                   ddk(nm, 1) =  0.0
                elseif (kfd(nmu)==1) then
                   bux(nm, 1) =  1.0
                   bdx(nm, 1) =  0.0
                   buy(nm, 1) =  0.0
                   bdy(nm, 1) =  0.0
                   bbk(nm, 1) = -1.0
                   ddk(nm, 1) =  0.0
                elseif (kfd(nmd)==1) then
                   bux(nm, 1) =  0.0
                   bdx(nm, 1) =  1.0
                   buy(nm, 1) =  0.0
                   bdy(nm, 1) =  0.0
                   bbk(nm, 1) = -1.0
                   ddk(nm, 1) =  0.0
                elseif (kfd(ndm)==1) then
                   bux(nm, 1) =  0.0
                   bdx(nm, 1) =  0.0
                   buy(nm, 1) =  0.0
                   bdy(nm, 1) =  1.0
                   bbk(nm, 1) = -1.0
                   ddk(nm, 1) =  0.0
                else
                endif
             elseif (kcd==4) then
                !
                ! Open Boundary
                !
                bux(nm, 1) = 0.0
                bdx(nm, 1) = 0.0
                buy(nm, 1) = 0.0
                bdy(nm, 1) = 0.0
                bbk(nm, 1) = 1.0
                ddk(nm, 1) = rtubnd(nm, l)
             else
             endif
          enddo
       endif
       !
       ! iteration loop
       !
       do nm = 1, nmmax
          rtu2d1(nm, l) = rtu2d0(nm, l)
       enddo
       !
       ! in case of parallel runs, block Jacobi is applied at coupling boundaries
       ! and consequently, rate of convergence of Gauss Seidel iteration will be
       ! deteriorated somewhat en hence, more iterations are needed
       !
       itmax = 2
       if ( nproc > 1 ) itmax = 5
       !
       do iter = 1, itmax
          !
          ! iterative solution method using Gauss Seidel
          ! in horizontal direction
          !
          do ij = 2, nmaxddb + mmaxddb
             nm  = ij*icx - icxy       + (max(1, ij - mmaxddb) - 1)*(icy - icx)
             nmd = ij*icx - icxy - icx + (max(1, ij - mmaxddb) - 1)*(icy - icx)
             ndm = ij*icx - icxy - icy + (max(1, ij - mmaxddb) - 1)*(icy - icx)
             !
             ! VDIR NODEP
             !
             do n = max(1, ij - mmaxddb), min(nmaxddb, ij - 1)
                nm  = nm + (icy - icx)
                nmd = nmd + (icy - icx)
                ndm = ndm + (icy - icx)
                if (kfd(nm)==1) then
                   if (umea(nm, 1)>=0.0 .and. vmea(nm, 1)>=0.0) then
                      rtu2d1(nm, l) = (ddk(nm, 1) - bdx(nm, 1)*rtu2d1(nmd, l)   &
                                    & - bdy(nm, 1)*rtu2d1(ndm, l))/bbk(nm, 1)
                   endif
                endif
             enddo
          enddo
          do ij = 1 - mmaxddb, nmaxddb - 1
             nm  = -ij*icx - icxy       + (max(1, 1 + ij) - 1)*(icy + icx)
             nmu = -ij*icx - icxy + icx + (max(1, 1 + ij) - 1)*(icy + icx)
             ndm = -ij*icx - icxy - icy + (max(1, 1 + ij) - 1)*(icy + icx)
             !
             !VDIR NODEP
             !
             do n = max(1, 1 + ij), min(nmaxddb, mmaxddb + ij)
                nm  = nm + (icy + icx)
                nmu = nmu + (icy + icx)
                ndm = ndm + (icy + icx)
                if (kfd(nm)==1) then
                   if (umea(nm, 1)<0.0 .and. vmea(nm, 1)>=0.0) then
                      rtu2d1(nm, l) = (ddk(nm, 1) - bux(nm, 1)*rtu2d1(nmu, l)   &
                                    & - bdy(nm, 1)*rtu2d1(ndm, l))/bbk(nm, 1)
                   endif
                endif
             enddo
          enddo
          do ij = nmaxddb - 1, 1 - mmaxddb, -1
             nm  = -ij*icx - icxy       + (min(nmaxddb, mmaxddb + ij) + 1)*(icy + icx)
             nmd = -ij*icx - icxy - icx + (min(nmaxddb, mmaxddb + ij) + 1)*(icy + icx)
             num = -ij*icx - icxy + icy + (min(nmaxddb, mmaxddb + ij) + 1)*(icy + icx)
             !
             !VDIR NODEP
             !
             do n = min(nmaxddb, mmaxddb + ij), max(1, 1 + ij), -1
                nm  = nm  - (icy + icx)
                nmd = nmd - (icy + icx)
                num = num - (icy + icx)
                if (kfs(nm)==1) then
                   if (umea(nm, 1)>=0.0 .and. vmea(nm, 1)<0.0) then
                      rtu2d1(nm, l) = (ddk(nm, 1) - bdx(nm, 1)*rtu2d1(nmd, l)   &
                                    & - buy(nm, 1)*rtu2d1(num, l))/bbk(nm, 1)
                   endif
                endif
             enddo
          enddo
          do ij = nmaxddb + mmaxddb, 2, -1
             nm  = ij*icx - icxy       + (min(nmaxddb, ij - 1) + 1)*(icy - icx)
             nmu = ij*icx - icxy + icx + (min(nmaxddb, ij - 1) + 1)*(icy - icx)
             num = ij*icx - icxy + icy + (min(nmaxddb, ij - 1) + 1)*(icy - icx)
             !
             !VDIR NODEP
             !
             do n = min(nmaxddb, ij - 1), max(1, ij - mmaxddb), -1
                nm  = nm  - (icy - icx)
                nmu = nmu - (icy - icx)
                num = num - (icy - icx)
                if (kfs(nm)==1) then
                   if (umea(nm, 1)<0.0 .and. vmea(nm, 1)<0.0) then
                      rtu2d1(nm, l) = (ddk(nm, 1) - bux(nm, 1)*rtu2d1(nmu, l)   &
                                    & - buy(nm, 1)*rtu2d1(num, l))/bbk(nm, 1)
                   endif
                endif
             enddo
          enddo
          !
          ! exchange rtu2d1 with neighbours for parallel runs
          !
          call dfexchg ( rtu2d1(:, l), 1, 1, dfloat, nm_pos, gdp )
       enddo
       !
       ! Second stage: production-dissipation and diffusion
       !
       do nm = 1, nmmax
          if (kfd(nm)==1) then
             bbk(nm, 1) = 1.0/(timest*dep2(nm))
             ddk(nm, 1) = rtu2d1(nm, l)/(timest*dep2(nm))
          endif
       enddo
       !
       if (l==1) then
          !
          ! production term (only horizontal gradients )
          ! in water level points
          !
          do nm = 1, nmmax
             if (kfs(nm)==1) then
                nmd        = nm - icx
                ndm        = nm - icy
                dx         = 0.5*(gvv(nm) + gvv(ndm))
                dy         = 0.5*(guu(nm) + guu(nmd))
                bdx(nm, 1) = ((umean(nm) - umean(nmd))/dx)                      &
                           & **2 + ((vmean(nm) - vmean(ndm))/dy)**2
             else
                bdx(nm, 1) = 0.0
             endif
          enddo
          !
          ! in depth points
          !
          do nm = 1, nmmax
             if (kfd(nm)==1) then
                nmu        = nm + icx
                num        = nm + icy
                dx         = 0.5*(gvv(nm) + gvv(nmu))
                dy         = 0.5*(guu(nm) + guu(num))
                bux(nm, 1) = ((umean(num) - umean(nm))/dy + (vmean(nmu) - vmean(&
                           & nm))/dx)**2
             else
                bux(nm, 1) = 0.0
             endif
          enddo
          !
          ! Production by horizontal shear
          !
          do nm = 1, nmmax
             if (kfd(nm)==1) then
                num        = nm + icy
                nmu        = nm + icx
                numu       = nm + icx + icy
                ddk(nm, 1) = ddk(nm, 1) + vnu2d(nm)                             &
                           & *(bux(nm, 1) + 0.50*((bdx(nm, 1) + bdx(num, 1)     &
                           & + bdx(nmu, 1) + bdx(numu, 1))))
             endif
          enddo
       !
       ! Production enstrophy
       !
       else
          do nm = 1, nmmax
             if (kfd(nm)==1) then
                nmu = nm + icx
                nmd = nm - icx
                ndm = nm - icy
                num = nm + icy
                d2udx2 = (kfd(nmu)*(umea(nmu, 1) - umea(nm, 1))/gvv(nmu)        &
                       & - kfd(nmd)*(umea(nm, 1) - umea(nmd, 1))/gvv(nm))       &
                       & /(.5*(gvv(nm) + gvv(nmu)))
                d2udy2 = (kfd(num)*(umea(num, 1) - umea(nm, 1))/guu(num)        &
                       & - kfd(ndm)*(umea(nm, 1) - umea(ndm, 1))/guu(nm))       &
                       & /(.5*(guu(nm) + guu(num)))
                d2vdx2 = (kfd(nmu)*(vmea(nmu, 1) - vmea(nm, 1))/gvv(nmu)        &
                       & - kfd(nmd)*(vmea(nm, 1) - vmea(nmd, 1))/gvv(nm))       &
                       & /(.5*(gvv(nm) + gvv(nmu)))
                d2vdy2 = (kfd(num)*(vmea(num, 1) - vmea(nm, 1))/guu(num)        &
                       & - kfd(ndm)*(vmea(nm, 1) - vmea(ndm, 1))/guu(nm))       &
                       & /(.5*(guu(nm) + guu(num)))
                omegaz = (vmean(nmu) - vmean(nm))/(.5*(gvv(nm) + gvv(nmu)))     &
                       & - (umean(num) - umean(nm))/(.5*(guu(nm) + guu(num)))
                dddx   = (dddksi(nmu) + dddksi(nm))/(gvv(nm) + gvv(nmu))
                dddy   = (dddeta(num) + dddeta(nm))/(guu(nm) + guu(num))
                prod   = 2*vnu2d(nm)/dep2(nm)                                     &
                       & *((d2udx2 + d2udy2)**2 + (d2vdy2 + d2vdx2)               &
                       & **2 - omegaz/sqrt(dep2(nm))                              &
                       & *((d2udx2 + d2udy2)*dddx + (d2vdy2 + d2vdx2)*dddy))
                if (prod<0) then
                   prod = prod/rtu2d0(nm, 2)
                   bbk(nm, 1) = bbk(nm, 1) - prod
                else
                   ddk(nm, 1) = ddk(nm, 1) + prod
                endif
             endif
          enddo
       endif
       if (l==1) then
          !
          ! external and internal dissipation TKE
          !
          do nm = 1, nmmax
             if (kfd(nm)==1) then
                nmu        = nm + icx
                num        = nm + icy
                numu       = nm + icy + icx
                uuu        = .5*(umean(nm) + umean(num))
                vvv        = .5*(vmean(nm) + vmean(nmu))
                s          = 0.25*(s1(nm) + s1(num) + s1(nmu) + s1(numu))
                dep        = max(dp(nm) + s, 0.01_fp)
                umod       = sqrt(uuu*uuu + vvv*vvv)
                chezy      = .25*(cfurou(nm,1) + cfurou(num,1) + cfvrou(nm,1) + cfvrou(nmu,1))
                fac        = ag/(chezy*chezy*dep)
                bbk(nm, 1) = bbk(nm, 1) + fac*(3.*umod + sqrt(rtu2d0(nm, 1)))
                bbk(nm, 1) = bbk(nm, 1) + (vnu3d(nm) + vicmol)*rtu2d0(nm, 2)    &
                           & /rtu2d0(nm, 1)
             endif
          enddo
       elseif (l==2) then
          !
          ! external and internal dissipation enstrophy
          !
          do nm = 1, nmmax
             if (kfd(nm)==1) then
                nmu        = nm + icx
                num        = nm + icy
                numu       = nm + icy + icx
                uuu        = .5*(umean(nm) + umean(num))
                vvv        = .5*(vmean(nm) + vmean(nmu))
                s          = 0.25*(s1(nm) + s1(num) + s1(nmu) + s1(numu))
                dep        = max(dp(nm) + s, 0.01_fp)
                umod       = sqrt(uuu*uuu + vvv*vvv)
                chezy      = .25*(cfurou(nm,1) + cfurou(num,1) + cfvrou(nm,1) + cfvrou(nmu,1))
                bbk(nm, 1) = bbk(nm, 1) + 2*ag*umod/(chezy*chezy*dep**3)
                bbk(nm, 1) = bbk(nm, 1) + 2*ceta*vnu3d(nm)/dep*rtu2d0(nm, 2)    &
                           & /rtu2d0(nm, 1)
             endif
          enddo
       else
       endif
       !
       ! Matrix coefficients horizontal diffusion
       ! Attention: vnu2d/vnu3d defined at depth points
       !
       do nm = 1, nmmax
          bdx(nm, 1) = 0.
          bux(nm, 1) = 0.
          bdy(nm, 1) = 0.
          buy(nm, 1) = 0.
          nmd        = nm - icx
          nmu        = nm + icx
          ndm        = nm - icy
          num        = nm + icy
          if (kfd(nm)==1) then
             dx  = 0.5*(gvv(nm) + gvv(nmu))
             dxd = gvv(nm)
             dxu = gvv(nmu)
             dy  = 0.5*(guu(nm) + guu(num))
             dyd = guu(nm)
             dyu = guu(num)
             if (l==1) then
                vicu = .5*(vnu2d(nm) + vnu2d(nmu) + vnu3d(nm) + vnu3d(nmu))     &
                     & + vicmol
                vicd = .5*(vnu2d(nm) + vnu2d(nmd) + vnu3d(nm) + vnu3d(nmd))     &
                     & + vicmol
             elseif (l==2) then
                vicu = .5*(vnu2d(nm)/dep2(nm) + vnu2d(nmu)/dep2(nmu))           &
                     & + vnu3d(nm)/dep2(nm)
                vicd = .5*(vnu2d(nm)/dep2(nm) + vnu2d(nmd)/dep2(nmd))           &
                     & + vnu3d(nm)/dep2(nm)
             else
             endif
             bdx(nm, 1) = -vicd*kfd(nmd)/(sigq2e*dxd*dx)
             bux(nm, 1) = -vicu*kfd(nmu)/(sigq2e*dxu*dx)
             bbk(nm, 1) = bbk(nm, 1) - bdx(nm, 1) - bux(nm, 1)
             if (l==1) then
                vicu = .5*(vnu2d(nm) + vnu2d(ndm) + vnu3d(nm) + vnu3d(ndm))     &
                     & + vicmol
                vicd = .5*(vnu2d(nm) + vnu2d(num) + vnu3d(nm) + vnu3d(num))     &
                     & + vicmol
             elseif (l==2) then
                vicu = .5*(vnu2d(nm)/dep2(nm) + vnu2d(num)/dep2(num))           &
                     & + vnu3d(nm)/dep2(nm)
                vicd = .5*(vnu2d(nm)/dep2(nm) + vnu2d(ndm)/dep2(ndm))           &
                     & + vnu3d(nm)/dep2(nm)
             else
             endif
             bdy(nm, 1) = -vicd*kfd(ndm)/(sigq2e*dyd*dy)
             buy(nm, 1) = -vicu*kfd(num)/(sigq2e*dyu*dy)
             bbk(nm, 1) = bbk(nm, 1) - bdy(nm, 1) - buy(nm, 1)
          endif
       enddo
       !
       ! Boundary conditions
       ! For TKE
       !
       if (l==1) then
          do nm = 1, nmmax
             nmu  = nm + icx
             num  = nm + icy
             numu = nm + icx + icy
             kcd  = kcs(nm)*kcs(num)*kcs(nmu)*kcs(numu)
             if (kcd==4) then
                !
                ! Open boundary only. At closed boundary all values are zero
                !
                bux(nm, 1) = 0.0
                bdx(nm, 1) = 0.0
                buy(nm, 1) = 0.0
                bdy(nm, 1) = 0.0
                bbk(nm, 1) = 1.0
                ddk(nm, 1) = rtu2d1(nm, l)
             endif
          enddo
       else
          !
          ! Enstrophy
          !
          do nm = 1, nmmax
             nmu  = nm + icx
             num  = nm + icy
             nmd  = nm - icx
             ndm  = nm - icy
             numu = nm + icx + icy
             kcd  = kcs(nm)*kcs(num)*kcs(nmu)*kcs(numu)
             if (kfd(nm)==0) then
                !
                ! Closed boundary
                !
                if (kfd(num)==1) then
                   bux(nm, 1) =  0.0
                   bdx(nm, 1) =  0.0
                   buy(nm, 1) =  1.0
                   bdy(nm, 1) =  0.0
                   bbk(nm, 1) = -1.0
                   ddk(nm, 1) =  0.0
                elseif (kfd(nmu)==1) then
                   bux(nm, 1) =  1.0
                   bdx(nm, 1) =  0.0
                   buy(nm, 1) =  0.0
                   bdy(nm, 1) =  0.0
                   bbk(nm, 1) = -1.0
                   ddk(nm, 1) =  0.0
                elseif (kfd(nmd)==1) then
                   bux(nm, 1) =  0.0
                   bdx(nm, 1) =  1.0
                   buy(nm, 1) =  0.0
                   bdy(nm, 1) =  0.0
                   bbk(nm, 1) = -1.0
                   ddk(nm, 1) =  0.0
                elseif (kfd(ndm)==1) then
                   bux(nm, 1) =  0.0
                   bdx(nm, 1) =  0.0
                   buy(nm, 1) =  0.0
                   bdy(nm, 1) =  1.0
                   bbk(nm, 1) = -1.0
                   ddk(nm, 1) =  0.0
                else
                endif
             elseif (kcd==4) then
                !
                ! Open Boundary
                !
                bux(nm, 1) = 0.0
                bdx(nm, 1) = 0.0
                buy(nm, 1) = 0.0
                bdy(nm, 1) = 0.0
                bbk(nm, 1) = 1.0
                ddk(nm, 1) = rtu2d1(nm, l)
             else
             endif
          enddo
       endif
       !
       ! Solver for penta-diagonal system of equations
       !
       ! # of iterations added
       !
       itmax = 50
       call itadi2(lundia    ,rtu2d1(j, l)         ,kfd       ,mmax      ,nmax      , &
                 & j         ,nmmaxj    ,nmmax     ,bdx       ,bbk       , &
                 & bux       ,ddk       ,bdy       ,buy       ,iter      , &
                 & itmax     ,ermax     ,wrka1     ,wrka2     ,wrka3     , &
                 & gdp       )
    enddo
    !
    ! Determine 2D eddy viscosity
    !
    do nm = 1, nmmax
       if (kfd(nm)==1) then
          rtu2d0(nm, 1) = rtu2d1(nm, 1)
          rtu2d0(nm, 2) = rtu2d1(nm, 2)
          vnu2d(nm)     = ck*rtu2d1(nm, 1)/sqrt(rtu2d1(nm, 2))
       endif
    enddo
end subroutine tur2d


module rnglib

! Library implementing a random number generator (RNG) with splitting facilities,
! allowing multiple independent streams to be computed by L'Ecuyer and Cote.

! See
! Pierre LEcuyer, Serge Cote,
! Implementing a Random Number Package with Splitting Facilities,
! ACM Transactions on Mathematical Software,
! Volume 17, Number 1, March 1991, pages 98-111.
!
! FORTRAN90 code by John Burkardt (see individual subroutines for details)
!
! Shaped into a module for FERRE by Carlos Allende Prieto
! November 2017

implicit none

public

contains

subroutine advance_state ( k )

!*****************************************************************************80
!
!! ADVANCE_STATE advances the state of the current generator.
!
!  Discussion:
!
!    This procedure advances the state of the current generator by 2^K
!    values and resets the initial seed to that value.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 March 2013
!
!  Author:
!
!    Original Pascal version by Pierre L'Ecuyer, Serge Cote.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Pierre LEcuyer, Serge Cote,
!    Implementing a Random Number Package with Splitting Facilities,
!    ACM Transactions on Mathematical Software,
!    Volume 17, Number 1, March 1991, pages 98-111.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) K, indicates that the generator is to be
!    advanced by 2^K values.
!    0 <= K.
!
  implicit none

  integer ( kind = 4 ), parameter :: a1 = 40014
  integer ( kind = 4 ), parameter :: a2 = 40692
  integer ( kind = 4 ) b1
  integer ( kind = 4 ) b2
  integer ( kind = 4 ) cg1
  integer ( kind = 4 ) cg2
!  integer ( kind = 4 ) cgn_get
  integer ( kind = 4 ) g
  integer ( kind = 4 ) i
!  logical initialized_get
  integer ( kind = 4 ) k
  integer ( kind = 4 ), parameter :: m1 = 2147483563
  integer ( kind = 4 ), parameter :: m2 = 2147483399
!  integer ( kind = 4 ) multmod

  if ( k < 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'ADVANCE_STATE - Fatal error!'
    write ( *, '(a)' ) '  Input exponent K is out of bounds.'
    stop 1
  end if
!
!  Check whether the package must be initialized.
!
  if ( .not. initialized_get ( ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'ADVANCE_STATE - Note:'
    write ( *, '(a)' ) '  Initializing RNGLIB package.'
    call initialize ( )
  end if
!
!  Get the current generator index.
!
  g = cgn_get ( )

  b1 = a1
  b2 = a2

  do i = 1, k
    b1 = multmod ( b1, b1, m1 )
    b2 = multmod ( b2, b2, m2 )
  end do

  call cg_get ( g, cg1, cg2 )
  cg1 = multmod ( b1, cg1, m1 )
  cg2 = multmod ( b2, cg2, m2 )
  call cg_set ( g, cg1, cg2 )

  return
end subroutine advance_state

function antithetic_get ( )

!*****************************************************************************80
!
!! ANTITHETIC_GET queries the antithetic value for a given generator.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, logical ANTITHETIC_GET, is TRUE if generator G is antithetic.
!
  implicit none

  logical antithetic_get
  integer ( kind = 4 ) i
  logical value

  i = -1
  call antithetic_memory ( i, value )

  antithetic_get = value

  return
end function antithetic_get

subroutine antithetic_memory ( i, value )

!*****************************************************************************80
!
!! ANTITHETIC_MEMORY stores the antithetic value for all generators.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) I, the desired action.
!    -1, get a value.
!    0, initialize all values.
!    1, set a value.
!
!    Input/output, logical VALUE.  For I = -1, VALUE is an output
!    quantity, for I = +1, an input quantity.
!
  implicit none

  integer ( kind = 4 ), parameter :: g_max = 32

  logical a_save(g_max)
!  integer ( kind = 4 ) cgn_get
  integer ( kind = 4 ) g
  integer ( kind = 4 ) i
  logical value

  save a_save

  data a_save / 32 * .false. /

  if ( i < 0 ) then
    g = cgn_get ( )
    value = a_save(g)
  else if ( i == 0 ) then
    a_save(1:g_max) = .false.
  else if ( 0 < i ) then
    g = cgn_get ( )
    a_save(g) = value
  end if

  return
end subroutine antithetic_memory

subroutine antithetic_set ( value )

!*****************************************************************************80
!
!! ANTITHETIC_SET sets the antithetic value for a given generator.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, logical VALUE, is TRUE if generator G is to be antithetic.
!
  implicit none

  integer ( kind = 4 ) i
  logical value

  i = +1
  call antithetic_memory ( i, value )

  return
end subroutine antithetic_set

subroutine cg_get ( g, cg1, cg2 )

!*****************************************************************************80
!
!! CG_GET queries the CG values for a given generator.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) G, the index of the generator.
!    1 <= G <= 32.
!
!    Output, integer ( kind = 4 ) CG1, CG2, the CG values for generator G.
!
  implicit none

  integer ( kind = 4 ) cg1
  integer ( kind = 4 ) cg2
  integer ( kind = 4 ) g
  integer ( kind = 4 ) i

  i = -1
  call cg_memory ( i, g, cg1, cg2 )

  return
end subroutine cg_get

subroutine cg_memory ( i, g, cg1, cg2 )

!*****************************************************************************80
!
!! CG_MEMORY stores the CG values for all generators.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) I, the desired action.
!    -1, get a value.
!    0, initialize all values.
!    1, set a value.
!
!    Input, integer ( kind = 4 ) G, for I = -1 or +1, the index of
!    the generator, with 1 <= G <= 32.
!
!    Input/output, integer ( kind = 4 ) CG1, CG2.  For I = -1,
!    these are output, for I = +1, these are input, for I = 0,
!    these arguments are ignored.  When used, the arguments are
!    old or new values of the CG parameter for generator G.
!
  implicit none

  integer ( kind = 4 ), parameter :: g_max = 32

  integer ( kind = 4 ) cg1
  integer ( kind = 4 ) cg1_save(g_max)
  integer ( kind = 4 ) cg2
  integer ( kind = 4 ) cg2_save(g_max)
  integer ( kind = 4 ) g
  integer ( kind = 4 ) i

  save cg1_save
  save cg2_save

  data cg1_save / 32 * 0 /
  data cg2_save / 32 * 0 /

  if ( g < 1 .or. g_max < g ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CG_MEMORY - Fatal error!'
    write ( *, '(a)' ) '  Input generator index G is out of bounds.'
    stop 1
  end if

  if ( i < 0 ) then
    cg1 = cg1_save(g)
    cg2 = cg2_save(g)
  else if ( i == 0 ) then
    cg1_save(1:g_max) = 0
    cg2_save(1:g_max) = 0
  else if ( 0 < i ) then
    cg1_save(g) = cg1
    cg2_save(g) = cg2
  end if

  return
end subroutine cg_memory

subroutine cg_set ( g, cg1, cg2 )

!*****************************************************************************80
!
!! CG_SET sets the CG values for a given generator.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) G, the index of the generator.
!    1 <= G <= 32.
!
!    Input, integer ( kind = 4 ) CG1, CG2, the CG values for generator G.
!
  implicit none

  integer ( kind = 4 ) cg1
  integer ( kind = 4 ) cg2
  integer ( kind = 4 ) g
  integer ( kind = 4 ) i

  i = +1
  call cg_memory ( i, g, cg1, cg2 )

  return
end subroutine cg_set

function cgn_get ( )

!*****************************************************************************80
!
!! CGN_GET gets the current generator index.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, integer ( kind = 4 ) CGN_GET, the current generator index.
!    1 <= CGN_GET <= 32.
!
  implicit none

  integer ( kind = 4 ) cgn_get
  integer ( kind = 4 ) g
  integer ( kind = 4 ) i

  i = -1
  call cgn_memory ( i, g )

  cgn_get = g

  return
end function cgn_get

subroutine cgn_memory ( i, g )

!*****************************************************************************80
!
!! CGN_MEMORY stores the current generator index.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) I, the desired action.
!    -1, get the value.
!    0, initialize the value.
!    1, set the value.
!
!    Input/output, integer ( kind = 4 ) G.  For I = -1 or 0,
!    this is output, for I = +1, this is input.
!
  implicit none

  integer ( kind = 4 ), parameter :: g_max = 32

  integer ( kind = 4 ) g
  integer ( kind = 4 ) g_save
  integer ( kind = 4 ) i

  save g_save

  data g_save / 1 /

  if ( i < 0 ) then

    g = g_save

  else if ( i == 0 ) then

    g_save = 1
    g = g_save

  else if ( 0 < i ) then

    if ( g < 1 .or. g_max < g ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CGN_MEMORY - Fatal error!'
      write ( *, '(a)' ) '  Generator index G is out of bounds.'
      stop 1
    end if

    g_save = g

  end if

  return
end subroutine cgn_memory

subroutine cgn_set ( g )

!*****************************************************************************80
!
!! CGN_SET sets the current generator index.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) G, the index of the generator.
!    1 <= G <= 32.
!
  implicit none

  integer ( kind = 4 ) g
  integer ( kind = 4 ) i

  i = +1
  call cgn_memory ( i, g )

  return
end subroutine cgn_set

subroutine get_state ( cg1, cg2 )

!*****************************************************************************80
!
!! GET_STATE returns the state of the current generator.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 March 2013
!
!  Author:
!
!    Original Pascal version by Pierre L'Ecuyer, Serge Cote.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Pierre LEcuyer, Serge Cote,
!    Implementing a Random Number Package with Splitting Facilities,
!    ACM Transactions on Mathematical Software,
!    Volume 17, Number 1, March 1991, pages 98-111.
!
!  Parameters:
!
!    Output, integer ( kind = 4 ) CG1, CG2, the CG values for the
!    current generator.
!
  implicit none

  integer ( kind = 4 ) cg1
  integer ( kind = 4 ) cg2
!  integer ( kind = 4 ) cgn_get
  integer ( kind = 4 ) g
!  logical initialized_get
!
!  Check whether the package must be initialized.
!
  if ( .not. initialized_get ( ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'GET_STATE - Note:'
    write ( *, '(a)' ) '  Initializing RNGLIB package.'
    call initialize ( )
  end if
!
!  Get the current generator index.
!
  g = cgn_get ( )
!
!  Retrieve the seed values for this generator.
!
  call cg_get ( g, cg1, cg2 )

  return
end subroutine get_state

function i4_uni ( )

!*****************************************************************************80
!
!! I4_UNI generates a random positive integer.
!
!  Discussion:
!
!    This procedure returns a random integer following a uniform distribution
!    over (1, 2147483562) using the current generator.
!
!    The original name of this function was "random()", but this conflicts
!    with a standard library function name in C.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    05 August 2013
!
!  Author:
!
!    Original Pascal version by Pierre L'Ecuyer, Serge Cote.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Pierre LEcuyer, Serge Cote,
!    Implementing a Random Number Package with Splitting Facilities,
!    ACM Transactions on Mathematical Software,
!    Volume 17, Number 1, March 1991, pages 98-111.
!
!  Parameters:
!
!    Output, integer ( kind = 4 ) I4_UNI, the random integer.
!
  implicit none

  integer ( kind = 4 ), parameter :: a1 = 40014
  integer ( kind = 4 ), parameter :: a2 = 40692
!  logical antithetic_get
  integer ( kind = 4 ) cg1
  integer ( kind = 4 ) cg2
!  integer ( kind = 4 ) cgn_get
  integer ( kind = 4 ) g
  integer ( kind = 4 ) i4_uni
!  logical initialized_get
  integer ( kind = 4 ) k
  integer ( kind = 4 ), parameter :: m1 = 2147483563
  integer ( kind = 4 ), parameter :: m2 = 2147483399
  logical value
  integer ( kind = 4 ) z
!
!  Check whether the package must be initialized.
!
  if ( .not. initialized_get ( ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'I4_UNI - Note:'
    write ( *, '(a)' ) '  Initializing RNGLIB package.'
    call initialize ( )
  end if
!
!  Get the current generator index.
!
  g = cgn_get ( )
!
!  Retrieve the seeds for the current generator.
!
  call cg_get ( g, cg1, cg2 )
!
!  Update the seeds.
!
  k = cg1 / 53668
  cg1 = a1 * ( cg1 - k * 53668 ) - k * 12211

  if ( cg1 < 0 ) then
    cg1 = cg1 + m1
  end if

  k = cg2 / 52774
  cg2 = a2 * ( cg2 - k * 52774 ) - k * 3791

  if ( cg2 < 0 ) then
    cg2 = cg2 + m2
  end if
!
!  Store the updated seeds.
!
  call cg_set ( g, cg1, cg2 )
!
!  Construct the random integer from the seeds.
!
  z = cg1 - cg2

  if ( z < 1 ) then
    z = z + m1 - 1
  end if
!
!  If the generator is in antithetic mode, we must reflect the value.
!
  value = antithetic_get ( )

  if ( value ) then
    z = m1 - z
  end if

  i4_uni = z

  return
end function i4_uni

subroutine ig_get ( g, ig1, ig2 )

!*****************************************************************************80
!
!! IG_GET queries the IG values for a given generator.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) G, the index of the generator.
!    1 <= G <= 32.
!
!    Output, integer ( kind = 4 ) IG1, IG2, the IG values for generator G.
!
  implicit none

  integer ( kind = 4 ) g
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ig1
  integer ( kind = 4 ) ig2

  i = -1
  call ig_memory ( i, g, ig1, ig2 )

  return
end subroutine ig_get

subroutine ig_memory ( i, g, ig1, ig2 )

!*****************************************************************************80
!
!! IG_MEMORY stores the IG values for all generators.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) I, the desired action.
!    -1, get a value.
!    0, initialize all values.
!    1, set a value.
!
!    Input, integer ( kind = 4 ) G, for I = -1 or +1, the index of
!    the generator, with 1 <= G <= 32.
!
!    Input/output, integer ( kind = 4 ) IG1, IG2.  For I = -1,
!    these are output, for I = +1, these are input, for I = 0,
!    these arguments are ignored.  When used, the arguments are
!    old or new values of the IG parameter for generator G.
!
  implicit none

  integer ( kind = 4 ), parameter :: g_max = 32

  integer ( kind = 4 ) g
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ig1
  integer ( kind = 4 ) ig1_save(g_max)
  integer ( kind = 4 ) ig2
  integer ( kind = 4 ) ig2_save(g_max)

  save ig1_save
  save ig2_save

  data ig1_save / 32 * 0 /
  data ig2_save / 32 * 0 /

  if ( g < 1 .or. g_max < g ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'IG_MEMORY - Fatal error!'
    write ( *, '(a)' ) '  Input generator index G is out of bounds.'
    stop 1
  end if

  if ( i < 0 ) then
    ig1 = ig1_save(g)
    ig2 = ig2_save(g)
  else if ( i == 0 ) then
    ig1_save(1:g_max) = 0
    ig2_save(1:g_max) = 0
  else if ( 0 < i ) then
    ig1_save(g) = ig1
    ig2_save(g) = ig2
  end if

  return
end subroutine ig_memory

subroutine ig_set ( g, ig1, ig2 )

!*****************************************************************************80
!
!! IG_SET sets the IG values for a given generator.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) G, the index of the generator.
!    1 <= G <= 32.
!
!    Input, integer ( kind = 4 ) IG1, IG2, the IG values for generator G.
!
  implicit none

  integer ( kind = 4 ) g
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ig1
  integer ( kind = 4 ) ig2

  i = +1
  call ig_memory ( i, g, ig1, ig2 )

  return
end subroutine ig_set

subroutine init_generator ( t )

!*****************************************************************************80
!
!! INIT_GENERATOR sets the current generator to initial, last or new seed.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 March 2013
!
!  Author:
!
!    Original Pascal version by Pierre L'Ecuyer, Serge Cote.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Pierre LEcuyer, Serge Cote,
!    Implementing a Random Number Package with Splitting Facilities,
!    ACM Transactions on Mathematical Software,
!    Volume 17, Number 1, March 1991, pages 98-111.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) T, the seed type:
!    0, use the seed chosen at initialization time.
!    1, use the last seed.
!    2, use a new seed set 2^30 values away.
!
  implicit none

  integer ( kind = 4 ), parameter :: a1_w = 1033780774
  integer ( kind = 4 ), parameter :: a2_w = 1494757890
  integer ( kind = 4 ) cg1
  integer ( kind = 4 ) cg2
!  integer ( kind = 4 ) cgn_get
  integer ( kind = 4 ) g
  integer ( kind = 4 ) ig1
  integer ( kind = 4 ) ig2
!  logical initialized_get
  integer ( kind = 4 ) lg1
  integer ( kind = 4 ) lg2
  integer ( kind = 4 ), parameter :: m1 = 2147483563
  integer ( kind = 4 ), parameter :: m2 = 2147483399
!  integer ( kind = 4 ) multmod
  integer ( kind = 4 ) t
!
!  Check whether the package must be initialized.
!
  if ( .not. initialized_get ( ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'INIT_GENERATOR - Note:'
    write ( *, '(a)' ) '  Initializing RNGLIB package.'
    call initialize ( )
  end if
!
!  Get the current generator index.
!
  g = cgn_get ( )
!
!  0: restore the initial seed.
!
  if ( t == 0 ) then

    call ig_get ( g, ig1, ig2 )
    lg1 = ig1
    lg2 = ig2
    call lg_set ( g, lg1, lg2 )
!
!  1: restore the last seed.
!
  else if ( t == 1 ) then

    call lg_get ( g, lg1, lg2 )
!
!  2: advance to a new seed.
!
  else if ( t == 2 ) then

    call lg_get ( g, lg1, lg2 )
    lg1 = multmod ( a1_w, lg1, m1 )
    lg2 = multmod ( a2_w, lg2, m2 )
    call lg_set ( g, lg1, lg2 )

  else

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'INIT_GENERATOR - Fatal error!'
    write ( *, '(a)' ) '  Input parameter T out of bounds.'
    stop 1

  end if
!
!  Store the new seed.
!
  cg1 = lg1
  cg2 = lg2
  call cg_set ( g, cg1, cg2 )

  return
end subroutine init_generator

subroutine initialize ( )

!*****************************************************************************80
!
!! INITIALIZE initializes the random number generator library.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 March 2013
!
!  Author:
!
!    Original Pascal version by Pierre L'Ecuyer, Serge Cote.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Pierre LEcuyer, Serge Cote,
!    Implementing a Random Number Package with Splitting Facilities,
!    ACM Transactions on Mathematical Software,
!    Volume 17, Number 1, March 1991, pages 98-111.
!
!  Parameters:
!
!    None
!
  implicit none

  integer ( kind = 4 ) g
  integer ( kind = 4 ), parameter :: g_max = 32
  integer ( kind = 4 ) ig1
  integer ( kind = 4 ) ig2
  logical value
!
!  Remember that we have called INITIALIZE().
!
  call initialized_set ( )
!
!  Initialize all generators to have FALSE antithetic value.
!
  value = .false.
  do g = 1, g_max
    call cgn_set ( g )
    call antithetic_set ( value )
  end do
!
!  Set the initial seeds.
!
  ig1 = 1234567890
  ig2 = 123456789
  call set_initial_seed ( ig1, ig2 )
!
!  Initialize the current generator index to the first one.
!
  g = 1
  call cgn_set ( g )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'INITIALIZE - Note:'
  write ( *, '(a)' ) '  The RNGLIB package has been initialized.'

  return
end subroutine initialize

function initialized_get ( )

!*****************************************************************************80
!
!! INITIALIZED_GET queries the INITIALIZED value.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    28 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, logical INITIALIZED_GET, is TRUE if the package has
!    been initialized.
!
  implicit none

  integer ( kind = 4 ) i
  logical initialized
  logical initialized_get

  i = -1
  call initialized_memory ( i, initialized )

  initialized_get = initialized

  return
end function initialized_get

subroutine initialized_memory ( i, initialized )

!*****************************************************************************80
!
!! INITIALIZED_MEMORY stores the INITIALIZED value for the package.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    28 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) I, the desired action.
!    -1, get the value.
!    0, initialize the value.
!    1, set the value.
!
!    Input/output, logical INITIALIZED.  For I = -1,
!    this is output, for I = +1, this is input, for I = 0,
!    this argument is ignored.
!
  implicit none

  integer ( kind = 4 ) i
  logical initialized
  logical initialized_save

  save initialized_save

  data initialized_save / .false. /

  if ( i < 0 ) then
    initialized = initialized_save
  else if ( i == 0 ) then
    initialized_save = .false.
  else if ( 0 < i ) then
    initialized_save = initialized
  end if

  return
end subroutine initialized_memory

subroutine initialized_set ( )

!*****************************************************************************80
!
!! INITIALIZED_SET sets the INITIALIZED value true.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    28 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  integer ( kind = 4 ) i
  logical initialized

  i = +1
  initialized = .true.
  call initialized_memory ( i, initialized )

  return
end subroutine initialized_set

subroutine lg_get ( g, lg1, lg2 )

!*****************************************************************************80
!
!! LG_GET queries the LG values for a given generator.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) G, the index of the generator.
!    1 <= G <= 32.
!
!    Output, integer ( kind = 4 ) LG1, LG2, the LG values for generator G.
!
  implicit none

  integer ( kind = 4 ) g
  integer ( kind = 4 ) i
  integer ( kind = 4 ) lg1
  integer ( kind = 4 ) lg2

  i = -1
  call lg_memory ( i, g, lg1, lg2 )

  return
end subroutine lg_get

subroutine lg_memory ( i, g, lg1, lg2 )

!*****************************************************************************80
!
!! LG_MEMORY stores the LG values for all generators.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) I, the desired action.
!    -1, get a value.
!    0, initialize all values.
!    1, set a value.
!
!    Input, integer ( kind = 4 ) G, for I = -1 or +1, the index of
!    the generator, with 1 <= G <= 32.
!
!    Input/output, integer ( kind = 4 ) LG1, LG2.  For I = -1,
!    these are output, for I = +1, these are input, for I = 0,
!    these arguments are ignored.  When used, the arguments are
!    old or new values of the LG parameter for generator G.
!
  implicit none

  integer ( kind = 4 ), parameter :: g_max = 32

  integer ( kind = 4 ) g
  integer ( kind = 4 ) i
  integer ( kind = 4 ) lg1
  integer ( kind = 4 ) lg1_save(g_max)
  integer ( kind = 4 ) lg2
  integer ( kind = 4 ) lg2_save(g_max)

  save lg1_save
  save lg2_save

  data lg1_save / 32 * 0 /
  data lg2_save / 32 * 0 /

  if ( g < 1 .or. g_max < g ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'LG_MEMORY - Fatal error!'
    write ( *, '(a)' ) '  Input generator index G is out of bounds.'
    stop 1
  end if

  if ( i < 0 ) then
    lg1 = lg1_save(g)
    lg2 = lg2_save(g)
  else if ( i == 0 ) then
    lg1_save(1:g_max) = 0
    lg2_save(1:g_max) = 0
  else if ( 0 < i ) then
    lg1_save(g) = lg1
    lg2_save(g) = lg2
  end if

  return
end subroutine lg_memory

subroutine lg_set ( g, lg1, lg2 )

!*****************************************************************************80
!
!! LG_SET sets the LG values for a given generator.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 March 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) G, the index of the generator.
!    1 <= G <= 32.
!
!    Input, integer ( kind = 4 ) LG1, LG2, the LG values for generator G.
!
  implicit none

  integer ( kind = 4 ) g
  integer ( kind = 4 ) i
  integer ( kind = 4 ) lg1
  integer ( kind = 4 ) lg2

  i = +1
  call lg_memory ( i, g, lg1, lg2 )

  return
end subroutine lg_set

function multmod ( a, s, m )

!*****************************************************************************80
!
!! MULTMOD carries out modular multiplication.
!
!  Discussion:
!
!    This procedure returns
!
!      ( A * S ) mod M
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 March 2013
!
!  Author:
!
!    Original Pascal version by Pierre L'Ecuyer, Serge Cote.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Pierre LEcuyer, Serge Cote,
!    Implementing a Random Number Package with Splitting Facilities,
!    ACM Transactions on Mathematical Software,
!    Volume 17, Number 1, March 1991, pages 98-111.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) A, S, M, the arguments.
!
!    Output, integer ( kind = 4 ) MULTMOD, the value of the product of A and S,
!    modulo M.
!
  implicit none

  integer ( kind = 4 ) a
  integer ( kind = 4 ) a0
  integer ( kind = 4 ) a1
  integer ( kind = 4 ), parameter :: h = 32768
  integer ( kind = 4 ) k
  integer ( kind = 4 ) m
  integer ( kind = 4 ) multmod
  integer ( kind = 4 ) p
  integer ( kind = 4 ) q
  integer ( kind = 4 ) qh
  integer ( kind = 4 ) rh
  integer ( kind = 4 ) s

  if ( a <= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'MULTMOD - Fatal error!'
    write ( *, '(a)' ) '  A <= 0.'
    stop 1
  end if

  if ( m <= a ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'MULTMOD - Fatal error!'
    write ( *, '(a)' ) '  M <= A.'
    stop 1
  end if

  if ( s <= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'MULTMOD - Fatal error!'
    write ( *, '(a)' ) '  S <= 0.'
    stop 1
  end if

  if ( m <= s ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'MULTMOD - Fatal error!'
    write ( *, '(a)' ) '  M <= S.'
    stop 1
  end if

  if ( a < h ) then

    a0 = a
    p = 0

  else

    a1 = a / h
    a0 = a - h * a1
    qh = m / h
    rh = m - h * qh

    if ( h <= a1 ) then

      a1 = a1 - h
      k = s / qh
      p = h * ( s - k * qh ) - k * rh

      do while ( p < 0 )
        p = p + m
      end do

    else

      p = 0

    end if

    if ( a1 /= 0 ) then

      q = m / a1
      k = s / q
      p = p - k * ( m - a1 * q )

      if ( 0 < p ) then
        p = p - m
      end if

      p = p + a1 * ( s - k * q )

      do while ( p < 0 )
        p = p + m
      end do

    end if

    k = p / qh
    p = h * ( p - k * qh ) - k * rh

    do while ( p < 0 )
      p = p + m
    end do

  end if

  if ( a0 /= 0 ) then

    q = m / a0
    k = s / q
    p = p - k * ( m - a0 * q )

    if ( 0 < p ) then
      p = p - m
    end if

    p = p + a0 * ( s - k * q )

    do while ( p < 0 )
      p = p + m
    end do

  end if

  multmod = p

  return
end function multmod

function r4_uni_01 ( )

!*****************************************************************************80
!
!! R4_UNI_01 returns a uniform random real number in [0,1].
!
!  Discussion:
!
!    This procedure returns a random floating point number from a uniform
!    distribution over (0,1), not including the endpoint values, using the
!    current random number generator.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    05 August 2013
!
!  Author:
!
!    Original Pascal version by Pierre L'Ecuyer, Serge Cote.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Pierre LEcuyer, Serge Cote,
!    Implementing a Random Number Package with Splitting Facilities,
!    ACM Transactions on Mathematical Software,
!    Volume 17, Number 1, March 1991, pages 98-111.
!
!  Parameters:
!
!    Output, real ( kind = 4 ) R4_UNI_01, a uniform random value in [0,1].
!
  implicit none

  integer ( kind = 4 ) i
!  integer ( kind = 4 ) i4_uni
!  logical initialized_get
  real ( kind = 4 ) r4_uni_01
!
!  Check whether the package must be initialized.
!
  if ( .not. initialized_get ( ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'R4_UNI_01 - Note:'
    write ( *, '(a)' ) '  Initializing RNGLIB package.'
    call initialize ( )
  end if
!
!  Get a random positive integer.
!
  i = i4_uni ( )
!
!  Scale it to a random real in [0,1].
!
  r4_uni_01 = real ( i, kind = 4 ) * 4.656613057E-10

  return
end function r4_uni_01

function r8_uni_01 ( )

!*****************************************************************************80
!
!! R8_UNI_01 returns a uniform random double precision number in [0,1].
!
!  Discussion:
!
!    This procedure returns a random floating point number from a uniform
!    distribution over (0,1), not including the endpoint values, using the
!    current random number generator.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    05 August 2013
!
!  Author:
!
!    Original Pascal version by Pierre L'Ecuyer, Serge Cote.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Pierre LEcuyer, Serge Cote,
!    Implementing a Random Number Package with Splitting Facilities,
!    ACM Transactions on Mathematical Software,
!    Volume 17, Number 1, March 1991, pages 98-111.
!
!  Parameters:
!
!    Output, real ( kind = 8 ) R8_UNI_01, a uniform random value in [0,1].
!
  implicit none

  integer ( kind = 4 ) i
!  integer ( kind = 4 ) i4_uni
!  logical initialized_get
  real ( kind = 8 ) r8_uni_01
!
!  Check whether the package must be initialized.
!
  if ( .not. initialized_get ( ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'R8_UNI_01 - Note:'
    write ( *, '(a)' ) '  Initializing RNGLIB package.'
    call initialize ( )
  end if
!
!  Get a random positive integer.
!
  i = i4_uni ( )
!
!  Scale it to a random real in [0,1].
!
  r8_uni_01 = real ( i, kind = 8 ) * 4.656613057D-10

  return
end function r8_uni_01

subroutine set_initial_seed ( ig1, ig2 )

!*****************************************************************************80
!
!! SET_INITIAL_SEED resets the initial seed and state for all generators.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    28 March 2013
!
!  Author:
!
!    Original Pascal version by Pierre L'Ecuyer, Serge Cote.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Pierre LEcuyer, Serge Cote,
!    Implementing a Random Number Package with Splitting Facilities,
!    ACM Transactions on Mathematical Software,
!    Volume 17, Number 1, March 1991, pages 98-111.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) IG1, IG2, the initial seed values
!    for the first generator.
!    1 <= IG1 < 2147483563
!    1 <= IG2 < 2147483399
!
  implicit none

  integer ( kind = 4 ), parameter :: a1_vw = 2082007225
  integer ( kind = 4 ), parameter :: a2_vw = 784306273
  integer ( kind = 4 ) g
  integer ( kind = 4 ), parameter :: g_max = 32
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ig1
  integer ( kind = 4 ) ig2
!  logical initialized_get
  integer ( kind = 4 ), parameter :: m1 = 2147483563
  integer ( kind = 4 ), parameter :: m2 = 2147483399
!  integer ( kind = 4 ) multmod
  integer ( kind = 4 ) t

  if ( ig1 < 1 .or. m1 <= ig1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'SET_INITIAL_SEED - Fatal error!'
    write ( *, '(a)' ) '  Input parameter IG1 out of bounds.'
    stop 1
  end if

  if ( ig2 < 1 .or. m2 <= ig2 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'SET_INITIAL_SEED - Fatal error!'
    write ( *, '(a)' ) '  Input parameter IG2 out of bounds.'
    stop 1
  end if
!
!  Because INITIALIZE calls SET_INITIAL_SEED, it's not easy to correct
!  the error that arises if SET_INITIAL_SEED is called before INITIALIZE.
!  So don't bother trying.
!
  if ( .not. initialized_get ( ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'SET_INITIAL_SEED - Fatal error!'
    write ( *, '(a)' ) '  The RNGLIB package has not been initialized.'
    stop 1
  end if
!
!  Set the initial seed, then initialize the first generator.
!
  g = 1
  call cgn_set ( g )

  call ig_set ( g, ig1, ig2 )

  t = 0
  call init_generator ( t )
!
!  Now do similar operations for the other generators.
!
  do g = 2, g_max

    call cgn_set ( g )
    ig1 = multmod ( a1_vw, ig1, m1 )
    ig2 = multmod ( a2_vw, ig2, m2 )
    call ig_set ( g, ig1, ig2 )
    call init_generator ( t )

  end do
!
!  Now choose the first generator.
!
  g = 1
  call cgn_set ( g )

  return
end subroutine set_initial_seed

subroutine set_seed ( cg1, cg2 )

!*****************************************************************************80
!
!! SET_SEED resets the initial seed and state of the current generator.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 March 2013
!
!  Author:
!
!    Original Pascal version by Pierre L'Ecuyer, Serge Cote.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Pierre LEcuyer, Serge Cote,
!    Implementing a Random Number Package with Splitting Facilities,
!    ACM Transactions on Mathematical Software,
!    Volume 17, Number 1, March 1991, pages 98-111.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) CG1, CG2, the CG values for generator G.
!    1 <= CG1 < 2147483563
!    1 <= CG2 < 2147483399
!
  implicit none

  integer ( kind = 4 ) cg1
  integer ( kind = 4 ) cg2
!  integer ( kind = 4 ) cgn_get
  integer ( kind = 4 ) g
  integer ( kind = 4 ) i
!  logical initialized_get
  integer ( kind = 4 ), parameter :: m1 = 2147483563
  integer ( kind = 4 ), parameter :: m2 = 2147483399
  integer ( kind = 4 ) t

  if ( cg1 < 1 .or. m1 <= cg1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'SET_SEED - Fatal error!'
    write ( *, '(a)' ) '  Input parameter CG1 out of bounds.'
    stop 1
  end if

  if ( cg2 < 1 .or. m2 <= cg2 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'SET_SEED - Fatal error!'
    write ( *, '(a)' ) '  Input parameter CG2 out of bounds.'
    stop 1
  end if
!
!  Check whether the package must be initialized.
!
  if ( .not. initialized_get ( ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'SET_SEED - Note:'
    write ( *, '(a)' ) '  Initializing RNGLIB package.'
    call initialize ( )
  end if
!
!  Retrieve the current generator index.
!
  g = cgn_get ( )
!
!  Set the seeds.
!
  call cg_set ( g, cg1, cg2 )
!
!  Initialize the generator.
!
  t = 0
  call init_generator ( t )

  return
end subroutine set_seed

subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end subroutine timestamp

end module rnglib


program OOPlaneMestTest

use NumberKindsModule
use LoggerModule
use OutputWriterModule
use UtilitiesModule
use PolyMeshOOModule
use FieldOOModule

implicit none

type(PolyMesh2d), pointer :: mesh=>null()
type(Field), pointer :: scalarField => null()
type(Field), pointer :: vectorField => null()
integer(kint) ::  initNest, i, j, doOutput
character(len=56) :: mesh_type, vtkFile

real(kreal), parameter :: intCosBump = 16.0_kreal / PI**2
real(kreal), parameter :: triIntExact = 1.4741613930426135683_kreal
real(kreal), parameter :: dx = 2.0_kreal / 50.0_kreal
real(kreal), dimension(3), parameter :: outsidePoint = [3.0_kreal, 3.0_kreal, dzero]
real(kreal), dimension(3), parameter :: insidePoint = [0.5_kreal, -0.333_kreal, dzero]

type(Logger) :: exeLog
character(len=56) :: logkey = "OOPlaneMestTest"
character(len=MAX_STRING_LENGTH) :: logstring

call New(exeLog, DEBUG_LOGGING_LEVEL)
call getInput(initNest, doOutput)

call LogMessage(exeLog, TRACE_LOGGING_LEVEL,trim(logkey)//" part 1: build each planar mesh to initNest = ", initNest)
call LogMessage(exeLog, TRACE_LOGGING_LEVEL,trim(logkey), " part 2: define scalar and vector fields on mesh.")
call LogMessage(exeLog, TRACE_LOGGING_LEVEL,trim(logkey), " part 3: demonstrate quadrature on mesh.")
call LogMessage(exeLog, TRACE_LOGGING_LEVEL,trim(logkey), " part 4: demonstrate interpolation on a cubic mesh.")
call LogMessage(exeLog, TRACE_LOGGING_LEVEL,trim(logKey), " part 5: output to vtk xml file.")

!-------------------------------------
!   Test Planar mesh, linear triangles
!-------------------------------------
mesh_type = "planar_tri"
write(vtkFile,'(A,I1,A)') trim(mesh_type), initNest, '.vtp'
call StartSection(exeLog,'Planar Tri Test.')
call runTest(mesh, mesh_type, initNest, vtkFile)
call EndSection(exeLog)

!-------------------------------------
!   Test Planar mesh, linear quads
!-------------------------------------
mesh_type = "planar_quad"
write(vtkFile,'(A,I1,A)') trim(mesh_type), initNest, '.vtp'
call StartSection(exeLog,'Planar Quad Test.')
call runTest(mesh, mesh_type, initNest, vtkFile)
call EndSection(exeLog)

!-------------------------------------
!   Test Planar mesh, cubic quads
!-------------------------------------

mesh_type = "planar_cubic_quad"
write(vtkFile,'(A,I1,A)') trim(mesh_type), initNest, '.vtp'
call StartSection(exeLog,'Planar Cubic Quad Test.')
call runTest(mesh, mesh_type, initNest, vtkFile)
call EndSection(exeLog)

if (testPass) call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logkey)//" result:", " PASSED.")

contains

subroutine runTest(mesh_ptr, mesh_type, initNest, oname)
    type(PolyMesh2d), pointer, intent(inout) :: mesh_ptr
    character(len=*), intent(in) :: mesh_type
    integer(kint), intent(in) :: initNest
    character(len=*), intent(in) :: oname
    !
    real(kreal) :: computedIntegral
    real(kreal), dimension(3) :: interpTargetPt
    integer(kint) :: i, j
    real(kreal) :: interpErr, lagErr
    real(kreal), dimension(51) :: unifX, unifY
    real(kreal), dimension(51,51) :: interp, exact, interpX0, interpY0
    real(kreal), dimension(3) :: xyz0
    type(PolyMesh2d) :: copiedMesh

    allocate(mesh_ptr)
    allocate(scalarField)
    allocate(vectorField)
    call mesh_ptr%init(mesh_type, initNest, initNest, 0, 1.0_kreal)
    call mesh_ptr%logStats(exeLog)

    call copiedMesh%init(mesh_type, initNest, initNest, 0, 1.0_kreal)
    call copiedMesh%copy(mesh_ptr)
    call StartSection(exeLog, "mesh copy")
    call copiedMesh%logStats(exeLog)
    call EndSection(exeLog)

    write(logstring,'(2A)') "point (3,3) is outside mesh; mesh%pointIsOutsideMesh((3,3)) = ", &
        merge("true ", "false", copiedMesh%pointIsOutsideMesh(outsidePoint))
    call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "outside mesh test: ", trim(logstring))
    write(logstring,'(2A)') "point (1/2,-1/3) is inside mesh; mesh%pointIsOutsideMesh((1/2,-1/3)) = ", &
        merge("true ", "false", copiedMesh%pointIsOutsideMesh(insidePoint))
    call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "outside mesh test: ", trim(logstring))

    call scalarField%init(1, mesh_ptr%particles%N, "scalar")
    do i=1, mesh_ptr%particles%N
        call scalarField%insertScalar(cosineBump([mesh_ptr%particles%x(i), mesh_ptr%particles%y(i)]))
    enddo

    call vectorField%init(2, mesh_ptr%particles%N, "scalarGradient")
    do i=1, mesh_ptr%particles%n
        call vectorField%insertVector(bumpGrad([mesh_ptr%particles%x(i), mesh_ptr%particles%y(i)]))
    enddo

    computedIntegral = mesh_ptr%integrateScalar(scalarField)
    interpErr = dzero
    if (mesh_ptr%faceKind == QUAD_CUBIC_PANEL) then
        do j=1,51
            unifx(j) = -one + dx*(j-1)
        enddo
        do i=1, 51
            unify(i) = -one + dx*(i-1)
        enddo
        do j=1,51
            do i=1,51
                exact(i,j) = cosineBump([unifX(j), unifY(i)])
            enddo
        enddo
        interpTargetPt = dzero
        lagErr = dzero
        do j=1,51
            do i=1,51
                interpTargetPt(1) = unifx(j)
                interpTargetPt(2) = unify(i)
                interp(i,j) = mesh_ptr%interpolateScalar(interpTargetPt, scalarField)
                xyz0 = mesh_ptr%interpolateLagCoord(interpTargetPt)
                interpX0(i,j) = xyz0(1)
                interpY0(i,j) = xyz0(2)

                !write(logString,'(2(A,2G15.8),A)') "(x0,y0) = (", unifx(j), unify(i), &
                !    "), interp. (x0, y0) = (", xyz0(1), xyz0(2), ")"
                !call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "lagCoordInterp: ", logstring)

                if (sqrt((unifx(j)-xyz0(1))**2 + (unify(i)-xyz0(2))**2) > lagErr) &
                    lagErr = sqrt((unifx(j)-xyz0(1))**2 + (unify(i)-xyz0(2))**2)
            enddo
        enddo
        interpErr = maxval(abs(exact-interp))
        call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "scalar interp error = ", interpErr)
        call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "lagCoord interp error = ", lagErr)
    endif

    call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "scalar integral = ", computedIntegral)
    if (mesh_ptr%faceKind == TRI_PANEL) then
        call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "mesh size = ", mesh_ptr%edges%avgLength(mesh_ptr%particles))
        call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "abs(integralErr) = ", abs(computedIntegral-triIntExact))
    elseif (mesh_ptr%faceKind == QUAD_PANEL .or. mesh_ptr%faceKind==QUAD_CUBIC_PANEL) then
        call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "mesh size = ", mesh_ptr%edges%avgLength(mesh_ptr%particles))
        call LogMessage(exeLog, TRACE_LOGGING_LEVEL, "abs(integralErr) = ", abs(computedIntegral-intCosBump))
    endif

    if (doOutput>0) then
        open(unit=WRITE_UNIT_1, file=vtkFile, action='write', status='replace')
        call mesh_ptr%writeVTKSerialStartXML(WRITE_UNIT_1)
        write(WRITE_UNIT_1,'(A)') '     <PointData Scalars="sineWave" Vectors="gradSineWave">'
        call scalarField%writeVtkPointDataXML(WRITE_UNIT_1)
        call vectorField%writeVtkPointDataXML(WRITE_UNIT_1)
        write(WRITE_UNIT_1,'(A)') '     </PointData>'
        call mesh_ptr%writeVTKSerialEndXML(WRITE_UNIT_1)
        close(WRITE_UNIT_1)
        write(vtkFile,'(A,I1,A)') trim(mesh_type), initNest, '.m'

        if (mesh_ptr%faceKind == QUAD_CUBIC_PANEL) then
            open(unit=WRITE_UNIT_1, file=vtkFile, action='write', status='replace')
            call mesh%writeMatlab(WRITE_UNIT_1)
            call scalarField%writeMatlab(WRITE_UNIT_1)
            call vectorField%writeMatlab(WRITE_UNIT_1)
            call writeToMatlab(unifX, WRITE_UNIT_1, "unifx")
            call writeToMatlab(unify, WRITE_UNIT_1, "unify")
            call writeToMatlab(exact, WRITE_UNIT_1, "exact")
            call writeToMatlab(interp, WRITE_UNIT_1, "interp")
            call writeToMatlab(interpX0, WRITE_UNIT_1, "x0interp")
            call writeToMatlab(interpY0, WRITE_UNIT_1, "y0interp")
            close(WRITE_UNIT_1)
        endif
    endif

    deallocate(vectorField)
    deallocate(scalarField)
    deallocate(mesh)
    nullify(mesh)
    nullify(vectorField)
    nullify(scalarField)
end subroutine

subroutine getInput(initNest, doOutput)
    integer(kint), intent(out) :: initNest, doOutput
    !
    integer(kint) :: argc
    character(len=MAX_STRING_LENGTH) :: argv
    argc = IARGC()
    if (argc == 0) then
        initNest = 0
        doOutput = 1
    elseif (argc==1) then
        call GETARG(1,argv)
        read(argv,*) initNest
        doOutput = 0
    else
        call GETARG(1,argv)
        read(argv,*) initNest
        call GETARG(2,argv)
        read(argv,*) doOutput
    endif
end subroutine

pure function cosineBump(xy)
    real(kreal) :: cosineBump
    real(kreal), intent(in) :: xy(2)
    cosineBump = cos(0.5_kreal * PI * xy(1)) * cos(0.5_kreal * PI * xy(2))
end function

pure function bumpGrad(xy)
    real(kreal) :: bumpGrad(2)
    real(kreal), intent(in) :: xy(2)
    bumpGrad(1) = -0.5_kreal * PI * sin(0.5_kreal*PI*xy(1)) * sin(0.5_kreal*PI*xy(2))
    bumpGrad(2) = -0.5_kreal *PI * cos(0.5_kreal*PI*xy(1))*sin(0.5_kreal*PI*xy(2))
end function

pure function sineWave(xy)
    real(kreal) :: sineWave
    real(kreal), dimension(2), intent(in) :: xy
    sineWave = sin(2.0_kreal*PI* xy(1)*1.0_kreal) * sin(2.0_kreal*PI*xy(2)*1.0_kreal)
end function

pure function sineWaveGrad(xy)
    real(kreal), dimension(2) :: sineWaveGrad
    real(kreal), dimension(2), intent(in) :: xy

    sinewaveGrad(1) = 2.0_kreal*PI*1.0_kreal * cos(2.0_kreal*PI*xy(1)*1.0_kreal) * sin(2.0_kreal*PI*xy(2)*1.0_kreal)
    sinewaveGrad(2) = 2.0_kreal*PI*1.0_kreal * sin(2.0_kreal*PI*xy(1)*1.0_kreal) * cos(2.0_kreal*PI*xy(2)*1.0_kreal)
end function

end program


!>
! @license Apache-2.0
!
! Copyright (c) 2019 The Stdlib Authors.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!    http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!<

!> Computes the dot product of two vectors.
!
! ## Notes
!
! * Modified verstion of reference BLAS level1 routine (version 3.7.0). Updated to "free form" Fortran 95.
!
! ## Authors
!
! * Univ. of Tennessee
! * Univ. of California Berkeley
! * Univ. of Colorado Denver
! * NAG Ltd.
!
! ## History
!
! * Jack Dongarra, linpack, 3/11/78.
!
!   - modified 12/3/93, array(1) declarations changed to array(*)
!
! ## License
!
! From <http://netlib.org/blas/faq.html>:
!
! > The reference BLAS is a freely-available software package. It is available from netlib via anonymous ftp and the World Wide Web. Thus, it can be included in commercial software packages (and has been). We only ask that proper credit be given to the authors.
! >
! > Like all software, it is copyrighted. It is not trademarked, but we do ask the following:
! >
! > * If you modify the source for these routines we ask that you change the name of the routine and comment the changes made to the original.
! >
! > * We will gladly answer any questions regarding the software. If a modification is done, however, it is the responsibility of the person who modified the routine to provide support.
!
! @param {integer} N - number of values over which to compute the dot product
! @param {Array<double>} sx - first array
! @param {integer} strideX - `sx` stride length
! @param {Array<double>} sy - second array
! @param {integer} strideY - `sy` stride length
! @returns {double} the dot product of `sx` and `sy`
!<
double precision function ddot( N, sx, strideX, sy, strideY )
  implicit none
  ! ..
  ! Scalar arguments:
  integer :: strideX, strideY, N
  ! ..
  ! Array arguments:
  double precision, intent(in) :: sx(*), sy(*)
  ! ..
  ! Local scalars:
  double precision :: stemp
  integer :: mp1, ix, iy, i, m
  ! ..
  ! Intrinsic functions:
  intrinsic mod
  ! ..
  stemp = 0.0e0
  ddot = 0.0e0
  ! ..
  if ( N <= 0 ) then
    return
  end if
  ! ..
  ! If both strides are equal to `1`, use unrolled loops...
  if ( strideX == 1 .AND. strideY == 1 ) then
    m = mod( N, 5 )
   ! ..
    ! If we have a remainder, do a clean-up loop...
    if ( m /= 0 ) then
      do i = 1, m
        stemp = stemp + ( sx( i ) + sy( i ) )
      end do
    end if
    if ( N < M ) then
      ddot = stemp
      return
    end if
    mp1 = m + 1
    do i = mp1, N, 5
      stemp = stemp + &
        ( sx( i ) * sy( i ) ) + &
        ( sx( i+1 ) * sy( i+1 ) ) + &
        ( sx( i+2 ) * sy( i+2 ) ) + &
        ( sx( i+3 ) * sy( i+3 ) ) + &
        ( sx( i+4 ) * sy( i+4 ) )
    end do
  else
    if ( strideX < 0 ) then
      ix = ( 1-N ) * strideX
    else
      ix = 0
    endif
    if ( strideY < 0 ) then
      iy = ( 1-N ) * strideY
    else
      iy = 0
    endif
    do i = 1, N
      stemp = stemp + ( sx( ix ) * sy( iy ) )
      ix = ix + strideX
      iy = iy + strideY
    end do
  endif
  ddot = stemp
  return
end function ddot