module percolation
    !! A module with procedures for calculating various properties which
    !! are interesting when doing numerical percolation experiments.
    use utilities
    use hk
    implicit none

    private :: has_spanning_cluster_one_sample, spanning_density_one_sample, &
               label_recursively, growcluster

    real(kind=dp), parameter :: pc = 0.592746
        !! Known critical probability for a two-dimensional site-percolating
        !! system.
    contains
        function create_binary_matrix(p, L) result(binary_matrix)
            !! Create a random, binary (`logical`) matrix,
            !! which can be used in percolation experiments.

            logical, dimension(:,:), allocatable :: binary_matrix
                !! Randomly created matrix, where each element is `.true.`
                !! or `.false.` if a randomly generated number is smaller
                !! or greater than p.

            real(kind=dp), intent(in) :: p
                !! Probability for each matrix element to be `.true.`.

            integer, intent(in) :: L

            real(kind=dp), dimension(:,:), allocatable :: p_matrix
            allocate(p_matrix(L,L))

            call random_seed()
            call random_number(p_matrix)

            binary_matrix = p_matrix < p
        end function

        subroutine label(matrix, labelled_matrix, num_labels)
            !! Alternative interface to the Hoshen-Kopelman algorithm
            !! from the hk module, which uses a binary matrix created
            !! by [[create_binary_matrix]].

            logical, dimension(:,:), intent(in) :: matrix
                !! Binary matrix where clusters will be identified.

            integer, dimension(:,:), allocatable, intent(out) :: labelled_matrix
                !! Integer matrix which will store the labels of each cluster.
                !! Reallocated if necessary.

            integer, intent(out) :: num_labels
                !! Overwritten with the total number of disjoint clusters.

            integer :: L

            L = size(matrix,1)

            if(.not. allocated(labelled_matrix)) then
                allocate(labelled_matrix(L,L))
            else if(size(labelled_matrix,1) /= L) then
                deallocate(labelled_matrix)
                allocate(labelled_matrix(L,L))
            endif
            where(matrix)
                labelled_matrix = 1
            else where
                labelled_matrix = 0
            end where
            num_labels = hoshen_kopelman(labelled_matrix)
        end subroutine

        function find_sizes(labelled_matrix, num_labels) result(sizes)
            !! Count the number of sites belonging to each cluster
            !! in the labelled matrix.

            integer, dimension(:), allocatable :: sizes
                !! Array of cluster sizes. The i'th element is the size of
                !! the cluster with label i.

            integer, dimension(:,:), intent(in) :: labelled_matrix
                !! Integer matrix with labelled clusters, resulting from
                !! the Hoshen-Kopelman algorithm.

            integer, intent(in) :: num_labels
                !! The known number of clusters.

            integer :: L,i,j

            L = size(labelled_matrix,1)
            allocate(sizes(num_labels))
            sizes(:) = 0

            do j=1,L
                do i=1,L
                    associate (label => labelled_matrix(i,j))
                        if(label /= 0) then
                            sizes(label) = sizes(label) + 1
                        end if
                    end associate
                end do
            end do
        end function

        subroutine cluster_number_density(p, L, num_samples, bin_mids, results, binsize_base)
            !! Calculate the number density of clusters with different sizes.
            !! The cluster number density is defined as
            !! \\begin{equation}
            !!      n(s,p) = \sum_{\text{MC-samples}}
            !!                   \frac{\text{number of clusters with size }s}
            !!                        {L^2\cdot\text{number of MC-samples}}.
            !! \\end{equation}
            !! Direct calculations will usually give bad results, as there
            !! will be very few
            !! clusters with large sizes compared to the numbers of clusters
            !! with small sizes. This is circumvented by doing logarithmic
            !! binning and averaging, i.e.
            !! \\begin{equation}
            !!      n\left([s+\Delta s),p\right) = \sum_{\text{MC-samples}}
            !!                   \frac{\text{number of clusters with size }s
            !!                         \in[s,s+\Delta s)}
            !!                        {\Delta s\cdot L^2\cdot\text{number of MC-samples}},
            !!      \label{eq:nsp}
            !! \\end{equation}
            !! where \\(\Delta s\\) are logarithmically distributed. After execution,
            !! **bin_mids** will contain the centres of the bins.

            integer, intent(in) :: L
                !! Percolating systems will be \\(L\times L\\).

            integer, intent(in) :: num_samples
                !! Results will be averaged over this number of Monte Carlo-samples.
                !! Sampling is parallelised.

            real(kind=dp), intent(in) :: p
                !! Probability for a given site to allow transport.

            real(kind=dp), intent(in), optional :: binsize_base
                !! The edges of the logarithmically distributed bins will be
                !! integer powers of this number. Default: 1.5.

            real(kind=dp), dimension(:), intent(out), allocatable :: bin_mids
                !! Centres of bins.

            real(kind=dp), dimension(:), intent(out), allocatable :: results
                !! Cluster number density in \eqref{eq:nsp}.

            integer :: num_bins, i, j, num_labels, sizeindex, spanning_label
            real(kind=dp) :: a, loga

            logical, dimension(:,:), allocatable :: binary_matrix
            integer, dimension(:,:), allocatable :: label_matrix
            integer, dimension(:), allocatable :: clustersizes, histogram
            real(kind=dp), dimension(:), allocatable :: bin_edges, bin_sizes

            if(present(binsize_base)) then
                a = binsize_base
            else
                a = 1.5d0
            end if

            !/cndstart/!
            loga = log(a)

            num_bins  = ceiling(log(1.0d0*L**2)/loga)
            bin_edges = a**[(i, i=0 ,num_bins)]
            bin_mids  = 0.5*(bin_edges(1:num_bins) + bin_edges(2:num_bins+1))
            bin_sizes = bin_edges(2:num_bins+1) - bin_edges(1:num_bins)

            allocate(histogram(1:num_bins))
            histogram = 0

            !$omp  parallel do &
            !$omp& private(binary_matrix, label_matrix, num_labels, &
            !$omp&         clustersizes, spanning_label, sizeindex) &
            !$omp& reduction(+:histogram)
            do i = 1, num_samples
                binary_matrix = create_binary_matrix(p, L)
                call label(binary_matrix, label_matrix, num_labels)
                clustersizes = find_sizes(label_matrix, num_labels)
                spanning_label = find_spanning_cluster(label_matrix, num_labels)

                do j = 1, num_labels
                    if(j /= spanning_label) then
                        sizeindex = floor(log(1.0d0*clustersizes(j))/loga) + 1
                        histogram(sizeindex) = histogram(sizeindex) + 1
                    end if
                end do
            end do
            !$omp end parallel do

            results = histogram/(L**2 * num_samples * bin_sizes)
            !/cndend/!
        end subroutine

        function find_spanning_cluster(labelled_matrix, num_labels) result(spanning_label)
            !! Find the label of the percolating cluster, i.e. the one spanning from
            !! one side of the system to the opposing side.

            integer :: spanning_label
                !! Label of the percolating cluster. -1 if no percolating cluster is found.

            integer, dimension(:,:), intent(in) :: labelled_matrix
                !! Labelled matrix of clusters from [[hoshen_kopelman]]/[[label]].

            integer, intent(in) :: num_labels
                !! Known number of clusters.

            integer :: L

            L = size(labelled_matrix,1)

            spanning_label = find_intersection(labelled_matrix(:,1), labelled_matrix(:,L), num_labels)

            if (spanning_label == -1) then
                spanning_label = find_intersection(labelled_matrix(1,:), labelled_matrix(L,:), num_labels)
            end if
        end function

        function spanning_density_one_sample(p, L) result(spanning_density)
            real(kind=dp) :: spanning_density
            real(kind=dp), intent(in) :: p
            integer, intent(in) :: L

            logical, dimension(:,:), allocatable :: binary_matrix
            integer, dimension(:,:), allocatable :: labelled_matrix

            integer :: num_labels, spanning_label

            binary_matrix = create_binary_matrix(p,L)
            call label(binary_matrix, labelled_matrix, num_labels)

            spanning_label = find_spanning_cluster(labelled_matrix, num_labels)

            if (spanning_label == -1) then
                spanning_density = 0
                return
            end if

            spanning_density = count(labelled_matrix == spanning_label)/real(L**2,kind=dp)
        end function

        function spanning_density(p, L, num_samples)
            !! Density of the spanning/percolating cluster, i.e.
            !! the number of sites on the percolating cluster divided by \\(L^2\\).
            !! Averaged over **num_samples** Monte Carlo samples (with OpenMP).

            real(kind=dp) :: spanning_density
                !! The number of sites on the spanning cluster divided by \\(L^2\\).

            real(kind=dp), intent(in) :: p
                !! The probability for a site to allow transport.

            integer, intent(in) :: L
                !! The size of the system.

            integer, intent(in) :: num_samples
                !! The number of Monte Carlo samples.

            integer :: i
            real(kind=dp), dimension(:), allocatable :: results

            allocate(results(num_samples))

            !$omp parallel do
            do i=1,num_samples
                results(i) = spanning_density_one_sample(p, L)
            end do
            !$omp end parallel do

            spanning_density = sum(results)/num_samples
        end function

        function has_spanning_cluster_one_sample(p, L) result(has_spanning)
            logical :: has_spanning
            real(kind=dp), intent(in) :: p
            integer, intent(in) :: L

            logical, dimension(:,:), allocatable :: binary_matrix
            integer, dimension(:,:), allocatable :: labelled_matrix

            integer :: num_labels, spanning_label

            binary_matrix = create_binary_matrix(p,L)
            call label(binary_matrix, labelled_matrix, num_labels)

            spanning_label = find_spanning_cluster(labelled_matrix, num_labels)

            has_spanning = spanning_label /= -1
        end function

        function spanning_probability(p, L, num_samples)
            !! Calculate the probability of having a spanning/percolating cluster, given
            !! a system size **L** and probability for a site to have transport **p**.

            real(kind=dp) :: spanning_probability
                !! The probability of having a percolating cluster, calculated as the number
                !! of times a percolating cluster is found, divided by the number of attempts
                !! (**num_samples**).

            real(kind=dp), intent(in) :: p
                !! Probability for a site to allow transport.

            integer, intent(in) :: L
                !! Size of the system.

            integer, intent(in) :: num_samples
                !! Number of Monte Carlo samples.

            integer :: i
            logical, dimension(:), allocatable :: results

            allocate(results(num_samples))

            !$omp parallel do
            do i=1,num_samples
                results(i) = has_spanning_cluster_one_sample(p, L)
            end do
            !$omp end parallel do

            spanning_probability = count(results)/real(num_samples,kind=dp)
        end function

        function spanning_probability_inverse(x, L, num_samples, tolerance) result(p_x)
            !! Find the inverse of [[spanning_probability]] by use
            !! of the bisection method.

            real(kind=dp), intent(in) :: x
                !! The value of [[spanning_probability]] for which the inverse
                !! is calculated.

            real(kind=dp), intent(in) :: tolerance
                !! Tolerance of approximation. The return value is within
                !! **tolerance**/2 of the correct (but numerical) value.

            integer, intent(in) :: L
                !! Size of the system.

            integer, intent(in) :: num_samples
                !! Number of Monte Carlo samples to use when evaluating [[spanning_probability]].

            real(kind=dp) :: p_x
                !! The inverse of [[spanning_probability]]. If [[spanning_probability]] is
                !! denoted \\(\Pi(p,L)\\), this function returns \\(p\\) such
                !! that \\(\Pi(p,L)=x\\).

            real(kind=dp) :: lower, upper, lowerPI, upperPI, mid, midPI

            !/invPIstart/!
            lower = 0
            upper = 1
            lowerPI = 0
            upperPI = 1

            do while(upper - lower > tolerance)
                mid = (lower + upper)/2
                midPI = spanning_probability(mid, L, num_samples)
                if(midPI > x) then
                    upper = mid
                    upperPI = midPI
                else
                    lower = mid
                    lowerPI = midPI
                end if
            end do
            p_x = mid
            !/invPIend/!

        end function

        !/labelsubroutinestart/!
        subroutine label_recursively(matrix, labelled_matrix, num_labels)
            logical, dimension(:,:), allocatable, intent(in) :: matrix
            integer, dimension(:,:), allocatable, intent(inout) :: labelled_matrix
            integer, intent(inout) :: num_labels
            integer :: L, i, j

            L = size(matrix,1)
            num_labels = 0

            if(.not. allocated(labelled_matrix)) then
                allocate(labelled_matrix(L,L))
            end if

            labelled_matrix = 0

            do j=1,L
                do i=1,L
                    if(matrix(i,j) .and. labelled_matrix(i,j) == 0) then
                        num_labels = num_labels + 1
                        call growcluster(matrix,labelled_matrix,i,j,num_labels)
                    end if
                end do
            end do
        end subroutine
        !/labelsubroutineend/!

        !/growclustersubroutinestart/!
        recursive subroutine growcluster(matrix, labelled_matrix, i, j, label)
            logical, dimension(:,:), allocatable, intent(in) :: matrix
            integer, dimension(:,:), allocatable, intent(inout) :: labelled_matrix
            integer, intent(in) :: i, j, label
            integer :: L

            L = size(matrix,1)

            labelled_matrix(i,j) = label

            if(i<L) then
                if(matrix(i+1,j) .and. labelled_matrix(i+1,j)==0) then
                    call growcluster(matrix, labelled_matrix, i+1, j, label)
                end if
            end if
            if(j<L) then
                if(matrix(i,j+1) .and. labelled_matrix(i,j+1)==0) then
                    call growcluster(matrix, labelled_matrix, i, j+1, label)
                end if
            end if
            if(i>1) then
                if(matrix(i-1,j) .and. labelled_matrix(i-1,j)==0) then
                    call growcluster(matrix, labelled_matrix, i-1, j, label)
                end if
            end if
            if(j>1) then
                if(matrix(i,j-1) .and. labelled_matrix(i,j-1)==0) then
                    call growcluster(matrix, labelled_matrix, i, j-1, label)
                end if
            end if
        end subroutine
        !/growclustersubroutineend/!
