subroutine linip_arr(m, n, ts, ys, t, y)
!
!     Linear interpolation of time dependent profiles.
!     For times which are outside the bounds the profile is set to the last/first present time.
!
!     Note that this subroutine is different than the one in STRAHL's math.f (L194) because for transport coefficients
!     we don't care about whether a profile has previously been interpolated or not.
!
!     INPUTS:
!     m                       number of ts-vector elements
!     n                        number of used rho-vector elements
!     ts	                The time vector. Values MUST be monotonically increasing.
!     ys(rho, ts)          array of ordinate values.
!     t	                The time for which the ordinates shall be interpolated
!
!     OUTPUT:
!     y(rho)                 interpolated profiles at the chosen time
!
  IMPLICIT NONE

  INTEGER, INTENT(IN)                 :: m
  INTEGER, INTENT(IN)                 :: n
  REAL*8, INTENT(IN)                   :: ts(m)
  REAL*8, INTENT(IN)                   :: ys(n, m)

  REAL*8, INTENT(IN)                   :: t
  REAL*8, INTENT(OUT)                :: y(n)

  INTEGER :: k, i

  REAL*8 ::  ff

  ! if only one time point has been given, then return the same/only value
  if (m.eq.1) then
     do i=1,n
        y(i) = ys(i,1)
     enddo
     return
  endif

  ! if the requested time is greater than the maximum time provided, then use the last time
  if (t.ge.ts(m)) then
     do i=1,n
        y(i) = ys(i,m)
     enddo
     return
  endif

  ! if the requested time is smaller than the minimum time provided, then use the first time
  if (t.lt.ts(1)) then
     do i=1,n
        y(i) = ys(i,1)
     enddo
     return
  endif

  ! find time point in "ts" vector that is marginally larger than the requested "t"
  k=0
  do k=1,m+1
     if (t < ts(k+1)) then
        exit
     endif
  enddo

  ff = (t - ts(k))/(ts(k+1) - ts(k))
  do i=1,n
     y(i) = ys(i,k)*(1.0d0 - ff) + ys(i,k+1)*ff
  enddo

end subroutine linip_arr

subroutine asc_sort(n, a, index)
  ! sorts a in ascending order and gives the indices
  ! of the old vector for the new vector

  IMPLICIT NONE

  INTEGER, INTENT(IN)           :: n
  REAL*8, INTENT(INOUT)         :: a(n)
  INTEGER, INTENT(OUT)          :: index(n)

  REAL*8 ::  v
  INTEGER :: i,j,w

  do i=1,n
     index(i) = i
  enddo

  do j=2, n
     v = a(j)
     w = index(j)
     do i= j-1,  1, -1
        if (a(i) .le. v) goto 10
        a(i+1) = a(i)
        index(i+1) = index(i)
     enddo
     i = 0
10   a(i+1) = v
     index(i+1) = w
  enddo
  return
end subroutine asc_sort

subroutine chg_ord_r(n, a, index, wksp)
  ! changes order of real vector a according to index vector

  IMPLICIT NONE
  INTEGER, INTENT(IN)       :: n
  REAL*8, INTENT(INOUT)     :: a(n)
  INTEGER, INTENT(IN)       :: index(n)
  REAL*8, INTENT(OUT)       :: wksp(n)

  INTEGER :: i

  do i=1, n
     wksp(i) = a(index(i))
  enddo
  do i=1, n
     a(i) = wksp(i)
  enddo
  return
end subroutine chg_ord_r

subroutine chg_ord_i(n, a, index, wksp)
  ! changes order of integer vector a according to index vector

  IMPLICIT NONE
  INTEGER, INTENT(IN)    :: n
  INTEGER, INTENT(INOUT)     :: a(n)
  INTEGER, INTENT(IN)    :: index(n)
  INTEGER, INTENT(OUT)    :: wksp(n)

  INTEGER :: i

  do i=1, n
     wksp(i) = a(index(i))
  enddo
  do i=1, n
     a(i) = wksp(i)
  enddo
  return
end subroutine chg_ord_i


subroutine ham(a,p,v)
USE variables
implicit none
integer a(3),p(3)
real*8  v
! this subroutine computes <123|H|456>

v = H(a(1),p(1))*S(a(2),p(2))*S(a(3),p(3))+ &
    H(a(2),p(2))*S(a(1),p(1))*S(a(3),p(3))+ &
    H(a(3),p(3))*S(a(1),p(1))*S(a(2),p(2))+ &
    EE(a(1),a(2),p(1),p(2))*S(a(3),p(3))+   &
    EE(a(1),a(3),p(1),p(3))*S(a(2),p(2))+   &
    EE(a(2),a(3),p(2),p(3))*S(a(1),p(1));

!    write(6,*) a(3),p(3), H(2,3)
!    stop
end subroutine ham


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id$
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE RFFTF1 (N,IN,C,CH,WA,FAC)
      REAL       CH(*) ,C(IN,*)  ,WA(N)   ,FAC(15)
C
      NF = FAC(2)
      NA = 1
      L2 = N
      IW = N
      DO 111 K1=1,NF
         KH = NF-K1
         IP = FAC(KH+3)
         L1 = L2/IP
         IDO = N/L2
         IDL1 = IDO*L1
         IW = IW-(IP-1)*IDO
         NA = 1-NA
         IF (IP .NE. 4) GO TO 102
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IF (NA .NE. 0) GO TO 101
	 CALL R1F4KF (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  101    CALL R1F4KF (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  102    IF (IP .NE. 2) GO TO 104
         IF (NA .NE. 0) GO TO 103
	 CALL R1F2KF (IDO,L1,C,IN,CH,1,WA(IW))
         GO TO 110
  103    CALL R1F2KF (IDO,L1,CH,1,C,IN,WA(IW))
         GO TO 110
  104    IF (IP .NE. 3) GO TO 106
         IX2 = IW+IDO
         IF (NA .NE. 0) GO TO 105
	 CALL R1F3KF (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2))
         GO TO 110
  105    CALL R1F3KF (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2))
         GO TO 110
  106    IF (IP .NE. 5) GO TO 108
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IX4 = IX3+IDO
         IF (NA .NE. 0) GO TO 107
         CALL R1F5KF (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),
     1                      WA(IX3),WA(IX4))
         GO TO 110
  107    CALL R1F5KF (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),
     1                      WA(IX3),WA(IX4))
         GO TO 110
  108    IF (IDO .EQ. 1) NA = 1-NA
         IF (NA .NE. 0) GO TO 109
	 CALL R1FGKF (IDO,IP,L1,IDL1,C,C,C,IN,CH,CH,1,WA(IW))
         NA = 1
         GO TO 110
  109    CALL R1FGKF (IDO,IP,L1,IDL1,CH,CH,CH,1,C,C,IN,WA(IW))
         NA = 0
  110    L2 = L1
  111 CONTINUE
      SN = 1./N
      TSN = 2./N
      TSNM = -TSN
      MODN = MOD(N,2)
      NL = N-2
      IF(MODN .NE. 0) NL = N-1
      IF (NA .NE. 0) GO TO 120
      C(1,1) = SN*CH(1)
      DO 118 J=2,NL,2
	 C(1,J) = TSN*CH(J)
	 C(1,J+1) = TSNM*CH(J+1)
  118 CONTINUE
      IF(MODN .NE. 0) RETURN
      C(1,N) = SN*CH(N)
      RETURN
  120 C(1,1) = SN*C(1,1)
      DO 122 J=2,NL,2
	 C(1,J) = TSN*C(1,J)
	 C(1,J+1) = TSNM*C(1,J+1)
  122 CONTINUE
      IF(MODN .NE. 0) RETURN
      C(1,N) = SN*C(1,N)
      RETURN
      END


! BSD 3-Clause License
!
! Copyright (c) 2020, Fabio Durastante
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its
!    contributors may be used to endorse or promote products derived from
!    this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
submodule (psfun_z_quadrature_mod) psfun_z_quadrules_mod
  !! This submodule contains the impliementation of the legacy quadrature rules
  !! distributed with the library.

  ! Constants used internally
  real(psb_dpk_), parameter :: DPI = 4.0_psb_dpk_*ATAN(1.0_psb_dpk_) !! Double precision :math:`\pi` for internal usage
  complex, parameter :: iunit = cmplx(0.0_psb_dpk_,1.0_psb_dpk_) !! Immaginary unit

