C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 2011 by UCAR                   *
C     *                                                               *
C     *       University Corporation for Atmospheric Research         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                     FFTPACK  version 5.1                      *
C     *                                                               *
C     *                 A Fortran Package of Fast Fourier             *
C     *                                                               *
C     *                Subroutines and Example Programs               *
C     *                                                               *
C     *                             by                                *
C     *                                                               *
C     *               Paul Swarztrauber and Dick Valent               *
C     *                                                               *
C     *                             of                                *
C     *                                                               *
C     *         the National Center for Atmospheric Research          *
C     *                                                               *
C     *                Boulder, Colorado  (80307)  U.S.A.             *
C     *                                                               *
C     *                   which is sponsored by                       *
C     *                                                               *
C     *              the National Science Foundation                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      SUBROUTINE TABLES (IDO,IP,WA)
      REAL  WA(IDO,IP-1,2)
C
      TPI = 8.*ATAN(1.)
      ARGZ = TPI/REAL(IP)
      ARG1 = TPI/REAL(IDO*IP)
      DO 110 J=2,IP
         ARG2 = REAL(J-1)*ARG1
         DO 100 I=1,IDO
            ARG3 = REAL(I-1)*ARG2
            WA(I,J-1,1) = COS(ARG3)
            WA(I,J-1,2) = SIN(ARG3)
  100    CONTINUE
         IF (IP .LE. 5) GO TO 110
         ARG4 = REAL(J-1)*ARGZ
         WA(1,J-1,1) = COS(ARG4)
         WA(1,J-1,2) = SIN(ARG4)
  110 CONTINUE
      RETURN
      END


c----+----1----+----2
      program arithmetic

      integer number1,number2
      integer sum,diff,mul,div,pow

      write(6,*) 'Input the number 1'
      read(5,*) number1
      write(6,*) 'Input the number 2'
      read(5,*) number2

      sum=number1+number2
      diff=number1-number2
      mul=number1*number2
      div=number1/number2
      pow=number1**number2

      write(6,*) number1,' + ',number2,' = ',sum
      write(6,*) number1,' - ',number2,' = ',diff
      write(6,*) number1,' * ',number2,' = ',mul
      write(6,*) number1,' / ',number2,' = ',div
      write(6,*) number1,' ** ',number2,' = ',pow
      stop
      end


!!!    This program sloves Lid Driven Cavity Flow problem using Lattice Boltzmann Method
!!!    Lattice Boltzmann Equation with MRT-LBE model

module commondata
    implicit none

    integer, parameter :: nx=65, ny=65, nz =65
    integer, parameter :: nxHalf=(nx-1)/2+1, nyHalf=(ny-1)/2+1, nzHalf=(nz-1)/2+1
    real(8), parameter :: Reynolds=1000.0d0
    real(8), parameter :: rho0=1.0d0
    real(8), parameter :: U0=0.1d0
    real(8), parameter :: tauf=U0*dble(nx)/Reynolds*3.0d0+0.5d0

    integer :: itc
    integer, parameter :: itc_max=INT(50000000)

    real(8) :: errorU
    real(8), parameter :: eps=1e-6

    real(8) :: xp(0:nx+1), yp(0:ny+1), zp(0:nz+1)
    real(8), allocatable :: u(:, :, :), v(:, :, :), w(:, :, :)
    real(8), allocatable :: rho(:, :, :)
    real(8), allocatable :: up(:, :, :), vp(:, :, :), wp(:, :, :)

    real(8), allocatable :: f(:, :, :, :), f_post(:, :, :, :)

    integer :: idx
    ! real(8), parameter :: omega(0:18) = (/ 1.0d0/3.0d0, &
    !         1.0d0/18.0d0, 1.0d0/18.0d0, 1.0d0/18.0d0, 1.0d0/18.0d0, 1.0d0/18.0d0, 1.0d0/18.0d0, &
    !         1.0d0/36.0d0, 1.0d0/36.0d0, 1.0d0/36.0d0, 1.0d0/36.0d0, 1.0d0/36.0d0, 1.0d0/36.0d0, &
    !         1.0d0/36.0d0, 1.0d0/36.0d0, 1.0d0/36.0d0, 1.0d0/36.0d0, 1.0d0/36.0d0, 1.0d0/36.0d0 /)
    real(8), parameter :: omega(0:18) = (/ 1.0d0/3.0d0, &
                                        (1.0d0/18.0d0, idx = 1, 6), &
                                        (1.0d0/36.0d0, idx = 7, 18) /)
    integer, parameter :: ex(0:18) = (/ 0,  &
                                        1, -1,  0,  0,  0,  0, &
                                        1, -1,  1, -1,  1, -1,  1, -1,  0,  0,  0,  0 /)
    integer, parameter :: ey(0:18) = (/ 0, &
                                        0,  0,  1, -1,  0,  0, &
                                        1,  1, -1, -1,  0,  0,  0,  0,  1, -1,  1, -1 /)
    integer, parameter :: ez(0:18) = (/ 0, &
                                        0,  0,  0,  0,  1, -1, &
                                        0,  0,  0,  0,  1,  1, -1, -1,  1,  1, -1, -1 /)

    real(8), parameter :: Snu=1.0d0/tauf, Sq=8.0d0*(2.0d0*tauf-1.0d0)/(8.0d0*tauf-1.0d0)
end module commondata

program main
    use commondata
    implicit none
    real(8) :: start, finish
    real(8) :: start2, finish2
    integer :: myMaxThreads

    write(*,*) "--------------------------"
    write(*,*) "I am MRT collision operator"
    write(*,*) "--------------------------"

    call initial()
    ! call output_ASCII()
    call output_Tecplot()

    call CPU_TIME(start)

    do while((errorU.GT.eps).AND.(itc.LE.itc_max))

        itc = itc+1

        call collision()

        call streaming()

        call bounceback()

        call macro()

        if(MOD(itc,2000).EQ.0) then
            call check()
            ! call output_ASCII()
            ! call getVelocity()
        endif

        if(MOD(itc,20000).EQ.0) then
            call getVelocity()
        endif

        if(MOD(itc,10000) .EQ. 0) then
            EXIT
        endif

    enddo

    call CPU_TIME(finish)

    write(*,*) "Time (CPU) = ", real(finish-start), "s"

    itc = itc+1
    call output_Tecplot()
    ! call output_ASCII()
    call output_binary()
    call getVelocity()

    write(*,*) "Deallocate Array..."
    deallocate(u)
    deallocate(v)
    deallocate(w)
    deallocate(rho)
    deallocate(up)
    deallocate(vp)
    deallocate(wp)
    deallocate(f)
    deallocate(f_post)
    write(*,*) "    "

    write(*,*) "Successfully: DNS completed!"

    stop
end program main

subroutine initial()
    use commondata
    implicit none
    integer :: i, j, k
    integer :: alpha
    real(8) :: un(0:18)
    real(8) :: us2

    itc = 0
    errorU = 100.0d0

    write(*,*) "nx=",nx,", ny=",ny, ",  nz = ",nz
    write(*,*) "Reynolds=",real(Reynolds)
    write(*,*) "U0=",real(U0),",    tauf=",real(tauf)

    xp(0) = 0.0d0
    xp(nx+1) = dble(nx)
    do i=1,nx
        xp(i) = dble(i)-0.5d0
    enddo
    yp(0) = 0.0d0
    yp(ny+1) = dble(ny)
    do j=1,ny
        yp(j) = dble(j)-0.5d0
    enddo
    zp(0) = 0.0d0
    zp(nz+1) = dble(nz)
    do k=1,nz
        zp(k) = dble(k)-0.5d0
    enddo

    allocate (u(nx, ny, nz))
    allocate (v(nx, ny, nz))
    allocate (w(nx, ny, nz))
    allocate (rho(nx, ny, nz))
    allocate (up(nx, ny, nz))
    allocate (vp(nx, ny, nz))
    allocate (wp(nx, ny, nz))

    allocate (f(0:18, nx, ny, nz))
    allocate (f_post(0:18, 0:nx+1, 0:ny+1, 0:nz+1))

    rho = rho0
    u = 0.0d0
    v = 0.0d0
    w = 0.0d0
    up = 0.0d0
    vp = 0.0d0
    wp = 0.0d0

    do j = 1, ny
        do i = 1, nx
            u(i, j, nz) = U0
        enddo
    enddo

    do k = 1, nz
        do j = 1, ny
            do i = 1, nx
                us2 = u(i,j,k)*u(i,j,k) + v(i,j,k)*v(i,j,k) + w(i,j,k)*w(i,j,k)
                do alpha = 0, 18
                    un(alpha) = u(i,j,k)*ex(alpha) + v(i,j,k)*ey(alpha) + w(i,j,k)*ez(alpha)
                    f(alpha,i,j,k) = rho(i,j,k)*omega(alpha)*(1.0d0+3.0d0*un(alpha)+4.5d0*un(alpha)*un(alpha)-1.5d0*us2)
                enddo
            enddo
        enddo
    enddo

    return
end subroutine initial