end module percolation


module mod_interpolation
#include <messenger.h>
    use DNAD_D
    implicit none

contains

    !>  General interpolation routine. Based on given interpolation_type, select appropriate
    !!  interpolation routine(linear, quadratic, etc.).
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/2/2016
    !!
    !!
    !---------------------------------------------------------------------------------------
    !subroutine interpolate(interpolation_type, xarray, yarray, xnew, ynew)
    !    character(*),   intent(in)      :: interpolation_type
    !    real(rk),       intent(in)      :: xarray(:)
    !    real(rk),       intent(in)      :: yarray(:)
    !    real(rk),       intent(in)      :: xnew
    !    real(rk),       intent(inout)   :: ynew
    function interpolate(interpolation_type, xarray, yarray, xnew) result(ynew)
        character(*),   intent(in)      :: interpolation_type
        real(rk),       intent(in)      :: xarray(:)
        real(rk),       intent(in)      :: yarray(:)
        real(rk),       intent(in)      :: xnew

        real(rk) :: ynew

        if ( interpolation_type == 'linear' ) then
            !call interpolate_linear(xarray,yarray,xnew,ynew)
            ynew = interpolate_linear(xarray,yarray,xnew)

        else
            call chidg_signal_one(FATAL, "interpolate: invalid interpolation_type.", interpolation_type)

        end if

    end function interpolate
    !***************************************************************************************

    !>  Linearly interpolate a new value from a list of given x,y pairs.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/2/2016
    !!
    !---------------------------------------------------------------------------------------
    function interpolate_linear(xarray,yarray,xnew) result(ynew)
        real(rk),   intent(in)      :: xarray(:)
        real(rk),   intent(in)      :: yarray(:)
        real(rk),   intent(in)      :: xnew

        integer     :: ival, lindex, hindex
        real(rk)    :: xlow_current, xhigh_current, ynew
        logical     :: out_of_bounds

        !
        ! Test xnew is bounded by xarray min/max
        !
        out_of_bounds = ( xnew < minval(xarray) .or. xnew > maxval(xarray) )
        if ( out_of_bounds ) call chidg_signal_one(FATAL,"interpolate_linear: new x-value is not bounded by the min/max of given x-values.", xnew)

        !
        ! Find next lowest x-value
        !
        lindex          = minloc(xarray,dim=1)
        xlow_current    = minval(xarray)
        do ival = 1,size(xarray)

            if ( xarray(ival) < xnew  .and. xarray(ival) > xlow_current ) then
                xlow_current = xarray(ival)
                lindex       = ival
            end if

        end do

        !
        ! Find next highest x-value
        !
        hindex          = maxloc(xarray,dim=1)
        xhigh_current   = maxval(xarray)
        do ival = 1,size(xarray)

            if ( xarray(ival) > xnew  .and. xarray(ival) < xhigh_current ) then
                xhigh_current = xarray(ival)
                hindex        = ival
            end if

        end do

        !
        ! Compute linear interpolation between next highest/lowest values.
        !
        ynew = yarray(lindex) + ( yarray(hindex) - yarray(lindex) ) * ( xnew - xarray(lindex) )/( xarray(hindex) - xarray(lindex) )

    end function interpolate_linear
    !***************************************************************************************

    !>  Linearly interpolate a new value from a list of given x,y pairs.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/2/2016
    !!
    !---------------------------------------------------------------------------------------
    function interpolate_linear_ad(xarray,yarray,xnew) result(ynew)
        real(rk),   intent(in)      :: xarray(:)
        type(AD_D), intent(in)      :: yarray(:)
        real(rk),   intent(in)      :: xnew

        integer     :: ival, lindex, hindex
        real(rk)    :: xlow_current, xhigh_current
        logical     :: out_of_bounds
        type(AD_D)  :: ynew

        !
        ! Test xnew is bounded by xarray min/max
        !
        out_of_bounds = ( xnew < minval(xarray) .or. xnew > maxval(xarray) )
        if ( out_of_bounds ) call chidg_signal_one(FATAL,"interpolate_linear: new x-value is not bounded by the min/max of given x-values.", xnew)

        !
        ! Find next lowest x-value
        !
        lindex          = minloc(xarray,dim=1)
        xlow_current    = minval(xarray)
        do ival = 1,size(xarray)

            if ( xarray(ival) < xnew  .and. xarray(ival) > xlow_current ) then
                xlow_current = xarray(ival)
                lindex       = ival
            end if

        end do

        !
        ! Find next highest x-value
        !
        hindex          = maxloc(xarray,dim=1)
        xhigh_current   = maxval(xarray)
        do ival = 1,size(xarray)

            if ( xarray(ival) > xnew  .and. xarray(ival) < xhigh_current ) then
                xhigh_current = xarray(ival)
                hindex        = ival
            end if

        end do

        !
        ! Compute linear interpolation between next highest/lowest values.
        !
        ynew = yarray(lindex) + ( yarray(hindex) - yarray(lindex) ) * ( xnew - xarray(lindex) )/( xarray(hindex) - xarray(lindex) )

    end function interpolate_linear_ad
    !***************************************************************************************

end module mod_interpolation


module enforce_thickness

  implicit none

  contains

  ! ---------------------------------------------------------------------------
  !> Check that the free surface anomaly and layer thicknesses are consistent with the depth field. If they're not, then scale the layer thicnkesses to make them fit.

  subroutine enforce_depth_thickness_consistency(h, eta, depth, &
      freesurfFac, thickness_error, xlow, xhigh, ylow, yhigh, layers, OL)
    implicit none

    double precision, intent(inout) :: h(xlow-OL:xhigh+OL, &
                                          ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: eta(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in) :: depth(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in) :: freesurfFac, thickness_error
    integer, intent(in) :: xlow, xhigh, ylow, yhigh, layers, OL

    integer k
    double precision h_norming(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)

    h_norming = (freesurfFac*eta + depth) / sum(h,3)
    do k = 1, layers
      h(:, :, k) = h(:, :, k) * h_norming
    end do

    if (maxval(abs(h_norming - 1d0)) .gt. thickness_error) then
      write(17, "(A, F6.3, A)") 'Inconsistency between h and eta: ', &
          maxval(abs(h_norming - 1d0))*100d0, '%'
    end if

    return
  end subroutine enforce_depth_thickness_consistency

end module enforce_thickness


      program indexes
      integer i,j
      integer s(10)
      do i=1, 10
         do j=1, 10
            s(j)=s(j)+i
         enddo
         s(i)=s(i)+2
      enddo
      do i=1, 10
         s(3)=s(3)+i+j
         s(5)=i+s(5)+j
         s(7)=i+j+s(7)
      enddo
      end
!tps$ activate PRINT_CODE_PROPER_REDUCTIONS
!tps$ display PRINTED_FILE
!tps$ activate PRINT_CODE_CUMULATED_REDUCTIONS
!tps$ display PRINTED_FILE


C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 04.01.02/01                           *
C  *    TEST TITLE : Polymarker element                    *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

C  Declare program-specific variables

      INTEGER CELTYP, INTLEN, INTG, RLLEN, RL, STRLEN, STR, INLEN
      INTEGER STLEN, RELEN, N, STRID, I

      PARAMETER (INLEN = 50, STLEN = 50, RELEN = 50, STRID = 1)

      INTEGER INTAR(INLEN), STRARL(STLEN)

      LOGICAL CASE1, CASE2, RAREQ

      REAL XARR(5), YARR(5), ZARR(5), RLAR(RELEN), RLCOMB(15)

      CHARACTER STRAR(STLEN)

      DATA XARR /2.33, 55.55, -4.4, 123.0, 0.0/
      DATA YARR /0.0, 3.2, -99.99, 3.2E22, -2.2E-22/
      DATA ZARR /4.44, 0.0, 0.0, 5.5, 22.22/

      CALL INITGL ('04.01.02/01')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)

C  *** *** *** *** ***   Polymarker 3   *** *** *** *** ***

C  <polymarker 3> with n,xarr,yarr,zarr

      N = 5
      CALL POPST (STRID)
      CALL PPM3 (N, XARR, YARR, ZARR)

C  <inquire current element type and size> to set celtyp, celsiz

      CALL SETMSG ('1 2', '<Inquire current element type and size> '  //
     1             'should return polymarker 3 as the type of the '   //
     2             'created element and the appropriate element '     //
     3             'size.')

C    (celtyp = polymarker 3 and
C     celsiz = values specified by the standard and language binding;
C              fortran binding values are intlen, rllen, and strlen)

      CALL PQCETS (ERRIND, CELTYP, INTLEN, RLLEN, STRLEN)

      CALL IFPF (ERRIND   .EQ.   0   .AND.
     1           CELTYP   .EQ.   4   .AND.
     2           INTLEN   .EQ.   1   .AND.
     3           RLLEN    .EQ. 3*N   .AND.
     4           STRLEN   .EQ.   0)

      CALL SETMSG ('1 3', '<Inquire current element content> should ' //
     1             'return the standard representation for '          //
     2             'polymarker 3.')

      DO 10 I = 1, N
         RLCOMB(I)     = XARR(I)
         RLCOMB(I+N)   = YARR(I)
         RLCOMB(I+2*N) = ZARR(I)