contains

  module subroutine hhtmethod1(zfun,xi,c,eta,sign,N,info,cparams,rparams)
    !! Method 1 of Hale, Nicholas; Higham, Nicholas J.; Trefethen, Lloyd N.
    !! Computing \(\mathbf{A}^\alpha,\ \log(\mathbf{A})\), and related matrix functions
    !! by contour integrals. SIAM J. Numer. Anal. 46 (2008), no. 5, 2505--2523.
    use psb_base_mod
    use psfun_utils_mod, only: ellipkkp, ellipj
    implicit none
    procedure (zquadfun), pointer, intent(in) :: zfun               !! Function to integrate
    complex(psb_dpk_), allocatable, dimension(:), intent(out) :: xi     !! Poles of the formula
    complex(psb_dpk_), allocatable, dimension(:), intent(out) :: c      !! Scaling of the formula
    real(psb_dpk_), intent(out)    :: eta!! Global Scaling
    real(psb_dpk_), intent(out)    :: sign   !! Sign for A
    integer(psb_ipk_), intent(in)  :: N !! Number of Poles
    integer(psb_ipk_), intent(out) :: info !! Flag on the results
    complex(psb_dpk_), dimension(:), optional, intent(in) :: cparams !! Optional complex parameters
    real(psb_dpk_), dimension(:), optional, intent(in) :: rparams !! Optional real parameters

    ! local variables
    real(psb_dpk_)    :: mineig,maxeig,cond,L,K,Kp,Kvec(2)
    complex(psb_dpk_) :: u,cn,dn
    complex(psb_dpk_) :: t
    integer(psb_ipk_) :: j

    info = 0

    mineig = min(rparams(1),rparams(2)) ! Estimate of the minimum eigenvalue
    maxeig = max(rparams(1),rparams(2)) ! Estimate of the maximum eigenvalue

    allocate(xi(N), stat=info)
    allocate(c(N), stat=info)

    cond = (sqrt(maxeig/mineig)-1)/(sqrt(maxeig/mineig)+1)
    L = -log(cond)/DPI
    Kvec = ellipkkp(L)
    K = Kvec(1)
    Kp = Kvec(2)
    do j=1,N,1
      t = .5_psb_dpk_*iunit*Kp - K + (2.0_psb_dpk_*(j-1_psb_ipk_)+1_psb_dpk_)*K/N
      call ellipj(t,L,u,cn,dn)
      xi(j) = sqrt(mineig*maxeig)*((1.0_psb_dpk_/cond + u)/(1.0_psb_dpk_/cond -u))
      c(j) = (zfun(xi(j))/xi(j))*(cn*dn)/((1.0_psb_dpk_/cond - u)**2)
    end do
    eta = -(4.0_psb_dpk_*K*sqrt(mineig*maxeig))/(cond*DPI*N)
    sign = -1.0_psb_dpk_

  end subroutine hhtmethod1

end submodule


! This MODULE contains all the routines that
! are relative to sediment transport. Only the diffusion
! proccess is considered for the 1st verson.

#include "AMYCAI.h"

MODULE Sediment_Transport

    USE TimeCatcher
    USE FloatPrecision
    USE ArraySize
    USE GRIDS
    USE hydro
    USE Topography
    USE Parameters
    USE Suspended_Load
    USE LinearSolver

    IMPLICIT NONE

    REAL(fp) , DIMENSION(:) , POINTER :: VARS, VARP, VARN
    REAL(fp) , DIMENSION(:) , POINTER :: VSCS, VSCP, VSCN
    INTEGER  , DIMENSION(:) , POINTER :: GIDS, GIDP, GIDN
    REAL(fp) , DIMENSION(:) , POINTER :: CEP , HP  , FRUIT
    REAL(fp) , DIMENSION(:) , POINTER :: REQP
    REAL(fp) , POINTER                :: LX , LY  , LT
    INTEGER  , POINTER                :: ILOW , IUP , JLOW , JUP
    REAL(fp)                          :: LXX , LYY

    REAL(fp) , DIMENSION(:) , POINTER :: BP

    CONTAINS

! = = = = = = = = = = = = = = = =
!
!      1D diffusion model
!
! = = = = = = = = = = = = = = = =

    SUBROUTINE SSC_Diffusion_1D_Model(SSC1_1D,SSC2_1D)

        IMPLICIT NONE
        REAL(fp) , DIMENSION(:) , POINTER :: SSC1_1D , SSC2_1D , TEMP_1D

! Calculate local erosion

        CALL Local_Erosion
        CALL Local_Total_Erosion

! 1D diffusion equation

! Y-Direcsion

        LX   => DY
        LT   => DT
        LXX = LX**2

        ILOW => ML
        IUP  => MU
        JLOW => NL
        JUP  => NU

! results of last step

        VARP  => SSC1_1D(:)

! wet AND dry information

        GIDP  => NDD_HWL_1D(:)

! diffusion coefficient -Y

        VSCP  => SSC_DIFFU_HWL_Y_1D(:)

! erosion term: local source term

        CEP   => ERO_1D(:)

! local water Depth

        HP    => Max_Area(:)

! width

        BP    => B_HWL(:)

! Residual Discharge

        REQP  => Q_RESIDUAL1(:)

! result

        FRUIT => SSC2_1D(:)

! 1D solver

        CALL Tridiagonal_1D('Y',1)

! Exchange pointers

        TEMP_1D=>SSC2_1D
        SSC2_1D=>SSC1_1D
        SSC1_1D=>TEMP_1D
        NULLIFY(VARP,FRUIT,GIDP,VSCP,TEMP_1D,CEP,BP,REQP)
        NULLIFY(LX,LT,ILOW,IUP)

    END SUBROUTINE SSC_Diffusion_1D_Model

! = = = = = = = = = = = = = = = =
!
!  Diffusion proccess for SSC
!
! = = = = = = = = = = = = = = = =

    SUBROUTINE SSC_Diffusion_2D_Model(SSC1,SSC2)

        IMPLICIT NONE

        REAL(fp) , DIMENSION(:,:) , POINTER :: SSC1 , SSC2 , TEMP
        INTEGER :: i , j , i1 , i2 , j1 , j2

! Calculate local erosion

        CALL Local_Erosion

!- - - - - - - - - - - - - -
!    ADI method is used
!- - - - - - - - - - - - - -

! Y-Direcsion

        LX   => DY
        LY   => DX
        LT   => DT
        LXX = LX**2
        LYY = LY**2

        ILOW => ML
        IUP  => MU
        JLOW => NL
        JUP  => NU

        DO j = JLOW , JUP

            j1 = j+1
            j2 = j-1
            IF(j==JLOW) j2=j
            IF(j==JUP) j1=j

! results of last step

            VARS  => SSC1(:,j2)
            VARP  => SSC1(:,j)
            VARN  => SSC1(:,j1)

! wet AND dry information

            GIDS  => NDD_HWL(:,j2)
            GIDP  => NDD_HWL(:,j)
            GIDN  => NDD_HWL(:,j1)

! diffusion coefficient -Y

            VSCP  => SSC_DIFFU_HWL_Y(:,j)

! diffusion coefficient -X

            VSCS  => SSC_DIFFU_HWL_X(:,j2)
            VSCN  => SSC_DIFFU_HWL_X(:,j)

! erosion term: local source term

            CEP   => ERO(:,j)

! local water Depth

            HP    => Dep_HWL(:,j)

! result

            FRUIT => SSC2(:,j)

! ADI solver

            CALL Tridiagonal_ADI('Y',j)

        END DO

! Exchange pointers

        TEMP=>SSC2
        SSC2=>SSC1
        SSC1=>TEMP
        NULLIFY(VARS,VARP,VARN,FRUIT,GIDS,GIDP,GIDN,VSCP,VSCS,VSCN,TEMP,CEP)
        NULLIFY(LX,LY,LT,ILOW,IUP,JLOW,JUP)

 ! - - - - - - - - - - - - - - - - -

 ! X-Direcsion

        LX   => DX
        LY   => DY
        LT   => DT
        LXX = LX**2
        LYY = LY**2

        ILOW => NL
        IUP  => NU
        JLOW => ML
        JUP  => MU

        DO j = JLOW , JUP

            j1 = j+1
            j2 = j-1
            IF(j==JLOW) j2=j
            IF(j==JUP ) j1=j

! results of last step

            VARS  => SSC1(j2,:)
            VARP  => SSC1(j,:)
            VARN  => SSC1(j1,:)

! wet AND dry information

            GIDS  => NDD_HWL(j2,:)
            GIDP  => NDD_HWL(j,:)
            GIDN  => NDD_HWL(j1,:)

! diffusion coefficient -Y

            VSCP  => SSC_DIFFU_HWL_X(j,:)

! diffusion coefficient -X

            VSCS  => SSC_DIFFU_HWL_Y(j2,:)
            VSCN  => SSC_DIFFU_HWL_Y(j,:)

! erosion term: local source term

            CEP   => ERO(j,:)

! local water Depth

            HP    => Dep_HWL(j,:)

! result

            FRUIT => SSC2(j,:)

! ADI solver

            CALL Tridiagonal_ADI('X',j)

        END DO

! Exchange pointers

        TEMP=>SSC2
        SSC2=>SSC1
        SSC1=>TEMP
        NULLIFY(VARS,VARP,VARN,FRUIT,GIDS,GIDP,GIDN,VSCP,VSCS,VSCN,TEMP,CEP)
        NULLIFY(LX,LY,LT,ILOW,IUP,JLOW,JUP)

    END SUBROUTINE SSC_Diffusion_2D_Model

! = = = = = = = = = = = = = = = =
!
!     SSC constant model
!
! = = = = = = = = = = = = = = = =

    SUBROUTINE SSC_Constant_Model(SSC1)
        IMPLICIT NONE

        REAL(fp) , DIMENSION(:,:) , POINTER :: SSC1

        CALL Local_Erosion

    END SUBROUTINE SSC_Constant_Model