subroutine collision()
    use commondata
    implicit none
    integer :: i, j, k
    integer :: alpha
    !---------------------------
    real(8) :: s(0:18)
    real(8) :: m(0:18)
    real(8) :: m_post(0:18)
    real(8) :: meq(0:18)
    !---------------------------
    ! real(8) :: us2, un, feq
    !---------------------------

    do k = 1, nz
        do j = 1, ny
            do i = 1, nx
    ! loop body, re-indented for readability

    m(0) = f(0,i,j,k) &
        + f(1,i,j,k) + f(2,i,j,k) + f(3,i,j,k) + f(4,i,j,k) + f(5,i,j,k) + f(6,i,j,k) &
        + f(7,i,j,k) + f(8,i,j,k) + f(9,i,j,k) + f(10,i,j,k) + f(11,i,j,k) + f(12,i,j,k) &
        + f(13,i,j,k) + f(14,i,j,k) + f(15,i,j,k) + f(16,i,j,k) + f(17,i,j,k) + f(18,i,j,k)
    m(1) = -30.0d0 * f(0,i,j,k) &
        - 11.0d0 * (f(1,i,j,k) + f(2,i,j,k) + f(3,i,j,k) + f(4,i,j,k) + f(5,i,j,k) + f(6,i,j,k)) &
        + 8.0d0 * (f(7,i,j,k) + f(8,i,j,k) + f(9,i,j,k) + f(10,i,j,k) + f(11,i,j,k) + f(12,i,j,k)) &
        + 8.0d0 * (f(13,i,j,k) + f(14,i,j,k) + f(15,i,j,k) + f(16,i,j,k) + f(17,i,j,k) + f(18,i,j,k))
    m(2) = 12.0d0 * f(0,i,j,k) &
        - 4.0d0 * (f(1,i,j,k) + f(2,i,j,k) + f(3,i,j,k) + f(4,i,j,k) + f(5,i,j,k) + f(6,i,j,k)) &
        + f(7,i,j,k) + f(8,i,j,k) + f(9,i,j,k) + f(10,i,j,k) + f(11,i,j,k) + f(12,i,j,k) &
        + f(13,i,j,k) + f(14,i,j,k) + f(15,i,j,k) + f(16,i,j,k) + f(17,i,j,k) + f(18,i,j,k)
    m(3) = f(1,i,j,k) - f(2,i,j,k) &
        + f(7,i,j,k) - f(8,i,j,k) + f(9,i,j,k) - f(10,i,j,k) + f(11,i,j,k) - f(12,i,j,k) &
        + f(13,i,j,k) - f(14,i,j,k)
    m(4) = -4.0d0 * (f(1,i,j,k) - f(2,i,j,k)) &
        + f(7,i,j,k) - f(8,i,j,k) + f(9,i,j,k) - f(10,i,j,k) + f(11,i,j,k) - f(12,i,j,k) &
        + f(13,i,j,k) - f(14,i,j,k)
    m(5) = f(3,i,j,k) - f(4,i,j,k) &
        + f(7,i,j,k) + f(8,i,j,k) - f(9,i,j,k) - f(10,i,j,k) &
        + f(15,i,j,k) - f(16,i,j,k) + f(17,i,j,k) - f(18,i,j,k)
    m(6) = -4.0d0 * (f(3,i,j,k) - f(4,i,j,k)) &
        + f(7,i,j,k) + f(8,i,j,k) - f(9,i,j,k) - f(10,i,j,k) &
        + f(15,i,j,k) - f(16,i,j,k) + f(17,i,j,k) - f(18,i,j,k)
    m(7) = f(5,i,j,k) - f(6,i,j,k) &
        + f(11,i,j,k) + f(12,i,j,k) &
        - f(13,i,j,k) - f(14,i,j,k) + f(15,i,j,k) + f(16,i,j,k) - f(17,i,j,k) - f(18,i,j,k)
    m(8) = -4.0d0 * (f(5,i,j,k) - f(6,i,j,k)) &
        + f(11,i,j,k) + f(12,i,j,k) &
        - f(13,i,j,k) - f(14,i,j,k) + f(15,i,j,k) + f(16,i,j,k) - f(17,i,j,k) - f(18,i,j,k)
    m(9) = 2.0d0 * (f(1,i,j,k) + f(2,i,j,k)) - f(3,i,j,k) - f(4,i,j,k) - f(5,i,j,k) - f(6,i,j,k) &
        + f(7,i,j,k) + f(8,i,j,k) + f(9,i,j,k) + f(10,i,j,k) + f(11,i,j,k) + f(12,i,j,k) &
        + f(13,i,j,k) + f(14,i,j,k) - 2.0 * (f(15,i,j,k) + f(16,i,j,k) + f(17,i,j,k) + f(18,i,j,k))
    m(10) = -4.0d0 * (f(1,i,j,k) + f(2,i,j,k)) + 2.0d0 * (f(3,i,j,k) + f(4,i,j,k) + f(5,i,j,k) + f(6,i,j,k)) &
        + f(7,i,j,k) + f(8,i,j,k) + f(9,i,j,k) + f(10,i,j,k) + f(11,i,j,k) + f(12,i,j,k) &
        + f(13,i,j,k) + f(14,i,j,k) - 2.0 * (f(15,i,j,k) + f(16,i,j,k) + f(17,i,j,k) + f(18,i,j,k))
    m(11) = f(3,i,j,k) + f(4,i,j,k) - f(5,i,j,k) - f(6,i,j,k) &
        + f(7,i,j,k) + f(8,i,j,k) + f(9,i,j,k) + f(10,i,j,k) - f(11,i,j,k) - f(12,i,j,k) &
        - f(13,i,j,k) - f(14,i,j,k)
    m(12) = -2.0d0 * (f(3,i,j,k) + f(4,i,j,k) - f(5,i,j,k) - f(6,i,j,k)) &
        + f(7,i,j,k) + f(8,i,j,k) + f(9,i,j,k) + f(10,i,j,k) - f(11,i,j,k) - f(12,i,j,k) &
        - f(13,i,j,k) - f(14,i,j,k)
    m(13) = f(7,i,j,k) - f(8,i,j,k) - f(9,i,j,k) + f(10,i,j,k)
    m(14) = f(15,i,j,k) - f(16,i,j,k) - f(17,i,j,k) + f(18,i,j,k)
    m(15) = f(11,i,j,k) - f(12,i,j,k) - f(13,i,j,k) + f(14,i,j,k)
    m(16) = f(7,i,j,k) - f(8,i,j,k) + f(9,i,j,k) - f(10,i,j,k) - f(11,i,j,k) + f(12,i,j,k) &
        - f(13,i,j,k) + f(14,i,j,k)
    m(17) = -f(7,i,j,k) - f(8,i,j,k) + f(9,i,j,k) + f(10,i,j,k) &
        + f(15,i,j,k) - f(16,i,j,k) + f(17,i,j,k) - f(18,i,j,k)
    m(18) = f(11,i,j,k) + f(12,i,j,k) &
        - f(13,i,j,k) - f(14,i,j,k) - f(15,i,j,k) - f(16,i,j,k) + f(17,i,j,k) + f(18,i,j,k)

        meq(0) = rho(i,j,k)
        meq(1) = rho(i,j,k) * (-11.0d0 + 19.0d0 * (u(i,j,k)*u(i,j,k) + v(i,j,k)*v(i,j,k) + w(i,j,k)*w(i,j,k)))
        meq(2) = rho(i,j,k) * (3.0d0 - 11.0d0/2.0d0 * (u(i,j,k)*u(i,j,k) + v(i,j,k)*v(i,j,k) + w(i,j,k)*w(i,j,k)))
        meq(3) = rho(i,j,k) * u(i,j,k)
        meq(4) = -2.0d0/3.0d0 * rho(i,j,k) * u(i,j,k)
        meq(5) = rho(i,j,k) * v(i,j,k)
        meq(6) = -2.0d0/3.0d0 * rho(i,j,k) * v(i,j,k)
        meq(7) = rho(i,j,k) * w(i,j,k)
        meq(8) = -2.0d0/3.0d0 * rho(i,j,k) * w(i,j,k)
        meq(9) = rho(i,j,k) * (2.0d0 * u(i,j,k)*u(i,j,k) - v(i,j,k)*v(i,j,k) - w(i,j,k)*w(i,j,k))
        meq(10) = -1.0d0/2.0d0 * rho(i,j,k) * (2.0d0 * u(i,j,k)*u(i,j,k) - v(i,j,k)*v(i,j,k) - w(i,j,k)*w(i,j,k))
        meq(11) = rho(i,j,k) * (v(i,j,k)*v(i,j,k) - w(i,j,k)*w(i,j,k))
        meq(12) = -1.0d0/2.0d0 * (v(i,j,k)*v(i,j,k) - w(i,j,k)*w(i,j,k))
        meq(13) = rho(i,j,k) * u(i,j,k) * v(i,j,k)
        meq(14) = rho(i,j,k) * v(i,j,k) * w(i,j,k)
        meq(15) = rho(i,j,k) * u(i,j,k) * w(i,j,k)
        meq(16) = 0.0d0
        meq(17) = 0.0d0
        meq(18) = 0.0d0

        s(0) = 0.0d0    !! s_{\rho}
        s(1) = Snu      !! s_{e}
        s(2) = Snu      !! s_{epsilon}
        s(3) = 0.0d0    !! s_{j}
        s(4) = Sq       !! s_{q}
        s(5) = 0.0d0    !! s_{j}
        s(6) = Sq       !! s_{q}
        s(7) = 0.0d0    !! s_{j}
        s(8) = Sq       !! s_{q}
        s(9) = Snu      !! s_{\nu}
        s(10) = Snu     !! s_{\pi}
        s(11) = Snu     !! s_{\nu}
        s(12) = Snu     !! s_{\pi}
        s(13) = Snu     !! s_{nu}
        s(14) = Snu     !! s_{nu}
        s(15) = Snu     !! s_{nu}
        s(16) = Sq      !! s_{m}
        s(17) = Sq      !! s_{m}
        s(18) = Sq      !! s_{m}

        do alpha=0,18
            m_post(alpha) = m(alpha)-s(alpha)*(m(alpha)-meq(alpha))
        enddo

    f_post(0,i,j,k) = m_post(0)/19.0d0 - 5.0d0/399.0d0*m_post(1) + m_post(2)/21.0d0

    ! ------------
    f_post(1,i,j,k) = m_post(0)/19.0d0 - 11.0d0/2394.0d0*m_post(1) - m_post(2)/63.0d0 + m_post(3)/10.0d0 &
        - m_post(4)/10.0d0 + m_post(9)/18.0d0 - m_post(10)/18.0d0

    f_post(2,i,j,k) = m_post(0)/19.0d0 - 11.0d0/2394.0d0*m_post(1) - m_post(2)/63.0d0 - m_post(3)/10.0d0 &
        + m_post(4)/10.0d0 + m_post(9)/18.0d0 - m_post(10)/18.0d0

    ! ------------
    f_post(3,i,j,k) = m_post(0)/19.0d0 - 11.0d0/2394.0d0*m_post(1) - m_post(2)/63.0d0 + m_post(5)/10.0d0 &
        - m_post(6)/10.0d0 - m_post(9)/36.0d0 + m_post(10)/36.0d0 + m_post(11)/12.0d0 - m_post(12)/12.0d0

    f_post(4,i,j,k) = m_post(0)/19.0d0 - 11.0d0/2394.0d0*m_post(1) - m_post(2)/63.0d0 - m_post(5)/10.0d0 &
        + m_post(6)/10.0d0 - m_post(9)/36.0d0 + m_post(10)/36.0d0 + m_post(11)/12.0d0 - m_post(12)/12.0d0

    f_post(5,i,j,k) = m_post(0)/19.0d0 - 11.0d0/2394.0d0*m_post(1) - m_post(2)/63.0d0 + m_post(7)/10.0d0 &
        - m_post(8)/10.0d0 - m_post(9)/36.0d0 + m_post(10)/36.0d0 - m_post(11)/12.0d0 + m_post(12)/12.0d0

    f_post(6,i,j,k) = m_post(0)/19.0d0 - 11.0d0/2394.0d0*m_post(1) - m_post(2)/63.0d0 - m_post(7)/10.0d0 &
        + m_post(8)/10.0d0 - m_post(9)/36.0d0 + m_post(10)/36.0d0 - m_post(11)/12.0d0 + m_post(12)/12.0d0

    ! ------------
    f_post(7,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 + m_post(3)/10.0d0 &
        + m_post(4)/40.0d0 + m_post(5)/10.0d0 + m_post(6)/40.0d0 + m_post(9)/36.0d0 + m_post(10)/72.0d0 &
        + m_post(11)/12.0d0 + m_post(12)/24.0d0 + m_post(13)/4.0d0 + m_post(16)/8.0d0 - m_post(17)/8.0d0

    f_post(8,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 - m_post(3)/10.0d0 &
        - m_post(4)/40.0d0 + m_post(5)/10.0d0 + m_post(6)/40.0d0 + m_post(9)/36.0d0 + m_post(10)/72.0d0 &
        + m_post(11)/12.0d0 + m_post(12)/24.0d0 - m_post(13)/4.0d0 - m_post(16)/8.0d0 - m_post(17)/8.0d0

    f_post(9,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 + m_post(3)/10.0d0 &
        + m_post(4)/40.0d0 - m_post(5)/10.0d0 - m_post(6)/40.0d0 + m_post(9)/36.0d0 + m_post(10)/72.0d0 &
        + m_post(11)/12.0d0 + m_post(12)/24.0d0 - m_post(13)/4.0d0 + m_post(16)/8.0d0 + m_post(17)/8.0d0

    f_post(10,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 - m_post(3)/10.0d0 &
        - m_post(4)/40.0d0 - m_post(5)/10.0d0 - m_post(6)/40.0d0 + m_post(9)/36.0d0 + m_post(10)/72.0d0 &
        + m_post(11)/12.0d0 + m_post(12)/24.0d0 + m_post(13)/4.0d0 - m_post(16)/8.0d0 + m_post(17)/8.0d0

    ! -----------
    f_post(11,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 + m_post(3)/10.0d0 &
        + m_post(4)/40.0d0 + m_post(7)/10.0d0 + m_post(8)/40.0d0 + m_post(9)/36.0d0 + m_post(10)/72.0d0 &
        - m_post(11)/12.0d0 - m_post(12)/24.0d0 + m_post(15)/4.0d0 - m_post(16)/8.0d0 + m_post(18)/8.0d0

    f_post(12,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 - m_post(3)/10.0d0 &
        - m_post(4)/40.0d0 + m_post(7)/10.0d0 + m_post(8)/40.0d0 + m_post(9)/36.0d0 + m_post(10)/72.0d0 &
        - m_post(11)/12.0d0 - m_post(12)/24.0d0 - m_post(15)/4.0d0 + m_post(16)/8.0d0 + m_post(18)/8.0d0

    f_post(13,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 + m_post(3)/10.0d0 &
        + m_post(4)/40.0d0 - m_post(7)/10.0d0 - m_post(8)/40.0d0 + m_post(9)/36.0d0 + m_post(10)/72.0d0 &
        - m_post(11)/12.0d0 - m_post(12)/24.0d0 - m_post(15)/4.0d0 - m_post(16)/8.0d0 - m_post(18)/8.0d0

    f_post(14,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 - m_post(3)/10.0d0 &
        - m_post(4)/40.0d0 - m_post(7)/10.0d0 - m_post(8)/40.0d0 + m_post(9)/36.0d0 + m_post(10)/72.0d0 &
        - m_post(11)/12.0d0 - m_post(12)/24.0d0 + m_post(15)/4.0d0 + m_post(16)/8.0d0 - m_post(18)/8.0d0

    ! -----------
    f_post(15,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 + m_post(5)/10.0d0 &
        + m_post(6)/40.0d0 + m_post(7)/10.0d0 + m_post(8)/40.0d0 - m_post(9)/18.0d0 - m_post(10)/36.0d0 &
        + m_post(14)/4.0d0 + m_post(17)/8.0d0 - m_post(18)/8.0d0

    f_post(16,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 - m_post(5)/10.0d0 &
        - m_post(6)/40.0d0 + m_post(7)/10.0d0 + m_post(8)/40.0d0 - m_post(9)/18.0d0 - m_post(10)/36.0d0 &
        - m_post(14)/4.0d0 - m_post(17)/8.0d0 - m_post(18)/8.0d0

    f_post(17,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 + m_post(5)/10.0d0 &
        + m_post(6)/40.0d0 - m_post(7)/10.0d0 - m_post(8)/40.0d0 - m_post(9)/18.0d0 - m_post(10)/36.0d0 &
        - m_post(14)/4.0d0 + m_post(17)/8.0d0 + m_post(18)/8.0d0

    f_post(18,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 - m_post(5)/10.0d0 &
        - m_post(6)/40.0d0 - m_post(7)/10.0d0 - m_post(8)/40.0d0 - m_post(9)/18.0d0 - m_post(10)/36.0d0 &
        + m_post(14)/4.0d0 - m_post(17)/8.0d0 + m_post(18)/8.0d0

                ! us2 = u(i,j,k)*u(i,j,k) + v(i,j,k)*v(i,j,k) + w(i,j,k)*w(i,j,k)
                ! do alpha = 0, 18
                !     un = u(i,j,k)*ex(alpha) + v(i,j,k)*ey(alpha) + w(i,j,k)*ez(alpha)
                !     feq = rho(i,j,k) * omega(alpha) * (1.0d0 + 3.0d0*un + 4.5d0*un*un - 1.5d0*us2)

                !     f_post(alpha,i,j,k) = f(alpha,i,j,k) - Snu*(f(alpha,i,j,k) - feq)
                ! enddo

            enddo
        enddo
    enddo

    return
end subroutine collision

subroutine streaming()
    use commondata
    implicit none
    integer :: i, j, k
    integer :: ip, jp, kp
    integer :: alpha

    do k = 1, nz
        do j = 1, ny
            do i = 1, nx
                do alpha=0,18
                    ip = i - ex(alpha)
                    jp = j - ey(alpha)
                    kp = k - ez(alpha)

                    f(alpha,i,j,k) = f_post(alpha,ip,jp,kp)
                enddo
            enddo
        enddo
    enddo

    return
end subroutine streaming

subroutine bounceback()
    use commondata
    implicit none
    integer :: i, j, k

    do k = 1, nz
        do j = 1, ny
            ! (i = 1)
            f(1,1,j,k) = f_post(2,1,j,k)
            f(7,1,j,k) = f_post(10,1,j,k)
            f(9,1,j,k) = f_post(8,1,j,k)
            f(11,1,j,k) = f_post(14,1,j,k)
            f(13,1,j,k) = f_post(12,1,j,k)

            !(i = nx)
            f(2,nx,j,k) = f_post(1,nx,j,k)
            f(10,nx,j,k) = f_post(7,nx,j,k)
            f(8,nx,j,k) = f_post(9,nx,j,k)
            f(14,nx,j,k) = f_post(11,nx,j,k)
            f(12,nx,j,k) = f_post(13,nx,j,k)

        enddo
    enddo

    do k = 1, nz
        do i = 1, nx
            !(j = 1)
            f(3,i,1,k) = f_post(4,i,1,k)
            f(7,i,1,k) = f_post(10,i,1,k)
            f(8,i,1,k) = f_post(9,i,1,k)
            f(15,i,1,k) = f_post(18,i,1,k)
            f(17,i,1,k) = f_post(16,i,1,k)

            !(j = ny)
            f(4,i,ny,k) = f_post(3,i,ny,k)
            f(10,i,ny,k) = f_post(7,i,ny,k)
            f(9,i,ny,k) = f_post(8,i,ny,k)
            f(18,i,ny,k) = f_post(15,i,ny,k)
            f(16,i,ny,k) = f_post(17,i,ny,k)
        enddo
    enddo

    do j = 1, ny
        do i = 1, nx
            ! (k = 1)
            f(5,i,j,1) = f_post(6,i,j,1)
            f(11,i,j,1) = f_post(14,i,j,1)
            f(12,i,j,1) = f_post(13,i,j,1)
            f(15,i,j,1) = f_post(18,i,j,1)
            f(16,i,j,1) = f_post(17,i,j,1)

            ! (k = nz)
            f(6,i,j,nz) = f_post(5,i,j,nz)
            f(14,i,j,nz) = f_post(11,i,j,nz) - rho(i,j,nz) / 6.0d0 * (U0)
            f(13,i,j,nz) = f_post(12,i,j,nz) - rho(i,j,nz) / 6.0d0 * (-U0)
            f(18,i,j,nz) = f_post(15,i,j,nz)
            f(17,i,j,nz) = f_post(16,i,j,nz)
        enddo
    enddo

    return
end subroutine bounceback

subroutine macro()
    use commondata
    implicit none
    integer :: i, j, k, alpha

    rho = 0.0d0
    u = 0.0d0
    v = 0.0d0
    w = 0.0d0
    do k = 1, nz
        do j = 1, ny
            do i = 1, nx
                do alpha = 0, 18
                    rho(i,j,k) = rho(i,j,k) + f(alpha,i,j,k)
                    u(i,j,k) = u(i,j,k) + f(alpha,i,j,k) * ex(alpha)
                    v(i,j,k) = v(i,j,k) + f(alpha,i,j,k) * ey(alpha)
                    w(i,j,k) = w(i,j,k) + f(alpha,i,j,k) * ez(alpha)
                enddo

                u(i,j,k) = u(i,j,k)/rho(i,j,k)
                v(i,j,k) = v(i,j,k)/rho(i,j,k)
                w(i,j,k) = w(i,j,k)/rho(i,j,k)
            enddo
        enddo
    enddo

    return
end subroutine macro

subroutine check()
    use commondata
    implicit none
    integer :: i, j, k
    real(8) :: error1, error2

    error1 = 0.0d0
    error2 = 0.0d0

    do k = 1, nz
        do j = 1, ny
            do i = 1, nx
                error1 = error1 + (u(i,j,k)-up(i,j,k))*(u(i,j,k)-up(i,j,k))+(v(i,j,k)-vp(i,j,k))*(v(i,j,k)-vp(i,j,k))
                error2 = error2 + u(i,j,k)*u(i,j,k)+v(i,j,k)*v(i,j,k) + w(i,j,k)*w(i,j,k)
            enddo
        enddo
    enddo

    up = u
    vp = v
    wp = w

    errorU = sqrt(error1)/sqrt(error2)

    write(*,*) itc,' ',errorU

    return
end subroutine check

subroutine output_ASCII()
    use commondata
    implicit none
    integer :: i, j, k
    character(len=100) :: filename

    write(filename,*) itc
    filename = adjustl(filename)

    open(unit=77,file='MRTcavity-'//trim(filename)//'.dat',status='unknown')
        write(77,*) 'TITLE="Lid Driven Cavity"'
        write(77,*) 'VARIABLES="X" "Y" "Z" "U" "V" "W" "Pressure" '
        write(77,101) nx, ny, nz
        do k = 1, nz
            do j = 1, ny
                do i = 1, nx
                    write(77,100) xp(i), yp(j), zp(k), u(i,j,k), v(i,j,k), w(i,j,k), rho(i,j,k)/3.0d0
                enddo
            enddo
        enddo
100     format(1x,3(e11.4,' '),10(e13.6,' '))
101     format('ZONE',1x,'I=',1x,i5,2x,'J=',1x,i5,1x,'K=',1x,i5,1x,'F=POINT')
    close(77)

    return
end subroutine output_ASCII

subroutine output_binary()
    use commondata
    implicit none
    integer :: i, j, k
    character(len=100) :: filename

    write(filename,*) itc
    filename = adjustl(filename)

    open(unit=01,file='MRTcavity-'//trim(filename)//'.bin',form="unformatted",access="sequential")
    write(01) (((u(i,j,k), i = 1, nx), j = 1, ny), k = 1, nz)
    write(01) (((v(i,j,k), i = 1, nx), j = 1, ny), k = 1, nz)
    write(01) (((rho(i,j,k), i = 1, nx), j = 1, ny), k = 1, nz)
    close(01)

    return
end subroutine output_binary

!!!c--------------------------------
!!!c--------------------------------
    subroutine output_Tecplot()
    use commondata
    implicit none
    integer :: i, j, k
    character(len=9) :: B2
    REAL(4) :: zoneMarker, eohMarker
    character(len=40) :: title
    character(len=40) :: V1,V2,V3,V4,V5,V6,V7
    character(len=40) :: zoneName

    write(B2,'(i9.9)') itc

    open(41,file='MRTcavity-'//B2//'.plt', access='stream', form='unformatted')
    !---------------------------------------------
    zoneMarker= 299.0
    eohMarker = 357.0

    !I. HEAD SECTION--------------------------------------
    !c--Magic number, Version number
    write(41) "#!TDV101"

    !c--Integer value of 1
    write(41) 1

    Title="MyFirst"
    call dumpstring(title)

    !c-- Number of variables in this data file (here 5 variables)
    write(41) 7

    !c-- Variable names.
    V1 = 'X'
    call dumpstring(V1)
    V2 = 'Y'
    call dumpstring(V2)
    V3 = 'Z'
    call dumpstring(V3)
    V4 = 'U'
    call dumpstring(V4)
    V5 = 'V'
    call dumpstring(V5)
    V6 = 'W'
    call dumpstring(V6)
    V7 = 'Pressure'
    call dumpstring(V7)

    !c-----Zones-----------------------------

    !c--------Zone marker. Value = 299.0
    write(41) zoneMarker

    !--------Zone name.
    zoneName="ZONE 001"
    call dumpstring(zoneName)

    !---------Zone Color
    write(41) -1

    !---------ZoneType
    write(41) 0

    !---------DataPacking 0=Block, 1=Point
    write(41) 1

    !---------Specify Var Location. 0 = Do not specify, all data
    !---------is located at the nodes. 1 = Specify
    write(41) 0

    !---------Number of user defined face neighbor connections
    ! (value >= 0)
    write(41) 0

    !---------IMax,JMax,KMax
    write(41) nx
    write(41) ny
    write(41) nz

    !-----------1=Auxiliary name/value pair to follow
    !-----------0=No more Auxiliar name/value pairs.
    write(41) 0
    write(41) eohMarker

    !----zone ------------------------------------------------------------
    write(41) zoneMarker

    !--------variable data format, 1=Float, 2=Double, 3=LongInt,4=ShortInt, 5=Byte, 6=Bit
    write(41) 1
    write(41) 1
    write(41) 1
    write(41) 1
    write(41) 1
    write(41) 1
    write(41) 1

    !--------Has variable sharing 0 = no, 1 = yes.
    write(41) 0

    !----------Zone number to share connectivity list with (-1 = no
    ! sharing).
    write(41) -1

    !---------------------------------------------------------------------
    do k=1,nz
        do j=1,ny
            do i=1,nx
                write(41) real(xp(i))
                write(41) real(yp(j))
                write(41) real(zp(k))
                write(41) real(u(i,j,k))
                write(41) real(v(i,j,k))
                write(41) real(w(i,j,k))
                write(41) real(rho(i,j,k)/3.0d0)
            end do
        end do
    enddo
    close(41)
    !---------------------------------------------------------------------

    return
    end subroutine output_Tecplot
!!!c--------------------------------
    subroutine dumpstring(instring)
    implicit none
    character(len=40) instring
    integer :: stringLength
    integer :: ii
    integer :: I

    stringLength=LEN_TRIM(instring)
    do ii=1,stringLength
        I=ICHAR(instring(ii:ii))
        write(41) I
    end do
    write(41) 0

    return
    end subroutine dumpstring
!!!c--------------------------------
!!!c--------------------------------

subroutine getVelocity()
    use commondata
    implicit none
    integer :: i, j, k
    character(len=9) :: B2

    write(B2,'(i9.9)') itc

    open(unit=02,file='./u-z_'//B2//'.dat',status='unknown')
    do k=1,nz
        write(02,*) u(nxHalf, nyHalf, k)/U0, zp(k)/dble(nz)
    enddo
    close(02)

    open(unit=03,file='./x-w_'//B2//'.dat',status='unknown')
    do i=1,nx
        write(03,*) xp(i)/dble(nx), w(i, nyHalf, nzHalf)/U0
    enddo
    close(03)

    return
end subroutine getVelocity


	SUBROUTINE ST_NUMB  ( string, ival, iret )
C************************************************************************
C* ST_NUMB                                       			*
C*									*
C* This subroutine converts a string into an integer.			*
C*									*
C* ST_NUMB  ( STRING, IVAL, IRET )					*
C*									*
C* Input parameters:							*
C*	STRING		CHAR*		String				*
C*									*
C* Output parameters:							*
C*	IVAL		INTEGER		Integer value      		*
C*	IRET		INTEGER		Return code			*
C*				 	  0 = normal return		*
C*					 -2 = conversion error		*
C** 									*
C* Log:									*
C* M. desJardins/NMC	 3/92	Rewritten to avoid special cases	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*) 	string
C*
	CHARACTER	sss*12, c*1
	LOGICAL		good, plus
C------------------------------------------------------------------------
	iret = -2
	ival = IMISSD
C
C*	Remove blanks from string.
C
	CALL ST_RMBL  ( string, sss, lens, ier )
C
C*	Check for empty string.
C
	IF  ( lens .eq. 0 )  RETURN
C
C*	If last character is period, remove it.
C
	IF  ( sss (lens:lens) .eq. '.' )  THEN
	    sss (lens:lens) = ' '
	    lens = lens - 1
	END IF
	IF  ( lens .eq. 0 )  RETURN
C
C*	Check for + or - in first character.
C
	IF  ( sss (1:1) .eq. '+' )  THEN
	    ibeg = 2
	    plus = .true.
	  ELSE IF  ( sss (1:1) .eq. '-' )  THEN
	    ibeg = 2
	    plus = .false.
	  ELSE
	    ibeg = 1
	    plus = .true.
	END IF
	IF  ( ibeg .gt. lens )  RETURN
C
C*	Now loop through all characters and turn into integer.
C
	ival0 = ICHAR ( '0' )
	ival  = 0
	good  = .true.
	i     = ibeg
	DO  WHILE  ( good .and. ( i .le. lens ) )
	    c     = sss (i:i)
	    ivalc = ICHAR ( c ) - ival0
	    IF  ( ( ivalc .ge. 0 ) .and. ( ivalc .le. 9 ) )  THEN
		ival  = ival * 10 + ivalc
		i     = i + 1
	      ELSE
		good  = .false.
	    END IF
	END DO
C
C*	Check for good value and add sign.
C
	IF  ( .not. good )  THEN
	    ival = IMISSD
	  ELSE IF  ( plus )  THEN
	    iret = 0
	  ELSE
	    iret = 0
	    ival = -ival
	END IF
C*
	RETURN
	END


      i = l
      j = r
      v = raw_data(int((l+r)/2))

      do
          do while (raw_data(i)<v)
              i = i+1
          end do
          do while (v<raw_data(j))
              j = j-1
          end do
          if (i<=j) then
              t = raw_data(i)
              raw_data(i) = raw_data(j)
              raw_data(j) = t
              i = i+1
              j = j-1
          end if
          if (i>j) exit
      end do

      if (l<j) then
          call quicksort(l,j)
      end if

      if (i<r) then
          call quicksort(i,r)
      end if


! { dg-do compile }
! { dg-options "-O2 -ftree-loop-distribution" }

MODULE NFT_mod

implicit none
integer :: Nangle
real:: Z0
real, dimension(:,:), allocatable :: Angle
real, dimension(:), allocatable :: exth, ezth, hxth, hyth, hyphi

CONTAINS

SUBROUTINE NFT_Init()

real :: th, fi
integer :: n

do n = 1,Nangle
  th = Angle(n,1)
  fi = Angle(n,2)

  exth(n) =  cos(fi)*cos(th)
  ezth(n) = -sin(th)
  hxth(n) = -sin(fi)
  hyth(n) =  cos(fi)
  hyphi(n) = -sin(fi)
end do
END SUBROUTINE NFT_Init

END MODULE NFT_mod


program demo

! To demonstrate trapping on divide by zero and use of gdb.
! Similar to lab7/demo.py.

real(kind=8) :: x(1001),y(1001)
integer :: j

do j=1,1001
    x(j) = -20.d0 + (j-1)*40.d0/1000.d0
    y(j) = sin(x(j)) / x(j)
    enddo

print *, "The max value of y is ",maxval(y)

print *, "x(501) is ", x(501)
print *, "y(501) is ", y(501)

end program demo


program vin
  integer:: a=1,b=10,c=-3,d=4
  print *, min(a,b,d)
  print *, min(a,b,c)
  print *, min(b,c,d)
  print *, min(b,c)
  print *, max(a,b,d)
  print *, max(a,d,c)
  print *, max(b,c,d)
  print *, max(b,c,d,a)
  print *, max(a,d)
end program vin


include "sparseMod.f03"
      program sparse01
      USE sparseMod
!
!     This program will serve as a sandbox for learning about sparse vector and
!     sparse matrix algebra.
!
!
      implicit none
      integer::i,j
      integer::nDim,nDimSparse
      real,dimension(:),allocatable::vec1
      integer,dimension(:),allocatable::indexVec1
      real,dimension(:),allocatable::denseVec1
!
!     Let's get some values from the user...
!
      write(*,*)' What is the dimension of the vector space?'
      read(*,*) nDim
      write(*,*)' How many non-zero elements are there in the sparse vector?'
      read(*,*) nDimSparse
      ALLOCATE(vec1(nDimSparse),indexVec1(nDimSparse))
      write(*,*)'Please enter the non-zero vector elements and their values in pairs.'
      do i = 1,nDimSparse
        read(*,*) indexVec1(i),vec1(i)
      endDo
!
!     Echo the user input...
!
      write(*,*)' nDim = ',nDim
      write(*,*)' nDimSparse = ',nDimSparse
      do i = 1,nDimSparse
        write(*,*) 'i=',indexVec1(i),'  vec1(i) = ',vec1(i)
      endDo
!
!     Allocate space for a full-memory version of the sparse vector and then use
!     a scatter function.
!
      ALLOCATE(denseVec1(nDim))
      denseVec1 = scatter_realVector(vec1,indexVec1,nDim)
      do i = 1,nDim
        write(*,*) i,denseVec1(i)
      endDo
!
!     Scan over the values of the dense array and build a new index before we
!     run gather and rebuild the sparse array.
!
      j = 0
      do i = 1,nDim
        if (abs(denseVec1(i)).gt.0.001) then
          j = j+1
          if(j.gt.nDimSparse) STOP
          indexVec1(j) = i
        endIf
      endDo
      if(j.ne.nDimSparse) then
        write(*,*)' j = ',j,'  BUT nDimSparse = ',nDimSparse
        write(*,*)' YIKES!!!'
        STOP
      endIf
!
!     Test out the gather function.
!
      vec1 = 999.123123
      vec1 = gather_realVector(indexVec1,denseVec1)
      write(*,*)
      write(*,*)' Here''s the sparse vector after running the gather function...'
      do i = 1,nDimSparse
        write(*,*) 'i=',indexVec1(i),'  vec1(i) = ',vec1(i)
      endDo
!
      end program sparse01


!
! Copyright (C) 2001 PWSCF group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!-----------------------------------------------------------------------
subroutine simpson (mesh, func, rab, asum)
  !-----------------------------------------------------------------------
  !
  !     simpson's rule integration. On input:
  !       mesh = mhe number of grid points (should be odd)
  !       func(i)= function to be integrated
  !       rab(i) = r(i) * dr(i)/di * di
  !     For the logarithmic grid not including r=0 :
  !       r(i) = r_0*exp((i-1)*dx) ==> rab(i)=r(i)*dx
  !     For the logarithmic grid including r=0 :
  !       r(i) = a(exp((i-1)*dx)-1) ==> rab(i)=(r(i)+a)*dx
  !     Output in asum = \sum_i c_i f(i)*rab(i) = \int_0^\infty f(r) dr
  !     where c_i are alternativaly 2/3, 4/3 except c_1 = c_mesh = 1/3
  !
  use kinds, ONLY: DP
  implicit none
  integer, intent(in) :: mesh
  real(DP), intent(in) :: rab (mesh), func (mesh)
  real(DP), intent(out):: asum
  !
  real(DP) :: f1, f2, f3, r12
  integer :: i
  !
  !     routine assumes that mesh is an odd number so run check
  !     if ( mesh+1 - ( (mesh+1) / 2 ) * 2 .ne. 1 ) then
  !       write(*,*) '***error in subroutine radlg'
  !       write(*,*) 'routine assumes mesh is odd but mesh =',mesh+1
  !       stop
  !     endif
  asum = 0.0d0
  r12 = 1.0d0 / 12.0d0
  f3 = func (1) * rab (1) * r12

  do i = 2, mesh - 1, 2
     f1 = f3
     f2 = func (i) * rab (i) * r12
     f3 = func (i + 1) * rab (i + 1) * r12
     asum = asum + 4.0d0 * f1 + 16.0d0 * f2 + 4.0d0 * f3
  enddo

  return
end subroutine simpson

!=-----------------------------------------------------------------------
subroutine simpson_cp90( mesh, func, rab, asum )
  !-----------------------------------------------------------------------
  !
  !    This routine computes the integral of a function defined on a
  !    logaritmic mesh, by using the open simpson formula given on
  !    pag. 109 of Numerical Recipes. In principle it is used to
  !    perform integrals from zero to infinity. The first point of
  !    the function should be the closest to zero but not the value
  !    in zero. The formula used here automatically includes the
  !    contribution from the zero point and no correction is required.
  !
  !    Input as "simpson". At least 8 integrating points are required.
  !
  !    last revised 12 May 1995 by Andrea Dal Corso
  !
  use kinds, ONLY: DP
  implicit none
  integer, intent(in) :: mesh
  real(DP), intent(in) :: rab (mesh), func (mesh)
  real(DP), intent(out):: asum
  !
  real(DP) :: c(4)
  integer ::i
  !
  if ( mesh < 8 ) call errore ('simpson_cp90','few mesh points',8)

  c(1) = 109.0d0 / 48.d0
  c(2) = -5.d0 / 48.d0
  c(3) = 63.d0 / 48.d0
  c(4) = 49.d0 / 48.d0

  asum = ( func(1)*rab(1) + func(mesh  )*rab(mesh  ) )*c(1) &
       + ( func(2)*rab(2) + func(mesh-1)*rab(mesh-1) )*c(2) &
       + ( func(3)*rab(3) + func(mesh-2)*rab(mesh-2) )*c(3) &
       + ( func(4)*rab(4) + func(mesh-3)*rab(mesh-3) )*c(4)
  do i=5,mesh-4
     asum = asum + func(i)*rab(i)
  end do

  return
end subroutine simpson_cp90
!
!-----------------------------------------------------------------------
SUBROUTINE herman_skillman_int(mesh,func,rab,asum)
!-----------------------------------------------------------------------
  !     simpson rule integration for herman skillman mesh (obsolescent)
  !     Input as in "simpson". BEWARE: "func" is overwritten!!!
  !
  use kinds, ONLY: DP
  IMPLICIT NONE
  integer, intent(in) :: mesh
  real(DP), intent(in) :: rab (mesh)
  real(DP), intent(inout) :: func (mesh)
  real(DP), intent(out):: asum
  !
  INTEGER :: i, j, k, i1, nblock
  REAL(DP) :: a1, a2e, a2o, a2es
  !
  a1=0.0d0
  a2e=0.0d0
  asum=0.0d0
  nblock=mesh/40
  i=1
  func(1)=0.0d0
  DO j=1,nblock
     DO k=1,20
        i=i+2
        i1=i-1
        a2es=a2e
        a2o=func(i1)/12.0d0
        a2e=func(i)/12.0d0
        a1=a1+5.0d0*a2es+8.0d0*a2o-a2e
        func(i1)=asum+a1*rab(i1)
        a1=a1-a2es+8.0d0*a2o+5.0d0*a2e
        func(i)=asum+a1*rab(i)
     END DO
     asum=func(i)
     a1=0.0d0
  END DO
  !
  RETURN
END SUBROUTINE herman_skillman_int


! PR tree-optimization/70043
! { dg-do compile }
! { dg-additional-options "-Ofast -g" }
! { dg-additional-options "-march=haswell" { target i?86-*-* x86_64-*-* } }

subroutine fn1(a, b)
  real(8), intent(in) ::  b(100)
  real(8), intent(inout) :: a(100)
  real(8) c
  do i=1,100
     if( a(i) < 0.0 ) then
        c =  a(i) * b(i)
        a(i) = a(i) - c / b(i)
     endif
  enddo
end subroutine fn1


! { dg-do run }
! Contributed by Dominique Dhumieres <dominiq@lps.ens.fr>

character(100) :: str1 = &
  "123.00456.88 0.123E+01  +0.987+1 -0.2345+02 -0.6879E+2+0.7E+03 0.4E+03"
character(100), parameter :: should_be = &
  "123.00456.88 0.123E+01 0.987E+01-0.2345E+02-0.6879E+02 0.7E+03 0.4E+03"
character(100) :: output
complex :: c1, c2, c3, c4

100 format ( 2F6.2, 2E10.3, 2E11.4, 2E8.1)
read (str1,100) c1, c2, c3, c4
write (output, 100) c1, c2, c3, c4

print *, output
if (output /= should_be) then
  print *, should_be
  call abort ()
end if

end


PROGRAM main

  ! This programs produces the 2-parameter toy model presented in Rakovec et al (2014, WRR)
  ! which calculates first-order DELSA method shown in bottom Figure 5.

  USE mo_kind,  ONLY: dp, i4
  USE mo_delsa, ONLY: delsa
  use mo_ansi_colors, only: color, c_red, c_green

  IMPLICIT NONE

  integer(i4)                      :: ii,jj,set

  integer(i4), parameter           :: npara = 2         ! number of parameter
  integer(i4), parameter           :: nsets = 100       ! number of parametersets

  REAL(dp), DIMENSION(nsets,npara) :: parbase           ! array of base model parameters
  REAL(dp), DIMENSION(nsets,npara) :: parpert           ! array of perturbed model parameters (alltogether)
  REAL(dp), DIMENSION(nsets,npara) :: parpert1,parpert2 ! array of perturbed model parameters (individual param)
  REAL(dp), DIMENSION(nsets)       :: outbase           ! model output using the base runs
  REAL(dp), DIMENSION(nsets,npara) :: outpert           ! model output using the perturbed runs
  REAL(dp), DIMENSION(npara)       :: varprior          ! prior parameter variance

  REAL(dp), DIMENSION(nsets,npara) :: delsafirst,delsatest ! first-order DELSA results,delsa test results for a check

  ! Dummy variables
  logical                             :: isgood = .true.

  ! Data Files for delsa(parbase,parpert,outbase,outpert,varprior,delsafirst)
  ! read text files which were created externally:
  character(len=*), parameter :: fileparbase    = 'dummy_data/parbase.txt'
  character(len=*), parameter :: fileparpert1   = 'dummy_data/parpert1.txt'
  character(len=*), parameter :: fileparpert2   = 'dummy_data/parpert2.txt'
  character(len=*), parameter :: fileoutbase    = 'dummy_data/outbase.txt'
  character(len=*), parameter :: fileoutpert    = 'dummy_data/outpert.txt'
  character(len=*), parameter :: filetestoutput = 'dummy_data/test_output.txt'

  ! ************************************************************************
  ! read parameter sets and corresponding model outputs
  ! ************************************************************************

  ! read base parameter set:
  open(unit=50, file=fileparbase, action='read')
  do set=1,size(parbase,1)
     read(50,*) parbase(set,:)
  end do
  close(50)

  ! read parameter set, in which is perturbed parameter 1:
  open(unit=50, file=fileparpert1, action='read')
  do set=1,size(parbase,1)
     read(50,*) parpert1(set,:)
  end do
  close(50)

  ! read parameter set, in which is perturbed parameter 2:
  open(unit=50, file=fileparpert2, action='read')
  do set=1,size(parbase,1)
     read(50,*) parpert2(set,:)
  end do
  close(50)

  ! compose an array with only perturbed parameters
  parpert(:,1)=parpert1(:,1)
  parpert(:,2)=parpert2(:,2)

  ! read model output using the base parameter set
  open(unit=50, file=fileoutbase, action='read')
  do set=1,size(outbase,1)
     read(50,*) outbase(set)
  end do
  close(50)

  ! read model output using the perturbed parameter sets
  open(unit=50, file=fileoutpert, action='read')
  do set=1,size(outpert,1)
     read(50,*) outpert(set,:)
  end do
  close(50)

  ! prior variance (this comes from last sentence in Rakovec et al, 2014, WRR of Sect. 3.2)
  ! note, there is a typo in the paper, those values are standard deviations and not variances!!!
  varprior = (/28.83865_dp**2_i4,0.08660254_dp**2_i4/)
  Write(*,*) 'varprior: '
  Write(*,*) varprior
  Write(*,*) ' '

  call delsa(parbase,parpert,outbase,outpert,varprior,delsafirst)
  Write(*,*) 'delsa first, param 1:'
  Write(*,*) delsafirst(:,1)
  Write(*,*) ' '
  Write(*,*) 'delsa first, param 2:'
  Write(*,*) delsafirst(:,2)
  Write(*,*) ' '

  ! save results in a text file:
  open(unit=999,file='delsafirst_fortran.txt.make_check_test_file', action='write')

  do set=1,size(outbase,1)
     write(999,'(f12.6)', advance='no') delsafirst(set,1)
     write(999,'(f12.6)') delsafirst(set,2)
  end do
  close(999)
  Write(*,*) 'results saved in delsafirst_fortran.txt.make_check_test_file'

  ! ************************************************************************
  !       Verify that module runs correctly
  ! ************************************************************************
  open(unit=50, file=filetestoutput, action='read')
  do set=1,size(delsatest,1)
     read(50,*) delsatest(set,:)
  end do
  close(50)

  do ii=1,size(delsatest,1)
     do jj=1,size(delsatest,2)
     if (nint(delsafirst(ii,jj)*1000000._dp) .ne.  nint(delsatest(ii,jj)*1000000._dp))  isgood = .false.
     end do
  end do

  if (isgood) then
     write(*,*) 'mo_delsa ', color('o.k.', c_green)
  else
     write(*,*) 'mo_delsa ', color('failed', c_red)
  end if

END PROGRAM main


   program testing_permutation_algorithms

   implicit none
   integer :: nmax
   integer, dimension(:),allocatable :: ida
   logical :: mtc
   logical :: even
   integer :: i
   integer(8) :: ic
   integer :: clock_rate, clock_max, t1, t2
   real(8) :: dt
   integer :: pos_min, pos_max
!
!
!  Beginning:
!
   write(*,*) 'INPUT N:'
   read *, nmax
   write(*,*) 'N =', nmax
   allocate ( ida(1:nmax) )
!
!
!  (1) Starting:
!
   do i  =  1, nmax
      ida(i) = i
   enddo
!
   ic = 0
   call system_clock ( t1, clock_rate, clock_max )
!
   mtc = .false.
!
   do
      call subnexper ( nmax, ida, mtc, even )
!
!     1) counting the number of permutatations
!
      ic = ic + 1
!
!     2) writing out the result:
!
!     do i  =  1, nmax
!        write (100,"(i3,',')",advance = "no") ida(i)
!     enddo
!     write(100,*)
!
!     repeat if not being finished yet, otherwise exit.
!
      if (mtc) then
         cycle
      else
         exit
      endif
!
   enddo
!
   call system_clock ( t2, clock_rate, clock_max )
   dt =  ( dble(t2) - dble(t1) )/ dble(clock_rate)
!
!  Finishing (1)
!
   write(*,*) "1) subnexper:"
   write(*,*) 'Total permutations :', ic
   write(*,*) 'Total time elapsed :', dt
!
!
!  (2) Starting:
!
   do i  =  1, nmax
      ida(i) = i
   enddo
!
   pos_min = 1
   pos_max = nmax
!
   ic = 0
   call system_clock ( t1, clock_rate, clock_max )
!
   call generate ( pos_min )
!
   call system_clock ( t2, clock_rate, clock_max )
   dt =  ( dble(t2) - dble(t1) )/ dble(clock_rate)
!
!  Finishing (2)
!
   write(*,*) "2) generate:"
   write(*,*) 'Total permutations :', ic
   write(*,*) 'Total time elapsed :', dt
!
!
!  (3) Starting:
!
   do i  =  1, nmax
      ida(i) = i
   enddo
!
   ic = 0
   call system_clock ( t1, clock_rate, clock_max )
!
   i = 1
   call perm ( i )
!
   call system_clock ( t2, clock_rate, clock_max )
   dt =  ( dble(t2) - dble(t1) )/ dble(clock_rate)
!
!  Finishing (3)
!
   write(*,*) "3) perm:"
   write(*,*) 'Total permutations :', ic
   write(*,*) 'Total time elapsed :', dt
!
!
!  (4) Starting:
!
   do i  =  1, nmax
      ida(i) = i
   enddo
!
   ic = 0
   call system_clock ( t1, clock_rate, clock_max )
!
   do
!
!     1) counting the number of permutatations
!
      ic = ic + 1
!
!     2) writing out the result:
!
!     do i  =  1, nmax
!        write (100,"(i3,',')",advance = "no") ida(i)
!     enddo
!     write(100,*)
!
!     repeat if not being finished yet, otherwise exit.
!
      if ( nextp(nmax,ida) ) then
         cycle
      else
         exit
      endif
!
   enddo
!
   call system_clock ( t2, clock_rate, clock_max )
   dt =  ( dble(t2) - dble(t1) )/ dble(clock_rate)
!
!  Finishing (4)
!
   write(*,*) "4) nextp:"
   write(*,*) 'Total permutations :', ic
   write(*,*) 'Total time elapsed :', dt
!
!
!  What's else?
!  ...
!
!==
   deallocate(ida)
!
   stop
!==
   contains
!==
!     Modified version of SUBROUTINE NEXPER from the book of
!     Albert Nijenhuis and Herbert S. Wilf, "Combinatorial
!     Algorithms For Computers and Calculators", 2nd Ed, p.59.
!
      subroutine subnexper ( n, a, mtc, even )
      implicit none
      integer,intent(in)    ::  n
      integer,dimension(n),intent(inout)  :: a
      logical,intent(inout) :: mtc, even
!
!     local varialbes:
!
      integer,save :: nm3
      integer :: ia, i, s, d, i1, l, j, m
!
      if (mtc) goto 10

      nm3 = n-3

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

      mtc  = .true.
5     even = .true.

      if ( n .eq. 1 ) goto 8

6     if ( a(n) .ne. 1 .or. a(1) .ne. 2+mod(n,2) ) return

      if ( n .le. 3 ) goto 8

      do i = 1,nm3
         if( a(i+1) .ne. a(i)+1 ) return
      enddo

8     mtc = .false.

      return

10    if ( n .eq. 1 ) goto 27

      if( .not. even ) goto 20

      ia   = a(1)
      a(1) = a(2)
      a(2) = ia
      even = .false.

      goto 6

20    s = 0

      do i1 = 2,n
         ia = a(i1)
         i = i1-1
         d = 0
         do j = 1,i
            if ( a(j) .gt. ia ) d = d+1
         enddo
         s = d+s
         if ( d .ne. i*mod(s,2) ) goto 35
      enddo

27    a(1) = 0

      goto 8

35    m = mod(s+1,2)*(n+1)

      do j = 1,i
         if(isign(1,a(j)-ia) .eq. isign(1,a(j)-m)) cycle
         m = a(j)
         l = j
      enddo

      a(l) = ia
      a(i1) = m
      even = .true.

      return
      end subroutine
!=====
!
!     http://rosettacode.org/wiki/Permutations#Fortran
!
      recursive subroutine generate (pos)

      implicit none
      integer,intent(in) :: pos
      integer :: val

      if (pos > pos_max) then
!
!        1) counting the number of permutatations
!
         ic = ic + 1
!
!        2) writing out the result:
!
!        write (*,*) permutation
!
      else
         do val = 1, nmax
            if (.not. any (ida( : pos-1) == val)) then
               ida(pos) = val
               call generate (pos + 1)
            endif
         enddo
      endif

      end subroutine
!=====
!
!     http://rosettacode.org/wiki/Permutations#Fortran
!
      recursive subroutine perm (i)
      implicit none
      integer,intent(inout) :: i
!
      integer :: j, t, ip1
!
      if (i == nmax) then
!
!        1) couting the number of permutatations
!
         ic = ic + 1
!
!        2) writing out the result:
!
!        write (*,*) a
!
      else
         ip1 = i+1
         do j = i, nmax
            t = ida(i)
            ida(i) = ida(j)
            ida(j) = t
            call perm ( ip1 )
            t = ida(i)
            ida(i) = ida(j)
            ida(j) = t
         enddo
      endif
      return
      end subroutine
!=====
!
!     http://rosettacode.org/wiki/Permutations#Fortran
!
      function nextp ( n, a )
      logical :: nextp
      integer,intent(in) :: n
      integer,dimension(n),intent(inout) :: a
!
!     local variables:
!
      integer i,j,k,t
!
      i = n-1
   10 if ( a(i) .lt. a(i+1) ) goto 20
      i = i-1
      if ( i .eq. 0 ) goto 20
      goto 10
   20 j = i+1
      k = n
   30 t = a(j)
      a(j) = a(k)
      a(k) = t
      j = j+1
      k = k-1
      if ( j .lt. k ) goto 30
      j = i
      if (j .ne. 0 ) goto 40
!
      nextp = .false.
!
      return
!
   40 j = j+1
      if ( a(j) .lt. a(i) ) goto 40
      t = a(i)
      a(i) = a(j)
      a(j) = t
!
      nextp = .true.
!
      return
      end function
!=====
!
!     What's else ?
!     ...

!=====
   end program


      subroutine kostia(
     i                  rwdth)
c
c     + + + PURPOSE + + +
c     This subprogram calibrates modified Kostiakov infiltration
c     equation constants for a series of time-infiltration rate pairs
c     where infiltration rate is calculated using the Green and Ampt
c     infiltration function.
c
c     Called from FURROW
c     Author(s): E. R. Kottwitz
c     Reference in User Guide: Chapter 12
c
c     Changes:
c
c     Version: This module recoded from WEPP Version 93.06.
c     Date recoded: 07/07/93.
c     Recoded by: Charles R. Meyer.
c
c     + + + PARAMETERS + + +
      include 'pmxcrp.inc'
      include 'pmxhil.inc'
      include 'pmxnsl.inc'
      include 'pmxpln.inc'
      include 'pmxpnd.inc'
      include 'pmxres.inc'
      include 'pmxsrg.inc'
      include 'pmxtil.inc'
      include 'pmxtls.inc'
      include 'pntype.inc'
      include 'pxstep.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      real      rwdth
c
c     + + + ARGUMENT DEFINITIONS + + +
c     rwdth  - assumed row width of current overland flow element (m)
c
c     + + + COMMON BLOCKS + + +
      include 'cavepar.inc'
c     modify: aveks(mxplan),avesm(mxplan)
c
      include 'ccrpout.inc'
c       read: rh(mxplan)
c
      include 'cdist2.inc'
c       read: slplen(mxplan)
c
      include 'ciraflo.inc'
c       read: aqcnst,aqexp,botwid,sidslp
c
      include 'cirfur2.inc'
c       read: dtheta(mxplan),qspply(mxplan),surge,timtot
c     modify: srg
c
      include 'cirinfl.inc'
c     modify: kostf
c      write: kosta,kostk
c
      include 'cirriga.inc'
c       read: irofe,noirr
c
      include 'cparame.inc'
c       read: ks(mxplan),sm(mxplan)
c
      include 'cstruc.inc'
c       read: iplane
c
c     + + + LOCAL VARIABLES + + +
      integer   furint,i,nsteps
      real      avgdp2,deltai,denom,diydt,dlower,dupper,horcon,hormax,
     1          infadj,infil2,infilh(50),infilt,infilv(0:50),infold,
     1          inftmx,irsum1,irsum2,irsum3,irsum4,irsum5,kostfd,natlni,
     1          natlnt,piovr2,qmaxl,qmaxu,testf,time(50),timhmx,vertmx
      real      tmpvr1,tmpvr2,tmpvr3,tmpvr4
c
c     + + + LOCAL DEFINITIONS + + +
c     furint - irrigated furrow interval (1: all furrows irrigated, 2:
c              every other furrow irrigated)
c     i      - do loop counter
c     nsteps - number of infiltration increments
c     avgdp2 - two times the average of dlower and dupper (m)
c     deltai - 1-D vertical distance to the wetting front increment (m)
c     denom  - coefficient used as a denominator in calculating kosta
c              kostk (m**4)
c     diydt  - time derivative if vertical advance distance (m/s)
c     dlower - flow depth at lower end of current OFE for maximum of
c              furrow supply rates assuming steady state infiltration
c              (m)
c     dupper - flow depth at upper end of current OFE for maximum of
c              furrow supply rates (m)
c     horcon - horizontal infiltration constant equal to
c              (2*Ke*Ns)**.5/(change in soil moisture content) (m/s**.5)
c     hormax - maximum horizontal distance to the wetting front (m)
c     infadj - 2-D cumulative infiltration minus Ks*(infiltration
c              opportunity time)*(row spacing) (m**2)
c     infil2 - infilt*infilt (m**4)
c     infilh - 1-D horizontal distance to the wetting front (m)
c     infilt - 2-D cumulative infiltration (volume of water infiltrated
c              per unit furrow length) (m**2)
c     infilv - 1-D vertical distance to the wetting front as determined
c              by SR NEWTON (m)
c     infold - estimate of infiltration sent to SR NEWTON (m)
c     inftmx - cumulative 2-D infiltration at t=timhmx (m**2)
c     irsum1 - summation of infil2 (m**4)
c     irsum2 - summation of infil2*natlnt (m**4)
c     irsum3 - summation of infil2*natlnt**2 (m**4)
c     irsum4 - summation of infil2*natlni (m**4)
c     irsum5 - summation of infil2*natlnt*natlni (m**4)
c     kostfd - estimate of kostf using derivative of 2-D cumulative
c              infiltration function (m**2/s)
c     natlni - natural logarithm of infilt
c     natlnt - natural logarithm of time
c     piovr2 - one-half the ratio of circle area to square of its radius
c     qmaxl  - maximum flow rate at the lower end of the OFE (m**3/s)
c     qmaxu  - maximum furrow supply rate (m**3/s)
c     testf  - estimate of new value of kostf if old value was too large
c              (m**2/s)
c     time   - infiltration opportunity time (s)
c     timhmx - time when horizontal wetting fronts meet (s)
c     vertmx - vertical distance to the wetting front at t=timhmx (m)
c     tmpvr1 - variable to reduce number of calculations (m/s)
c     tmpvr2 - variable to reduce number of calculations (m)
c     tmpvr3 - variable to reduce number of calculations (m)
c
c     + + + SUBROUTINES CALLED + + +
c     newton
c
c     + + + DATA INITIALIZATIONS + + +
      data      nsteps/50/,piovr2/1.57080/
c
c     + + + OUTPUT FORMATS + + +
 2001 format(' *** WARNING ***',/,
     1       'Furrow irrigation flow depth (',f5.1,' mm) exceeds',
     1       ' ridge height (',f5.1,' mm).',/,
     1       ' *** WARNING ***',/)
c
c     + + + END SPECIFICATIONS + + +
c
c     Assume furint = 1.  User will eventually be required to provide
c     this information.
c
      furint = 1
c
c     Initialize variables
c
      infilv(0)=0.0
      inftmx = 0.0
      vertmx = 0.0
      kostfd = 1.0
      aveks(iplane) = ks(iplane)
      avesm(iplane) = sm(iplane)
      tmpvr1 = aveks(iplane)/dtheta(iplane)
      tmpvr2 = avesm(iplane)/dtheta(iplane)
      tmpvr3 = dtheta(iplane)*float(furint)*rwdth
c
c     Determine maximum furrow inflow rate
c
      qmaxu = qspply(1)
      if(noirr.eq.2 .and. surge.ge.2)then
        do 100  srg = 2, surge
          qmaxu = max(qmaxu,qspply(srg))
  100   continue
      endif
c
c     Determine flow depth at the upper end of the OFE
c
      if(sidslp.gt.0.001)then
        dupper = (sqrt(botwid**2+4.0*sidslp*(qmaxu/aqcnst)**(1.0/aqexp))
     1          -botwid)/2.0/sidslp
      else
        dupper = (qmaxu/aqcnst)**(1.0/aqexp)/botwid
      endif
c
c     Print warning to user if dupper exceeds ridge height
c
      if(iplane.eq.irofe .and. dupper.gt.rh(iplane))
     1       write (6,2001)dupper*1000.0,rh(iplane)*1000.0
c
c     Determine horizontal infiltration constant
c
c      ---- The value in parenthesis is from that portion of WEPP
c           Equation 12.3 also in parenthesis.  HORCON is the square
c           root of it.
c           Note that avesm(iplane) = (total head loss)*dtheta(iplane).
c
      horcon = sqrt(2.0*tmpvr1*tmpvr2)
c
c     Determine maximum horizontal wetting distance and time when
c     horizontal wetting fronts meet
c
c      ---- (WEPP Equation 12.5, with W = float(furint)*rwdth)
      hormax = (float(furint)*rwdth-botwid)*0.5
      timhmx = (hormax/horcon)**2
c
c     Determine vertical advance distance at t=timhmx
c
      infold = timhmx*aveks(iplane)
      call newton(timhmx,infold,aveks(iplane),avesm(iplane),vertmx)
      vertmx = vertmx/dtheta(iplane)
c
c     Determine 1-D vert. distance to the wetting front for t=timtot
c
      infold = timtot*aveks(iplane)
      call newton(timtot,infold,aveks(iplane),avesm(iplane),
     1            infilv(nsteps))
      infilv(nsteps) = infilv(nsteps)/dtheta(iplane)
c
c     Determine deltai
c
      deltai = infilv(nsteps)/float(nsteps)
c
c     Determine 1-D horizontal distance to the wetting front for
c     t=timtot
c
      if(timtot.lt.timhmx)then
c
c       ---- (WEPP Equation 12.3)
        infilh(nsteps) = horcon*sqrt(timtot)
      else
        infilh(nsteps) = hormax
      endif
c
c     Determine infiltration rate at t=timtot using 2-D infiltration
c     function
c
c      ---- (WEPP Equation 4.2.3) divided by change in soil water
c           content
      diydt = tmpvr1*(1.0+tmpvr2/infilv(nsteps))
c
c     If the following is true then horizontal wetting fronts have not
c     met.
c
      if(timtot.le.timhmx)then
c
c        ---- Time derivative of WEPP Equation 12.1
        kostfd = (infilh(nsteps)*(dupper/timtot+piovr2*infilv(nsteps)/
     1           (2.0*timtot)+piovr2*diydt)+botwid*diydt)*dtheta(iplane)
      else
        kostfd = diydt*tmpvr3
      endif
c
c     Calculate values for elements of infilh, infilv, and time arrays.
c     Also determine the minimum infiltration rate.
c
      do 400  i = 1, nsteps-1
c
c       Determine 1-D vertical distance to the wetting front
c
        infilv(i) = infilv(i-1)+deltai
c
c       Calculate time required for infiltration depth infilv(i)
c
c        ---- (WEPP Equation 12.2, solved for time (tau in 12.2))
        time(i) = infilv(i)/tmpvr1-avesm(iplane)/aveks(iplane)*
     1            log(1.0+infilv(i)/tmpvr2)
c
c       Determine 1-D horizontal advance distance to the wetting front
c
        if(time(i).lt.timhmx)then
c
c         ---- (WEPP Equation 12.3)
          infilh(i) = horcon*sqrt(time(i))
        else
          infilh(i) = hormax
        endif
c
c       Determine kostf using derivative of 2-D cumulative infiltration
c       function
c
c        ---- (WEPP Equation 4.2.3) divided by change in soil water
c             content
        diydt = tmpvr1*(1.0+tmpvr2/infilv(i))
        if(timtot.le.timhmx)then
c
c          ---- Time derivative of WEPP Equation 12.1
          kostf = (infilh(i)*(dupper/time(i)+piovr2*infilv(i)/(2.0*
     1            time(i))+piovr2*diydt)+botwid*diydt)*dtheta(iplane)
        else
          kostf = diydt*tmpvr3
        endif
        kostfd = min(kostf,kostfd)
  400 continue
c
c     Determine kostf using wetted perimeter at the upper end of the
c     furrow
c
      kostf = aveks(iplane)*(botwid+2.0*dupper*sqrt(1.0+sidslp**2))
c
c     Set kostf to minimum of possible values
c
      kostf = min(kostf,kostfd)
c
c     Determine maximum flow rate at the lower end of the OFE
c
   10 qmaxl = qmaxu-slplen(iplane)*kostf
c
c     Determine 2*(average depth of flow) for steady state conditions
c
      if(qmaxl.gt.0.0)then
        if(sidslp.gt.0.001)then
          dlower = (sqrt(botwid**2+4.0*sidslp*(qmaxl/aqcnst)**(1.0/
     1             aqexp))-botwid)/2.0/sidslp
        else
          dlower = (qmaxl/aqcnst)**(1.0/aqexp)/botwid
        endif
        avgdp2 = dupper+dlower
      else
        avgdp2 = dupper
      endif
c
c     Determine 2-D cumulative infiltration for t=timtot
c
      if(timtot.le.timhmx)then
c
c        ---- (WEPP Equation 12.1)
        infilt = (avgdp2*infilh(nsteps)+botwid*infilv(nsteps)+
     1           piovr2*infilh(nsteps)*infilv(nsteps))*dtheta(iplane)
      else
        inftmx = (avgdp2*hormax+botwid*vertmx+piovr2*hormax*vertmx)*
     1           dtheta(iplane)
        infilt = inftmx+(infilv(nsteps)-vertmx)*float(furint)*rwdth*
     1           dtheta(iplane)
      endif
c
c     Adjust 2-D cumulative infiltration to eliminate steady state
c     infiltration rate
c
      infadj = infilt-kostf*timtot
c
c     Adjust kostf if infadj is less than 0.000001 m**2
c
      if(infadj.lt.0.000001)then
        infadj = 0.000001
        testf = (infilt-infadj)/timtot
        if(testf.lt.0.999*kostf)then
          kostf = testf
        else
          kostf = 0.999*kostf
        endif
        goto 10
      endif
c
c     Determine values for functions of cumulative infiltration and time
c
      natlni = log(infadj)
      infil2 = infadj**2
      natlnt = log(timtot)
c
c     Calculate summations
c
      irsum1 = infil2
      irsum2 = infil2*natlnt
      irsum3 = irsum2*natlnt
      irsum4 = infil2*natlni
      irsum5 = irsum2*natlni
c
c     Initialize variables for calculation loop
c
      i = 0
c
c     Calculation loop
c
  200 i = i+1
c
c       Determine 2-D cumulative infiltration
c
        if(time(i).le.timhmx)then
c
c          ---- (WEPP Equation 12.1)
          infilt = (avgdp2*infilh(i)+botwid*infilv(i)+piovr2*
     1             infilh(i)*infilv(i))*dtheta(iplane)
        else
          infilt = inftmx+(infilv(i)-vertmx)*float(furint)*rwdth*
     1             dtheta(iplane)
        endif
c
c       Adjust 2-D cumulative infiltration to eliminate steady state
c       infiltration rate
c
        infadj = infilt-kostf*time(i)
c
c       Adjust kostf if infadj is less than 0.0001 m**2
c
        if(infadj.lt.0.000001)then
          testf = (infilt-infadj)/time(i)
          if(testf.lt.0.999*kostf)then
            kostf = testf
          else
            kostf = 0.999*kostf
          endif
          goto 10
        endif
c
c       Determine values for functions of infadj and time
c
        natlni = log(infadj)
        infil2 = infadj*infadj
        natlnt = log(time(i))
        tmpvr4 = infil2*natlnt
c
c       Perform summations
c
        irsum1 = irsum1+infil2
        irsum2 = irsum2+tmpvr4
        irsum3 = irsum3+tmpvr4*natlnt
        irsum4 = irsum4+infil2*natlni
        irsum5 = irsum5+tmpvr4*natlni
c
c     Check for completion of calculation loop
c
      if(i.lt.nsteps-1)goto 200
c
c     Determine Kostiakov-Lewis infiltration equation constants
c
      denom = irsum2*irsum2-irsum1*irsum3
      kosta = (irsum2*irsum4-irsum1*irsum5)/denom
      if(kosta.gt.1.0)then
        kosta = 1.0
        kostk = infadj/timtot
      else
        kostk = exp((irsum2*irsum5-irsum3*irsum4)/denom)
      endif
c
      return
      end


c
c***************************************************************************
c
      subroutine wl_fst2(xkperpl, xkperpr, xkprll, xkprlr,
     .   tn, tnp, tnpp, bn, zetan, lmaxdim,
     .   xkphi, xm, q, xkt, omgc, omgp2, omgrf,
     .   lmin, lmax, nzfun,
     .   dxdth, capr, xntau, btau,
     .   wxx, wxy, wxz, fyxx, fyxy, fyxz,
     .   wyx, wyy, wyz, fyyx, fyyy, fyyz,
     .   wzx, wzy, wzz, fyzx, fyzy, fyzz)

      implicit none

      integer lmin, lmax, nzfun, lmaxdim, l, labs

      real xkperpl, xkperpr, xkprll, xkprlr,
     .     xkprl, gamleft, gamright,
     .     xm, q, xkt, omgc, omgp2, omgrf

      real akprl, gammab, rho, alpha, eps0

      real xkphi, dxdth, capr, xntau, btau

      complex gambar, gamtild
      complex wxx, wxy, wxz,
     1        wyx, wyy, wyz,
     2        wzx, wzy, wzz

      complex fyxx, fyxy, fyxz,
     1        fyyx, fyyy, fyyz,
     2        fyzx, fyzy, fyzz

      complex wxxl, wxyl, wxzl,
     1        wyxl, wyyl, wyzl,
     2        wzxl, wzyl, wzzl

      complex exil(0: lmaxdim), exilp(0: lmaxdim), exilpp(0: lmaxdim)

      complex zi, zieps0

      complex tn(-lmaxdim : lmaxdim),
     .        tnp(-lmaxdim : lmaxdim),
     .        tnpp(-lmaxdim : lmaxdim),
     .        zetan(-lmaxdim : lmaxdim),
     .        bn(-lmaxdim : lmaxdim)

      zi = cmplx(0.0, 1.0)
      eps0 = 8.85e-12

      zieps0 = zi * eps0
      alpha = sqrt(2. * xkt / xm)
      rho = alpha / omgc

      gamleft  = 0.5 * xkperpl**2 * rho**2
      gamright = 0.5 * xkperpr**2 * rho**2

c      gamtild = sqrt(gamleft * gamright)
c      The sqrt loses sign of k's so use instead
      gamtild = 0.5 * xkperpl * xkperpr * rho**2
      gambar = 0.5 * (gamleft + gamright)

c--   Calculate and store Bessel functions for l=0 to l = lmax (Il is ever in l):

      call besiexp2(gamtild, gambar, lmax, exil, exilp, exilpp, lmaxdim)

      wxx = 0.0
      wxy = 0.0
      wxz = 0.0
      wyx = 0.0
      wyy = 0.0
      wyz = 0.0
      wzx = 0.0
      wzy = 0.0
      wzz = 0.0

      fyxx = 0.0
      fyxy = 0.0
      fyxz = 0.0
      fyyx = 0.0
      fyyy = 0.0
      fyyz = 0.0
      fyzx = 0.0
      fyzy = 0.0
      fyzz = 0.0

      do l = lmin, lmax
         labs = abs(l)

         wxxl = - zieps0 * l**2 * exil(labs)/ gamtild * tn(l)
         wxyl = - eps0 * l * (gamright / gamtild * exil(labs)
     1              - exilp(labs)) * tn(l)
         wxzl = zieps0 * xkperpl * l * exil(labs) / gamleft * bn(l)

         wyxl =   eps0 * l * (gamleft / gamtild * exil(labs)
     1              - exilp(labs)) *  tn(l)
         wyyl = - zieps0 * (l**2 / gamtild * exil(labs)
     1                + 2. * gamtild * exil(labs)
     1                - 2. * gambar * exilp(labs) ) *  tn(l)
         wyzl = - eps0 * ( xkperpl * exil(labs)
     1                           - xkperpr * exilp(labs) ) * bn(l)

         wzxl = zieps0 * xkperpr * l * exil(labs)/ gamright * bn(l)
         wzyl =   eps0 * ( xkperpr * exil(labs)
     1                           - xkperpl * exilp(labs) ) * bn(l)
         wzzl = zieps0 * exil(labs) * zetan(l) * tnp(l)

         wxx = wxx + wxxl
         wxy = wxy + wxyl
         wxz = wxz + wxzl
         wyx = wyx + wyxl
         wyy = wyy + wyyl
         wyz = wyz + wyzl
         wzx = wzx + wzxl
         wzy = wzy + wzyl
         wzz = wzz + wzzl

         fyxx = fyxx + l / (2. * omgrf) * wxxl
         fyxy = fyxy + l / (2. * omgrf) * wxyl
         fyxz = fyxz + l / (2. * omgrf) * wxzl
         fyyx = fyyx + l / (2. * omgrf) * wyxl
         fyyy = fyyy + l / (2. * omgrf) * wyyl
         fyyz = fyyz + l / (2. * omgrf) * wyzl
         fyzx = fyzx + l / (2. * omgrf) * wzxl
         fyzy = fyzy + l / (2. * omgrf) * wzyl
         fyzz = fyzz + l / (2. * omgrf) * wzzl

      end do

      return

  101 format(i10, 1p8e12.4)
 1314 format(4i10, 1p9e12.4)
 1312 format(1p9e12.4)
  100 format('ier = ', i5, 'besic failed')
      end
c
c***************************************************************************
c
      subroutine wl_fst(xkperpl, xkperpr, xkprll, xkprlr,
     .   tn, tnp, tnpp, bn, zetan, lmaxdim,
     .   xkphi, xm, q, xkt, omgc, omgp2,
     .   lmin, lmax, nzfun,
     .   dxdth, capr, xntau, btau,
     .   wxx, wxy, wxz,
     .   wyx, wyy, wyz,
     .   wzx, wzy, wzz)

      implicit none

      integer lmin, lmax, nzfun, lmaxdim, l, labs

      real xkperpl, xkperpr, xkprll, xkprlr,
     .     xkprl, gamleft, gamright,
     .     xm, q, xkt, omgc, omgp2

      real akprl, gammab, rho, alpha, eps0, omgrf, v0i

      real xkphi, dxdth, capr, xntau, btau

      complex gambar, gamtild
      complex wxx, wxy, wxz,
     1        wyx, wyy, wyz,
     2        wzx, wzy, wzz

      complex wxxl, wxyl, wxzl,
     1        wyxl, wyyl, wyzl,
     2        wzxl, wzyl, wzzl

      complex exil(0: lmaxdim), exilp(0: lmaxdim), exilpp(0: lmaxdim)

      complex zi, zieps0

      common/sigcom/zi, eps0, v0i, omgrf
      complex tn(-lmaxdim : lmaxdim),
     .        tnp(-lmaxdim : lmaxdim),
     .        tnpp(-lmaxdim : lmaxdim),
     .        zetan(-lmaxdim : lmaxdim),
     .        bn(-lmaxdim : lmaxdim)

      zieps0 = zi * eps0
      alpha = sqrt(2. * xkt / xm)
      rho = alpha / omgc

      gamleft  = 0.5 * xkperpl**2 * rho**2
      gamright = 0.5 * xkperpr**2 * rho**2

c      gamtild = sqrt(gamleft * gamright)
c      The sqrt loses sign of k's so use instead
      gamtild = 0.5 * xkperpl * xkperpr * rho**2
      gambar = 0.5 * (gamleft + gamright)

c--   Calculate and store Bessel functions for l=0 to l = lmax (Il is ever in l):

      call besiexp2(gamtild, gambar, lmax, exil, exilp, exilpp, lmaxdim)

      wxx = 0.0
      wxy = 0.0
      wxz = 0.0

      wyx = 0.0
      wyy = 0.0
      wyz = 0.0

      wzx = 0.0
      wzy = 0.0
      wzz = 0.0

      do l = lmin, lmax
         labs = abs(l)

         wxxl = - zieps0 * l**2 * exil(labs)/ gamtild * tn(l)
         wxyl = - eps0 * l * (gamright / gamtild * exil(labs)
     1              - exilp(labs)) * tn(l)
         wxzl = zieps0 * xkperpl * l * exil(labs) / gamleft * bn(l)

         wyxl =   eps0 * l * (gamleft / gamtild * exil(labs)
     1              - exilp(labs)) *  tn(l)
         wyyl = - zieps0 * (l**2 / gamtild * exil(labs)
     1                + 2. * gamtild * exil(labs)
     1                - 2. * gambar * exilp(labs) ) *  tn(l)
         wyzl = - eps0 * ( xkperpl * exil(labs)
     1                           - xkperpr * exilp(labs) ) * bn(l)

         wzxl = zieps0 * xkperpr * l * exil(labs)/ gamright * bn(l)
         wzyl =   eps0 * ( xkperpr * exil(labs)
     1                           - xkperpl * exilp(labs) ) * bn(l)
         wzzl = zieps0 * exil(labs) * zetan(l) * tnp(l)

         wxx = wxx + wxxl
         wxy = wxy + wxyl
         wxz = wxz + wxzl
         wyx = wyx + wyxl
         wyy = wyy + wyyl
         wyz = wyz + wyzl
         wzx = wzx + wzxl
         wzy = wzy + wzyl
         wzz = wzz + wzzl

      end do

      return

  101 format(i10, 1p8e12.4)
 1314 format(4i10, 1p9e12.4)
 1312 format(1p9e12.4)
  100 format('ier = ', i5, 'besic failed')
      end
c
c***************************************************************************
c
      subroutine estix(ex, ey, ez, ealpp, ebetp, ebp,
     .   bx, by, bz,
     .   xkx, xky, xkphi,
     .   xkprl, xkperp)

      implicit none

      real bx, by, bz, sqx, xkprl, xkalp, xkbet, xkperp,
     .   cosalp, sinalp, xkx, xky, xkphi

      real uxx, uxy, uxz,
     1     uyx, uyy, uyz,
     2     uzx, uzy, uzz

      complex ex, ey, ez, ealpp, ebetp, ebp, ealp, ebet, eb

      sqx = sqrt(1.0 - bx**2)

      xkprl = bx * xkx + by * xky + bz * xkphi
      xkalp = (xkx * (1.0 - bx**2) - xky * bx * by
     .       - xkphi * bx * bz) / sqx
      xkbet = (xky * bz - xkphi * by) / sqx

      xkperp = sqrt(xkalp**2 + xkbet**2)

      cosalp = xkalp / xkperp
      sinalp = xkbet / xkperp

      uxx =   sqx
      uxy = - bx * by / sqx
      uxz = - bx * bz / sqx
      uyx =   0.0
      uyy =   bz / sqx
      uyz = - by / sqx
      uzx =   bx
      uzy =   by
      uzz =   bz

      ealp = uxx * ex + uxy * ey + uxz * ez
      ebet = uyx * ex + uyy * ey + uyz * ez
      eb   = uzx * ex + uzy * ey + uzz * ez

      ealpp =   cosalp * ealp + sinalp * ebet
      ebetp = - sinalp * ealp + cosalp * ebet
      ebp   = eb

      return
      end
c
c***************************************************************************
c
      subroutine besiexp2(gamtild, gambar, lmax, expbes, expbesp,
     1   expbespp, lmaxdim)
c*****   calculates exp(-gambar) times Il(gamtild)
c*****   (and derivatives) of order up to lmax

      implicit none

      integer lmax, nmax, ier, l, lmaxdim
      real gammod
      complex gamtild, gambar, expbes(0:lmaxdim), expbesp(0:lmaxdim),
     1   expbespp(0:lmaxdim),
     1   b(100), xil(0:99), xilp(0:99), xilpp(0:99), exgam

      exgam = cexp(-gambar)
      gammod = cabs(gamtild)

      if(gammod .le. 700.)then
         nmax = lmax + 1

         call besic(gamtild, nmax, b, ier)
         if(ier .ne. 0)write(15,100) ier

         do l = 0, lmax
            xil(l) = b(l+1)
         end do

         do l = 0, lmax
           if(l .eq. 0) xilp(0) = xil(1)
           if(l .ne. 0) xilp(l) = xil(l-1) - l / gamtild * xil(l)
           xilpp(l) = - xilp(l) / gamtild
     1                 + (1. + (l / gamtild)**2)* xil(l)

           expbes(l) =  exgam * xil(l)
           expbesp(l) = exgam * xilp(l)
           expbespp(l) = exgam * xilpp(l)
         end do
      end if

      if(gammod .gt. 700.)then
         do l = 0, lmax
            call bes_asymp(gamtild, gambar, l, expbes(l), expbesp(l))
            expbespp(l) = - expbesp(l) / gamtild
     1             + (1. + (l / gamtild)**2)* expbes(l)
         end do
      end if

  100 format('ier = ', i5, 'besic failed')
  101 format(1p8e12.4)
  102 format(i10, 1p8e12.4)
      return
      end
c
c***************************************************************************
c
      subroutine bes_asymp(z, y, n, exil, exilp)

      implicit none

      integer mu, n
      real pi
      complex z, y, exil, exilp
      data pi/3.141592654/

      mu = 4 * n**2
      exil =  1.0 / csqrt(2.0 * pi * z) * cexp(z - y)
     1   * (1.0
     1   - (mu - 1)/(8.0 * z)
     1   + (mu - 1) * (mu - 9) / (2.0 * (8.0 * z)**2)
     1   - (mu - 1) * (mu - 9) * (mu - 25) / (6.0 * (8.0 * z)**3)  )

      exilp = 1.0 / csqrt(2.0 * pi * z) * cexp(z - y)
     1   * (1.0
     1   - (mu + 3)/(8.0 * z)
     1   + (mu - 1) * (mu + 15) / (2.0 * (8.0 * z)**2)
     1   - (mu - 1) * (mu - 9) * (mu + 35) / (6.0 * (8.0 * z)**3)  )

  102 format(i10, 1p8e12.4)
      return
      end


      subroutine runCY_i(i,j,i1,f,Xtwiddle,Gtt,Gtwiddle,Shat2,Bzero1,N0)
      implicit none
C---  Expression for Eq. 5.57
C---  Calculates Ci, requires C00i
C---  Small terms of order Xtwiddle(0,j)*Cii
C---  Denominator Xtwiddle(i,j)

      include 'TRconstants.f'
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,i,j,i1,n,m,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),
     . Gtwiddle(np,np),f(np),Gtt(np,np,np,np)
      double complex Shat2(np,z1max,-2:0),Bzero1(z1max,-2:0),
     . bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gtt(i,n,j,m)*f(n)
     . *(Shat2(m,i1,ep)-2d0*delta(m,i1)*Cv(cc00+N0,ep))
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=-4d0*Cv(czzi(i1)+N0,ep-1)
      Cv(ci(i1)+N0,ep)=
     .  (Gtwiddle(i,j)*(6d0*Cv(czzi(i1)+N0,ep)+pole-Bzero1(i1,ep))
     . +bit+Xtwiddle(0,j)*Cv(cii(z2(i,i1))+N0,ep))/Xtwiddle(i,j)
      enddo
      return
      end


      subroutine gafill(iplmax_ext)
c
!     implicit real*8 (a-h,o-z)
      implicit none
c
!     include 'atom_param.h'
      integer iplmax_ext
      include 'gfill.h'
!     parameter ( lamp=1,lammp=(lamp+1)*(lamp+1) )
c
!     complex*16 gacoeff(lmmaxp,lmmaxp,lammp)
!     complex*16 rgacoeff(kmymaxp,kmymaxp,lammp)
c
!     common/ggaunt/gacoeff
!     common/rggaunt/rgacoeff

      character*32 sname
      character*32 istop
      parameter(sname='gafill')

      integer i,l,m
      integer lam,lp,lmp
      integer lpmax,lpmin
      integer lm,mp
      integer nu
      integer lmmaxp
      integer kkr1

      real*8 gaunt
      real*8 plmg((2*iplmax+1)*(2*iplmax+2)/2,2*iplmax+1)
      real*8 clm((2*iplmax+1)*(2*iplmax+2)/2)
      real*8 tg(2*(2*iplmax+1))
      real*8 wg(2*(2*iplmax+1))
      real*8 sqfpi,fac

c
!     set up things for the gaunt coeff:s
!      call getclm(2*iplmax,clm)
! meis: changed to normalized associated Legendre functions
      call ylm_coefficients(2*iplmax,clm)
      call gauss_legendre_points(-1.d0,1.d0,tg,wg,2*(2*iplmax+1))
      do i=1,2*iplmax+1
! meis: changed to normalized associated Legendre functions
        call plm_normalized(2*iplmax,tg(i),plmg(1,i))
      end do

      lmmaxp =(iplmax+1)*(iplmax+1)

      sqfpi=dsqrt(16.d0*datan(1.d0))
      i=0
      do lam=0,lamp
      fac=sqfpi/(2*lam+1)
      do nu=-lam,lam
        i=i+1
c
        call zeroout(gacoeff(1,1,i),2*lmmaxp*lmmaxp)
        call zeroout(rgacoeff(1,1,i),2*kmymaxp*kmymaxp)
c
        do l=0,iplmax
        do m=-l,l
          lm=l*l+l+m+1
          mp=m-nu
          lpmin=iabs(l-lam)
          lpmax=l+lam
          do 1 lp=lpmin,lpmax,2
            if(lp.gt.iplmax) goto 1
            if(iabs(mp).gt.lp) goto 1
            lmp=lp*lp+lp+mp+1
!           gacoeff(lm,lmp,i)=fac*skkr_gaunt(l,lam,lp,m,nu,mp)
            gacoeff(lm,lmp,i)=fac*gaunt(lam,nu,l,m,lp,mp,
     >                         2*iplmax,2*iplmax+1,wg,plmg,clm)
    1     continue
        end do
        end do
c       call outmat(gacoeff(1,1,i),lmmaxp,lmmaxp,lmmaxp,6)
!       call relmtrx(gacoeff(1,1,i),rgacoeff(1,1,i),iplmax)
        kkr1=(iplmax+1)*(iplmax+1)
        call relmtrx(gacoeff(1,1,i),rgacoeff(1,1,i),kkr1,kkr1)
c       call outmat(rgacoeff(1,1,i),kmymaxp,kmymaxp,kmymaxp,6)
c
      end do
      end do

c
      return
      end