10    CONTINUE

      CALL PQCECO (INLEN, RELEN, STLEN, ERRIND, INTG, INTAR,
     1            RL, RLAR, STR, STRARL, STRAR)

      IF (ERRIND   .EQ.   0  .AND.
     1    INTG     .EQ.   1  .AND.
     2    INTAR(1) .EQ.   N  .AND.
     3    RL       .EQ.  3*N .AND.
     4    STR      .EQ.   0)    THEN
          CASE1 = .TRUE.
      ELSE
          CASE1 = .FALSE.
          CALL INMSG ('Array sizes are incorrect.')
          GOTO 20
      ENDIF

      CASE2 = RAREQ (3*N, RLAR, RLCOMB, 0.0, 0.0)
      IF (.NOT. CASE2)
     1    CALL INMSG ('Geometric point values are incorrect.')

20    CONTINUE
      CALL IFPF (CASE1 .AND. CASE2)

C  *** *** *** *** ***   Polymarker   *** *** *** *** ***

C  <polymarker> with n,xarr,yarr

      N = 5
      CALL PPM (N, XARR, YARR)

C  <inquire current element type and size> to set celtyp, celsiz

      CALL SETMSG ('4 5', '<Inquire current element type and size> '  //
     1             'should return polymarker as the type of the '     //
     2             'created element and the appropriate element '     //
     3             'size.')

C    (celtyp = polymarker and
C     celsiz = values specified by the standard and language binding;
C              fortran binding values are intlen, rllen, and strlen)

      CALL PQCETS (ERRIND, CELTYP, INTLEN, RLLEN, STRLEN)

      CALL IFPF (ERRIND   .EQ.   0   .AND.
     1           CELTYP   .EQ.   5   .AND.
     2           INTLEN   .EQ.   1   .AND.
     3           RLLEN    .EQ. 2*N   .AND.
     4           STRLEN   .EQ.   0)

      CALL SETMSG ('4 6', '<Inquire current element content> should ' //
     1             'return the standard representation for '          //
     2             'polymarker.')

      CALL PQCECO (INLEN, RELEN, STLEN, ERRIND, INTG, INTAR,
     1             RL, RLAR, STR, STRARL, STRAR)

      IF (ERRIND   .EQ.   0   .AND.
     1    INTG     .EQ.   1   .AND.
     2    INTAR(1) .EQ.   N   .AND.
     3    RL       .EQ.  2*N  .AND.
     4    STR      .EQ.   0)     THEN
          CASE1 = .TRUE.
      ELSE
          CASE1 = .FALSE.
          CALL INMSG ('Array sizes are incorrect.')
          GOTO 30
      ENDIF

      CASE2 = RAREQ (2*N, RLAR, RLCOMB, 0.0, 0.0)
      IF (.NOT. CASE2)
     1    CALL INMSG ('Geometric point values are incorrect.')

30    CONTINUE
      CALL IFPF (CASE1 .AND. CASE2)

777   CONTINUE
      CALL ENDIT
      END


PROGRAM LA_DPPSVX_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => DP
   USE F95_LAPACK, ONLY: LA_PPSVX
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMT = '(8(1X,F10.3))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: EQU
   INTEGER :: I, J, K, INFO, N, NRHS, NS
   REAL(WP) :: RCOND