! - - - - - - - - - - - - - - - -
!
!       Local Erosion
!
! - - - - - - - - - - - - - - - -

    SUBROUTINE Local_Erosion

        IMPLICIT NONE

        INTEGER :: i , j

#ifdef SAINT_VENENT

    ! tau > critical shear stress

            WHERE(TAU_TD > CTAUE)

    ! Linear Function

                EROQ = QE0 * (TAU_TD/CTAUE-1.D0) / RHOS !* Upsilon

    ! tau <= critical shear stress

            ELSEWHERE(TAU_TD <= CTAUE)

    ! set erosion zero

                EROQ = 0.D0

            ENDWHERE

    ! The location of EROQ is not at the grid points
    ! So center average

            DO j = NL , NU
                DO i = ML , MU
                    IF(i==ML) THEN
                        ERO(i,j) = EROQ(i,j)
                    ELSEIF(i==MU) THEN
                        ERO(i,j) = EROQ(i-1,j)
                    ELSE
                        ERO(i,j) = 0.5D0*(EROQ(i,j)+EROQ(i-1,j))
                    END IF
                END DO
            END DO

#elif defined(CONTINUITY)

    ! tau > critical shear stress

            WHERE(TAU_TD > CTAUE)

    ! Linear Function

                ERO = QE0 * (TAU_TD/CTAUE-1.D0) / RHOS !* Upsilon

    ! tau <= critical shear stress

            ELSEWHERE(TAU_TD <= CTAUE)

    ! set erosion zero

                ERO = 0.D0

            ENDWHERE

#endif

    END SUBROUTINE Local_Erosion

! - - - - - - - - - - - - - - - -
!
!       Local Total Erosion
!
! - - - - - - - - - - - - - - - -

    SUBROUTINE Local_Total_Erosion

        IMPLICIT NONE

        INTEGER :: i

        DO i = ML , MU
            ERO_1D(i) = (2.D0*SUM(ERO(i,:))-ERO(i,NL)-ERO(i,NU))*dx/2.D0
        END DO

    END SUBROUTINE Local_Total_Erosion

! - - - - - - - - - - - -
!
!   BED LOAD TRANSPORT
!
! - - - - - - - - - - - -

    SUBROUTINE  Lateral_Bedload_Transport

        IMPLICIT NONE

        INTEGER :: i , j
        REAL(fp) :: slope1

#ifdef SAINT_VENENT

        DO i = ML , MU-1
            DO j = (NL+NU)/2 , NU-1
                slope1 = (DepQ(i,j+1)-DepQ(i,j))/dx

    ! discontinuous case

                !IF(TAU_TD(i,j)>CTAUB) THEN
                !    Lateral_Transport_Q(i,j) = LBFC*slope1*(TAU_TD(i,j)/CTAUB-1.D0)
                !ELSE
                !    Lateral_Transport_Q(i,j) = 0.D0
                !END IF

    ! continuous case

                Lateral_Transport_Q(i,j) = LBFC*slope1*(0.4D0*TAU_TD(i,j)**2/CTAUB/rhoRsgd)

    ! SYMMETRY

                Lateral_Transport_Q(i,NU-j) = - Lateral_Transport_Q(i,j)

            END DO
        END DO

    ! The location of Lateral_Transport is not at the grid points
    ! So center average

        DO j = NL , NU-1
            DO i = ML , MU
                IF(i==ML) THEN
                    Lateral_Transport(i,j) = Lateral_Transport_Q(i,j)
                ELSEIF(i==MU) THEN
                    Lateral_Transport(i,j) = Lateral_Transport_Q(i-1,j)
                ELSE
                    Lateral_Transport(i,j) = 0.5D0*(Lateral_Transport_Q(i,j)+Lateral_Transport_Q(i-1,j))
                END IF
            END DO
        END DO

#elif defined(CONTINUITY)

        DO i = ML , MU
            DO j = (NL+NU)/2 , NU-1
                slope1 = (DepQ(i,j+1)-DepQ(i,j))/dx

    ! discontinuous case

                !IF(TAU_TD(i,j)>CTAUB) THEN
                !    Lateral_Transport_Q(i,j) = LBFC*slope1*(TAU_TD(i,j)/CTAUB-1.D0)
                !ELSE
                !    Lateral_Transport_Q(i,j) = 0.D0
                !END IF

    ! continuous case

                Lateral_Transport_Q(i,j) = LBFC*slope1*(0.4D0*TAU_TD(i,j)**2/CTAUB/rhoRsgd)

    ! SYMMETRY

                Lateral_Transport_Q(i,NU-j) = - Lateral_Transport_Q(i,j)

            END DO
        END DO

#endif

    END SUBROUTINE Lateral_Bedload_Transport

! - - - - - - - - - - - -
!
!   AVALANCHE
!
! - - - - - - - - - - - -

    SUBROUTINE  Lateral_Avalanche_Transport

        IMPLICIT NONE

        INTEGER :: i , j
        REAL(fp) :: slope1

! - - - - - - - - - - - -
!
!   AVALANCHE
!
! - - - - - - - - - - - -

        DO i = ML , MU
            DO j = NL , NU-1
                DDep(i,j) = DATAN((Dep0(i,j+1)-Dep0(i,j))/dx)
                IF(DDep(i,j)>=0.D0) THEN
                    Lateral_Avalanche(i,j) = DTAN(DMAX1(0.D0,DDep(i,j)-Repose_Angle))*Avalanche_Coef
                ELSEIF(DDep(i,j)<0.D0) THEN
                    Lateral_Avalanche(i,j) = DTAN(DMIN1(0.D0,DDep(i,j)+Repose_Angle))*Avalanche_Coef
                END IF
            END DO
        END DO

    END SUBROUTINE Lateral_Avalanche_Transport

! = = = = = = = = = = = = = = = = = = = =
!
!   ADI ROUTINE: solve tridiagonal matrix
!
! = = = = = = = = = = = = = = = = = = = =

    SUBROUTINE Tridiagonal_ADI(DIR,ROW)

        IMPLICIT NONE

        CHARACTER(LEN=1) :: DIR
        INTEGER          :: ROW

        REAL(fp) :: AMT(6,3001)
        REAL(fp) :: DCE , DCW , DCN , DCS
        INTEGER  :: i , ic , k
        INTEGER  :: IDE, IDW, IDS, IDN
        ic = 0

        DO i = ILOW , IUP

            ic = ic+1

! Local point is dry

            IF(GIDP(i)==1) THEN

! set zero

                amt(1,ic) = 0.D0
                amt(2,ic) = 1.D0
                amt(3,ic) = 0.D0
                amt(4,ic) = 0.D0
                CYCLE

! Local point is wet

            ELSEIF(GIDP(i)==0) THEN

!- - - - - - - - - - - - - -
! Set diffusion coefficients
!- - - - - - - - - - - - - -

!SOUTH

                IF(ROW==JLOW) THEN
                    IDS = 1
                ELSE
                    IDS = GIDS(I)
                END IF

                IF(IDS==0) THEN
                    DCS = VSCS(i)  * LT / LYY * 0.5D0 / HP(i)
                END IF

!NORTH

                IF(ROW==JUP) THEN
                    IDN = 1
                ELSE
                    IDN = GIDN(I)
                END IF

                IF(IDN==0) THEN
                    DCN = VSCN(i)  * LT / LYY * 0.5D0 / HP(i)
                END IF

!WEST

                IF(i==ILOW) THEN
                    IDW = 1
                ELSE
                    IDW = GIDP(i-1)
                END IF

                IF(IDW==0) THEN
                    DCW = VSCP(i-1) * LT / LXX * 0.5D0 / HP(i)
                END IF

!EAST

                IF(i==IUP) THEN
                    IDE = 1
                ELSE
                    IDE = GIDP(i+1)
                END IF

                IF(IDE==0) THEN
                    DCE = VSCP(i)  * LT / LXX * 0.5D0 / HP(i)
                END IF

!- - - - - - - - - - - - - - - -
! Left hand side of the equation
!- - - - - - - - - - - - - - - -

                IF(IDE==1.AND.IDW==0) THEN

                    amt(1,ic) = - 2.D0*DCW
                    amt(2,ic) = + 2.D0*DCW + 1.D0
                    amt(3,ic) = 0.D0

                ELSEIF(IDW==1.AND.IDE==0) THEN

                    amt(1,ic) =   0.D0
                    amt(2,ic) = + 2.D0*DCE + 1.D0
                    amt(3,ic) = - 2.D0*DCE

                ELSEIF(IDW==1.AND.IDE==1) THEN

                    amt(1,ic) =   0.D0
                    amt(2,ic) =   1.D0
                    amt(3,ic) =   0.D0

                ELSEIF(IDW==0.AND.IDE==0)  THEN

                    amt(1,ic) = - DCW
                    amt(2,ic) = + DCW + DCE + 1.D0
                    amt(3,ic) = - DCE

                ELSE

                    WRITE(*,*) ROW, GIDP(i-1) , GIDP(i+1)
                    PAUSE 'tri_matrix_error_1'

                END IF

