C    @(#)gettapfp.f	20.1 1/4/99
C****************************************************************
C
C        File: gettapfp.f (GeT tapfp)
C
C        Purpose: Routine to deterimine tapfp such that tstart is
C                 a discrete tap.
C
C        Input parameters:
C
C             tstart:   Starting primary tap
C             tmin:     Minimum Per unit primary tap
C             tmax:     Maximum Per unit primary tap
C             numtaps:  Number of taps
C
C        Output parameters:
c
C             numtaps:  Number of taps (if original value was zero)
C             stepsize: Step size Per Unit (with f12.8 resolution)
C             tappf:    Ancilliary tap to assure tstart is discrete
C
C        Author: Walt Powell  Date: 21 May 1996
C        Called by: ext_gel.f
C
C****************************************************************
	integer function gettapfp (tstart, tmin, tmax, numtaps,
     &                             stepsize, tapfp)

        include 'ipfinc/parametr.inc'
        include 'ipfinc/prt.inc'

        character tempc*12

        gettapfp = 0

        if (numtaps .gt. 1) then
          stepsize = (tmax - tmin) / (float(numtaps) - 1.0)
        else
          stepsize = 0.00025
          steptot = (tmax - tmin) / stepsize
          numtaps = steptot + 1.5
        endif
        write (tempc, fmt='(f12.6)') stepsize
        stepsize = ftn_atof (tempc)

        tmax = tmin + (float(numtaps) - 1.0) * stepsize + 0.00001
c
c       Test if tstart is at a discrete tap
c
        step = (tstart - tmin) / stepsize
        if (step .ge. 0.0) then
          istep = step + 0.99
        else
          istep = step - 0.99
        endif
        tapfp = tmin + float (istep) * stepsize
        return
        end


      double precision function lotopdecaywidth(mt,mb,mw,gamw)
************************************************************************
*     Authors: R.K. Ellis and J. Campbell, February 2012               *
*                                                                      *
*     LO width of the top quark, including the effect of the           *
*     bottom quark mass and off shellness                              *
*                                                                      *
*     Formula is taken from Eq. (27) of                                *
*                                                                      *
*     \bibitem{Czarnecki:1990kv}                                       *
*     A.~Czarnecki,                                                    *
*     ``QCD corrections to the decay t ---> W b                        *
*       in dimensional regularization,''                               *
*     Phys.\ Lett.\ B {\bf 252}, 467 (1990).                           *
*     %%CITATION = PHLTA,B252,467;%%                                   *
*                                                                      *
*                                                                      *
************************************************************************
      implicit none
      include 'zerowidth.f'
      double precision mb,mt,mt1,mw,om,omsq,be,besq,dgauss,Gamma0,
     & xlo,xhi,xi,gamw,ga,Gamma0int
      double precision cachemass,cachewidth,tiny
      data cachemass,cachewidth,tiny/0d0,0d0,1d-8/
      common/transfer/mt1,besq,xi,ga
      save cachemass,cachewidth,tiny
!$omp threadprivate(cachemass,cachewidth,tiny,/transfer/)
      external Gamma0int

c--- check to see if result has already been computed
      if (abs(mt*mw-mb-cachemass) .lt. tiny) then
        lotopdecaywidth=cachewidth
        return
      endif

      mt1=mt
      om=mw/mt
      be=mb/mt
      besq=be**2

      if (zerowidth) then
      omsq=om**2
      lotopdecaywidth=Gamma0(mt,besq,omsq)
      else
      xlo=0d0
      xhi=(1d0-be)**2
      ga=gamw/mw
      xi=(mt/mw)**2
      lotopdecaywidth=dgauss(Gamma0int,xlo,xhi,tiny)
      endif

c--- set-up caching variables
      cachemass=mt*mw-mb
      cachewidth=lotopdecaywidth

      return
      end


module fcn_monopole
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, ONE, TWO, THREE, FOUR, PI, EIGHT
    use type_point,     only: point_t
    use type_point_ad,  only: point_ad_t
    use type_function,  only: function_t
    use DNAD_D
    implicit none

    !>  Gaussian function.
    !!
    !!  Three 1D Gaussian functions are computed; one for each dimension. They are multiplied
    !!  together to create a 3D version of the function.
    !!
    !!  \f$  f_x(t,\vec{x}) = a e^{- \frac{(x-b_x)^2}{2c^2} }    \\
    !!       f_y(t,\vec{x}) = a e^{- \frac{(y-b_y)^2}{2c^2} }    \\
    !!       f_z(t,\vec{x}) = a e^{- \frac{(z-b_z)^2}{2c^2} }    \\
    !!       f(t,\vec{x}) = f_x * f_y * f_z                      \f$
    !!
    !!  Function parameters:
    !!
    !!  \f$ a   -   \text{Amplitude of the distribution}   \\
    !!      b_i -   \text{Offset in coordinate 'i'}        \\
    !!      c   -   \text{Width of the distribution}   \f$
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !-------------------------------------------------------------------------------------
    type, extends(function_t), public :: monopole_f

    contains
        procedure   :: init
        procedure   :: compute
    end type monopole_f
    !*************************************************************************************

contains

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(monopole_f),  intent(inout)   :: self

        ! Set function name
        call self%set_name("monopole")

        ! Set function options to default settings
        call self%add_option('a',1._rk)

    end subroutine init
    !*************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !!  Removed the use of complex numbers with algebraic operations to allow the use
    !!  of AD_D type for coordinates.
    !!
    !!  @author Matteo Ugolotti
    !!  @date   8/19/2018
    !!
    !----------------------------------------------------------------------------------
    impure elemental function compute(self,time,coord) result(val)
        class(monopole_f),  intent(inout)   :: self
        real(rk),           intent(in)      :: time
        type(point_ad_t),   intent(in)      :: coord

        type(AD_D)  :: val

        type(AD_D)  :: x, y, z, r, B_real, B_imag, e_real, e_imag,  &
                       exp_real, exp_imag, mul_real, mul_imag
        real(rk)    :: omega, k, q, imag_real, imag_imag,           &
                       rhobar, cbar, a, Lw, freq

        complex(rk) :: B, imag

        !imag = cmplx(ZERO,ONE)
        imag_real = ZERO
        imag_imag = ONE

        !
        ! Get inputs and function parameters
        !
        x = coord%c1_
        y = coord%c2_
        z = coord%c3_
        r = sqrt(x*x + y*y + z*z)

        !
        ! Set physical constants
        !
        rhobar = 1.225_rk
        cbar   = 340.25_rk
        Lw     = 0.004819_rk
        freq   = 42.5_rk

        !
        ! Compute monpole amplitude(B) at r
        !
        omega = TWO*PI*freq
        k     = omega/cbar
        q = sqrt(EIGHT*PI*cbar*Lw/(rhobar*((TWO*PI*freq)**TWO)))
        ! (x + yi)*u = xu + yui
        B_real = imag_real * ( rhobar*cbar*q*k/(FOUR*PI*r) )
        B_imag = imag_imag * ( rhobar*cbar*q*k/(FOUR*PI*r) )
        !B = imag*rhobar*cbar*q*k/(FOUR*PI*r)

        !
        ! Get indicator to compute 'real' or 'imaginary' component
        !
        a   = self%get_option_value('a')

        !
        ! Decompose complex number calculations into algebraic steps
        !
        ! -imag*k*r => -(x + yi)*u = -xu - yui
        e_real = -imag_real * k * r
        e_imag = -imag_imag * k * r
        ! exp(-imag*k*r) => e^(x+yi) = e^(x) * e^(yi)
        !                => e^(yi)   = cos(y) + isin(y)
        !                => e^(x+yi) = e^(x) * cos(y) + (e^(x) * sin(y))i
        exp_real = exp(e_real) * dcos(e_imag)
        exp_imag = exp(e_real) * dsin(e_imag)
        ! B * exp(-imag*k*r) => (x + yi)*(u + vi) = (xu - yv) + (xv + yu)i
        mul_real = B_real * exp_real - B_imag * exp_imag
        mul_imag = B_real * exp_imag + B_imag * exp_real

        if ( a < ONE ) then
            !val = B*cos(-k*r)
            !val = real(B*exp(-imag*k*r))
            val = mul_real
        else if ( a > ONE ) then
            !val = B*sin(-k*r)
            !val = aimag(B*exp(-imag*k*r))
            val = mul_imag
        end if

    end function compute
    !***********************************************************************************

end module fcn_monopole


!! This module contains optimization subroutine and parametric model
module mod_minimize
  !! This module contains optimization subroutine and parametric model
  use mod_constants
  use mod_array
  use mod_optimize
  use mod_optimize_lym

  implicit none

  private

  public :: minimize_spec, minimize

contains

  subroutine minimize_spec(n, m, x, lb, ub, line, dim_v, n_gauss, maxiter, iprint)
    !! Minimize algorithn for a specturm
    implicit none

    integer, intent(in) :: n
    integer, intent(in) :: m
    integer, intent(in) :: dim_v
    integer, intent(in) :: n_gauss, maxiter
    integer, intent(in) :: iprint

    real(xp), intent(in), dimension(:), allocatable :: lb, ub
    real(xp), intent(in), dimension(dim_v) :: line

    real(xp), intent(in), dimension(:), allocatable :: x

    real(xp), parameter    :: factr  = 1.0d+7, pgtol  = 1.0d-5

    character(len=60)      :: task, csave
    logical                :: lsave(4)
    integer                :: isave(44)
    real(xp)               :: f
    real(xp)               :: dsave(29)
    integer,  dimension(:), allocatable  :: nbd, iwa
    real(xp), dimension(:), allocatable  :: g, wa

    real(xp), dimension(:), allocatable  :: residual

    !     Allocate dynamic arrays
    allocate(nbd(n), g(n))
    allocate(iwa(3*n))
    allocate(wa(2*m*n + 5*n + 11*m*m + 8*m))

    allocate(residual(dim_v))
    residual = 0._xp

    ! Init nbd
    nbd = 2

    !     We now define the starting point.
    !     We start the iteration by initializing task.
    task = 'START'

    !     The beginning of the loop
    do while(task(1:2).eq.'FG'.or. task.eq.'NEW_X' .or. task.eq.'START')

       !     This is the call to the L-BFGS-B code.
       call setulb (n, m, x, lb, ub, nbd, f, g, factr, pgtol, wa, iwa, task, iprint, csave, lsave, isave, dsave)

       if (task(1:2) .eq. 'FG') then
          !     Compute function f and gradient g for the sample problem.
          call myresidual(x, line, residual, n_gauss, dim_v)
          f = myfunc_spec(residual)
          call mygrad_spec(n_gauss, g, residual, x, dim_v)

       elseif (task(1:5) .eq. 'NEW_X') then
          !        1) Terminate if the total number of f and g evaluations
          !             exceeds maxiter.
          if (isave(34) .ge. maxiter) &
               task='STOP: TOTAL NO. of f AND g EVALUATIONS EXCEEDS LIMIT'

          !        2) Terminate if  |proj g|/(1+|f|) < 1.0d-10.
          if (dsave(13) .le. 1.d-10*(1.0d0 + abs(f))) &
               task='STOP: THE PROJECTED GRADIENT IS SUFFICIENTLY SMALL'
       endif
    !     end of loop do while
    end do

    deallocate(nbd, g)
    deallocate(iwa)
    deallocate(wa)
    deallocate(residual)
  end subroutine minimize_spec

  ! Minimize algorithn for a cube with regularization
  subroutine minimize(n, m, x, lb, ub, cube, n_gauss, dim_v, dim_y, dim_x, lambda_amp, lambda_mu, lambda_sig, &
       lambda_var_amp, lambda_var_mu, lambda_var_sig, lambda_lym_sig, maxiter, kernel, iprint, std_map, lym, c_lym)
    implicit none

    integer, intent(in) :: n
    integer, intent(in) :: m
    integer, intent(in) :: dim_v, dim_y, dim_x
    integer, intent(in) :: n_gauss, maxiter
    integer, intent(in) :: iprint

    real(xp), intent(in) :: c_lym
    real(xp), intent(in) :: lambda_amp, lambda_mu, lambda_sig
    real(xp), intent(in) :: lambda_var_amp, lambda_var_mu, lambda_var_sig
    real(xp), intent(in) :: lambda_lym_sig
    real(xp), intent(in), dimension(:), allocatable :: lb, ub
    real(xp), intent(in), dimension(:,:,:), allocatable :: cube
    real(xp), intent(in), dimension(:,:), allocatable :: kernel
    real(xp), intent(in), dimension(:,:), allocatable :: std_map

    real(xp), intent(in), dimension(:), allocatable :: x

    logical, intent(in) :: lym !! if true --> activate 2-Gaussian decomposition for Lyman alpha nebula emission

    real(xp), parameter    :: factr  = 1.0d+7, pgtol  = 1.0d-5

    character(len=60)      :: task, csave
    logical                :: lsave(4)
    integer                :: isave(44)
    real(xp)               :: f
    real(xp)               :: dsave(29)
    integer,  dimension(:), allocatable  :: nbd, iwa
    real(xp), dimension(:), allocatable  :: g, wa

    !     Allocate dynamic arrays
    allocate(nbd(n), g(n))
    allocate(iwa(3*n))
    allocate(wa(2*m*n + 5*n + 11*m*m + 8*m))

    f = 0._xp
    g = 0._xp

    ! Init nbd
    nbd = 2

    !     We now define the starting point.
    !     We start the iteration by initializing task.
    task = 'START'

    !     The beginning of the loop
    do while(task(1:2).eq.'FG'.or. task.eq.'NEW_X' .or. task.eq.'START')

       !     This is the call to the L-BFGS-B code.
       call setulb (n, m, x, lb, ub, nbd, f, g, factr, pgtol, wa, iwa, task, iprint, csave, lsave, isave, dsave)

       if (task(1:2) .eq. 'FG') then
          !     Compute function f and gradient g for the sample problem.
          if (lym .eqv. .true.) then
             call f_g_cube_fast_lym(f, g, cube, x, dim_v, dim_y, dim_x, n_gauss, kernel, lambda_amp, lambda_mu, lambda_sig, &
                  lambda_var_amp, lambda_var_mu, lambda_var_sig, lambda_lym_sig, std_map, c_lym)
          else
             call f_g_cube_fast(f, g, cube, x, dim_v, dim_y, dim_x, n_gauss, kernel, lambda_amp, lambda_mu, lambda_sig, &
                  lambda_var_amp, lambda_var_mu, lambda_var_sig, std_map)
          end if

       elseif (task(1:5) .eq. 'NEW_X') then
          !        1) Terminate if the total number of f and g evaluations
          !             exceeds maxiter.
          if (isave(34) .ge. maxiter) &
               task='STOP: TOTAL NO. of f AND g EVALUATIONS EXCEEDS LIMIT'

          !        2) Terminate if  |proj g|/(1+|f|) < 1.0d-10.
          if (dsave(13) .le. 1.d-10*(1.0d0 + abs(f))) &
               task='STOP: THE PROJECTED GRADIENT IS SUFFICIENTLY SMALL'
       endif
    !     end of loop do while
    end do

    deallocate(nbd, g)
    deallocate(iwa)
    deallocate(wa)
  end subroutine minimize