!  .. LOCAL ARRAYS ..
   INTEGER, ALLOCATABLE :: IPIV(:)
   REAL(WP), ALLOCATABLE :: A(:), B(:,:), X(:,:), AF(:)
   REAL(WP), ALLOCATABLE :: AA(:), BB(:,:), S(:), FERR(:), BERR(:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'DPPSVX ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) N, NRHS
   PRINT *, 'N = ', N, ' NRHS = ', NRHS
   NS = N*(N+1)/2
   ALLOCATE ( A(NS), AA(NS), B(N,NRHS), BB(N,NRHS), X(N,NRHS), IPIV(N), &
              AF(NS), S(N), FERR(NRHS), BERR(NRHS) )
!
      AA = HUGE(1.0_WP)
      READ (NIN, *) AA
      DO K = 1, NRHS
         DO I = 1, N
            DO J = 1, I
               BB(J,K) = BB(J,K) + AA(J+(I-1)*I/2)
               IF ( J /= I ) BB(I,K) = BB(I,K) + AA(J+(I-1)*I/2)
            ENDDO
         ENDDO
         BB(:,K) = BB(:,K)*K
      ENDDO
   A=AA; B=BB
      WRITE(NOUT,*) 'The matrix A:'
      DO I = 1, N
        WRITE (NOUT,*) 'J = ', I; WRITE (NOUT,FMT) (A(J+(I-1)*I/2),J=1,I)
      ENDDO
      WRITE(NOUT,*) 'The RHS matrix B:'
      DO J = 1, NRHS
        WRITE (NOUT,*) 'RHS', J; WRITE (NOUT,FMT) B(:,J)
      ENDDO
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_DPPSVX LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSVX( A, B, X, INFO=INFO )'
   A=AA; B=BB
   CALL LA_PPSVX( A, B, X, INFO=INFO )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PPSVX, INFO = ', INFO
   DO J = 1, NRHS; WRITE (NOUT,FMT) X(:,J); END DO
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSVX( A, B(1:N,1), X(1:N,1), RCOND=RCOND, INFO=INFO )'
   A=AA; B=BB
   CALL LA_PPSVX( A, B(1:N,1), X(1:N,1), RCOND=RCOND, INFO=INFO )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PPSVX, INFO = ', INFO
   WRITE (NOUT,FMT) X(:,1)
   WRITE(NOUT,*) 'RCOND = ', RCOND
!
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PPSVX:'
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSVX( A, B, X )'
   A=AA; B=BB
   CALL LA_PPSVX( A, B, X )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PPSVX:'
   DO J = 1, NRHS; WRITE (NOUT,FMT) X(:,J); END DO
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSVX(A, B(1:N,1), X(1:N,1) )'
   A=AA; B=BB
   CALL LA_PPSVX(A, B(1:N,1), X(1:N,1) )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PPSVX:'
   WRITE (NOUT,FMT) X(:,1)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSVX(A, B, X, ''L'', RCOND=RCOND)'
!  A=TRANSPOSE(AA)
   DO I = 1,N
      DO J = I, N
         A(J+(I-1)*(2*N-I)/2) = AA(I+J*(J-1)/2)
      ENDDO
   ENDDO
   B=BB
   CALL LA_PPSVX( A, B, X, 'L', RCOND=RCOND)
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PPSVX:'
   DO J = 1, NRHS; WRITE (NOUT,FMT) X(:,J); END DO
   WRITE(NOUT,*) 'RCOND = ', RCOND
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSVX( A, B(1:N,1), X(1:N,1), ''L'', RCOND=RCOND )'
!  A=TRANSPOSE(AA)
   DO I = 1,N
      DO J = I, N
         A(J+(I-1)*(2*N-I)/2) = AA(I+J*(J-1)/2)
      ENDDO
   ENDDO
   B=BB
   CALL LA_PPSVX( A, B(1:N,1), X(1:N,1), 'L', RCOND=RCOND )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PPSVX:'
   WRITE (NOUT,FMT) X(1:N,1)
   WRITE(NOUT,*) 'RCOND = ', RCOND
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSVX(A(:,:), B(1:N-1,:), X, INFO =INFO )'
   A=AA; B=BB; X=HUGE(1.0_WP)
   CALL LA_PPSVX( A(:), B(1:N-1,:), X, INFO=INFO)
   WRITE(NOUT,*)'   INFO = ', INFO
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSVX( A(4:4), B(1:N,1), X(1:N,1), INFO=INFO )'
   A=AA; B=BB; X=HUGE(1.0_WP)
   CALL LA_PPSVX( A(4:4), B(1:N,1), X(1:N,1), INFO=INFO )
   WRITE(NOUT,*)'   B - the RHS vector.'
   WRITE (NOUT,FMT) B(1:N,1)
   WRITE(NOUT,*)'  INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSVX(A, B, X, FACT=''F'', INFO =INFO )'
   A=AA; B=BB; X=HUGE(1.0_WP)
   CALL LA_PPSVX( A, B, X, FACT='F', INFO=INFO)
   WRITE(NOUT,*)'   INFO = ', INFO
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSVX( A, B(1:N,1), X(1:N,1), FACT=''4'', INFO=INFO )'
   A=AA; B=BB; X=HUGE(1.0_WP)
   CALL LA_PPSVX( A, B(1:N,1), X(1:N,1), FACT='4', INFO=INFO )
   WRITE(NOUT,*)'   INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSVX(A, B, X, ''U'', AF, ''N'', EQU, S, FERR, BERR, RCOND, INFO)'
   A=AA; B=BB; X=HUGE(1.0_WP); EQU = 'N'
   CALL LA_PPSVX(A, B, X, 'U', AF, 'N', EQU, S, FERR, BERR, RCOND, INFO)
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PPSVX, INFO = ', INFO
   DO J = 1, NRHS; WRITE (NOUT,FMT) X(:,J); END DO
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSVX(A, B(1:N,1), X(1:N,1), ''U'', AF, ''N'', EQU, S, FERR, BERR, RCOND, INFO)'
   A=AA; B=BB; X=HUGE(1.0_WP); EQU = 'N'
   CALL LA_PPSVX(A, B(1:N,1), X(1:N,1), 'U', AF, 'N', EQU, S, FERR(1), BERR(1), RCOND, INFO)
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PPSVX, INFO = ', INFO
   WRITE (NOUT,FMT) X(1:N,1)
END PROGRAM LA_DPPSVX_ET_EXAMPLE


*DECK RUNIF
      FUNCTION RUNIF (T, N)
C***BEGIN PROLOGUE  RUNIF
C***PURPOSE  Generate a uniformly distributed random number.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  L6A21
C***TYPE      SINGLE PRECISION (RUNIF-S)
C***KEYWORDS  FNLIB, RANDOM NUMBER, SPECIAL FUNCTIONS, UNIFORM
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C This random number generator is portable among a wide variety of
C computers.  It generates a random number between 0.0 and 1.0 accord-
C ing to the algorithm presented by Bays and Durham (TOMS, 2, 59,
C 1976).  The motivation for using this scheme, which resembles the
C Maclaren-Marsaglia method, is to greatly increase the period of the
C random sequence.  If the period of the basic generator (RAND) is P,
C then the expected mean period of the sequence generated by RUNIF is
C given by   new mean P = SQRT (PI*FACTORIAL(N)/(8*P)),
C where FACTORIAL(N) must be much greater than P in this asymptotic
C formula.  Generally, N should be around 32 if P=4.E6 as for RAND.
C
C             Input Argument --
C N      ABS(N) is the number of random numbers in an auxiliary table.
C        Note though that ABS(N)+1 is the number of items in array T.
C        If N is positive and differs from its value in the previous
C        invocation, then the table is initialized for the new value of
C        N.  If N is negative, ABS(N) is the number of items in an
C        auxiliary table, but the tables are now assumed already to
C        be initialized.  This option enables the user to save the
C        table T at the end of a long computer run and to restart with
C        the same sequence.  Normally, RUNIF would be called at most
C        once with negative N.  Subsequent invocations would have N
C        positive and of the correct magnitude.
C
C             Input and Output Argument  --
C T      an array of ABS(N)+1 random numbers from a previous invocation
C        of RUNIF.  Whenever N is positive and differs from the old
C        N, the table is initialized.  The first ABS(N) numbers are the
C        table discussed in the reference, and the N+1 -st value is Y.
C        This array may be saved in order to restart a sequence.
C
C             Output Value --
C RUNIF  a random number between 0.0 and 1.0.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  RAND
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   910819  Added EXTERNAL statement for RAND due to problem on IBM
C           RS 6000.  (WRB)
C***END PROLOGUE  RUNIF
      DIMENSION T(*)
      EXTERNAL RAND
      SAVE NOLD, FLOATN
      DATA NOLD /-1/
C***FIRST EXECUTABLE STATEMENT  RUNIF
      IF (N.EQ.NOLD) GO TO 20
C
      NOLD = ABS(N)
      FLOATN = NOLD
      IF (N.LT.0) DUMMY = RAND (T(NOLD+1))
      IF (N.LT.0) GO TO 20
C
      DO 10 I=1,NOLD
        T(I) = RAND (0.)
 10   CONTINUE
      T(NOLD+1) = RAND (0.)
C
 20   J = T(NOLD+1)*FLOATN + 1.
      T(NOLD+1) = T(J)
      RUNIF = T(J)
      T(J) = RAND (0.)
C
      RETURN
      END


      subroutine cdgl
************************************************************************
*
*  CDGL -- Local Mass matrix diagonal.
*
************************************************************************
      include "parameters.h"

      integer x
      parameter(x=npde+1)

      integer nnod,nelt
      common /mfe010/ nnod,nelt

      integer kreg
      double precision wpde,segvsc,segspr
      common /mfe020/ wpde(npde)
      common /mfe021/ segvsc(npde),segspr(npde),kreg

      double precision a00,a10,a01,a11
      common /loc20/ a00(mnod,nepn,nepn),a10(mnod,nepn,nepn),
     +               a01(mnod,nepn,nepn),a11(mnod,nepn,nepn)

      double precision l,n1,n2
      common /loc30/ l(mnod,npde),n1(mnod,npde),n2(mnod,npde)

      integer i,j,k
      double precision c,aa,ab,bb(mnod),term
*     ==================================================================
*      Load the zero elements of the local mass matrix diagonal.
*     ==================================================================
      do 10 k=2,npde
      do 10 i=1,k-1
      do 10 j=1,nelt
       a00(j,i,k) = 0.d0
       a11(j,i,k) = 0.d0
       a00(j,k,i) = 0.d0
       a11(j,k,i) = 0.d0
   10 continue
*     ==================================================================
*      Load the pure MFE mass matrix diagonal.
*     ==================================================================
      do 20 j=1,nelt
   20 bb(j) = 0.d0

      do 30 k=1,npde
      c = wpde(k)/3.d0
      do 30 j=1,nelt
       aa = (c*l(j,k))*n2(j,k)**2
       ab = (c*l(j,k))*n1(j,k)*n2(j,k)
       bb(j) = bb(j) + (c*l(j,k))*n1(j,k)**2

*      Load the (alpha,alpha) inner products.
       a00(j,k,k) = aa
       a11(j,k,k) = aa

*      Load the (alpha,beta) inner products.
       a00(j,k,x) = ab
       a00(j,x,k) = ab
       a11(j,k,x) = ab
       a11(j,x,k) = ab
   30 continue

*     Load the (beta,beta) inner products.
      do 40 j=1,nelt
       a00(j,x,x) = bb(j)
       a11(j,x,x) = bb(j)
   40 continue
*     ==================================================================
*      Regularization contribution to the mass matrix diagonal.
*     ==================================================================
      if(kreg .eq. 1) then
*     ----------------------------------------------------------
*      Old regularization on the grad of the tangential motion.
*     ----------------------------------------------------------
      do 100 k=1,npde
      c = wpde(k)*segvsc(k)
      do 100 j=1,nelt
       term = (c/l(j,k))*n1(j,k)**2
       a00(j,k,k) = a00(j,k,k) + term
       a11(j,k,k) = a11(j,k,k) + term

       term = (c/l(j,k))*n1(j,k)*n2(j,k)
       a00(j,k,x) = a00(j,k,x) - term
       a00(j,x,k) = a00(j,x,k) - term
       a11(j,k,x) = a11(j,k,x) - term
       a11(j,x,k) = a11(j,x,k) - term

       term = (c/l(j,k))*n2(j,k)**2
       a00(j,x,x) = a00(j,x,x) + term
       a11(j,x,x) = a11(j,x,x) + term
  100 continue

      elseif(kreg .eq. 2) then
*     ----------------------------------------------------
*      New regularization on the grad of x and u motions.
*     ----------------------------------------------------
      do 200 k=1,npde
      c = wpde(k)*segvsc(k)
      do 200 j=1,nelt
       a00(j,k,k) = a00(j,k,k) + (c/l(j,k))
       a11(j,k,k) = a11(j,k,k) + (c/l(j,k))

       a00(j,x,x) = a00(j,x,x) + (c/l(j,k))
       a11(j,x,x) = a11(j,x,x) + (c/l(j,k))
  200 continue
      endif

      return
      end


#include "AMYCAI.h"

MODULE Lateral_1D_Model

    USE TimeCatcher
    USE FloatPrecision
    USE ArraySize
    USE GRIDS
    USE hydro
    USE ReGrid
    USE Parameters
    USE LinearSolver

    IMPLICIT NONE

    CONTAINS

!= = = = = = = = = = = = = = = = = = = = = = = = = =
!
!   Main Routine to calculate the transversal
!   distribution of shear stress and velocity
!
!= = = = = = = = = = = = = = = = = = = = = = = = = =

    SUBROUTINE Cross_Sectional_Tau(TDUD,TDTAU,QQ1,TDEP0,Upsilon,XDistance,WetSegments,FC,MaxTau,MeanTau,Sf,RHOGSD)

        IMPLICIT NONE
        REAL(fp) , ALLOCATABLE , DIMENSION(:,:) ,           INTENT(INOUT) :: TDUD
        REAL(fp) , ALLOCATABLE , DIMENSION(:,:) ,           INTENT(INOUT) :: TDTAU
        REAL(fp) ,               DIMENSION(:)   , POINTER , INTENT(IN)    :: QQ1
        REAL(fp) , ALLOCATABLE , DIMENSION(:,:)           , INTENT(IN)    :: TDEP0
        REAL(fp) , ALLOCATABLE , DIMENSION(:,:) , TARGET  , INTENT(IN)    :: Upsilon
        REAL(fp) , ALLOCATABLE , DIMENSION(:)   ,           INTENT(IN)    :: XDistance
        INTEGER  , ALLOCATABLE , DIMENSION(:)   ,           INTENT(INOUT) :: WetSegments
        REAL(fp) , ALLOCATABLE , DIMENSION(:)   , TARGET  , INTENT(INOUT) :: FC
        REAL(fp) , ALLOCATABLE , DIMENSION(:,:)   ,         INTENT(INOUT) :: MaxTau
        REAL(fp) , ALLOCATABLE , DIMENSION(:,:)   ,         INTENT(INOUT) :: MeanTau
        REAL(fp) , ALLOCATABLE , DIMENSION(:)     ,         INTENT(INOUT) :: Sf
        REAL(fp) , ALLOCATABLE , DIMENSION(:,:)   ,         INTENT(INOUT) :: RHOGSD
        !--------------------------------------------------------------------------------

        INTEGER                                                           :: Re_Multiples
        INTEGER                                                           :: NG
        INTEGER                                                           :: I   , J  , JJ , J1 , J2
        REAL(fp)                                                          :: ReX , XL , XR , Dep1
        INTEGER                                                           :: status
        CHARACTER(len=80)                                                 :: err_msg

!- - - - - - - - - - - - - - - - - - - - - - - - - -
!
!   Calculate the shear stress over each cross-section
!
!- - - - - - - - - - - - - - - - - - - - - - - - - -

        DO I = ML , MU

! - - - - - - - - - - - - - - - - - - - -
! get the wet points of each cross-section
! - - - - - - - - - - - - - - - - - - - -

            !JSTART(I) = NL
            !JEND(I) = NU
            !LPJ9: DO J = (NL+NU)/2 , NU
            !    IF(TDEP0(I,J)<0.D0) THEN
            !        JEND(I)  = J
            !        JSTART(I) = NL + NU - JEND(I)
            !        EXIT LPJ9
            !    END IF
            !END DO LPJ9
            !IF(JSTART(I)>(NU+NL)/2) THEN
            !    PAUSE 'error regrid'
            !END IF
            !WetSegments(I) = -JSTART(I) + JEND(I) - 1

            JSTART(I) = NL
            JEND(I) = NU
            LPJ9: DO J = NU , NL , -1
                IF(TDEP0(I,J)<0.D0) THEN
                    JSTART(I) = J
                    EXIT LPJ9
                END IF
            END DO LPJ9
            WetSegments(I) = -JSTART(I) + JEND(I) - 1

! - - - - - - - - - - - - - - - - - - - -
! IF the WetSegments > 9, directly calculate
! the shear stress
! - - - - - - - - - - - - - - - - - - - -

            IF(WetSegments(I)>=9) THEN

                IF(QQ1(I)/=0.D0) THEN
                    CALL Iterate_Tau(I,NL,NU,DX,QQ1(I),TDEP0(I,:),Upsilon(I,:),TDUD(I,:),TDTAU(I,:),FC(I),Sf(I))
                ELSEIF(QQ1(I)==0.D0) THEN
                    TDUD(I,:)     = 0.D0
                    TDTAU(I,:) = 0.D0
                    FC(I)     = 0.D0
                    Sf(I) = 0.D0
                END IF

! - - - - - - - - - - - - - - - - - - - -
! IF the WetSegments < 9, refine the grid
! - - - - - - - - - - - - - - - - - - - -

            ELSEIF(WetSegments(I)<9.and.WetSegments(I)>0) THEN

! calculate multiple times

                Re_Multiples = 9 / WetSegments(I) + 1

! number of new points

                NG = Re_Multiples * (WetSegments(I) + 1) + 1

! New Grid size

                Re_dx = dx / DBLE(Re_Multiples)

! Calculate TTDepthQ after regrid

                !IF(WetSegments(I)>5) THEN

                    DO J = 1 , NG
                        ReX = XDistance(JSTART(I)) + dble(J-1)*Re_dx
                        LPR1:DO JJ = JSTART(I) , JEND(I)-1
                            XL = XDistance(JJ)
                            XR = XDistance(JJ+1)
                            IF(ReX>=XL.and.ReX<=XR) THEN
                                Re_TTDep(J) = ((ReX-XL)*TDEP0(I,JJ+1)+(XR-ReX)*TDEP0(I,JJ))/dx
                                Re_Upsilon0(J) = ((ReX-XL)*Upsilon(I,JJ+1)+(XR-ReX)*Upsilon(I,JJ))/dx
                                EXIT LPR1
                            END IF
                        END DO LPR1
                    END DO

                !ELSE
                !
                !    Re_Upsilon0(:) = 1.D0
                !    Re_TTDep(:) = TDEP0(I,NU)
                !    Re_TTDep(1) = TDEP0(I,JSTART(I))
                !    Re_TTDep(NG) = TDEP0(I,JEND(I))
                !
                !ENDIF

                IF(QQ1(I)/=0.D0) THEN

                    CALL Iterate_Tau(I,NL,NG,Re_dx,QQ1(I),Re_TTDep,Re_Upsilon0,Re_U0,Re_TAU0,FC(I),Sf(I))

! fit back to coarse grid

                    JJ = JSTART(I) - 1
                    DO J = 1 , NG , Re_Multiples
                        JJ = JJ + 1
                        TDUD(I,JJ) = Re_U0(J)
                        TDTAU(I,JJ) = Re_TAU0(J)
                    END DO

                ELSEIF(QQ1(I)==0.D0) THEN

                    TDUD(I,:)   = 0.D0
                    TDTAU(I,:) = 0.D0
                    FC(I)     = 0.D0
                    Sf(I) = 0.D0

                END IF

            ELSE

                TDUD(I,:)   = 0.D0
                TDTAU(I,:) = 0.D0
                FC(I)     = 0.D0
                Sf(I) = 0.D0

            ENDIF

        END DO

! MaxTau

        DO I = ML , MU
            DO J = NL , NU
                MaxTau(I,J)  = dmax1(MaxTau(I,J),TDTAU(I,J))
                MeanTau(I,J) = MeanTau(I,J) + TDTAU(I,J)
            ENDDO
        ENDDO

!RHOGSD
        DO I = ML , MU
            DO J = NL , NU
                IF(J==NU) THEN
                    J1 = J
                ELSE
                    J1 = J+1
                ENDIF

                IF(J==NL) THEN
                    J2 = J
                ELSE
                    J2 = J-1
                ENDIF

                IF(TDEP0(I,J)>0.D0) THEN
                    Dep1 = TDEP0(I,J)
                ELSE
                    Dep1 = DMAX1(TDEP0(I,J1),TDEP0(I,J2))
                ENDIF

                RHOGSD(I,J) = RHOW*gra*Dep1*DABS(SF(I))

            ENDDO
        ENDDO

END SUBROUTINE Cross_Sectional_Tau

!= = = = = = = = = = = = = = = = = = = = = = = = = =
!
!   Iterate the shear stress over each cross-section
!
!= = = = = = = = = = = = = = = = = = = = = = = = = =

    SUBROUTINE Iterate_Tau(IROW,JLOW,JUP,LX0,TargetQ,TTDep,Upsilon0,U0,TAU0,FC0,SFS)

        IMPLICIT NONE

        INTEGER                                         , INTENT(IN)    :: IROW
        INTEGER                                         , INTENT(IN)    :: JLOW
        INTEGER                                         , INTENT(IN)    :: JUP
        REAL(fp)                                        , INTENT(IN)    :: LX0
        REAL(fp)                                        , INTENT(IN)    :: TargetQ
        REAL(fp)               , DIMENSION(:)           , INTENT(IN)    :: TTDep
        REAL(fp)               , DIMENSION(:)           , INTENT(IN)    :: Upsilon0
        REAL(fp)               , DIMENSION(:)           , INTENT(INOUT) :: U0
        REAL(fp)               , DIMENSION(:)           , INTENT(INOUT) :: TAU0
        REAL(fp)                                        , INTENT(INOUT) :: FC0
        REAL(fp)                                        , INTENT(INOUT) :: SFS
        !-----------------------------------------------------------------------------
        REAL(fp)               , PARAMETER                              :: TOL = 1.D-6
        REAL(fp)                                                        :: ShootQ
        REAL(fp)                                                        :: Dep1 , FF1
        REAL(fp)                                                        :: CC1  , CC2
        INTEGER                                                         :: J,ITE,JC,JJ,J1,J2
        INTEGER                                                         :: status
        CHARACTER(LEN=80)                                               :: err_msg
        REAL(fp) ,  DIMENSION(500) :: LateralDiff
        REAL(fp) ,  DIMENSION(500) :: DWFriction

! IF discharge is zero, all is zero

        IF(TargetQ==0) THEN
            RETURN
        END IF

! Calculate the friction coefficients

        DO J = JLOW , JUP

            IF(J==JUP) THEN
                J1 = J
            ELSE
                J1 = J+1
            ENDIF

            IF(J==JLOW) THEN
                J2 = J
            ELSE
                J2 = J-1
            ENDIF

            IF(TTDep(J)>0.D0) THEN
                Dep1 = TTDep(J)
            ELSE
                Dep1 = DMAX1(TTDep(J1),TTDep(J2))
            ENDIF

            IF(Dep1>0.D0) THEN
#ifdef Shiono_Knight_1988
                !DWFriction(J) = manning**2*gra*DMAX1(TTDep(J),0.1D0)**(-1.D0/3.D0)
                DWFriction(J) = manning**2*gra*Dep1**(-1.D0/3.D0) !* Upsilon0(J)
#else
                DWFriction(J) = manning**2*gra*Dep1**(-1.D0/3.D0)
#endif
            ELSE
                DWFriction(J) = 0.D0
            END IF
        END DO

! Calculate the diffusion term

        DO J = JLOW , JUP-1
            IF(TTDep(J)>0.D0.AND.TTDep(J+1)>0.D0) THEN
                !Dep1 = DMAX1(0.5d0*(TTDep(J)+TTDep(J+1)),0.5D0)
                Dep1 = 0.5d0*(TTDep(J)+TTDep(J+1))
                FF1 = manning**2*gra*Dep1**(-1.D0/3.D0)
                LateralDiff(J) = 0.5D0*Lambda*Dep1**2*SQRT(FF1)
            ELSEIF(TTDep(J)>0.D0.AND.TTDep(J+1)<=0.D0) THEN
                !Dep1 = DMAX1(TTDep(J),0.5D0)
                Dep1 = TTDep(J)
                FF1 = manning**2*gra*Dep1**(-1.D0/3.D0)
                LateralDiff(J) = 0.5D0*Lambda*Dep1**2*SQRT(FF1)
            ELSEIF(TTDep(J+1)>0.D0.AND.TTDep(J)<=0.D0) THEN
                !Dep1 = DMAX1(TTDep(J+1),0.5D0)
                Dep1 = TTDep(J+1)
                FF1 = manning**2*gra*Dep1**(-1.D0/3.D0)
                LateralDiff(J) = 0.5D0*Lambda*Dep1**2*SQRT(FF1)
            ELSE
                LateralDiff(J) = 0.D0
            END IF
        END DO

! initial guess of SFS : Surface slope

        SFS = 0.5D0

!  - - - - - - - - - - - - - - - - - - - - - -
! LPK: the iteration loop
! The upper limit of iteration times is 1000
!- - - - - - - - - - - - - - - - - - - - - - -

        LPK: DO ITE = 1 , 1000

            JC = 0

! - - - - - - - - - - - - - - - - - - - - - - - -
! LPJ: the loop calculate the transversal distribution
!      of the shear stress AND the velocity
! - - - - - - - - - - - - - - - - - - - - - - - -

            LPJ:DO J = JLOW , JUP

                JC = JC + 1

                IF(J==JUP) THEN
                    J1 = J
                ELSE
                    J1 = J+1
                ENDIF

                IF(J==JLOW) THEN
                    J2 = J
                ELSE
                    J2 = J-1
                ENDIF

! Dry point

                IF(TTDep(J)<=0.AND.TTDep(J1)<=0.AND.TTDep(J2)<=0) THEN
                    AMT(1,JC) = 0.D0
                    AMT(2,JC) = 1.D0
                    AMT(3,JC) = 0.D0
                    AMT(4,JC) = 0.D0
                    cycle LPJ
                END IF

! DEPTH

                IF(TTDep(J)>0.D0) THEN
                    Dep1 = TTDep(J)
                ELSE
                    Dep1 = DMAX1(TTDep(J1),TTDep(J2))
                ENDIF

! Left Edge (Intertidal side)

                IF(J==JLOW) THEN
                    CC2 = 1.D0/LX0**2*LateralDiff(J)
                    AMT(1,JC) = 0.D0
                    AMT(2,JC) = DWFriction(J) + 2.D0*CC2
                    AMT(3,JC) = - 2.D0*CC2
                    AMT(4,JC) = gra*Dep1*DABS(SFS)
                    cycle LPJ
                END IF

! Right Edge (Intertidal side)

                IF(J==JUP) THEN
                    CC1 = 1.D0/LX0**2*LateralDiff(J-1)
                    AMT(1,JC) = - 2.D0*CC1
                    AMT(2,JC) = DWFriction(J) + 2.D0*CC1
                    AMT(3,JC) = 0.D0
                    AMT(4,JC) = gra*Dep1*DABS(SFS)
                    cycle LPJ
                END IF

! General case

                CC1 = 1.D0/LX0**2*LateralDiff(J-1) ! DIFFUSION TERMS
                CC2 = 1.D0/LX0**2*LateralDiff(J)

                IF(CC1==0.D0.AND.CC2>0.D0) THEN ! Left dry

                    AMT(1,JC) = 0.D0
                    AMT(2,JC) = DWFriction(J) + 2.D0*CC2
                    AMT(3,JC) = - 2.D0*CC2
                    AMT(4,JC) = gra*Dep1*DABS(SFS)

                ELSEIF(CC1>0.D0.AND.CC2==0.D0) THEN ! Right dry

                    AMT(1,JC) = - 2.D0*CC1
                    AMT(2,JC) = DWFriction(J) + 2.D0*CC1
                    AMT(3,JC) = 0.D0
                    AMT(4,JC) = gra*Dep1*DABS(SFS)

                ELSE ! All wet

                    AMT(1,JC) = - CC1
                    AMT(2,JC) = DWFriction(J) + CC1 + CC2
                    AMT(3,JC) = - CC2
                    AMT(4,JC) = gra*Dep1*DABS(SFS)

                END IF

            END DO LPJ

            !IF(IROW==1.and.cd==1021162) then
            !OPEN(111,file='AMT1.txt')
            !DO J = 1 , JC
            !    WRITE(111,'(50e25.15)') (AMT(JJ,J),JJ=1,4),DWFriction(J)
            !END DO
            !CLOSE(111)
            !END IF

            CALL solve3_LU(JC)

            !IF(IROW==1.and.cd==1021162) then
            !OPEN(111,file='AMT2.txt')
            !DO J = 1 , JC
            !    WRITE(111,'(50e25.15)') (AMT(JJ,J),JJ=1,4)
            !END DO
            !CLOSE(111)
            !pause 'AMT6'
            !END IF

! get the velocity

            DO J = JLOW , JUP
                U0(J) = SQRT(AMT(4,J))
                IF(TargetQ<0.D0) U0(J) = - U0(J)
            END DO

! estimate the discharge

            ShootQ = 0.D0
            DO J = JLOW , JUP-1
                ShootQ = ShootQ + 0.25D0*(U0(J)+U0(J+1))*(dmax1(0.D0,TTDep(J+1))+dmax1(0.D0,TTDep(J)))*LX0
            END DO

! compare with the actual discharge

            IF(DABS(ShootQ-TargetQ) <= TOL) THEN

                DO J = 1 , JC
                    TAU0(J) = DWFriction(J)*U0(J)**2*RHOW !/ Upsilon0(J)
                END DO

! calculate FC
! Coupling the lateral 1d model with the longitudinal model.
! I.e., modify the friction coefficient of the longitudinal
! 1d model to match the intergral bed resistance calculated
! by 1d lateral model.

                !FC0 = 0.D0
                !
                !DO J = JLOW , JUP-1 , 1
                !    IF(DWFriction(J)>0.D0.OR.DWFriction(J+1)>0.D0) THEN
                !        FC0 = FC0 &
                !                & + 0.5D0 * (&
                !                &   DWFriction(J)*U0(J)**2 &
                !                & + DWFriction(J+1)*U0(J+1)**2 &
                !                & ) * LX0
                !    END IF
                !END DO
                !FC0 = FC0 / DABS(TargetQ)

                RETURN

            END IF

            SFS = SFS*(TargetQ/ShootQ)**2 ! modify the energy slope

        END DO LPK

! error message

        IF(ITE == 1001) THEN
            WRITE(*,*) IROW , CD
            PAUSE 'error1'
        END IF

    END SUBROUTINE Iterate_Tau

END MODULE Lateral_1D_Model


      SUBROUTINE vpassm(a, b, c, d, trigs, inc1, inc2, inc3, inc4, lot,
     1   n, ifac, la)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: SIN36=0.587785252292473_dp
      REAL(rprec), PARAMETER :: COS36=0.809016994374947_dp
      REAL(rprec), PARAMETER :: SIN72=0.951056516295154_dp
      REAL(rprec), PARAMETER :: COS72=0.309016994374947_dp
      REAL(rprec), PARAMETER :: SIN60=0.866025403784437_dp
      REAL(rprec), PARAMETER :: p5 = 0.5_dp
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER inc1, inc2, inc3, inc4, lot, n, ifac, la
      REAL(rprec), DIMENSION(*) :: a, b, c, d
      REAL(rprec), DIMENSION(*) :: trigs
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: m, iink, jink, jump, ibase, jbase, igo, ia, ja, ib, jb
     1   , l, i, j, ijk, la1, k, kb, ic, jc, kc, id, jd, kd, ie, je, ke
      REAL(rprec) :: c1,s1,c2,s2,c3,s3,c4,s4
C-----------------------------------------------
c
c     SUBROUTINE 'vpassm' - multiple version of 'vpassa'
c     performs one pass through data
c     as part of multiple complex (inverse) fft routine
c     a is first real input vector
c     b is first imaginary input vector
c     c is first real output vector
c     d is first imaginary output vector
c     trigs is precalculated table of sines & cosines
c     inc1 is addressing increment for a and b
c     inc2 is addressing increment for c and d
c     inc3 is addressing increment between a's & b's
c     inc4 is addressing increment between c's & d's
c     lot is the number of vectors
c     n is length of vectors
c     ifac is current factor of n
c     la is product of previous factors
c
c
      m=n/ifac
      iink=m*inc1
      jink=la*inc2
      jump=(ifac-1)*jink
      ibase=0
      jbase=0
      igo=ifac-1
      IF (igo .gt. 4) RETURN
      GOTO (10,50,90,130),igo
c
c     coding for factor 2
c
   10 ia=1
      ja=1
      ib=ia+iink
      jb=ja+jink
      DO 20 l=1,la
      i=ibase
      j=jbase
cdir$ ivdep
      DO 15 ijk=1,lot
      c(ja+j)=a(ia+i)+a(ib+i)
      d(ja+j)=b(ia+i)+b(ib+i)
      c(jb+j)=a(ia+i)-a(ib+i)
      d(jb+j)=b(ia+i)-b(ib+i)
      i=i+inc3
      j=j+inc4
   15 CONTINUE
      ibase=ibase+inc1
      jbase=jbase+inc2
   20 CONTINUE
      IF (la.eq.m) RETURN
      la1=la+1
      jbase=jbase+jump
      DO 40 k=la1,m,la
      kb=k+k-2
      c1=trigs(kb+1)
      s1=trigs(kb+2)
      DO 30 l=1,la
      i=ibase
      j=jbase
cdir$ ivdep
      DO 25 ijk=1,lot
      c(ja+j)=a(ia+i)+a(ib+i)
      d(ja+j)=b(ia+i)+b(ib+i)
      c(jb+j)=c1*(a(ia+i)-a(ib+i))-s1*(b(ia+i)-b(ib+i))
      d(jb+j)=s1*(a(ia+i)-a(ib+i))+c1*(b(ia+i)-b(ib+i))
      i=i+inc3
      j=j+inc4
   25 CONTINUE
      ibase=ibase+inc1
      jbase=jbase+inc2
   30 CONTINUE
      jbase=jbase+jump
   40 CONTINUE
      RETURN
c
c     coding for factor 3
c
   50 ia=1
      ja=1
      ib=ia+iink
      jb=ja+jink
      ic=ib+iink
      jc=jb+jink
      DO 60 l=1,la
      i=ibase
      j=jbase
cdir$ ivdep
      DO 55 ijk=1,lot
      c(ja+j)=a(ia+i)+(a(ib+i)+a(ic+i))
      d(ja+j)=b(ia+i)+(b(ib+i)+b(ic+i))
      c(jb+j)=(a(ia+i)-p5*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)-b(ic+i)))
      c(jc+j)=(a(ia+i)-p5*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)-b(ic+i)))
      d(jb+j)=(b(ia+i)-p5*(b(ib+i)+b(ic+i)))+(sin60*(a(ib+i)-a(ic+i)))
      d(jc+j)=(b(ia+i)-p5*(b(ib+i)+b(ic+i)))-(sin60*(a(ib+i)-a(ic+i)))
      i=i+inc3
      j=j+inc4
   55 CONTINUE
      ibase=ibase+inc1
      jbase=jbase+inc2
   60 CONTINUE
      IF (la.eq.m) RETURN
      la1=la+1
      jbase=jbase+jump
      DO 80 k=la1,m,la
      kb=k+k-2
      kc=kb+kb
      c1=trigs(kb+1)
      s1=trigs(kb+2)
      c2=trigs(kc+1)
      s2=trigs(kc+2)
      DO 70 l=1,la
      i=ibase
      j=jbase