!- - - - - - - - - - - - - - - -
! Left hand side of the equation
!- - - - - - - - - - - - - - - -

                IF(    IDN==1.AND.IDS==0) THEN

                    amt(4,ic) = VARP(i) + 2.D0*DCS*(VARS(i)-VARP(i))

                ELSEIF(IDS==1.AND.IDN==0) THEN

                    amt(4,ic) = VARP(i) + 2.D0*DCN*(VARN(i)-VARP(i))

                ELSEIF(IDS==1.AND.IDN==1) THEN

                    amt(4,ic) = VARP(i)

                ELSEIF(IDS==0.AND.IDN==0)  THEN

                    amt(4,ic) = VARP(i) + DCN*(VARN(i)-VARP(i)) + DCS*(VARS(i)-VARP(i))

                ELSE

                    WRITE(*,*) ROW, IDS , IDN
                    PAUSE 'tri_matrix_error_2'

                END IF

        ! sourse term

                amt(4,ic) = amt(4,ic) + CEP(i)/HP(i)*0.5D0*LT
                amt(2,ic) = amt(2,ic) + WS/HP(i)*0.5D0*LT

            END IF

        END DO

    !    OPEN(5,file='amt.txt')
    !    do i = 1, ic
    !        WRITE(5,'(10e25.10)') (amt(k,i),k=1,4)
    !    end do
    !    CLOSE(5)

        CALL solve3_LU(ic)

        fruit(:) = amt(4,:)

        !IF(pros=='sedi') THEN
        !IF(dir=='y') THEN
        !OPEN(5,file='amt2.txt')
        !do i = 1, ic
        !    WRITE(5,'(10e25.10)') (amt(k,i),k=1,4)
        !end do
        !CLOSE(5)
        !pause 'xg'
        !end IF

    END SUBROUTINE Tridiagonal_ADI

!- - - - - - - - - - - - - -
!
!   Bed evolution per step
!
!- - - - - - - - - - - - - -

! 2D routine

    SUBROUTINE Bed_Evolution(SSC1)

        IMPLICIT NONE

        REAL(fp) , DIMENSION(:,:) , POINTER :: SSC1
        INTEGER :: i , j

! Erosion is positive and Deposition is negative

        DO i = ML , MU
            DO j = NL , NU
                Evolution_Step(i,j) = ERO(i,j) - SSC1(i,j)*WS
                Evolution_TDCYC(i,j) = Evolution_TDCYC(i,j) + Evolution_Step(i,j)
            END DO
        END DO

    END SUBROUTINE Bed_Evolution

! 1D routine

    SUBROUTINE Bed_Evolution_1D(SSC1_1D,EE1)

        IMPLICIT NONE

        REAL(fp) , DIMENSION(:) , POINTER :: SSC1_1D , EE1
        REAL(fp) :: cc , MC
        REAL(fp) :: erosion0, Deposition0, bedload0, avalanche0
        INTEGER :: i , j

! - - - - - - - - - - - - - - - - -
!
!   SUM THE bedevolution
!   Erosion is positive and Deposition is negative
!
! - - - - - - - - - - - - - - - - -

        DO i = ML , MU
            DO j = (NL+NU)/2 , NU

    ! erosion

                erosion0 = ERO(i,j)

    ! Deposition

                IF(NDD_HWL(i,j)==0) THEN

#ifdef SSC_1D_DIFFUSION
                    Deposition0 = - SSC1_1D(i)*WS
#elif defined(SSC_2D_DIFFUSION)
                    Deposition0 = - SSC1(i)*WS
#elif defined(SSC_CONSTANT)
                    Deposition0 = - SSC_CONST*WS
#endif

                ELSE

                    Deposition0 = 0.D0

                ENDIF

    ! bedload

#ifdef BEDLOAD_INC

                IF(j==NL) THEN
                    bedload0 = + Lateral_Transport(i,j)/dx
                ELSEIF(j==NU) THEN
                    bedload0 = - Lateral_Transport(i,j-1)/dx
                ELSE
                    bedload0 = (Lateral_Transport(i,j)-Lateral_Transport(i,j-1))/dx
                END IF

#else
                bedload0 = 0.D0
#endif

    ! avalanche

#ifdef AVAlANCHE_INC

                IF(j==NL) THEN
                    avalanche0 = Lateral_Avalanche(i,j)/dx
                ELSEIF(j==NU) THEN
                    avalanche0 = - Lateral_Avalanche(i,j-1)/dx
                ELSE
                    avalanche0 = (Lateral_Avalanche(i,j)-Lateral_Avalanche(i,j-1))/dx
                END IF

#else
                avalanche0 = 0.D0
#endif

    ! UPDATE THE BED

#ifdef CUT_OFF_SSC
                IF(CD2>CUT_OFF_SSC) THEN
                    Evolution_Step(i,j) = erosion0 + bedload0 + avalanche0
                ElSE
                    Evolution_Step(i,j) = erosion0 + Deposition0 + bedload0 + avalanche0
                ENDIF
#else
                Evolution_Step(i,j) = erosion0 + Deposition0 + bedload0 + avalanche0
#endif
                cc = Evolution_Step(i,j)*dt*MorFactor
                Dep0(i,j) = Dep0(i,j) + cc
                Dep0(i,NL+NU-j) = Dep0(i,j)

#ifndef TIDE_OSCILLATION
                IF(Dep0(i,j)<0.05D0) Dep0(i,j)=0.05D0
#endif

            END DO
        END DO

    END SUBROUTINE Bed_Evolution_1D

! only erosion

    SUBROUTINE Bed_Evolution_Only_ERO(SSC1_1D)

        IMPLICIT NONE

        REAL(fp) , DIMENSION(:) , POINTER :: SSC1_1D
        INTEGER :: i , j

! Erosion is positive and Deposition is negative
! calculate lateral transport

        DO i = ML , MU
            DO j = NL , NU-1
                DDep(i,j) = DATAN((Dep1(i,j+1)-Dep1(i,j))/dx)
                IF(DDep(i,j)>=0.D0) THEN
                    Lateral_Transport(i,j) = DTAN(DMAX1(0.D0,DDep(i,j)-Repose_Angle))*Avalanche_Coef
                ELSEIF(DDep(i,j)<0.D0) THEN
                    Lateral_Transport(i,j) = DTAN(DMIN1(0.D0,DDep(i,j)+Repose_Angle))*Avalanche_Coef
                END IF
            END DO
        END DO

        DO i = ML , MU
            DO j = NL , NU

! erosion and Deposition

                Evolution_Step(i,j) = ERO(i,j)

! lateral transport

                IF(j==NL) THEN
                    Evolution_Step(i,j) = Evolution_Step(i,j) + Lateral_Transport(i,j)/dx
                ELSEIF(j==NU) THEN
                    Evolution_Step(i,j) = Evolution_Step(i,j) - Lateral_Transport(i,j-1)/dx
                ELSE
                    Evolution_Step(i,j) = Evolution_Step(i,j) + (Lateral_Transport(i,j)-Lateral_Transport(i,j-1))/dx
                END IF

                IF(CD2 > 2)  Dep1(i,j) = Dep1(i,j) + Evolution_Step(i,j)*dt*MorFactor

            END DO
        END DO

    END SUBROUTINE Bed_Evolution_Only_ERO

! constant Deposition

    SUBROUTINE Bed_Evolution_Const_DepOSIT(SSC1_1D,EE1)

        IMPLICIT NONE

        REAL(fp) , DIMENSION(:) , POINTER :: SSC1_1D, EE1
        REAL(fp)                          :: c0
        INTEGER :: i , j

! Erosion is positive and Deposition is negative
! calculate lateral transport

        DO i = ML , MU
            DO j = NL , NU-1
                DDep(i,j) = DATAN((Dep0(i,j+1)-Dep0(i,j))/dx)
                IF(DDep(i,j)>=0.D0) THEN
                    Lateral_Transport(i,j) = DTAN(DMAX1(0.D0,DDep(i,j)-Repose_Angle))*Avalanche_Coef
                ELSEIF(DDep(i,j)<0.D0) THEN
                    Lateral_Transport(i,j) = DTAN(DMIN1(0.D0,DDep(i,j)+Repose_Angle))*Avalanche_Coef
                END IF
            END DO
        END DO

        DO i = ML , MU

!! sediment concentration

            IF(i<=30) then
                c0 = 0.D0
            ELSEIF(i>=100) then
                c0 = 0.005D0
            ELSE
                c0 = DBLE(i-30)/DBLE(100-30)*0.005D0
            END IF

            DO j = NL , NU

! erosion

                Evolution_Step(i,j) = ERO(i,j)

! lateral transport

                IF(j==NL) THEN
                    Evolution_Step(i,j) = Evolution_Step(i,j) + Lateral_Transport(i,j)/dx
                ELSEIF(j==NU) THEN
                    Evolution_Step(i,j) = Evolution_Step(i,j) - Lateral_Transport(i,j-1)/dx
                ELSE
                    Evolution_Step(i,j) = Evolution_Step(i,j) + (Lateral_Transport(i,j)-Lateral_Transport(i,j-1))/dx
                END IF