end module mod_minimize


module rabs_nucleus
!
!***** February 2012, wide *****
!-----------------------------------------------------------------------------------------------------------------------
! This module stores information about the nucleus and how it is modeled in the calculation. It also allows for to read
! this information from a GRASP92 .iso file.
!-----------------------------------------------------------------------------------------------------------------------
   !
   use rabs_constant
   implicit none
   private
   !
   public  :: gamma_r
                 ! Return the relativistic gamma factor for a given symmetry kappa.
   public  :: nuclear_charge_density
                 ! Return the nuclear charge density rho(r) at r0.
   public  :: nuclear_charge_density_prime
                 ! Return the derivative of the nuclear charge density d rho(r) / dr at r0.
   public  :: nuclear_extent
                 ! Return a nuclear radius R_nuc which includes at least 99 percent of charge.
   public  :: nuclear_potential
                 ! Return the nuclear potential at r0.
   public  :: nuclear_potential_es
                 ! Utility subroutine for nuclear_potential.
   public  :: nuclear_radial_points
                 ! Determines the number of radial points inside of R_nuc.
   !
   real(kind=dp), public     :: nuclear_charge
   real(kind=dp), public     :: nuclear_mass
   real(kind=dp), public     :: nuclear_spin
   real(kind=dp), public     :: nuclear_dipole_moment
   real(kind=dp), public     :: nuclear_quadrupole_moment
   real(kind=dp), public     :: atomic_mass
   real(kind=dp), public     :: fermi_a_parameter
   real(kind=dp), public     :: fermi_c_parameter
   !
   real(kind=dp), public     :: nuclear_screening_lambda    = zero
   real(kind=dp), public     :: nuclear_ion_sphere_Nb       = zero
   real(kind=dp), public     :: nuclear_ion_sphere_R0       = zero
   real(kind=dp), public     :: nuclear_debye_sphere_R0     = zero
   !
   character(len=12), public :: nuclear_model
   !