cdir$ ivdep
      DO 65 ijk=1,lot
      c(ja+j)=a(ia+i)+(a(ib+i)+a(ic+i))
      d(ja+j)=b(ia+i)+(b(ib+i)+b(ic+i))
      c(jb+j)=
     *    c1*((a(ia+i)-p5*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)-b(ic+i))))
     *   -s1*((b(ia+i)-p5*(b(ib+i)+b(ic+i)))+(sin60*(a(ib+i)-a(ic+i))))
      d(jb+j)=
     *    s1*((a(ia+i)-p5*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)-b(ic+i))))
     *   +c1*((b(ia+i)-p5*(b(ib+i)+b(ic+i)))+(sin60*(a(ib+i)-a(ic+i))))
      c(jc+j)=
     *    c2*((a(ia+i)-p5*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)-b(ic+i))))
     *   -s2*((b(ia+i)-p5*(b(ib+i)+b(ic+i)))-(sin60*(a(ib+i)-a(ic+i))))
      d(jc+j)=
     *    s2*((a(ia+i)-p5*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)-b(ic+i))))
     *   +c2*((b(ia+i)-p5*(b(ib+i)+b(ic+i)))-(sin60*(a(ib+i)-a(ic+i))))
      i=i+inc3
      j=j+inc4
   65 CONTINUE
      ibase=ibase+inc1
      jbase=jbase+inc2
   70 CONTINUE
      jbase=jbase+jump
   80 CONTINUE
      RETURN