! Deposition

                IF(EE1(i)+Dep0(i,j)>DDRY) THEN
                    !Evolution_Step(i,j) = Evolution_Step(i,j)*dt*MorFactor - DMIN1(0.5D0*(EE1(i)+Dep0(i,j)-DDRY),WS*c0*dt*MorFactor)
                    Evolution_Step(i,j) = Evolution_Step(i,j)*dt*MorFactor - WS*c0*dt*MorFactor
                ELSE
                    Evolution_Step(i,j) = Evolution_Step(i,j)*dt*MorFactor
                ENDIF

                IF(CD2 > 2) THEN
                    Dep0(i,j) = Dep0(i,j) + Evolution_Step(i,j)
                ENDIF

            END DO
        END DO

    END SUBROUTINE Bed_Evolution_Const_DepOSIT

!= = = = = = = =
!
! 1D sediment diffusion equation
!
!= = = = = = = =

    SUBROUTINE Tridiagonal_1D(DIR,ROW)

        IMPLICIT NONE

        CHARACTER(LEN=1) :: DIR
        INTEGER          :: ROW

        REAL(fp) :: DCE , DCW
        REAL(fp) :: ADE , ADW , ADP
        INTEGER  :: i , ic , k
        INTEGER  :: IDE, IDW
        ic = 0

        DO i = ILOW , IUP

            ic = ic+1

! Local point is dry

            IF(GIDP(i)==1) THEN

! set zero

                amt(1,ic) = 0.D0
                amt(2,ic) = 1.D0
                amt(3,ic) = 0.D0
                amt(4,ic) = 0.D0
                CYCLE

! Local point is wet

            ELSEIF(GIDP(i)==0) THEN

!- - - - - - - - - - - - - -
! Set diffusion coefficients
!- - - - - - - - - - - - - -

!WEST

                IF(i==ILOW) THEN
                    !IDW = 1    ! NEUMANN BOUNDARY
                    IDW = -2    ! zero Dirichlet
                ELSE
                    IDW = GIDP(i-1)
                END IF

                IF(IDW==0) THEN
                    DCW = VSCP(i-1) * LT / LXX / HP(i)
                END IF

!EAST

                IF(i==IUP) THEN
                    IDE = 1
                ELSE
                    IDE = GIDP(i+1)
                END IF

                IF(IDE==0) THEN
                    DCE = VSCP(i)  * LT / LXX / HP(i)
                END IF

!- - - - - - - - - - - - - - - -
! Residual Advection --- Upwind scheme
!- - - - - - - - - - - - - - - -

                IF(i/=IUP.and.i/=ILOW) THEN
                    ADE = DMIN1(REQP(i),0.D0) * LT / LX
                    ADW = -DMAX1(REQP(i-1),0.D0) * LT / LX
                    ADP = (DMAX1(REQP(i),0.D0)-DMIN1(REQP(i-1),0.D0)) * LT / LX
                ELSE
                    ADE = 0.D0
                    ADW = 0.D0
                    ADP = 0.D0
                END IF

!- - - - - - - - - - - - - - - -
! Left hand side of the equation
!- - - - - - - - - - - - - - - -

                IF(IDE==1.AND.IDW==0) THEN

                    amt(1,ic) = - 2.D0*DCW
                    amt(2,ic) = + 2.D0*DCW + 1.D0
                    amt(3,ic) = 0.D0

                ELSEIF(IDW==1.AND.IDE==0) THEN

                    amt(1,ic) =   0.D0
                    amt(2,ic) = + 2.D0*DCE + 1.D0
                    amt(3,ic) = - 2.D0*DCE

                ELSEIF(IDW==1.AND.IDE==1) THEN

                    amt(1,ic) =   0.D0
                    amt(2,ic) =   1.D0
                    amt(3,ic) =   0.D0

                ELSEIF(IDW==0.AND.IDE==0)  THEN

                    amt(1,ic) = - DCW
                    amt(2,ic) = + DCW + DCE + 1.D0
                    amt(3,ic) = - DCE

                ELSEIF(IDW==-2.AND.IDE==0)  THEN   ! zero dirichlet boundary

                    amt(1,ic) =   0.D0
                    amt(2,ic) = + DCW + DCE + 1.D0
                    amt(3,ic) = - DCE

                ELSE

                    WRITE(*,*) ROW, GIDP(i-1) , GIDP(i+1)
                    PAUSE 'tri_matrix_error_1'

                END IF

!- - - - - - - - - - - - - - - -
! Advection term ---- RESIDUAL
!- - - - - - - - - - - - - - - -

#ifdef RESIDUALINC

                amt(1,ic) = amt(1,ic) + ADW
                amt(2,ic) = amt(2,ic) + ADP
                amt(3,ic) = amt(3,ic) + ADE

#endif

!- - - - - - - - - - - - - - - -
! Right hand side of the equation
!- - - - - - - - - - - - - - - -

                amt(4,ic) = VARP(i)

        ! sourse term

                amt(4,ic) = amt(4,ic) + CEP(i)/HP(i)*LT
                amt(2,ic) = amt(2,ic) + WS/HP(i)*LT*BP(i)

            END IF

        END DO

    !    OPEN(5,file='amt.txt')
    !    do i = 1, ic
    !        WRITE(5,'(10e25.10)') (amt(k,i),k=1,4)
    !    end do
    !    CLOSE(5)

        CALL solve3_LU(ic)

        fruit(:) = amt(4,:)

        !IF(pros=='sedi') THEN
        !IF(dir=='y') THEN
        !OPEN(5,file='amt2.txt')
        !do i = 1, ic
        !    WRITE(5,'(10e25.10)') (amt(k,i),k=1,4)
        !end do
        !CLOSE(5)
        !pause 'xg'
        !end IF

    END SUBROUTINE Tridiagonal_1D

    END MODULE Sediment_Transport


      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44
C  IBIS ROUTINE "ibislsq"
C
C  PURPOSE:  PERFORMS A LEAST SQUARES LINEAR FIT TO A NUMBER
C  OF COLUMNS IN AN IBIS INTERFACE FILE PLACING THE SOLUTION
C  COEFFICIENTS AND/OR  RESIDUALS IN OTHER COLUMNS AS DESIRED.
C  THE SOLUTION IS ALSO PRINTED.
C
C   1-95  AMS   (CRI) MSTP S/W CONVERSION (VICAR PORTING)
C   1-87  SXP   Modified to use LLSQ to solve linear least
C               squares system of equations.

	IMPLICIT NONE
	INTEGER	MAXLEN, MAXIND, MAXDEP, MAXTOTLEN
	PARAMETER (MAXLEN = 5000, MAXIND=20, MAXDEP=5,  MAXTOTLEN=10000)
	REAL INDBUF(MAXLEN*MAXIND), A(MAXLEN*MAXIND)
        REAL ASAVE(MAXLEN*MAXIND), DEPBUF(MAXLEN*MAXDEP)
        REAL B(MAXLEN*MAXDEP), BSAVE(MAXLEN*MAXDEP)
	REAL RES(MAXLEN*MAXDEP), RESBUF(MAXTOTLEN*MAXDEP)
	REAL SOLUTION(MAXDEP*MAXIND), SOLBUF(MAXTOTLEN*MAXDEP)
	REAL CONTROL(MAXTOTLEN), LASTCONTROL
	REAL IPIV(MAXIND), AUX(2*MAXIND)
	REAL ROWBUF(40)
	REAL EPS
	INTEGER	CLEN, NCOL, COLS(40),  UNIT, STATUS, UPIBIS, UPRECORD
	INTEGER	INDCOL(MAXIND), DEPCOL(MAXDEP), RESCOL(MAXDEP)
	INTEGER	SOLCOL(MAXDEP), NINDCOL, NDEPCOL, NRESCOL, NSOLCOL
	INTEGER	RESDEF, SOLDEF, CONCOL, DUMMY, CONDEF
	INTEGER	LEN, I,J, ROW, STARTROW, IER, SET
	INTEGER	INDPTR, DEPPTR, RESPTR, SOLPTR
	LOGICAL NOPRINT, XVPTST, NOSOLUTION
	CHARACTER*78	STRING
	DATA	EPS/1.E-7/

	EXTERNAL TRANSPOSE

        CALL IFMESSAGE('IBISLSQ version 2-JAN-95')
        CALL XVEACTION('SA',' ')

C		GET PARAMETERS

	CALL XVP ('INDCOL', INDCOL, NINDCOL)
	CALL XVP ('DEPCOL', DEPCOL, NDEPCOL)
	CALL XVPARM ('SOLCOL', SOLCOL, NSOLCOL, SOLDEF, MAXDEP)
	CALL XVPARM ('RESCOL', RESCOL, NRESCOL, RESDEF, MAXDEP)
	CALL XVPARM ('CONCOL', CONCOL, DUMMY, CONDEF, 1)
	NOPRINT = XVPTST ('NOPRINT')

	IF (RESDEF .EQ. 0) THEN
	    IF (NRESCOL .NE. NDEPCOL) THEN
		CALL XVMESSAGE
     +	  ('NUMBER OF RESIDUAL COLS MUST EQUAL NUMBER OF DEP. COLS',' ')
		CALL ABEND
	    ENDIF
	ENDIF
	IF (SOLDEF .EQ. 0) THEN
	    IF (NSOLCOL .NE. NDEPCOL) THEN
		CALL XVMESSAGE
     +	  ('NUMBER OF SOLUTION COLS MUST EQUAL NUMBER OF DEP. COLS',' ')
		CALL ABEND
	    ENDIF
	ENDIF