contains
   !
   !
   function gamma_r(kappa)   result(gamma)
   !--------------------------------------------------------------------------------------------------------------------
   ! Returns the relativistic gamma factor for a given symmetry kappa.
   !--------------------------------------------------------------------------------------------------------------------
      !
      integer, intent(in) :: kappa
      real(kind=dp)       :: gamma
      !
      gamma = kappa * kappa - nuclear_charge * nuclear_charge / (c * c)
      if (rabs_use_stop   .and.  gamma < zero) then
         stop "gamma_r(): program stop A."
      end if
      gamma = sqrt(gamma)
      !
   end function gamma_r
   !
   !
   function nuclear_charge_density(r0)                   result(density)
   !--------------------------------------------------------------------------------------------------------------------
   ! Returns a nuclear charge density at a given radius r0.
   !--------------------------------------------------------------------------------------------------------------------
      !
      real(kind=dp), intent(in) :: r0
      real(kind=dp)             :: density, Rnuc
      !
      select case(nuclear_model)
      case("point")
         density = zero
      case("uniform")
         Rnuc = nuclear_extent()
	 if (r0 <= Rnuc) then
	    density = three / (two*two*pi*(Rnuc**3))
	 !!! else if (r0 < Rnuc + 0.0001_dp) then
	 !!!    density = three / (two*two*pi*(Rnuc**3)) &
	 !!!              *(one- (r0-Rnuc)/0.0001_dp)
	 else
	    density = zero
	 end if
      case("fermi")
         density = one /(exp( (r0-fermi_c_parameter)/fermi_a_parameter ) + one)
      case default
         stop "nuclear_charge_density(): program stop A."
      end select
      !
   end function nuclear_charge_density
   !
   !
   function nuclear_charge_density_prime(r0)              result(rho_prime)
   !--------------------------------------------------------------------------------------------------------------------
   ! Returns a nuclear charge density at a given radius r0.
   !--------------------------------------------------------------------------------------------------------------------
      !
      real(kind=dp), intent(in) :: r0
      real(kind=dp)             :: rho_prime, wa
      !
      select case(nuclear_model)
      case("point")
         rho_prime = zero
      case("uniform")
         rho_prime = zero
      case("fermi")
         wa = exp( (r0-fermi_c_parameter)/fermi_a_parameter )
         rho_prime = - wa / ((one + wa)*(one + wa)*fermi_a_parameter)
      case default
         stop "nuclear_charge_density_prime(): program stop A."
      end select
      !
   end function nuclear_charge_density_prime
   !
   !
   function nuclear_extent()   result(Rnuc)
   !--------------------------------------------------------------------------------------------------------------------
   ! Returns a nuclear radius Rnuc which should include at least 99 percent of the total nuclear charge.
   !--------------------------------------------------------------------------------------------------------------------
      !
      real(kind=dp) :: Rnuc
      !
      select case(nuclear_model)
      case("point")
         Rnuc = zero
      case("uniform")
         Rnuc = 0.836_dp * (nuclear_mass)**(one/three) + 0.570_dp
         Rnuc = Rnuc   * convert_fermi_to_bohr
      case("fermi")
         Rnuc = 0.836_dp * (nuclear_mass)**(one/three) + 0.570_dp
         Rnuc = two * two * Rnuc   * convert_fermi_to_bohr
      case default
         stop "nuclear_extent(): program stop A."
      end select
      !
   end function nuclear_extent
   !
   !
   function nuclear_potential(r0)   result(nucpot)
   !--------------------------------------------------------------------------------------------------------------------
   ! Returns the nuclear potential at point r0 in dependence of the nuclear model.
   !--------------------------------------------------------------------------------------------------------------------
      !
      implicit none
      real(kind=dp), intent(in) :: r0
      real(kind=dp)             :: nucpot, Rnuc, a, abc, abc2, abc3, c, cba, tabc, thabc2, hpiac2, sabc3, dmsas, en, &
                                   rmc, rmcba, rbc, s2mcba, s3mcba, s2rcba, s3rcba, h3php, zz0, zbn
      !
      if (rabs_use_stop   .and.   r0 <= zero) then
         print *, "r0 = ",r0
         stop     "nuclear_potential(): program stop A."
      end if
      !
      select case(nuclear_model)
      case("point")
         !
         nucpot = - nuclear_charge / r0
      case("uniform")
         !
         Rnuc   = nuclear_extent()
         if( r0 <= Rnuc ) then
            nucpot =  - nuclear_charge/(two*Rnuc) * (three - r0*r0/(Rnuc*Rnuc))
         else
            nucpot = - nuclear_charge / r0
         end if
      case("fermi")
         !
         Rnuc   = nuclear_extent()
         if( r0 <= two * two * Rnuc ) then
            c      = fermi_c_parameter
            a      = fermi_a_parameter
            abc    = a/c
            tabc   = two * abc
            abc2   = abc * abc
            thabc2 = three * abc2
            abc3   = abc2 * abc
            cba    = c / a
            hpiac2 = half * pi * pi * abc2
            h3php  = three / two + hpiac2
            call nuclear_potential_es(-cba,s2mcba,s3mcba)
            sabc3  = two * three * abc3
            dmsas  = -sabc3 * s3mcba
            en     = one + abc2 * pi * pi + dmsas
            zbn    = nuclear_charge / en
            !
            rmc    = r0 - c
            rmcba  = rmc / a
            rbc    = r0 / c
            if (rbc < one) then
               call nuclear_potential_es(rmcba,s2rcba,s3rcba)
               zz0 = zbn *(dmsas + sabc3 * s3rcba + rbc * (h3php - thabc2 * s2rcba - half * rbc * rbc))
            else
               call nuclear_potential_es(-rmcba,s2rcba,s3rcba)
               zz0 = nuclear_charge * (one + thabc2 * (rbc * s2rcba + tabc * s3rcba) / en)
            end if
            nucpot = - zz0 / r0
         else
            nucpot = - nuclear_charge / r0
         end if
         !
      case("debye")
         !
         nucpot = - nuclear_charge / r0 * exp(-nuclear_screening_lambda * r0)
      case("debye-box")
         !
         if (r0  <= nuclear_debye_sphere_R0) then
            nucpot = - nuclear_charge / r0 * exp(-nuclear_screening_lambda * r0)
         else
            nucpot = zero
         end if
      case("ion-sphere")
         !
         if (r0  <= nuclear_ion_sphere_R0) then
            nucpot = - nuclear_charge / r0 + half * (nuclear_charge - nuclear_ion_sphere_Nb) / &
                       nuclear_ion_sphere_R0 * (three - r0*r0/(nuclear_ion_sphere_R0*nuclear_ion_sphere_R0) )
         else
            nucpot = zero
         end if
      case default
         stop "nuclear_potential(): program stop B."
      end select
      !
   end function nuclear_potential
   !
   !
   subroutine nuclear_potential_es(f,s2f,s3f)
   !--------------------------------------------------------------------------------------------------------------------
   ! Evaluate the sum of the series
   !
   !                       infinity      n              k
   !              S  (f) =   Sum     (-1)  exp (n*f) / n
   !               k        n = 0
   !
   ! for k = 2, 3 to machine precision. This is a utility subroutine for nuclear_potential(). This subroutine was
   ! originally written by F A Parpia and adapted to the rabs package.
   !--------------------------------------------------------------------------------------------------------------------
      !
      implicit none
      real(kind=dp), intent(in)  :: f
      real(kind=dp), intent(out) :: s2f, s3f
      integer                    :: n
      real(kind=dp)              :: enf, fase, obn, s2last, term2, term3
      !
      n    = 0
      s2f  = zero
      s3f  = zero
      fase = one
      !
    1 n   = n+1
      obn   = one / n
      fase  = - fase
      enf   = exp (n*f)
      term2 = fase * enf * obn * obn
      term3 = term2* obn
      s2last= s2f
      s2f   = s2f + term2
      s3f   = s3f + term3
      if (abs(s2f) /= abs(s2last)) then
         goto 1
      end if
      !
   end subroutine nuclear_potential_es
   !
   !
   function nuclear_radial_points(r_grid)                  result(number)
   !--------------------------------------------------------------------------------------------------------------------
   ! Returns the number of radial points inside of the nuclear radius Rnuc as calculated in nuclear_extent().
   !--------------------------------------------------------------------------------------------------------------------
      !
      real(kind=dp), dimension(:), intent(in) :: r_grid
      !
      integer       :: i, number
      real(kind=dp) :: Rnuc
      !
      number = 0
      Rnuc   = nuclear_extent()
      !
      do  i = 1,1000
         if (r_grid(i) > Rnuc)  then
	    exit
	 end if
	 !
	 number = i
      end do
      !
   end function nuclear_radial_points
   !
end module rabs_nucleus