c
c     coding for factor 4
c
   90 ia=1
      ja=1
      ib=ia+iink
      jb=ja+jink
      ic=ib+iink
      jc=jb+jink
      id=ic+iink
      jd=jc+jink
      DO 100 l=1,la
      i=ibase
      j=jbase
cdir$ ivdep
      DO 95 ijk=1,lot
      c(ja+j)=(a(ia+i)+a(ic+i))+(a(ib+i)+a(id+i))
      c(jc+j)=(a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i))
      d(ja+j)=(b(ia+i)+b(ic+i))+(b(ib+i)+b(id+i))
      d(jc+j)=(b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i))
      c(jb+j)=(a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i))
      c(jd+j)=(a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i))
      d(jb+j)=(b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i))
      d(jd+j)=(b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i))
      i=i+inc3
      j=j+inc4
   95 CONTINUE
      ibase=ibase+inc1
      jbase=jbase+inc2
  100 CONTINUE
      IF (la.eq.m) RETURN
      la1=la+1
      jbase=jbase+jump
      DO 120 k=la1,m,la
      kb=k+k-2
      kc=kb+kb
      kd=kc+kb
      c1=trigs(kb+1)
      s1=trigs(kb+2)
      c2=trigs(kc+1)
      s2=trigs(kc+2)
      c3=trigs(kd+1)
      s3=trigs(kd+2)
      DO 110 l=1,la
      i=ibase
      j=jbase
cdir$ ivdep
      DO 105 ijk=1,lot
      c(ja+j)=(a(ia+i)+a(ic+i))+(a(ib+i)+a(id+i))
      d(ja+j)=(b(ia+i)+b(ic+i))+(b(ib+i)+b(id+i))
      c(jc+j)=
     *    c2*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i)))
     *   -s2*((b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i)))
      d(jc+j)=
     *    s2*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i)))
     *   +c2*((b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i)))
      c(jb+j)=
     *    c1*((a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i)))
     *   -s1*((b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i)))
      d(jb+j)=
     *    s1*((a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i)))
     *   +c1*((b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i)))
      c(jd+j)=
     *    c3*((a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i)))
     *   -s3*((b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i)))
      d(jd+j)=
     *    s3*((a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i)))
     *   +c3*((b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i)))
      i=i+inc3
      j=j+inc4
  105 CONTINUE
      ibase=ibase+inc1
      jbase=jbase+inc2
  110 CONTINUE
      jbase=jbase+jump
  120 CONTINUE
      RETURN
c
c     coding for factor 5
c
  130 ia=1
      ja=1
      ib=ia+iink
      jb=ja+jink
      ic=ib+iink
      jc=jb+jink
      id=ic+iink
      jd=jc+jink
      ie=id+iink
      je=jd+jink
      DO 140 l=1,la
      i=ibase
      j=jbase
cdir$ ivdep
      DO 135 ijk=1,lot
      c(ja+j)=a(ia+i)+(a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i))
      d(ja+j)=b(ia+i)+(b(ib+i)+b(ie+i))+(b(ic+i)+b(id+i))
      c(jb+j)=(a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i)))
     *  -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i)))
      c(je+j)=(a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i)))
     *  +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i)))
      d(jb+j)=(b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i)))
     *  +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i)))
      d(je+j)=(b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i)))
     *  -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i)))
      c(jc+j)=(a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i)))
     *  -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i)))
      c(jd+j)=(a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i)))
     *  +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i)))
      d(jc+j)=(b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i)))
     *  +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i)))
      d(jd+j)=(b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i)))
     *  -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i)))
      i=i+inc3
      j=j+inc4
  135 CONTINUE
      ibase=ibase+inc1
      jbase=jbase+inc2
  140 CONTINUE
      IF (la.eq.m) RETURN
      la1=la+1
      jbase=jbase+jump
      DO 160 k=la1,m,la
      kb=k+k-2
      kc=kb+kb
      kd=kc+kb
      ke=kd+kb
      c1=trigs(kb+1)
      s1=trigs(kb+2)
      c2=trigs(kc+1)
      s2=trigs(kc+2)
      c3=trigs(kd+1)
      s3=trigs(kd+2)
      c4=trigs(ke+1)
      s4=trigs(ke+2)
      DO 150 l=1,la
      i=ibase
      j=jbase