C		INITIALIZE VARIABLES
	RESPTR = 1
	SOLPTR = 1
	DO I = 1,40
	    COLS(I) = I
	ENDDO
	SET = 1
	ROW = 1

C		OPEN THE INTERFACE FILE
        CALL XVUNIT(UNIT, 'INP', 1, STATUS, ' ')
	CALL IBIS_FILE_OPEN(UNIT,UPIBIS,'UPDATE',0,0,' ',' ',STATUS)
        IF (STATUS.NE.1) CALL IBIS_SIGNAL_U(UNIT,STATUS,1)
        CALL IBIS_FILE_GET(UPIBIS,'NC',NCOL,1,1)
        CALL IBIS_FILE_GET(UPIBIS,'NR',CLEN,1,1)

	IF (CLEN .GT. MAXTOTLEN) THEN
	    CALL MABEND ('COLUNM LENGTH TOO LONG')
	ENDIF

C		READ IN CONTROL COLUMN
	IF (CONDEF .EQ. 0) THEN
	   CALL IBIS_COLUMN_READ(UPIBIS,CONTROL,CONCOL,1,CLEN,STATUS)
           IF (STATUS.NE.1) CALL IBIS_SIGNAL_U(UPIBIS,STATUS,1)
	ENDIF

C		LOOP THROUGH ALL OF THE SETS OF DATA
100	CONTINUE

C		FILL MATRICES FOR LLSQ

	STARTROW = ROW
	LASTCONTROL = CONTROL(STARTROW)
	INDPTR = 0
	DEPPTR = 0
        CALL IBIS_RECORD_OPEN(UPIBIS,UPRECORD,'FORMAT:REAL',
     &                        COLS,NCOL,'REAL',STATUS)
        IF (STATUS.NE.1) CALL IBIS_SIGNAL_U(UNIT,STATUS,1)
	DO WHILE (ROW .LE. CLEN .AND. CONTROL(ROW) .EQ. LASTCONTROL )
	    CALL IBIS_RECORD_READ(UPRECORD, ROWBUF, ROW, STATUS)
            IF (STATUS.NE.1) CALL IBIS_SIGNAL_U(UPIBIS,STATUS,1)
	    DO I = 1, NINDCOL
		INDBUF(INDPTR+I) = ROWBUF(INDCOL(I))
	    ENDDO
	    INDPTR = INDPTR + NINDCOL
	    DO I = 1, NDEPCOL
		DEPBUF(DEPPTR+I) = ROWBUF(DEPCOL(I))
	    ENDDO
	    DEPPTR = DEPPTR + NDEPCOL
	    LASTCONTROL = CONTROL(ROW)
	    ROW = ROW + 1
	ENDDO
	LEN = ROW - STARTROW
	IF (LEN .GT. MAXLEN) THEN
	    CALL MABEND('SET LENGTH TOO LONG')
	ENDIF

	NOSOLUTION = (LEN .LT. NINDCOL)
	IF (NOSOLUTION) GO TO 999

	CALL TRANSPOSE (INDBUF, A, ASAVE, LEN, NINDCOL)
	CALL TRANSPOSE (DEPBUF, B, BSAVE, LEN, NDEPCOL)

C  PERFORM LEAST SQUARES FIT.

	CALL LLSQ (A, B, LEN, NINDCOL, NDEPCOL,
     +			SOLUTION, IPIV, EPS, IER, AUX)
	IF (IER .NE. 0) THEN
	    CALL XVMESSAGE ('MATRIX RANK TOO SMALL',' ')
	    NOSOLUTION = .TRUE.
	ENDIF

999	CONTINUE
	IF (NOSOLUTION) THEN
	    DO I = 1, NDEPCOL*NINDCOL
		SOLUTION(I) = -999.0
	    ENDDO
	ENDIF

C		CALCULATE THE RESIDUALS

	IF (RESDEF .EQ. 0) THEN
	    CALL CALCRES (ASAVE, BSAVE, SOLUTION, RES,
     +				LEN, NINDCOL, NDEPCOL,   NOSOLUTION)
	    CALL TRANSPOSE (RES, RESBUF(RESPTR), BSAVE, NDEPCOL, LEN)
	    RESPTR = RESPTR + LEN*NDEPCOL
	ENDIF

C		PRINT OUT THE SOLUTION

	CALL TRANSPOSE (SOLUTION, SOLBUF(SOLPTR), BSAVE, NDEPCOL,
     +                  NINDCOL)
	IF (.NOT. NOPRINT) THEN
	    WRITE (STRING, '(A,I3)' )  ' SOLUTION FOR SET: ', SET
	    CALL XVMESSAGE (STRING,' ')
	    DO J = 0, NINDCOL-1
               DO I = 1,NDEPCOL
		  WRITE (STRING((1+(I-1)*14):(1+(I-1)*14+13)),
     +                   '(E12.5,2X)') SOLBUF(SOLPTR+J*NDEPCOL+(I-1))
               ENDDO
	       CALL XVMESSAGE (STRING,' ')
	    ENDDO
	    CALL XVMESSAGE (' ',' ')
	ENDIF
	SOLPTR = SOLPTR + LEN*NDEPCOL

	SET = SET + 1
	IF (ROW .LE. CLEN) GO TO 100
C		GO BACK FOR MORE SETS

	CALL IBIS_FILE_CLOSE (UPIBIS,' ',STATUS)
        IF (STATUS.NE.1) CALL IBIS_SIGNAL_U(UNIT,STATUS,1)

C   REOPEN FILE IF WE NEED TO PUT RESIDUALS OR SOLUTIONS IN IT

	IF (RESDEF .EQ. 0 .OR. SOLDEF .EQ. 0) THEN
            CALL XVUNIT(UNIT, 'INP', 1, STATUS, ' ')
	    CALL IBIS_FILE_OPEN(UNIT,UPIBIS,'UPDATE',0,0,
     &                          ' ',' ',STATUS)
            IF (STATUS.NE.1) CALL IBIS_SIGNAL_U(UNIT,STATUS,1)
            CALL IBIS_FILE_GET(UPIBIS,'NC',NCOL,1,1)
            CALL IBIS_FILE_GET(UPIBIS,'NR',CLEN,1,1)
	    RESPTR = 0
	    SOLPTR = 0
            CALL IBIS_RECORD_OPEN(UPIBIS,UPRECORD,'FORMAT:REAL',
     &                            COLS,NCOL,'REAL',STATUS)
            IF (STATUS.NE.1) CALL IBIS_SIGNAL_U(UNIT,STATUS,1)
	    DO ROW = 1, CLEN
	        CALL IBIS_RECORD_READ(UPRECORD, ROWBUF, ROW, STATUS)
                IF (STATUS.NE.1) CALL IBIS_SIGNAL_U(UPIBIS,STATUS,1)
		IF (RESDEF .EQ. 0) THEN
		    DO I = 1, NDEPCOL
			ROWBUF(RESCOL(I)) = RESBUF(RESPTR+I)
		    ENDDO
		    RESPTR = RESPTR + NDEPCOL
		ENDIF
		IF (SOLDEF .EQ. 0) THEN
		    DO I = 1, NDEPCOL
			ROWBUF(SOLCOL(I)) = SOLBUF(SOLPTR+I)
		    ENDDO
		    SOLPTR = SOLPTR + NDEPCOL
		ENDIF
	        CALL IBIS_RECORD_WRITE(UPRECORD, ROWBUF, ROW, STATUS)
                IF (STATUS.NE.1) CALL IBIS_SIGNAL_U(UPIBIS,STATUS,1)
	    ENDDO
	    CALL IBIS_FILE_CLOSE (UPIBIS,' ',STATUS)
            IF (STATUS.NE.1) CALL IBIS_SIGNAL_U(UNIT,STATUS,1)
	ENDIF

	RETURN
	END

	SUBROUTINE TRANSPOSE (IN, OUT, SAVE,  M, N)
	IMPLICIT NONE
	INTEGER	I,J,  M,N
	REAL	IN(N,M), OUT(M,N), SAVE(M,N)

	DO I = 1, M
	    DO J = 1, N
		OUT(I,J) = IN(J,I)
		SAVE(I,J) = OUT(I,J)
	    ENDDO
	ENDDO

	RETURN
	END

	SUBROUTINE CALCRES (A, B, X, RES, M, N, L, NOSOLUTION)
	IMPLICIT NONE
	INTEGER	I,J,K,  M,N,L
	REAL	A(M,N), B(M,L), X(N,L), RES(M,L), SUM
	LOGICAL	NOSOLUTION

	IF (NOSOLUTION) THEN
	    DO I = 1, M
		DO J = 1, L
		    RES(I,J) = 0.0
		ENDDO
	    ENDDO
	ELSE
	    DO I = 1, M
		DO J = 1, L
		    SUM = B(I,J)
		    DO K = 1, N
			SUM = SUM - A(I,K)*X(K,J)
		    ENDDO
		    RES(I,J) = SUM
		ENDDO
	    ENDDO
	ENDIF

	RETURN
	END


      subroutine fpbacp(a,b,z,n,k,c,k1,nest)