subroutine difu(icreep    ,timest    ,lundia    ,nst       ,icx       , &
              & icy       ,j         ,nmmaxj    ,nmmax     ,kmax      , &
              & lstsci    ,lstsc     ,lsal      ,ltem      ,lsecfl    , &
              & lsec      ,lsed      ,lsts      ,norow     ,irocol    , &
              & kcs       ,kcu       ,kfs       ,kfu       ,kfv       , &
              & kadu      ,kadv      ,s0        ,s1        ,hu        , &
              & hv        ,dps       ,qxk       ,qyk       ,qzk       , &
              & guu       ,gvv       ,guv       ,gvu       ,gsqs      , &
              & rbnd      ,sigdif    ,sigmol    ,r0        ,r1        , &
              & sour      ,sink      ,ws        ,sedtyp    ,thick     , &
              & sig       ,dicuv     ,vicww     ,dsdksi    ,dsdeta    , &
              & dtdksi    ,dtdeta    ,aak       ,bbk       ,cck       , &
              & bdddx     ,bddx      ,bdx       ,bux       ,buux      , &
              & buuux     ,uvdwk     ,vvdwk     ,areau     ,areav     , &
              & aakl      ,bbkl      ,cckl      ,ddkl      , &
              & eqmbcsand ,eqmbcmud  ,seddif    ,volum0    ,volum1    , &
              & rscale    ,bruvai    ,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: difu.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/difu.f90 $
!!--description-----------------------------------------------------------------
!
!    Function: Computes transport in the u, v and w-direction.
!              Implicit in the u- and w-direction, explicit in
!              v-direction.
!              Sinks are treated implicitly and sources explicit-
!              y. A special approach is used for the hori-
!              ontal diffusion to avoid artificial creeping.
! Method used: Reference : On the approximation of horizontal
!              gradients in sigma co-ordinates for bathymetry
!              with steep bottom slopes (G.S. Stelling and J.
!              van Kester - International Journal for Methods
!              in Fluids, Vol. 18 1994)
!              - Horizontal Advection in U-direction :
!                implicit, higher order upwind
!              - Horizontal Advection in V-direction :
!                explicit, central scheme
!              - Horizontal Diffusion :
!                3D: explicit, along Z-planes
!                2D: implicit in U-direction
!                    explicit in V-direction
!              - Option: horizontal diffusion strictly horizontal
!                using special filter
!              - Vertical Advection :
!                implicit, central scheme
!              - Vertical Diffusion : implicit
!              - Sources are integrated explicitly.
!              - Sinks are integrated implicitly.
!     Comment: For the Thatcher Harleman boundaries the boundary
!              points for outflow are reflected from the inner
!              points; for inflow the boundary conditions are
!              used (see also thahbc.for).
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    use mathconsts
    use flow2d3d_timers
    use globaldata
    use dfparall
    use sediment_basics_module
    !
    implicit none
    !
    type(globdat),target :: gdp
    !
    ! The following list of pointer parameters is used to point inside the gdp structure
    !
    include 'flow_steps_f.inc'
    integer                , pointer :: iro
    integer                , pointer :: mfg
    integer                , pointer :: nfg
    integer                , pointer :: nudge
    real(fp)               , pointer :: ck
    real(fp)               , pointer :: dicoww
    real(fp)               , pointer :: eps
    real(fp)               , pointer :: hdt
    real(fp)               , pointer :: vicmol
    real(fp)               , pointer :: xlo
!
! Global variables
!
integer                                                 , intent(in)  :: icreep    !  Description and declaration in tricom.igs
integer                                                               :: icx       !!  Increment in the X-dir., if ICX= NMAX
                                                                                !!  then computation proceeds in the X-
                                                                                !!  dir. If icx=1 then computation pro-
                                                                                !!  ceeds in the Y-dir.
integer                                                               :: 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                                                               :: kmax      !  Description and declaration in esm_alloc_int.f90
integer                                                               :: lsal      !  Description and declaration in dimens.igs
integer                                                 , intent(in)  :: lsec      !  Description and declaration in dimens.igs
integer                                                               :: lsecfl    !  Description and declaration in dimens.igs
integer                                                               :: lsed      !  Description and declaration in esm_alloc_int.f90
integer                                                 , intent(in)  :: lsts      !  Description and declaration in dimens.igs
integer                                                 , intent(in)  :: lstsc     !  Description and declaration in dimens.igs
integer                                                               :: lstsci    !  Description and declaration in esm_alloc_int.f90
integer                                                               :: ltem      !  Description and declaration in dimens.igs
integer                                                               :: lundia    !  Description and declaration in inout.igs
integer                                                               :: nmmax     !  Description and declaration in dimens.igs
integer                                                               :: nmmaxj    !  Description and declaration in dimens.igs
integer                                                               :: norow     !  Description and declaration in esm_alloc_int.f90
integer                                                 , intent(in)  :: nst
integer, dimension(5, norow)                                          :: irocol    !  Description and declaration in esm_alloc_int.f90
integer, dimension(gdp%d%nmlb:gdp%d%nmub)                             :: kcs       !  Description and declaration in esm_alloc_int.f90
integer, dimension(gdp%d%nmlb:gdp%d%nmub)               , intent(in)  :: kcu       !  Description and declaration in esm_alloc_int.f90
integer, dimension(gdp%d%nmlb:gdp%d%nmub)                             :: kfs       !  Description and declaration in esm_alloc_int.f90
integer, dimension(gdp%d%nmlb:gdp%d%nmub)                             :: kfu       !  Description and declaration in esm_alloc_int.f90
integer, dimension(gdp%d%nmlb:gdp%d%nmub)                             :: kfv       !  Description and declaration in esm_alloc_int.f90
integer, dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                       :: kadu      !  Description and declaration in esm_alloc_int.f90
integer, dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                       :: kadv      !  Description and declaration in esm_alloc_int.f90
integer, dimension(lsed)                                , intent(in)  :: sedtyp    !! sediment type: 0=total/1=noncoh/2=coh
logical                                                 , intent(in)  :: eqmbcsand !  Description and declaration in morpar.igs
logical                                                 , intent(in)  :: eqmbcmud  !  Description and declaration in morpar.igs
real(fp)                                                , intent(in)  :: timest    !!  Half Integration time step [sec.]
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)                            :: gsqs      !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)                            :: 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)                            :: gvv       !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: hu        !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)              , intent(in)  :: hv        !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)                            :: s0        !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)                            :: s1        !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax)                    :: bruvai    !  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)      , intent(in)  :: qzk       !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax, lsed), intent(in)  :: seddif    !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax, lsed)              :: ws        !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: aak       !!  Internal work array (in CUCNP & UZD)
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: bbk       !!  Internal work array (in CUCNP & UZD)
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: bdddx     !!  Internal work array, implicit coup-
                                                                                !!  ling of concentration in (N,M,K)
                                                                                !!  with layer concentration in (N,M-3,K)
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: bddx      !!  Internal work array, implicit coup-
                                                                                !!  ling of concentration in (N,M,K)
                                                                                !!  with layer concentration in (N,M-2,K)
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: bdx       !!  Internal work array, implicit coup-
                                                                                !!  ling of concentration in (N,M,K)
                                                                                !!  with layer concentration in (N,M-1,K)
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: buuux     !!  Internal work array, implicit coup-
                                                                                !!  ling of concentration in (N,M,K)
                                                                                !!  with layer concentration in (N,M+3,K)
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: buux      !!  Internal work array, implicit coup-
                                                                                !!  ling of concentration in (N,M,K)
                                                                                !!  with layer concentration in (N,M+2,K)
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: bux       !!  Internal work array, implicit coup-
                                                                                !!  ling of concentration in (N,M,K)
                                                                                !!  with layer concentration in (N,M+1,K)
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: cck       !!  Internal work array (in CUCNP & UZD)
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax+2)                    :: dicuv     !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: dsdeta    !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: dsdksi    !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: dtdeta    !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: dtdksi    !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)         , intent(in) :: areau
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)         , intent(in) :: areav
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)         , intent(in) :: qxk       !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)         , intent(in) :: qyk       !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: rscale    !  Internal work array, row scaling parameter in difu
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)         , intent(in) :: volum0
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)         , intent(in) :: volum1
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: uvdwk     !!  Internal work array for Jac.iteration
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax)                      :: vvdwk     !!  Internal work array for Jac.iteration
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax, lstsci)              :: aakl      !!  Internal work array, lower diagonal
                                                                                !!  tridiagonal matrix, implicit coupling
                                                                                !!  of concentration in (N,M,K) with con-
                                                                                !!  centration in (N,M,K-1)
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax, lstsci)              :: bbkl      !!  Internal work array, main diagonal
                                                                                !!  tridiagonal matrix, implicit coupling
                                                                                !!  of concentration in (N,M,K)
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax, lstsci)              :: cckl      !!  Internal work array, upper diagonal
                                                                                !!  tridiagonal matrix, implicit coupling
                                                                                !!  of concentration in (N,M,K) with con-
                                                                                !!  centration in (N,M,K+1)
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax, lstsci)              :: ddkl      !!  Internal work array, diagonal space
                                                                                !!  at (N,M,K,L)
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax, lstsci)              :: r0        !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax, lstsci)              :: r1        !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax, lstsci)              :: sink      !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(gdp%d%nmlb:gdp%d%nmub, kmax, lstsci)              :: sour      !  Description and declaration in esm_alloc_real.f90
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
real(fp), dimension(kmax, max(lstsc, 1), 2, norow)      , intent(in)  :: rbnd      !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(lstsci)                                           :: sigdif    !  Description and declaration in esm_alloc_real.f90
real(fp), dimension(lstsci)                             , intent(in)  :: sigmol    !  Description and declaration in esm_alloc_real.f90
!
! Local variables
!
integer                 :: nmsta
integer                 :: ddb
integer                 :: iad1
integer                 :: iad2
integer                 :: iad3
integer                 :: ic
integer                 :: icxy
integer                 :: iter
integer                 :: itr
integer                 :: j1
integer                 :: j2
integer                 :: j3
integer                 :: jj
integer                 :: k
integer                 :: kfw
integer                 :: l
integer                 :: ll
integer                 :: ls
integer                 :: lst
integer                 :: maskval
integer                 :: mf
integer                 :: ml
integer                 :: n
integer                 :: ndm
integer                 :: nhystp
integer                 :: nm
integer                 :: nmd
integer                 :: nmdd
integer                 :: nmf
integer                 :: nmfu
integer                 :: nml
integer                 :: nmlu
integer, dimension(10)  :: nms
integer                 :: nmu
integer                 :: nmuu
integer                 :: nnudge
integer                 :: num
real(fp)                :: adza
real(fp)                :: adzc
real(fp)                :: bi
real(fp)                :: cl
real(fp)                :: cr
real(fp)                :: d0k    ! Internal work array
real(fp)                :: ddzc
real(fp)                :: difiwe
real(fp)                :: difl
real(fp)                :: difr
real(fp)                :: diz1
real(fp)                :: epsitr ! Maximum value of relative error and absolute error of iteration process
real(fp)                :: flux
real(fp)                :: h0
real(fp)                :: h0i
real(fp)                :: h0new
real(fp)                :: h0old
real(fp), dimension(10) :: mu
real(fp)                :: nudgefac
real(fp)                :: qxu
real(fp)                :: qyv
real(fp)                :: qzw
real(fp)                :: rb
real(fp), external      :: reddic
real(fp)                :: rp
real(fp)                :: sqrtbv
real(fp)                :: timesti ! inverse of time step
real(fp)                :: tnudge
real(fp)                :: tsg
character(20)           :: errtxt
integer                 :: nm_pos ! indicating the array to be exchanged has nm index at the 2nd place, e.g., dbodsd(lsedtot,nm)
!
!! executable statements -------------------------------------------------------
!
    eps         => gdp%gdconst%eps
    vicmol      => gdp%gdphysco%vicmol
    dicoww      => gdp%gdphysco%dicoww
    iro         => gdp%gdphysco%iro
    xlo         => gdp%gdturcoe%xlo
    ck          => gdp%gdturcoe%ck
    mfg         => gdp%gdparall%mfg
    nfg         => gdp%gdparall%nfg
    nudge       => gdp%gdnumeco%nudge
    hdt         => gdp%gdnumeco%hdt
    !
    ! INITIALISATION
    !
    ddb    = gdp%d%ddbound
    icxy   = max(icx, icy)
    nm_pos = 1
    !
    !  INITIALIZE
    !
    call timer_start(timer_difu_ini, gdp)
    !
    ! Initialise arrays aak - cck for all (nm,k)
    !
    aak   = 0.0_fp
    buuux = 0.0_fp
    buux  = 0.0_fp
    bux   = 0.0_fp
    bdx   = 0.0_fp
    bddx  = 0.0_fp
    bdddx = 0.0_fp
    cck   = 0.0_fp
    !
    timesti = 1.0_fp / timest
    do k = 1, kmax
       do nm = 1, nmmax
          if (kfs(nm) == 1) then
             bbk(nm, k) = volum1(nm, k) * timesti
          else
             bbk(nm, k) = 1.0_fp
             if (lsec > 0) r0(nm, k, lsecfl) = 0.0_fp
          endif
       enddo
    enddo
    do l = 1, lstsci
       if (lsec==2 .and. l==lsecfl) then
          cycle
       endif
       do k = 1, kmax
          do nm = 1, nmmax
             if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
                ddkl(nm, k, l) = volum0(nm, k) * r0(nm, k, l) * timesti
             else
                ddkl(nm, k, l) = r0(nm, k, l)
             endif
          enddo
       enddo
    enddo
    call timer_stop(timer_difu_ini, gdp)
    !
    ! CONTRIBUTION OF ADVECTION IN X-DIRECTION
    !
    call timer_start(timer_difu_horadv, gdp)
    do k = 1, kmax
       !
       ! CONTRIBUTION TO VOLUME NM AND NMU
       !
       nmd  = -icx
       nmdd = -icx - icx
       nmu  =  icx
       nmuu =  icx + icx
       do nm = 1, nmmax
          nmd  = nmd  + 1
          nmdd = nmdd + 1
          nmu  = nmu  + 1
          nmuu = nmuu + 1
          qxu  = qxk(nm, k)/6.0_fp
          if (qxu > 0.0) then
             iad1 =      kfu(nm)  *kadu(nm, k)
             iad2 = iad1*kfu(nmd) *kadu(nmd, k)
             iad3 = iad2*kfu(nmdd)*kadu(nmdd, k)
             !
             j1 = 6*iad1 + 3*iad2 +   iad3
             j2 =        - 3*iad2 - 2*iad3
             j3 =                     iad3
             !
             bbk  (nm , k) = bbk  (nm , k) + qxu*j1
             bdx  (nm , k) = bdx  (nm , k) + qxu*j2
             bddx (nm , k) = bddx (nm , k) + qxu*j3
             bdx  (nmu, k) = bdx  (nmu, k) - qxu*j1
             bddx (nmu, k) = bddx (nmu, k) - qxu*j2
             bdddx(nmu, k) = bdddx(nmu, k) - qxu*j3
          else
             iad1 =        kfu(nm)   * kadu(nm  , k)
             iad2 = iad1 * kfu(nmu)  * kadu(nmu , k)
             iad3 = iad2 * kfu(nmuu) * kadu(nmuu, k)
             !
             j1 = 6*iad1 + 3*iad2 +   iad3
             j2 =        - 3*iad2 - 2*iad3
             j3 =                     iad3
             !
             bux  (nm , k) = bux  (nm , k) + qxu*j1
             buux (nm , k) = buux (nm , k) + qxu*j2
             buuux(nm , k) = buuux(nm , k) + qxu*j3
             bbk  (nmu, k) = bbk  (nmu, k) - qxu*j1
             bux  (nmu, k) = bux  (nmu, k) - qxu*j2
             buux (nmu, k) = buux (nmu, k) - qxu*j3
          endif
       enddo
    enddo
    !
    ! CONTRIBUTION OF ADVECTION IN Y-DIRECTION
    !
    do l = 1, lstsci
       if (lsec==2 .and. l==lsecfl) then
          cycle
       endif
       do k = 1, kmax
          !
          ! CONTRIBUTION TO VOLUME NM AND NUM
          !
          ndm = -icy
          num =  icy
          do nm = 1, nmmax
             ndm = ndm + 1
             num = num + 1
             qyv  = qyk(nm, k)
             iad1 = kfv(nm)*kadv(nm, k)
             iad2 = iad1*kfv(num)*kadv(num, k)*kfv(ndm)*kadv(ndm, k)
             if (qyv > 0.0_fp) then
                d0k = 0.5_fp*qyv*( (2*iad1 - iad2)*r0(nm , k, l) &
                    &          +          iad2 *r0(num, k, l))
             else
                d0k = 0.5_fp*qyv*( (2*iad1 - iad2)*r0(num, k, l) &
                    &          +          iad2 *r0(nm , k, l))
             endif
             if (kcs(nm)  == 1) ddkl(nm , k, l) = ddkl(nm , k, l) - d0k
             if (kcs(num) == 1) ddkl(num, k, l) = ddkl(num, k, l) + d0k
          enddo
       enddo
    enddo
    call timer_stop(timer_difu_horadv, gdp)
    !
    !
    ! Explicit algoritm (call DIFACR) leads to extra stablity criterium
    ! DT <= (DX**2)/(2*DICUV)
    !
    ! This diffusion part (loop 410) is constituent independent.
    ! The value of SIGDIF(L) = 0.7 (see TKECOF) for all LSTSCI
    !
    call timer_start(timer_difu_hordiff, gdp)
    if (icreep==0 .or. kmax==1) then
       !
       ! HORIZONTAL DIFFUSION IN X-DIRECTION ALONG SIGMA PLANES
       !
       do k = 1, kmax
          !
          ! CONTRIBUTION TO VOLUME NM AND NMU
          !
          nmu = icx
          do nm = 1, nmmax
             nmu = nmu + 1
             if (kfu(nm)*kadu(nm, k) /= 0) then
                difl    = dicuv(nm, k)
                difr    = dicuv(nmu, k)
                flux    = 0.5*(difl + difr)/(0.7*gvu(nm))
                maskval = max(0, 2 - abs(kcs(nm)))
                bbk(nm, k) = bbk(nm, k) + areau(nm, k)*flux*maskval
                bux(nm, k) = bux(nm, k) - areau(nm, k)*flux*maskval
                maskval    = max(0, 2 - abs(kcs(nmu)))
                bbk(nmu, k) = bbk(nmu, k) + areau(nm, k)*flux*maskval
                bdx(nmu, k) = bdx(nmu, k) - areau(nm, k)*flux*maskval
             endif
          enddo
       enddo
       !
       ! HORIZONTAL DIFFUSION IN Y-DIRECTION ALONG SIGMA PLANES
       !
       do l = 1, lstsci
          if (lsec==2 .and. l==lsecfl) then
             cycle
          endif
          do k = 1, kmax
             !
             ! CONTRIBUTION TO VOLUME NM AND NUM
             !
             num = icy
             do nm = 1, nmmax
                num = num + 1
                if (kfv(nm)*kadv(nm, k) /= 0) then
                   cl      = r0(nm, k, l)
                   difl    = dicuv(nm, k)
                   cr      = r0(num, k, l)
                   difr    = dicuv(num, k)
                   flux    = 0.5_fp*(cr - cl)*(difl + difr)/(0.7*guv(nm))
                   maskval = max(0, 2 - abs(kcs(nm)))
                   ddkl(nm, k, l)  = ddkl(nm, k, l) + areav(nm, k)*flux*maskval
                   maskval         = max(0, 2 - abs(kcs(num)))
                   ddkl(num, k, l) = ddkl(num, k, l) - areav(nm, k)*flux*maskval
                endif
             enddo
          enddo
       enddo
    else
       !
       ! Explicit algoritm (call DIFACR) leads to extra stablity criterium
       ! dt <= (dx**2)/(2*dicuv)
       !
       ! HORIZONTAL DIFFUSION ALONG Z-PLANES (only if KMAX > 1 and Anti Creep)
       !
       call difacr(icx       ,icy       ,j         ,nmmaxj    ,nmmax     , &
                 & kmax      ,lstsci    ,lsal      ,ltem      ,kcs       , &
                 & kfu       ,kfv       ,kadu      ,kadv      ,s0        , &
                 & dps       ,r0        ,ddkl      ,guu       ,gvv       , &
                 & guv       ,gvu       ,thick     ,sig       ,dicuv     , &
                 & sigdif    ,dsdksi    ,dtdksi    ,dsdeta    ,dtdeta    , &
                 & gdp       )
    endif
    call timer_stop(timer_difu_hordiff, gdp)
    call timer_start(timer_difu_vertadv, gdp)
    if (kmax > 1) then
       do k = 1, kmax - 1
          if (k==1 .or. k==kmax - 1) then
             kfw = 1
          else
             kfw = 0
          endif
          do nm = 1, nmmax
             !
             ! ADVECTION IN VERTICAL DIRECTION; W*DC/DZ
             !
             if (kfs(nm) == 1) then
                qzw = qzk(nm, k)
                if (qzw > 0.0) then
                   adza = 0.5_fp*qzw*(1 - kfw)
                   adzc = 0.5_fp*qzw*(1 + kfw)
                else
                   adza = 0.5_fp*qzw*(1 + kfw)
                   adzc = 0.5_fp*qzw*(1 - kfw)
                endif
                aak(nm, k + 1) = aak(nm, k + 1) + adza
                bbk(nm, k + 1) = bbk(nm, k + 1) + adzc
                bbk(nm, k    ) = bbk(nm, k    ) - adza
                cck(nm, k    ) = cck(nm, k    ) - adzc
             endif
          enddo
       enddo
    endif
    do l = 1, lstsci
       if (lsec==2 .and. l==lsecfl) then
          cycle
       endif
       do k = 1, kmax
          do nm = 1, nmmax
                aakl(nm, k, l) = aak(nm, k)
                bbkl(nm, k, l) = bbk(nm, k)
                cckl(nm, k, l) = cck(nm, k)
          enddo
       enddo
    enddo
    call timer_stop(timer_difu_vertadv, gdp)
    !
    ! DIFFUSION IN VERTICAL DIRECTION
    !
    call timer_start(timer_difu_vertdiff, gdp)
    if (kmax > 1) then
       do l = 1, lstsci
          !
          ! l = sediment: ls > 0
          ! else        : ls = 0
          !
          ls = 0
          if ((l>max(lsal, ltem)) .and. (l<=lsts)) ls = l - max(lsal, ltem)
          do k = 1, kmax - 1
             tsg = 0.5_fp * (thick(k) + thick(k+1))
             do nm = 1, nmmax
                if (kfs(nm) == 1) then
                   h0  = max(0.1_fp, s0(nm) + real(dps(nm),fp))
                   h0i = 1.0_fp / h0
                   !
                   ! Internal wave contribution
                   !
                   sqrtbv = max(0.0_fp, bruvai(nm, k))
                   sqrtbv = sqrt(sqrtbv)
                   difiwe = 0.2_fp * sqrtbv * xlo**2
                   if (ls > 0) then
                      !
                      ! sediment constituent:
                      ! No dicoww-restriction in reddic
                      !
                      diz1 = vicmol/sigmol(l) + difiwe + seddif(nm, k, ls)/sigdif(l)
                   else
                      !
                      ! all other constituents:
                      ! dicoww-restriction is moved from TURCLO to here (in reddic)
                      ! vicww is used instead of dicww
                      !
                      diz1 = vicmol/sigmol(l) + reddic(difiwe + vicww(nm,k)/sigdif(l), gdp)
                   endif
                   ddzc             = gsqs(nm) * diz1 * h0i / tsg
                   aakl(nm, k+1, l) = aakl(nm, k+1, l) - ddzc
                   bbkl(nm, k+1, l) = bbkl(nm, k+1, l) + ddzc
                   bbkl(nm, k  , l) = bbkl(nm, k  , l) + ddzc
                   cckl(nm, k  , l) = cckl(nm, k  , l) - ddzc
                endif
             enddo
          enddo
       enddo
    endif
    call timer_stop(timer_difu_vertdiff, gdp)
    !
    ! Include settling velocities and Dirichlet BC for sediments in
    ! matrices AAKL/BBKL/CCKL/DDKL
    !
    if (lsed > 0) then
       call timer_start(timer_difu_difws, gdp)
       call dif_ws(j         ,nmmaxj    ,nmmax     ,kmax      ,lsal      , &
                 & ltem      ,lstsci    ,lsed      ,kcs       ,kfs       , &
                 & gsqs      ,ws        ,aakl      ,bbkl      ,cckl      , &
                 & gdp       )
       call timer_stop(timer_difu_difws, gdp)
    endif
    !
    ! SET VALUES IN OPEN BOUNDARY POINTS (IN PART. FOR Y-DIRECTION)
    !     On open boundary no seconday flow (=> loop over LSTSC)
    !
    call timer_start(timer_difu_bounopen, gdp)
    do nm = 1, nmmax
       if (kcs(nm) == 2) then
          do l = 1, lstsc
             do k = 1, kmax
                ddkl(nm, k, l) = r0(nm, k, l)
                aakl(nm, k, l) = 0.0_fp
                bbkl(nm, k, l) = 1.0_fp
                cckl(nm, k, l) = 0.0_fp
             enddo
          enddo
       endif
    enddo
    !
    ! BOUNDARY CONDITIONS
    !     On open boundary no seconday flow (=> loop over LSTSC)
    !
    do ic = 1, norow
       n    = irocol(1, ic)
       mf   = irocol(2, ic) - 1
       ml   = irocol(3, ic)
       nmf  = (n + ddb)*icy + (mf + ddb)*icx - icxy
       nml  = (n + ddb)*icy + (ml + ddb)*icx - icxy
       nmfu = nmf + icx
       nmlu = nml + icx
       !
       ! IMPLEMENTATION OF BOUNDARY CONDITIONS
       !
       if (kcu(nmf) == 1) then
          do k = 1, kmax
             do l = 1, lstsc
                ddkl(nmf, k, l) = rbnd(k, l, 1, ic)
             enddo
          enddo
       endif
       if (kcu(nml) == 1) then
          do k = 1, kmax
             do l = 1, lstsc
                ddkl(nmlu, k, l) = rbnd(k, l, 2, ic)
             enddo
          enddo
       endif
       !
       ! optional Neumann boundary condition for suspended sediment fractions
       !
       lst = max(lsal, ltem)
       do l = 1, lsed
          ll = lst + l
          if ((eqmbcsand .and. sedtyp(l) == SEDTYP_NONCOHESIVE_SUSPENDED) .or. &
            & (eqmbcmud  .and. sedtyp(l) == SEDTYP_COHESIVE)             ) then
             if (kcu(nmf) == 1) then
                do k = 1, kmax
                   ddkl(nmf, k, ll) = max(0.0_fp, r0(nmfu, k, ll))
                enddo
             endif
             if (kcu(nml) == 1) then
                do k = 1, kmax
                   ddkl(nmlu, k, ll) = max(0.0_fp, r0(nml, k, ll))
                enddo
             endif
          endif
       enddo
    enddo
    call timer_stop(timer_difu_bounopen, gdp)
    do l = 1, lstsci
       !
       ! SOURCES AND SINK TERMS
       !
       ! SINKS ARE TREATED IMPLICITLY
       !
       call timer_start(timer_difu_sourcesink, gdp)
       if (lsec==2 .and. l==lsecfl) then
          !
          ! secondary flow (equilibrium equals to new intensity)
          !       start-up problems SINK might be 0.0 when
          !       UMOD = 0.0 in SECRHS
          !
          do k = 1, kmax
             do nm = 1, nmmax
                if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
                   h0new = s1(nm) + real(dps(nm),fp)
                   if (abs(sink(nm,k,l)*h0new) > eps) then
                      h0old = s0(nm) + real(dps(nm),fp)
                      r1(nm, k, l) = sour(nm, k, l)*h0old/(sink(nm, k, l)*h0new)
                   else
                      r1(nm, k, l) = 0.0_fp
                   endif
                endif
             enddo
          enddo
       else
          do k = 1, kmax
             do nm = 1, nmmax
                if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
                   bbkl(nm, k, l) = bbkl(nm, k, l) + sink(nm, k, l)*volum1(nm, k)
                   ddkl(nm, k, l) = ddkl(nm, k, l) + sour(nm, k, l)*volum0(nm, k)
                endif
             enddo
          enddo
          !
          ! set concentrations in dry points and in open boundary points
          !
          do k = 1, kmax
             do nm = 1, nmmax
                if ((kfs(nm)==0 .and. kcs(nm)==1) .or. kcs(nm)==2) then
                   r1(nm, k, l) = ddkl(nm, k, l)
                endif
             enddo
          enddo
       endif
       call timer_stop(timer_difu_sourcesink, gdp)
       !
       if (l == lsecfl) then
          !
          ! boundary conditions secondary flow (spiral motion intensity)
          !
          call timer_start(timer_difu_secbou, gdp)
          call secbou(j         ,nmmaxj    ,kmax      ,icx       ,icy       , &
                    & lstsci    ,lsecfl    ,kfu       ,irocol    ,norow     , &
                    & s0        ,s1        ,dps       ,r1        ,sour      , &
                    & sink      ,gdp       )
          call timer_stop(timer_difu_secbou, gdp)
          if (lsec == 2) then
             !
             ! exchange r1 with neighbours for parallel runs
             !
             call dfexchg ( r1(:,:,l), 1, kmax, dfloat, nm_pos, gdp )
             !
             cycle
          endif
       endif
       !
       ! DD code added:
       !
       ! left hand-side is now set by Delft3D-FLOW instead of the mapper
       !
       call timer_start(timer_difu_lhs, gdp)
       do nm = 1, nmmax
          if (kcs(nm) == 3 ) then
             do k = 1, kmax
                aakl(nm,k,l) = 0.0_fp
                bbkl(nm,k,l) = 1.0_fp
                cckl(nm,k,l) = 0.0_fp
                ddkl(nm,k,l) = r0(nm,k,l)
             enddo
          endif
       enddo
       call timer_stop(timer_difu_lhs, gdp)
       !
       !
       !        D3dFlow_Build_ADI_Conc: poke the coupling equations into system
       !
       nhystp = nxtstp(d3dflow_build_adi_conc, gdp)
       !
       ! DD code added end
       !
       !***SCALE ROWS OF MATRIX/RIGHT HAND SIDE VECTOR
       !
       !   Store scale factor in array rscale
       !   They are used for the constituent independent flux arrays b[d/u][d/u][d/u]x
       !
       call timer_start(timer_difu_rowsc, gdp)
       do k = 1, kmax
          do nm = 1, nmmax
             if (kfs(nm)==1) then
                rscale(nm, k)    = 1.0_fp / bbkl(nm, k, l)
                aakl  (nm, k, l) = aakl(nm, k, l) * rscale(nm, k)
                bbkl  (nm, k, l) = 1.0_fp
                cckl  (nm, k, l) = cckl(nm, k, l) * rscale(nm, k)
                ddkl  (nm, k, l) = ddkl(nm, k, l) * rscale(nm, k)
             endif
          enddo
       enddo
       call timer_stop(timer_difu_rowsc, gdp)
       !
       !***SOLUTION PROCEDURE SYSTEM OF EQUATIONS
       !
       ! Division by the pivot for k=1 is not needed anymore
       ! because of row scaling
       !
       call timer_start(timer_difu_solve1, gdp)
       do nm = 1, nmmax
          if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
             do k = 2, kmax
                bi             = 1.0_fp/(bbkl(nm, k, l) - aakl(nm, k, l)*cckl(nm, k - 1, l))
                bbkl(nm, k, l) = bi
                cckl(nm, k, l) = cckl(nm, k, l)*bi
             enddo
          endif
       enddo
       call timer_stop(timer_difu_solve1, gdp)
       !
       ! ITERATION LOOP
       !
       call timer_start(timer_difu_solve2, gdp)
       iter = 0
       do k = 1, kmax
          do nm = 1, nmmax
             if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
                r1(nm, k, l) = r0(nm, k, l)
                uvdwk(nm, k) = r0(nm, k, l)
             endif
          enddo
       enddo
       call timer_stop(timer_difu_solve2, gdp)
       !
       ! exchange r1 with neighbours for parallel runs
       !
       call dfexchg ( r1(:,:,l), 1, kmax, dfloat, nm_pos, gdp )
       !
       ! assure that loop starts at point of correct color in own subdomain
       !
       if (mod(mfg+nfg,2) == 1) then
          ! red points
          nmsta = 1
       else
          ! black points
          nmsta = 2
       endif
       !
       ! DD code added:
       !
       !
       !       (re)solve system of equations
       !
  111  continue
       gdp%dd%difuiter = gdp%dd%difuiter + 1
       !
       ! DD code added end
       !
 1100  continue
       iter = iter + 1
       !
       ! ITERATIVE SOLUTION METHOD USING CHECKERBOARD JACOBI
       ! IN HORIZONTAL DIRECTION
       !
       itr = 0
       !
       ! set concentrations in coupling points
       !
       call timer_start(timer_difu_solve3, gdp)
       do k = 1, kmax
          do nm = 1, nmmax
             if (kcs(nm) == 3) then
                r1(nm, k, l) = ddkl(nm, k, l)
             endif
          enddo
       enddo
       call timer_stop(timer_difu_solve3, gdp)
       if(icx == 1) then
         call timer_start(timer_difu_solve4u, gdp)
       else
         call timer_start(timer_difu_solve6v, gdp)
       end if
       !
       ! loop starts at red or black point depending on own subdomain
       !
       nmsta = 3 - nmsta
       !
       do k = 1, kmax
          do nm = nmsta, nmmax, 2
             !
             ! COMPUTE RIGHT HAND SIDE
             ! ( CHECK FOR KCS TO AVOID AN ARRAY INDEX OUT OF BOUNDS )
             !
             if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
                uvdwk(nm, k) =   bdddx(nm, k) * r1(nm - icx - icx - icx, k, l) &
                             & + bddx (nm, k) * r1(nm - icx - icx, k, l)       &
                             & + bdx  (nm, k) * r1(nm - icx, k, l)             &
                             & + bux  (nm, k) * r1(nm + icx, k, l)             &
                             & + buux (nm, k) * r1(nm + icx + icx, k, l)       &
                             & + buuux(nm, k) * r1(nm + icx + icx + icx, k, l)
                uvdwk(nm, k) = ddkl(nm, k, l) - rscale(nm, k)*uvdwk(nm, k)
             endif
          enddo
       enddo
       if(icx == 1) then
         call timer_stop(timer_difu_solve4u, gdp)
         call timer_start(timer_difu_solve5u, gdp)
       else
         call timer_stop(timer_difu_solve6v, gdp)
         call timer_start(timer_difu_solve7v, gdp)
       end if
       do nm = nmsta, nmmax, 2
          if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
             vvdwk(nm, 1) = uvdwk(nm, 1)*bbkl(nm, 1, l)
          endif
       enddo
       do k = 2, kmax
          do nm = nmsta, nmmax, 2
             if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
                vvdwk(nm,k) = (uvdwk(nm,k) - aakl(nm,k,l)*vvdwk(nm,k-1)) * bbkl(nm,k,l)
             endif
          enddo
       enddo
       do k = kmax - 1, 1, -1
          do nm = nmsta, nmmax, 2
             if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
                 vvdwk(nm, k) = vvdwk(nm, k) - cckl(nm, k, l) *vvdwk(nm, k + 1)
             endif
          enddo
       enddo
       !
       ! CHECK FOR CONVERGENCE
       !
       do k = 1, kmax
          do nm = nmsta, nmmax, 2
             if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
                epsitr = max(1.e-8_fp, 0.5e-3*abs(r1(nm, k, l)))
                if (abs(vvdwk(nm, k) - r1(nm, k, l)) > epsitr) itr = 1
                r1(nm, k, l) = vvdwk(nm, k)
             endif
          enddo
       enddo
       if(icx == 1) then
         call timer_stop(timer_difu_solve5u, gdp)
         call timer_start(timer_difu_solve4u, gdp)
       else
         call timer_stop(timer_difu_solve7v, gdp)
         call timer_start(timer_difu_solve6v, gdp)
       end if
       !
       call dfexchg ( r1(:,:,l), 1, kmax, dfloat, nm_pos, gdp )
       !
       ! loop starts at point of other color now (black respectively red)
       !
       nmsta = 3 - nmsta
       !
       do k = 1, kmax
          do nm = nmsta, nmmax, 2
             !
             ! COMPUTE RIGHT HAND SIDE
             !
             if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
                uvdwk(nm, k) =   bdddx(nm, k) * r1(nm - icx - icx - icx, k, l) &
                             & + bddx (nm, k) * r1(nm - icx - icx, k, l)       &
                             & + bdx  (nm, k) * r1(nm - icx, k, l)             &
                             & + bux  (nm, k) * r1(nm + icx, k, l)             &
                             & + buux (nm, k) * r1(nm + icx + icx, k, l)       &
                             & + buuux(nm, k) * r1(nm + icx + icx + icx, k, l)
                uvdwk(nm, k) = ddkl(nm, k, l) - rscale(nm, k)*uvdwk(nm, k)
             endif
          enddo
       enddo
       if(icx == 1) then
         call timer_stop(timer_difu_solve4u, gdp)
         call timer_start(timer_difu_solve5u, gdp)
       else
         call timer_stop(timer_difu_solve6v, gdp)
         call timer_start(timer_difu_solve7v, gdp)
       end if
       do nm = nmsta, nmmax, 2
          if (kfs(nm)==1 .and. kcs(nm) == 1) then
             vvdwk(nm, 1) = uvdwk(nm, 1)*bbkl(nm, 1, l)
          endif
       enddo
       do k = 2, kmax
          do nm = nmsta, nmmax, 2
             if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
                vvdwk(nm, k) = (uvdwk(nm,k) -  aakl(nm,k,l)*vvdwk(nm,k-1)) * bbkl(nm,k,l)
             endif
          enddo
       enddo
       do k = kmax - 1, 1, -1
          do nm = nmsta, nmmax, 2
             if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
                vvdwk(nm, k) = vvdwk(nm, k) - cckl(nm, k, l) *vvdwk(nm, k + 1)
             endif
          enddo
       enddo
       !
       ! CHECK FOR CONVERGENCE
       !
       do k = 1, kmax
          do nm = nmsta, nmmax, 2
             if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
                epsitr = max(1.e-8_fp, 0.5e-3*abs(r1(nm, k, l)))
                if (abs(vvdwk(nm, k) - r1(nm, k, l)) > epsitr) itr = 1
                r1(nm, k, l) = vvdwk(nm, k)
             endif
          enddo
       enddo
       if(icx == 1) then
         call timer_stop(timer_difu_solve5u, gdp)
       else
         call timer_stop(timer_difu_solve7v, gdp)
       end if
       call dfexchg ( r1(:,:,l), 1, kmax, dfloat, nm_pos, gdp )
       !
       ! determine global maximum of 'itr' over all nodes
       ! Note: this enables to synchronize the iteration process
       !
       call dfreduce_gdp( itr, 1, dfint, dfmax, gdp )
       !
       if (itr>0 .and. iter<50) goto 1100
       !
       if (gdp%gdflwpar%flwoutput%iteroutputsteps >= gdp%gdinttim%ntstep) then
          write (lundia, '(3(a,i0))') 'difu(ntstep,l,iter):',gdp%gdinttim%ntstep, ' ', l, ' ',iter
       endif
       if (iter >= 50) then
          write (errtxt, '(i0,a,i0)') l, ' ', nst
          call prterr(lundia    ,'S206'    ,trim(errtxt)    )
       endif
       !
       ! DD code added:
       !
       !
       !       D3dFlow_Solve_ADI_Conc: Check for convergence
       !
       nhystp = nxtstp(d3dflow_solve_adi_conc, gdp)
       if (nhystp == d3dflow_solve_adi_conc) goto 111
       !
       ! DD code added end
       !
       ! Nudging of constituents at open boundaries
       !
       if (nudge==1) then
          ! Nudging layer
          nnudge    = 4
          nudgefac  = 10.0_fp
          tnudge    = hdt
          mu(1)     = max(hdt / tnudge, 1.0_fp)
          do jj = 2, nnudge
             mu(jj) = mu(jj-1) / nudgefac
          enddo
          !
          do nm = 1, nmmax
             nmu = nm + icx
             nmd = nm - icx
             if (kcs(nmd) == 2 .and. kcs(nm) == 1 ) then
                nms(1) = nm
                do jj = 2, nnudge
                   nms(jj) = nms(jj-1) + icx
                enddo
                do jj = 1, nnudge
                   do k = 1, kmax
                      if (r1(nmd, k, l )>1.0e-6) then
                         rb = r1(nmd, k, l )
                         rp = r1(nms(jj), k, l)
                         r1(nms(jj), k, l) = rp + mu(jj)*(rb-rp)
                         r0(nms(jj), k, l) = r1(nms(jj), k, l)
                      endif
                   enddo
                enddo
             endif
             if (kcs(nmu) == 2 .and. kcs(nm) == 1) then
                nms(1) = nm
                do jj = 2, nnudge
                   nms(jj) = nms(jj-1) - icx
                enddo
                do jj = 1, nnudge
                   do k = 1, kmax
                      if (r1(nmu, k, l )>1.0e-6) then
                         rb = r1(nmu, k, l )
                         rp = r1(nms(jj), k, l)
                         r1(nms(jj), k, l) = rp + mu(jj)*(rb-rp)
                         r0(nms(jj), k, l) = r1(nms(jj), k, l)
                      endif
                   enddo
                enddo
             endif
          enddo
       endif
       !
    enddo
end subroutine difu


      SUBROUTINE PL2LN (A1,B1,C1,D1, A2,B2,C2,D2, A,B,C, PX,PY,PZ)

C  Given two planes, return line-intersection

      INTEGER  IXYZ, ABEST3
      REAL     A1,B1,C1,D1, A2,B2,C2,D2, A,B,C, PX,PY,PZ

C  Direction of line is cross-product of normal vectors
      CALL CROSSP (A1,B1,C1, A2,B2,C2, A,B,C)

C  use most stable variable as basis - effectively, use x=0, y=0,
C  or z=0 as 3rd plane.
      IXYZ = ABEST3 (A,B,C)
      IF (IXYZ .EQ. 1) THEN
         PX = 0
         CALL LINTPT (B1,C1,D1, B2,C2,D2, PY,PZ)
      ELSEIF (IXYZ .EQ. 2) THEN
         PY = 0
         CALL LINTPT (A1,C1,D1, A2,C2,D2, PX,PZ)
      ELSE
         PZ = 0
         CALL LINTPT (A1,B1,D1, A2,B2,D2, PX,PY)
      ENDIF

      END