cdir$ ivdep
      DO 145 ijk=1,lot
      c(ja+j)=a(ia+i)+(a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i))
      d(ja+j)=b(ia+i)+(b(ib+i)+b(ie+i))+(b(ic+i)+b(id+i))
      c(jb+j)=
     *    c1*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i)))
     *      -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))
     *   -s1*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i)))
     *      +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
      d(jb+j)=
     *    s1*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i)))
     *      -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))
     *   +c1*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i)))
     *      +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
      c(je+j)=
     *    c4*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i)))
     *      +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))
     *   -s4*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i)))
     *      -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
      d(je+j)=
     *    s4*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i)))
     *      +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))
     *   +c4*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i)))
     *      -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
      c(jc+j)=
     *    c2*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i)))
     *      -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))
     *   -s2*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i)))
     *      +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
      d(jc+j)=
     *    s2*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i)))
     *      -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))
     *   +c2*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i)))
     *      +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
      c(jd+j)=
     *    c3*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i)))
     *      +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))
     *   -s3*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i)))
     *      -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
      d(jd+j)=
     *    s3*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i)))
     *      +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))
     *   +c3*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i)))
     *      -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
      i=i+inc3
      j=j+inc4
  145 CONTINUE
      ibase=ibase+inc1
      jbase=jbase+inc2
  150 CONTINUE
      jbase=jbase+jump
  160 CONTINUE

      END SUBROUTINE vpassm


! use tregn96 from cps to calculate the dcdL and dcdA
subroutine depthkernelTI(nx, ny, nz, vel, pvRc, iwave, igr, kmaxRc, tRc, depz, minthk, Lsen_Gsc)
    use omp_lib
    implicit none

    integer nx, ny, nz
    real vel(nx, ny, nz)
    integer iwave,igr
    real minthk
    real depz(nz)
    integer kmaxRc
    real*8 tRc(kmaxRc)
    ! output
    real*8 pvRc(nx*ny, kmaxRc)
    ! parameter list
    real vpz(nz),vsz(nz),rhoz(nz)
    integer mmax,iflsph,mode,rmax
    integer ii,jj,k,i,j,jjj
    integer, parameter:: NL=200
    integer, parameter:: NP=60

    real*8 cgRc(NP)
    real rdep(NL),rvp(NL),rvs(NL),rrho(NL),rthk(NL)
    ! for tregn96
    real t_in(kmaxRc), cp_in(kmaxRc)
    real TA_in(NL), TC_in(NL), TF_in(NL)
    real TL_in(NL), TN_in(NL), TRho_in(NL)
    real qp(NL), qs(NL), etap(NL)
    real etas(NL), frefp(NL), frefs(NL)

    real*4 dcdah(NP,NL),dcdn(NP,NL)
    real*4 dcdbv(NP,NL)
    real*4 dcR_dL, dcR_dA
    real*4 Lsen_Gsc(nx*ny, kmaxRc, nz-1)
    integer nsublay(NL), post

    mmax=nz
    iflsph=1
    mode=1
    pvRc=0.0
    Lsen_Gsc=0.0
    ! write(6, *) ' depth kernel parallel:'
    !$omp parallel &
    !$omp default(private) &
    !$omp shared(nx,ny,nz,vel,minthk,mmax,depz,kmaxRc) &
    !$omp shared(tRc,pvRc,iflsph,iwave,mode,igr,Lsen_Gsc)
    !$omp do
    do jj=1,ny
        do ii=1,nx
            post=ii+(jj-1)*nx
            vsz(1:nz)=vel(ii,jj,1:nz)
            ! some other emperical relationship maybe better,
            do k=1,nz
                vpz(k)=0.9409 + 2.0947*vsz(k) - 0.8206*vsz(k)**2+ &
                0.2683*vsz(k)**3 - 0.0251*vsz(k)**4
                rhoz(k)=1.6612*vpz(k) - 0.4721*vpz(k)**2 + &
                0.0671*vpz(k)**3 - 0.0043*vpz(k)**4 + &
                0.000106*vpz(k)**5
            enddo
            ! change from refineGrid2LayerMdl into refineLayerMdl
            ! call refineGrid2LayerMdl(minthk, mmax, depz, vpz, vsz, rhoz, rmax, rdep, &
            ! rvp, rvs, rrho, rthk)
            call refineLayerMdl(minthk, mmax, depz, vpz, vsz, rhoz, rmax, rdep, &
            rvp, rvs, rrho, rthk, nsublay)

            call surfdisp96(rthk, rvp, rvs, rrho, rmax, iflsph, iwave, mode, igr, kmaxRc, &
            tRc, cgRc)
            pvRc(ii+(jj-1)*nx,1:kmaxRc)=cgRc(1:kmaxRc)
            !print*,cgRc(1:kmaxRc)
            !------------------------------------------------------------------!
            do i = 1, rmax
                TA_in(i)=rrho(i)*rvp(i)**2
                TC_in(i)=TA_in(i)
                TL_in(i)=rrho(i)*rvs(i)**2
                TN_in(i)=TL_in(i)
                TF_in(i)=1.0*(TA_in(i) - 2 * TL_in(i))
                TRho_in(i)=rrho(i)
            enddo
            qp(1:rmax)=150.0
            qs(1:rmax)=50.0
            etap(1:rmax)=0.00
            etas(1:rmax)=0.00
            frefp(1:rmax)=1.00
            frefs(1:rmax)=1.00

            cp_in(1:kmaxRc)=sngl(cgRc(1:kmaxRc))
            t_in(1:kmaxRc)=sngl(tRc(1:kmaxRc))

            ! ! write(6, *)'tregn96'
            call tregn96(rmax, rthk, TA_in, TC_in, TF_in, TL_in, TN_in, TRho_in, &
            qp, qs, etap, etas, frefp, frefs,  &
            kmaxRc, t_in, cp_in(1:kmaxRc),&
            dcdah, dcdbv, dcdn)
            !
            ! ! write(*,*)"nsublay:", nsublay(1:nz)
            do i=1,kmaxRc  ! period
                k=0
                do j=1,nz-1                ! inversion layer
                    do jjj=1,nsublay(j)    ! refined layer k-th in jth inversion layer
                        k=k+1
                        dcR_dA = 0.5/(rrho(k)*rvp(k))*dcdah(i, k) - TF_in(k)/((TA_in(k)-2.0*TL_in(k))**2)*dcdn(i,k)
                        dcR_dL = 0.5/(rrho(k)*rvs(k))*dcdbv(i, k) + 2.0*TF_in(k)/((TA_in(k)-2.0*TL_in(k))**2)*dcdn(i,k)
                        Lsen_Gsc(post,i,j)=Lsen_Gsc(post,i,j)+dcR_dA*TA_in(k)+dcR_dL*TL_in(k)
                    enddo
                enddo
            enddo

        enddo
    enddo
    !$omp end do
    !$omp end parallel
end subroutine

! do i=1, kmaxRc
! 	do j=1, rmax
! 		dcR_dA(i, j)= 0.5/(rrho(j)*rvp(j))*dcdah(i, j) - TF_in(j)/((TA_in(j)-2.0*TL_in(j))**2)*dcdn(i,j)
! 		dcR_dL(i, j)= 0.5/(rrho(j)*rvs(j))*dcdbv(i, j) + 2.0*TF_in(j)/((TA_in(j)-2.0*TL_in(j))**2)*dcdn(i,j)
! 	enddo
! enddo


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 2015 Adrian Martinez Vargas                            %
!                                                                      %
! This software may be modified and distributed under the terms        %
! of the MIT license.  See the LICENSE.txt file for details.           %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
! Junior University.  All rights reserved.                             %
!                                                                      %
! The programs in GSLIB are distributed in the hope that they will be  %
! useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
! responsibility to anyone for the consequences of using them or for   %
! whether they serve any particular purpose or work at all, unless he  %
! says so in writing.  Everyone is granted permission to copy, modify  %
! and redistribute the programs in GSLIB, but only under the condition %
! that this notice and the above copyright notice remain intact.       %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!-----------------------------------------------------------------------
!
! The functions and subroutines below were modified from the
! version 2.0 of the gslib code written in fortran 77
!
! The objective is to add functionality to GSLIB and to link
! this code with python using f2py. It uses f90 code convention.
! The arrays are dynamic and externally declared (from python)
!
! the code was converted from Fortran 77 to Fortran 90 using F2F.pl
!
! for more information please refer to:
! - gslib77 source code: http://www.statios.com/software/gslib77_ls.tar.gz
! - GSLIB: Geostatistical Software Library and User's Guide. Second edition
!   by Clayton V. Deutsch, Andre G. Journel, 1997.
! - F2PY Users Guide: http://docs.scipy.org/doc/numpy-dev/f2py/
! - F2F https://bitbucket.org/lemonlab/f2f
!-----------------------------------------------------------------------

real*8 function sqdist(x1,y1,z1,x2,y2,z2,ind,maxrot,rotmat)
    !-----------------------------------------------------------------------
    !
    !    Squared Anisotropic Distance Calculation Given Matrix Indicator
    !    ***************************************************************
    !
    ! This routine calculates the anisotropic distance between two points
    !  given the coordinates of each point and a definition of the
    !  anisotropy.
    !
    !
    ! INPUT VARIABLES:
    !
    !   x1,y1,z1         Coordinates of first point
    !   x2,y2,z2         Coordinates of second point
    !   ind              The rotation matrix to use
    !   maxrot           The maximum number of rotation matrices dimensioned
    !   rotmat           The rotation matrices
    !
    !
    !
    ! OUTPUT VARIABLES:
    !
    !   sqdis           The squared distance accounting for the anisotropy
    !                      and the rotation of coordinates (if any).
    !
    !
    ! NO EXTERNAL REFERENCES
    !
    !
    !-----------------------------------------------------------------------

    implicit none

    ! input
    integer, intent(in) ::  maxrot, ind
    real, intent(in):: x1,y1,z1,x2,y2,z2
    real*8, intent(in), dimension(maxrot,3,3) ::  rotmat

    ! output
    ! real*8 :: sqdis

    ! Internal
    real*8 :: cont,dx,dy,dz
    integer  :: i

    !
    ! Compute component distance vectors and the squared distance:
    !
      dx = dble(x1 - x2)
      dy = dble(y1 - y2)
      dz = dble(z1 - z2)
      sqdist = 0.0
      do i=1,3
            cont   = rotmat(ind,i,1) * dx &
                   + rotmat(ind,i,2) * dy &
                   + rotmat(ind,i,3) * dz
            sqdist = sqdist + cont * cont
      end do
    return
end function sqdist

real*8 function dsqdist(x1,y1,z1,x2,y2,z2,ind,maxrot,rotmat)
    !-----------------------------------------------------------------------
    !
    !    Squared Anisotropic Distance Calculation Given Matrix Indicator
    !    ***************************************************************
    !
    ! This routine calculates the anisotropic distance between two points
    !  given the coordinates of each point and a definition of the
    !  anisotropy.
    !
    !
    ! INPUT VARIABLES:
    !
    !   x1,y1,z1         Coordinates of first point
    !   x2,y2,z2         Coordinates of second point
    !   ind              The rotation matrix to use
    !   maxrot           The maximum number of rotation matrices dimensioned
    !   rotmat           The rotation matrices
    !
    !
    !
    ! OUTPUT VARIABLES:
    !
    !   sqdis           The squared distance accounting for the anisotropy
    !                      and the rotation of coordinates (if any).
    !
    !
    ! NO EXTERNAL REFERENCES
    !
    !
    !-----------------------------------------------------------------------

    implicit none

    ! input
    integer, intent(in) ::  maxrot, ind
    real*8, intent(in):: x1,y1,z1,x2,y2,z2
    real*8, intent(in), dimension(maxrot,3,3) ::  rotmat

    ! output
    ! real*8 :: sqdis

    ! Internal
    real*8 :: cont,dx,dy,dz
    integer  :: i

    !
    ! Compute component distance vectors and the squared distance:
    !
      dx = x1 - x2
      dy = y1 - y2
      dz = z1 - z2
      dsqdist = 0.0
      do i=1,3
            cont   = rotmat(ind,i,1) * dx &
                   + rotmat(ind,i,2) * dy &
                   + rotmat(ind,i,3) * dz
            dsqdist = dsqdist + cont * cont
      end do
    return