c  subroutine fpbacp calculates the solution of the system of equations
c  g * c = z  with g  a n x n upper triangular matrix of the form
c            ! a '   !
c        g = !   ' b !
c            ! 0 '   !
c  with b a n x k matrix and a a (n-k) x (n-k) upper triangular
c  matrix of bandwidth k1.
c  ..
c  ..scalar arguments..
      integer n,k,k1,nest
c  ..array arguments..
      real*8 a(nest,k1),b(nest,k),z(n),c(n)
c  ..local scalars..
      integer i,i1,j,l,l0,l1,n2
      real*8 store
c  ..
      n2 = n-k
      l = n
      do 30 i=1,k
        store = z(l)
        j = k+2-i
        if(i.eq.1) go to 20
        l0 = l
        do 10 l1=j,k
          l0 = l0+1
          store = store-c(l0)*b(l,l1)
  10    continue
  20    c(l) = store/b(l,j-1)
        l = l-1
        if(l.eq.0) go to 80
  30  continue
      do 50 i=1,n2
        store = z(i)
        l = n2
        do 40 j=1,k
          l = l+1
          store = store-c(l)*b(i,j)
  40    continue
        c(i) = store
  50  continue
      i = n2
      c(i) = c(i)/a(i,1)
      if(i.eq.1) go to 80
      do 70 j=2,n2
        i = i-1
        store = c(i)
        i1 = k
        if(j.le.k) i1=j-1
        l = i
        do 60 l0=1,i1
          l = l+1
          store = store-c(l)*a(i,l0+1)
  60    continue
        c(i) = store/a(i,1)
  70  continue
  80  return
      end


      SUBROUTINE getbrho (brhomn, frho, bsupu, bsupv, mmax, nmax)
      USE stel_kinds
      USE vmec_input, ONLY: nfp, nzeta
      USE vmec_dim, ONLY: ntheta1, ntheta2, ntheta3
      USE vmec_persistent, ONLY: cosmu, sinmu, cosnv, sinnv
      USE vmec_main, ONLY: r0scale
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(in) :: mmax, nmax
      REAL(rprec), INTENT(out) :: brhomn(0:mmax, -nmax:nmax)
      REAL(rprec), DIMENSION(nzeta, ntheta3), INTENT(in) ::
     1    bsupu, bsupv, frho
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: p5 = 0.5_dp, one = 1
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: i, j, m, n, nmax1, itotal, ijtot, mntot
      REAL(rprec) :: ccmn, ssmn, dm, dn, termsc, termcs
      REAL(rprec), ALLOCATABLE :: amatrix(:,:), save_matrix(:,:),
     1   brhs(:)
      LOGICAL :: lpior0
      EXTERNAL solver
C-----------------------------------------------
!
!     Solves the radial force balance B dot Brho = Fs for Brho in real space using collocation
!     Here, Fs = frho(mn) is the Fourier transform SQRT(g)*F (part of radial force
!     balance sans the B dot Brho term)
!

      nmax1 = MAX(0,nmax-1)
      itotal = ntheta2*nzeta - 2*nmax1
      ALLOCATE (amatrix(itotal, itotal),
     1      brhs(itotal), save_matrix(itotal, itotal), stat=m)
      IF (m .ne. 0) STOP 'Allocation error in getbrho'

      amatrix = 0

!
!     BRHO = BSC(M,N)*SIN(MU)COS(NV) + BCS(M,N)*COS(MU)SIN(NV)
!          + BCC(M,N)*COS(MU)COS(NV) + BSS(M,N)*SIN(MU)SIN(NV)   (ONLY IF ASYMMETRIC MODE ALLOWED)
!

      ijtot = 0
      brhs = 0

      DO i = 1, ntheta2
         DO j = 1, nzeta
!           IGNORE u=0,pi POINTS FOR v > pi: REFLECTIONAL SYMMETRY
            lpior0 = ((i.eq.1 .or. i.eq.ntheta2) .and. (j.gt.nzeta/2+1))
            IF (lpior0) CYCLE
            ijtot = ijtot + 1
            brhs(ijtot) = frho(j,i)
            mntot = 0
            DO m = 0, mmax
               DO n = 0, nmax
                  ccmn = cosmu(i,m)*cosnv(j,n)
                  ssmn = sinmu(i,m)*sinnv(j,n)
                  dm = m * bsupu(j,i)
                  dn = n * bsupv(j,i) * nfp
                  termsc = dm*ccmn - dn*ssmn
                  termcs =-dm*ssmn + dn*ccmn
                  IF (n.eq.0 .or. n.eq.nmax) THEN
                     mntot = mntot + 1
                     IF (m .gt. 0) THEN
                        amatrix(ijtot,mntot) = termsc     !!ONLY bsc != 0 for n=0, nmax1
                     ELSE IF (n .eq. 0) THEN
                        amatrix(ijtot,mntot) = bsupv(j,i) !!pedestal for m=0,n=0 mode, which should = 0
                     ELSE
                        amatrix(ijtot,mntot) = termcs     !!bcs(m=0,n=nmax)
                     END IF
                  ELSE IF (m.eq.0 .or. m.eq.mmax) THEN
                     mntot = mntot + 1
                     amatrix(ijtot,mntot) = termcs        !!ONLY bcs != 0 for m=0,mmax
                  ELSE
                     amatrix(ijtot,mntot+1) = termsc
                     amatrix(ijtot,mntot+2) = termcs
                     mntot = mntot + 2
                  END IF
               END DO
            END DO
         END DO
      END DO

      save_matrix = amatrix

      IF (ijtot .ne. itotal .or. mntot .ne. itotal) THEN
         PRINT *,' itotal = ', itotal,' ijtot = ', ijtot,
     1   ' mntot = ', mntot
         STOP
      END IF
      IF (mmax+1 .ne. ntheta2) STOP 'Error 1 in getbrho'
      IF (nmax   .ne. nzeta/2) STOP 'Error 2 in getbrho'

      CALL solver (amatrix, brhs, itotal)

!
!     CHECK SOLUTION FROM SOLVER
!

!      ijtot = 0
!      DO i = 1, ntheta2
!         DO j = 1, nzeta
!           lpior0 = ((i.eq.1 .or. i.eq.ntheta2) .and. (j.gt.nzeta/2+1))
!           IF (lpior0) CYCLE
!           ijtot = ijtot + 1
!           amn = SUM(save_matrix(ijtot,:)*brhs(:))
!           IF (ABS(frho(j,i) - amn) .gt. 1.e-8_dp*ABS(amn))
!    1      PRINT *,' i = ',i,' j = ',j,' Original force = ',
!    2      frho(j,i),' Final force = ', amn
!        END DO
!     END DO

!
!     CONVERT TO BS*SIN(MU - NV) REPRESENTATION
!
      mntot = 0
      brhomn = 0
      DO m = 0, mmax
         DO n = 0, nmax
            IF (n.eq.0 .or. n.eq.nmax) THEN
               mntot = mntot + 1
               IF (m .gt. 0) THEN
                  IF (n .eq. 0) THEN
                     brhomn(m,n) = brhs(mntot)         !!bcs(m,0), m > 0
                  ELSE
                     brhomn(m,n) = p5*brhs(mntot)      !!bsc(m,nmax), m > 0
                     brhomn(m,-n)= p5*brhs(mntot)
                  END IF
               ELSE IF (n .ne. 0) THEN
                  brhomn(m,n) = -brhs(mntot)            !!bcs(0,nmax): needed for derivative
               END IF
            ELSE IF (m.eq.0 .or. m.eq.mmax) THEN
               mntot = mntot + 1
               IF (m .eq. 0) THEN
                  brhomn(m,n)  = -brhs(mntot)          !!bcs(0,n) for n !=0, nmax
               ELSE
                  brhomn(m,n)  = -p5*brhs(mntot)       !!bcs(mmax,n)
                  brhomn(m,-n) =  p5*brhs(mntot)
               END IF
            ELSE
               brhomn(m,n)  = p5*(brhs(mntot+1) - brhs(mntot+2))
               brhomn(m,-n) = p5*(brhs(mntot+1) + brhs(mntot+2))
               mntot = mntot + 2
            END IF
         END DO
      END DO

      IF (mntot .ne. ijtot) STOP 'mntot != ijtot at END of getbrho'

      DEALLOCATE (amatrix, save_matrix, brhs)

      END SUBROUTINE getbrho


subroutine head(x,y)
  double precision :: x
  double precision :: y

  y=tan(x)

end subroutine


program compute_center_of_mass
use, intrinsic :: iso_fortran_env
use hdf5
implicit none
integer, parameter :: sp = REAL32
integer, parameter :: mass_rank = 1, pos_rank = 2
character(len=1024) :: file_name
character(len=50), parameter :: mass_loc = "particles/mass", &
                                pos_loc = "particles/position"
integer(hid_t) :: file_id, mass_dset_id, mass_dspace_id, &
                  pos_dset_id, pos_dspace_id
integer(hsize_t), dimension(mass_rank) :: mass_dim, mass_max_dim
integer(hsize_t), dimension(pos_rank) :: pos_dim, pos_max_dim
integer :: status
real(kind=sp), dimension(:), allocatable :: mass
real(kind=sp), dimension(:, :), allocatable :: pos
real(kind=sp) :: total_mass
real(kind=sp), dimension(:), allocatable :: center_pos
integer :: i

! check whether at least one command line argument was given
if (command_argument_count() < 1) then
    write (unit=error_unit, fmt="(A)") "#error: expecting file name"
    stop
end if

! get command line argument
call get_command_argument(1, file_name)
file_name = trim(file_name)

! open HDF5 Fortran interface
call h5open_f(status)

! open HDF5 file
call h5fopen_f(file_name, H5F_ACC_RDONLY_F, file_id, status)
if (status /= 0) then
    write (unit=error_unit, fmt="(A, A)") "#error: can not open file ", &
                                          file_name
    stop
end if

! open mass and position dataset
call h5dopen_f(file_id, mass_loc, mass_dset_id, status)
if (status /= 0) then
    write (unit=error_unit, fmt="(A, A)") "#error: can not open dataset ", &
                                          file_name
    stop
end if
call h5dopen_f(file_id, pos_loc, pos_dset_id, status)
if (status /= 0) then
    write (unit=error_unit, fmt="(A, A)") "#error: can not open dataset ", &
                                          file_name
    stop
end if

! get correspoding dataspaces
call h5dget_space_f(mass_dset_id, mass_dspace_id, status)
call h5dget_space_f(pos_dset_id, pos_dspace_id, status)

! find mass and position dimensions
call h5sget_simple_extent_dims_f(mass_dspace_id, mass_dim, mass_max_dim, &
                                 status)
call h5sget_simple_extent_dims_f(pos_dspace_id, pos_dim, pos_max_dim, &
                                 status)

! allocate mass array
allocate(mass(mass_dim(1)))
allocate(pos(pos_dim(1), pos_dim(2)))
allocate(center_pos(pos_dim(1)))

! read mass data
call h5dread_f(mass_dset_id, H5T_NATIVE_REAL, mass, mass_dim, status)
call h5dread_f(pos_dset_id, H5T_NATIVE_REAL, pos, pos_dim, status)

! close mass and position data set
call h5dclose_f(mass_dset_id, status)
call h5dclose_f(pos_dset_id, status)

! close HDF5 file
call h5fclose_f(file_id, status)

! close HDF5 Fortran interface
call h5close_f(status)

! compute center of mass and print it
total_mass = sum(mass)
center_pos(:) = 0.0_sp
do i = 1, pos_dim(2)
    center_pos(:) = center_pos(:) + mass(i)*pos(:, i)
end do
center_pos = center_pos/total_mass
print "(3E15.6)", center_pos

! deallocate mass and pos
deallocate(mass)
deallocate(pos)
deallocate(center_pos)

end program compute_center_of_mass


* FORTRAN test file to implement the DATA statement
* This file uses the DATA statement to assign arrays

**********************************************************************
* Expected Output:  X: 9.0
*
*                   VEC:
*                   9.0
*                   9.0
*                   0.1
*                   0.5
*                   0.5
*
*                   Y: 6.0
**********************************************************************

      PROGRAM MAIN

      IMPLICIT NONE

      REAL, DIMENSION(5) :: VEC
      REAL :: X,Y

      DATA X,VEC,Y /3*9.0, 0.1, 2*0.5,6.0/
*      DATA VEC,X,Y /7*2/

      INTEGER :: I

      WRITE(*,30) 'X: ', X

      WRITE (*,11)
      WRITE (*,12) 'VEC: '
      DO I = 1, 5
          WRITE (*,10) VEC(I)
      END DO

      WRITE (*,11)
      WRITE(*,30) 'Y: ', Y

 10   FORMAT(F3.1)
 11   FORMAT('')
 12   FORMAT(A)
 20   FORMAT(4(F3.1,2X))
 30   FORMAT(A, F3.1)

      END PROGRAM MAIN


program serial_rectangular_prism_test
    use precision,      only : i4k, r8k
    use vtk_datasets,   only : struct_pts
    use vtk_attributes, only : scalar, attributes
    use vtk,            only : vtk_serial_write
    implicit none
    !! author: Ian Porter
    !! date: 12/28/2017
    !!
    !! this is a test of a rectangular_prism geometry using structured points
    !!
    integer(i4k), parameter     :: n_params_to_write = 3
    type (struct_pts)           :: rectangular_prism
    type (attributes), dimension(n_params_to_write) :: vals_to_write
    integer(i4k)                :: i = 0_i4k
    integer(i4k),     parameter :: n_x = 11, n_y = 6, n_z = 3, unit = 20
    real(r8k)                   :: j = 0.0_r8k
    real(r8k),        parameter :: temp_val = 555.0_r8k
    character(len=*), parameter :: filename = 'serial_struct_pts'
    character(len=*), parameter :: title    = 'testing of rectangular_prism geometry'
    integer(i4k), dimension(3)  :: dims
    real(r8k), dimension(3), parameter :: origin  = &
        & [ 0.0_r8k, 0.0_r8k, 0.0_r8k ]
    real(r8k), dimension(3), parameter :: spacing = &
        & [ 0.3_r8k, 0.2_r8k, 0.1_r8k ]
    real(r8k), dimension(n_x*n_y*n_z,1:n_params_to_write) :: vals
    character(len=20), dimension(n_params_to_write), parameter :: dataname = &
        & [ 'temperature_(k)     ', 'pressure_(pa)       ', 'stress_(pa)         ' ]

    vals(1,:) = temp_val
    do i = 2, size(vals,dim=1)
        if (i <= size(vals) / 2) then
            vals(i,1) = vals(i-1,1) + 2.0_r8k          !! temperature
        else
            vals(i,1) = vals(i-1,1) - 2.0_r8k          !! temperature
        end if
        j = j + 1.0_r8k
        vals(i,2) = vals(i-1,2) + max(50.0_r8k, j)     !! pressure
        vals(i,3) = vals(i-1,3) + sqrt(real(i))        !! stress
    end do
    dims = [ n_x, n_y, n_z ]
    call rectangular_prism%init (dims=dims, origin=origin, spacing=spacing)
    do i = 1, n_params_to_write
        if (.not. allocated(vals_to_write(i)%attribute))then
            allocate(scalar::vals_to_write(i)%attribute)
        end if
        call vals_to_write(i)%attribute%init (trim(dataname(i)), numcomp=1, real1d=vals(:,i))
    end do

    call vtk_serial_write (rectangular_prism, pointdatasets=vals_to_write, unit=unit, filename=filename, title=title)

    write(*,*) 'Finished'

end program serial_rectangular_prism_test


program test
implicit none
integer, ALLOCATABLE , DIMENSION(:)::  x
integer, ALLOCATABLE , DIMENSION(:)::  y
real z
call AddToListInt(y,15)
call AddToListInt(y,156)
call AddToListInt(y,155)
call AddToListInt(y,175)
call AddToListInt(y,185)
z = sum_(y)
call essai(5,y)
print *, 20
contains

    subroutine essai(n, x)
        integer, INTENT(IN) :: n
        integer, ALLOCATABLE , DIMENSION(:), INTENT(INOUT) ::  x
        integer i
        x = (/5,4,6,8,4,6/)
        call AddToListInt(x,63)
        do i=1, size(x)
            print *, x(i)
        end do
        i = sum_(x)
        print *, i
    end subroutine

    FUNCTION sum_(x) RESULT(y)
    INTEGER ,ALLOCATABLE, DIMENSION(: ), INTENT(IN):: x
    INTEGER:: y
    INTEGER:: i
    INTEGER:: i_cyml0
    y = 0
    DO i_cyml0 = 1, SIZE(x)
        i = x(i_cyml0)
        y = y + i
    END DO
    END FUNCTION sum_

    SUBROUTINE AddToListInt(list, element)
        IMPLICIT NONE
        INTEGER :: i, isize
        INTEGER, INTENT(IN) :: element
        INTEGER, DIMENSION(:), ALLOCATABLE, INTENT(INOUT) :: list
        INTEGER, DIMENSION(:), ALLOCATABLE :: clist
        IF(ALLOCATED(list)) THEN
            isize = SIZE(list)
            ALLOCATE(clist(isize+1))
            DO i=1,isize
                clist(i) = list(i)
            END DO
            clist(isize+1) = element
            DEALLOCATE(list)
            CALL MOVE_ALLOC(clist, list)
        ELSE
            ALLOCATE(list(1))
            list(1) = element
        END IF
    END SUBROUTINE AddToListInt

end program