end function dsqdist


        subroutine idd_sffti2(l,ind,n,wsave)
c
c       routine idd_sffti serves as a wrapper around
c       the present routine; please see routine idd_sffti
c       for documentation.
c
        implicit none
        integer l,ind(l),n,nblock,ii,m,idivm,imodm,i,j,k
        real*8 r1,twopi,fact
        complex*16 wsave(2*l+15+4*n),ci,twopii
c
        ci = (0,1)
        r1 = 1
        twopi = 2*4*atan(r1)
        twopii = twopi*ci
c
c
c       Determine the block lengths for the FFTs.
c
        call idd_ldiv(l,n,nblock)
        m = n/nblock
c
c
c       Initialize wsave for using routine dfftf.
c
        call dffti(nblock,wsave)
c
c
c       Calculate the coefficients in the linear combinations
c       needed for the direct portion of the calculation.
c
        fact = 1/sqrt(r1*n)
c
        ii = 2*l+15
c
        do j = 1,l
c
c
          i = ind(j)
c
c
          if(i .le. n/2-m/2) then
c
            idivm = (i-1)/m
            imodm = (i-1)-m*idivm
c
            do k = 1,m
              wsave(ii+m*(j-1)+k) = exp(-twopii*(k-1)*imodm/(r1*m))
     1         * exp(-twopii*(k-1)*(idivm+1)/(r1*n)) * fact
            enddo ! k
c
          endif ! i .le. n/2-m/2
c
c
          if(i .gt. n/2-m/2) then
c
            idivm = i/(m/2)
            imodm = i-(m/2)*idivm
c
            do k = 1,m
              wsave(ii+m*(j-1)+k) = exp(-twopii*(k-1)*imodm/(r1*m))
     1                            * fact
            enddo ! k
c
          endif ! i .gt. n/2-m/2
c
c
        enddo ! j
c
c
        return
        end
c
c
c
c
        subroutine idd_sfft(l,ind,n,wsave,v)
c
c       computes a subset of the entries of the DFT of v,
c       composed with permutation matrices both on input and on output,
c       via a two-stage procedure (debugging code routine dfftf2 above
c       is supposed to calculate the full vector from which idd_sfft
c       returns a subset of the entries, when dfftf2 has
c       the same parameter nblock as in the present routine).
c
c       input:
c       l -- number of pairs of entries in the output to compute
c       ind -- indices of the pairs of entries in the output
c              to compute; the indices must be chosen
c              in the range from 1 to n/2
c       n -- length of v; n must be a positive integer power of 2
c       v -- vector to be transformed
c       wsave -- processing array initialized by routine idd_sffti
c
c       output:
c       v -- pairs of entries indexed by ind are given
c            their appropriately transformed values
c
c       _N.B._: n must be a positive integer power of 2.
c
c       references:
c       Sorensen and Burrus, "Efficient computation of the DFT with
c            only a subset of input or output points,"
c            IEEE Transactions on Signal Processing, 41 (3): 1184-1200,
c            1993.
c       Woolfe, Liberty, Rokhlin, Tygert, "A fast randomized algorithm
c            for the approximation of matrices," Applied and
c            Computational Harmonic Analysis, 25 (3): 335-366, 2008;
c            Section 3.3.
c
        implicit none
        integer l,ind(l),n
        real*8 v(n)
        complex*16 wsave(2*l+15+4*n)
c
c
        if(l .eq. 1) call idd_sfft1(ind,n,v,wsave)
        if(l .gt. 1) call idd_sfft2(l,ind,n,v,wsave)
c
c
        return
        end
c
c
c
c


       program xdenc

c*********************************************************************
c
c     dl_poly program to calculate planar densities of all atom types
c     in a given direction from a dl_poly CONFIG file
c
c     copyright daresbury laboratory 1996
c     author  w.smith oct 1996
c
c*********************************************************************

      implicit real*8(a-h,o-z)

      parameter (ndiv=500,ntyp=4)
      character*40 fname
      character*80 title
      character*8 atname,atmnam(ntyp)
      dimension cell(9),xden(ndiv,ntyp)

c     open the I/O files

      open(5,file='xden_input')
      open(6,file='xden_output')

      write(6,'(a)')'# X-density Program'

c     name of selected CONFIG file
      read(5,*)fname

c     total number of atoms in a CONFIG file configuration
      read(5,*)natms

c     bin width for X density histogram
      read(5,*)delx

c     projection vector
      read(5,*)xx0,yy0,zz0
      rrr=sqrt(xx0**2+yy0**2+zz0**2)
      xx0=xx0/rrr
      yy0=yy0/rrr
      zz0=zz0/rrr

c     check on specified control variables

      write(6,'(a,a40)')'# name of target CONFIG file   : ',fname
      write(6,'(a,i8)')'# total no. of atoms in config  : ',natms
      write(6,'(a,1p,e12.4)')'# x-density histogram bin width : ',delx
      write(6,'(a,1p,3e12.4)')'# normalised projection vector  : ',
     x    xx0,yy0,zz0

c     open CONFIG file

      open(7,file=fname)

      read(7,'(a80)')title
      write(6,'(a10,a80)')'# Header: ',title
      read(7,*)levcfg,imcon

      if(imcon.gt.0)then

        read(7,*)cell(1),cell(2),cell(3)
        read(7,*)cell(4),cell(5),cell(6)
        read(7,*)cell(7),cell(8),cell(9)

        write(6,'(a)')     '# cell vectors:'
        write(6,'(a,3f12.6)')'# vector A :',cell(1),cell(2),cell(3)
        write(6,'(a,3f12.6)')'# vector B :',cell(4),cell(5),cell(6)
        write(6,'(a,3f12.6)')'# vector C :',cell(7),cell(8),cell(9)

      endif

c     initialise x-density array

      do j=1,ntyp
        do i=1,ndiv

          xden(i,j)=0.d0

        enddo
      enddo

c     read configuration

      ityp=0
      nmin=ndiv/2
      nmax=ndiv/2

      do i=1,natms

        read(7,'(a8)')atname

        read(7,*)xxx,yyy,zzz
        if(levcfg.gt.0)read(7,*)uuu,vvv,www
        if(levcfg.gt.1)read(7,*)uuu,vvv,www

        ktyp=0
        do jtyp=1,ityp

          if(atname.eq.atmnam(jtyp))ktyp=jtyp

        enddo
        if(ktyp.eq.0.and.ityp.lt.ntyp)then

          ityp=ityp+1
          atmnam(ityp)=atname
          ktyp=ityp

        endif

        if(ktyp.le.ntyp)then

          rrr=xxx*xx0+yyy*yy0+zzz*zz0
          ix=nint(rrr/delx)+ndiv/2
          if(ix.gt.0.and.ix.le.ndiv)then

            xden(ix,ktyp)=xden(ix,ktyp)+1.d0
            nmin=min(nmin,ix)
            nmax=max(nmax,ix)

          endif

        endif

      enddo

c     print out final histogram

      do i=nmin,nmax

        xxx=delx*dble(i-ndiv/2)
        write(6,'(1p,5e12.4)')xxx,(xden(i,j),j=1,ityp)

      enddo

      stop

      end


module hammett

interface Zfun
    module procedure Zfun_zd
    module procedure Zfun_rd
end interface

contains

complex function Zfun_zd(zeta)

  use constants
  use z_erf

  implicit none

  complex(kind=dbl), intent(in) :: zeta
  logical :: flag
  real(kind=dbl), parameter :: sqrt_pi = 1.772453850905516
  complex(kind=dbl) :: y

  call wofz_f90(zeta, y, flag)

  if(flag)then
    write(*,*) 'CRAP: wofz_f90 failed'
    stop
  endif

  Zfun_zd = sqrt_pi*zi*y

end function Zfun_zd

complex function Zfun_rd(zeta)

  use constants
  use z_erf

  implicit none

  real(kind=dbl), intent(in) :: zeta
  logical :: flag
  real(kind=dbl), parameter :: sqrt_pi = 1.772453850905516
  complex(kind=dbl) :: y

  call wofz_f90(cmplx(zeta,0,dbl),y, flag)

  if(flag)then
    write(*,*) 'CRAP: wofz_f90 failed'
    stop
  endif

  Zfun_rd = sqrt_pi*zi*y

end function Zfun_rd

end module hammett


!!## MODULE SUBROUTINE: FlagDuplicateVectors
MODULE SUB_FlagDuplicateVectors
!!### PURPOSE
!! Flag duplicates in a list of vectors by setting
!! the duplicates to the error number, and optionally
!! returning a mask that is true only for the unique vectors.

!!### USAGE
!
!     CALL FlagDuplicateVectors( VECS [,tol] [,reltol] [,unique])
!
!! where <VECS> is a list of vectors <VECS(1:Nd,:)>, where <Nd>
!! is the number of dimensions and <tol>, <reltol> are the
!! tolerances and relative tolerances of the comparison
!! for duplicate status, respectively.
!!
!! The vectors that are duplicates will be changed to the
!! error number, and have a value of <.FALSE.> in the <unique> mask.
!!
!! If you provide a mask, then getting a list
!! of unique vectors is easy.
!
!     Nd = SIZE(VECS,1)
!     Nv = COUNT(unique)
!     ALLOCATE( unique_VECS(Nd,Nv) )
!
!     unique_VECS = PACKvectors( VECS , unique )
!
!! If you don't provide a <unique> mask then pick one dimension to get
!! the <IsError> mask and do it this way:
!
!    DO i=1,Nd
!     unique_VECS(i,:) = PACK( VECS(i,:) , IsError(VECS(1,:)) )
!    END DO
!

!!### DETAILS
!! Optional arguments, <tol> and <reltol> provide
!! absolute and relative tolerances, with <tol> overriding
!! <reltol> if (for some reason) both are present, for determining
!! whether or not two points are actually duplicates.

!!### NOTES
!! You may not mix kinds.

!!### MODULAR KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp     !!((01-A-KND_IntrinsicTypes.f90))

!!### MODULAR PROCEDURES
USE FUN_IsApprox                                   !!((03-A-FUN_IsApprox.f90))
USE FUN_Error                                      !!((04-A-FUN_Error.f90))
USE SUB_FlagDuplicateVectors0                      !!((05-A-SUB_FlagDuplicateVectors0.f90))
USE SUB_Sort2_quick,ONLY: SortVectors=>Sort2_quick !!((06-A-SUB_Sort2_quick.f90))

!!### DEFAULT IMPLICIT
IMPLICIT NONE

!!### DEFAULT ACCESS
PRIVATE

!!### OPERATOR DEFINITION
INTERFACE FlagDuplicateVectors
 MODULE PROCEDURE FlagDuplicateVectors_Rsp
 MODULE PROCEDURE FlagDuplicateVectors_Rdp
END INTERFACE

!!### PUBLIC ACCESS LIST
PUBLIC :: FlagDuplicateVectors

CONTAINS

SUBROUTINE FlagDuplicateVectors_Rsp(VECS,tol,reltol,unique)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-B-SUB_FlagDuplicateVectors.f90.hdr"
!!--begin--
INCLUDE "08-B-SUB_FlagDuplicateVectors.f90.bdy"
!!--end--
END SUBROUTINE

SUBROUTINE FlagDuplicateVectors_Rdp(VECS,tol,reltol,unique)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-B-SUB_FlagDuplicateVectors.f90.hdr"
!!--begin--
INCLUDE "08-B-SUB_FlagDuplicateVectors.f90.bdy"
!!--end--
END SUBROUTINE

END MODULE