module finite_differences

  implicit none

  public :: first_order_upwind
  public :: third_order_upwind
  public :: fifth_order_upwind
  public :: third_order_upwind_zed
  public :: first_order_upwind_zed
  public :: second_order_centered
  public :: fourth_order_centered
  public :: second_order_centered_zed
  public :: four_point_triangle
  public :: fd3pt, fd5pt
  public :: d2_3pt
  public :: fd_variable_upwinding_vpa
  public :: fd_variable_upwinding_zed
  public :: fd_cell_centres_zed, cell_centres_zed

  interface fd3pt
     module procedure fd3pt_real
     module procedure fd3pt_real_array
     module procedure fd3pt_complex_array
  end interface

  interface fd5pt
     module procedure fd5pt_real
     module procedure fd5pt_array
  end interface

  interface first_order_upwind
     module procedure first_order_upwind_real
     module procedure first_order_upwind_complex
  end interface

  interface third_order_upwind
     module procedure third_order_upwind_complex
     module procedure third_order_upwind_real
  end interface

  interface fifth_order_upwind
     module procedure fifth_order_upwind_complex
     module procedure fifth_order_upwind_real
  end interface

  interface tridag
     module procedure tridag_real
     module procedure tridag_complex
  end interface

  interface second_order_centered
     module procedure second_order_centered_real
     module procedure second_order_centered_complex
  end interface

  interface four_point_triangle
     module procedure  four_point_triangle_real
     module procedure  four_point_triangle_complex
  end interface

  interface fourth_order_centered
     module procedure fourth_order_centered_real
     module procedure fourth_order_centered_complex
  end interface

  interface second_order_centered_zed
     module procedure second_order_centered_zed_real
     module procedure second_order_centered_zed_complex
  end interface

  interface d2_3pt
     module procedure d2_3pt_real
     module procedure d2_3pt_complex
  end interface

contains

  subroutine first_order_upwind_real (llim, f, del, sgn, df)

    implicit none

    integer, intent (in) :: llim
    real, dimension (llim:), intent (in) :: f
    real, intent (in) :: del
    integer, intent (in) :: sgn
    real, dimension (llim:), intent (out) :: df

    integer :: i, n, istart, iend

    n = size(f)

    if (sgn == -1) then
       istart = llim
       iend = llim+n-1
    else
       istart = llim+n-1
       iend = llim
    end if

    ! zero BC, 1st order accurate upwind
    df(istart) = -f(istart)*sgn/del
    do i = istart-sgn, iend, -sgn
       df(i) = sgn*(f(i+sgn)-f(i))/del
    end do

  end subroutine first_order_upwind_real

  subroutine first_order_upwind_complex (llim, f, del, sgn, df)

    implicit none

    integer, intent (in) :: llim
    complex, dimension (llim:), intent (in) :: f
    real, intent (in) :: del
    integer, intent (in) :: sgn
    complex, dimension (llim:), intent (out) :: df

    integer :: i, n, istart, iend

    n = size(f)

    if (sgn == -1) then
       istart = llim
       iend = llim+n-1
    else
       istart = llim+n-1
       iend = llim
    end if

    ! zero BC, 1st order accurate upwind
    df(istart) = -f(istart)*sgn/del
    do i = istart-sgn, iend, -sgn
       df(i) = sgn*(f(i+sgn)-f(i))/del
    end do

  end subroutine first_order_upwind_complex

  subroutine third_order_upwind_complex (llim, f, del, sgn, df)

    implicit none

    integer, intent (in) :: llim
    complex, dimension (llim:), intent (in) :: f
    real, intent (in) :: del
    integer, intent (in) :: sgn
    complex, dimension (llim:), intent (out) :: df

    integer :: i, n, istart, iend

    n = size(f)
    if (sgn == -1) then
       istart = llim
       iend = llim+n-1
    else
       istart = llim+n-1
       iend = llim
    end if

    i = istart-sgn
    ! zero BC, 1st order accurate upwind
    df(istart) = -f(istart)*sgn/del

    ! zero BC, 3rd order accurate upwind
    df(i) = -sgn*(2.*f(i-sgn)+3.*f(i)-6.*f(i+sgn))/(6.*del)

    ! 1st order accurate upwind
    df(iend) = sgn*(f(iend+sgn)-f(iend))/del

    ! 3rd order accurate upwind
    do i = istart-2*sgn, iend+sgn, -sgn
       df(i) = -sgn*(2.*f(i-sgn)+3*f(i)-6.*f(i+sgn)+f(i+2*sgn))/(6.*del)
    end do

  end subroutine third_order_upwind_complex

  subroutine third_order_upwind_real (llim, f, del, sgn, df)

    implicit none

    integer, intent (in) :: llim
    real, dimension (llim:), intent (in) :: f
    real, intent (in) :: del
    integer, intent (in) :: sgn
    real, dimension (llim:), intent (out) :: df

    integer :: i, n, istart, iend

    n = size(f)
    if (sgn == -1) then
       istart = llim
       iend = llim+n-1
    else
       istart = llim+n-1
       iend = llim
    end if

    i = istart-sgn
    ! zero BC, 1st order accurate upwind
    df(istart) = -f(istart)*sgn/del
    ! zero BC, 3rd order accurate upwind
    df(i) = -sgn*(2.*f(i-sgn)+3.*f(i)-6.*f(i+sgn))/(6.*del)

    ! 1st order accurate upwind
    df(iend) = sgn*(f(iend+sgn)-f(iend))/del

    ! 3rd order accurate upwind
    do i = istart-2*sgn, iend+sgn, -sgn
       df(i) = -sgn*(2.*f(i-sgn)+3*f(i)-6.*f(i+sgn)+f(i+2*sgn))/(6.*del)
    end do

  end subroutine third_order_upwind_real

  subroutine fifth_order_upwind_complex (llim, f, del, sgn, df)

    implicit none

    integer, intent (in) :: llim
    complex, dimension (llim:), intent (in) :: f
    real, intent (in) :: del
    integer, intent (in) :: sgn
    complex, dimension (llim:), intent (out) :: df

    integer :: i, n, istart, iend

    n = size(f)
    if (sgn == -1) then
       istart = llim
       iend = llim+n-1
    else
       istart = llim+n-1
       iend = llim
    end if

    ! zero BC, 1st order accurate upwind
    df(istart) = -f(istart)*sgn/del
    ! zero BC, 3rd order accurate upwind
    i = istart-sgn
    df(i) = -sgn*(2.*f(i-sgn)+3.*f(i)-6.*f(i+sgn))/(6.*del)
    ! zero BC, 5th order accurate upwind
    i = istart-2*sgn
    df(i) = -sgn*(-3.*f(i-2*sgn)+30.*f(i-sgn)+20.*f(i)-60.*f(i+sgn)+15.*f(i+2*sgn))/(60.*del)

    ! 1st order accurate upwind
    df(iend) = sgn*(f(iend+sgn)-f(iend))/del
    ! 3rd order accurate upwind
    df(iend+sgn) = -sgn*(2.*f(iend)+3*f(iend+sgn)-6.*f(iend+2*sgn)+f(iend+3*sgn))/(6.*del)

    ! 5th order accurate upwind
    do i = istart-3*sgn, iend+2*sgn, -sgn
       df(i) = -sgn*(-3.*f(i-2*sgn)+30.*f(i-sgn)+20.*f(i)-60.*f(i+sgn)+15.*f(i+2*sgn)-2.*f(i+3*sgn)) &
                /(60.*del)
    end do

  end subroutine fifth_order_upwind_complex

  subroutine fifth_order_upwind_real (llim, f, del, sgn, df)

    implicit none

    integer, intent (in) :: llim
    real, dimension (llim:), intent (in) :: f
    real, intent (in) :: del
    integer, intent (in) :: sgn
    real, dimension (llim:), intent (out) :: df

    integer :: i, n, istart, iend

    n = size(f)
    if (sgn == -1) then
       istart = llim
       iend = llim+n-1
    else
       istart = llim+n-1
       iend = llim
    end if

    ! zero BC, 1st order accurate upwind
    df(istart) = -f(istart)*sgn/del
    ! zero BC, 3rd order accurate upwind
    i = istart-sgn
    df(i) = -sgn*(2.*f(i-sgn)+3.*f(i)-6.*f(i+sgn))/(6.*del)
    ! zero BC, 5th order accurate upwind
    i = istart-2*sgn
    df(i) = -sgn*(-3.*f(i-2*sgn)+30.*f(i-sgn)+20.*f(i)-60.*f(i+sgn)+15.*f(i+2*sgn))/(60.*del)

    ! 1st order accurate upwind
    df(iend) = -sgn*(f(iend)-f(iend+sgn))/del
    ! 3rd order accurate upwind
    df(iend+sgn) = -sgn*(2.*f(iend)+3*f(iend+sgn)-6.*f(iend+2*sgn)+f(iend+3*sgn))/(6.*del)

    ! 5th order accurate upwind
    do i = istart-3*sgn, iend+2*sgn, -sgn
       df(i) = -sgn*(-3.*f(i-2*sgn)+30.*f(i-sgn)+20.*f(i)-60.*f(i+sgn)+15.*f(i+2*sgn)-2.*f(i+3*sgn)) &
                /(60.*del)
    end do

  end subroutine fifth_order_upwind_real

  subroutine third_order_upwind_zed (llim, iseg, nseg, f, del, sgn, fl, fr, periodic, df)

    implicit none

    integer, intent (in) :: llim, iseg, nseg
    complex, dimension (llim:), intent (in) :: f
    real, intent (in) :: del
    integer, intent (in) :: sgn
    logical, intent (in) :: periodic
    complex, dimension (:), intent (in) :: fl, fr
    complex, dimension (llim:), intent (out) :: df

    integer :: i, istart, iend, ulim

    ulim = size(f)+llim-1
    ! if sgn > 0, then stream speed is negative
    ! so sweep from more positive to more negative zed
    if (sgn > 0) then
       if (iseg == nseg .and..not.periodic) then
          i = ulim
          df(i) = -f(i)/del
          i = ulim-1
          df(i) = -(2.*f(i-1)+3.*f(i)-6.*f(i+1))/(6.*del)
       else
          i = ulim
          df(i) = -(2.*f(i-1)+3.*f(i)-6.*fr(1)+fr(2))/(6.*del)
          i = ulim-1
          df(i) = -(2.*f(i-1)+3.*f(i)-6.*f(i+1)+fr(1))/(6.*del)
       end if
       if (iseg == 1.and..not.periodic) then
          i = llim
          df(i) = (f(i+1)-f(i))/del
       else
          i = llim
          df(i) = -(2.*fl(2)+3*f(i)-6.*f(i+1)+f(i+2))/(6.*del)
       end if
       istart = ulim
       iend = llim
    else
       if (iseg == 1.and..not.periodic) then
          i = llim
          df(i) = f(i)/del
          i = llim+1
          df(i) = (2.*f(i+1)+3.*f(i)-6.*f(i-1))/(6.*del)
       else
          i = llim
          df(i) = (2.*f(i+1)+3*f(i)-6.*fl(2)+fl(1))/(6.*del)
          i = llim+1
          df(i) = (2.*f(i+1)+3*f(i)-6.*f(i-1)+fl(2))/(6.*del)
       end if
       if (iseg == nseg.and..not.periodic) then
          i = ulim
          df(i) = (f(i)-f(i-1))/del
       else
          i = ulim
          df(i) = (2.*fr(1)+3*f(i)-6.*f(i-1)+f(i-2))/(6.*del)
       end if
       istart = llim
       iend = ulim
    end if

    ! 3rd order accurate upwind
    do i = istart-2*sgn, iend+sgn, -sgn
       df(i) = -sgn*(2.*f(i-sgn)+3*f(i)-6.*f(i+sgn)+f(i+2*sgn))/(6.*del)
    end do

  end subroutine third_order_upwind_zed

  subroutine first_order_upwind_zed (llim, iseg, nseg, f, del, sgn, fl, fr, periodic, df)

    implicit none

    integer, intent (in) :: llim, iseg, nseg
    complex, dimension (llim:), intent (in) :: f
    real, intent (in) :: del
    integer, intent (in) :: sgn
    logical, intent (in) :: periodic
    complex, dimension (:), intent (in) :: fl, fr
    complex, dimension (llim:), intent (out) :: df

    integer :: i, istart, iend, ulim

    ulim = size(f)+llim-1
    ! if sgn > 0, then stream speed is negative
    ! so sweep from more positive to more negative zed
    if (sgn > 0) then
       if (iseg == nseg.and..not.periodic) then
          i = ulim
          df(i) = -f(i)/del
          i = ulim-1
          df(i) = (f(i+1)-f(i))/del
       else
          i = ulim
          df(i) = (fr(1)-f(i))/del
          i = ulim-1
          df(i) = (f(i+1)-f(i))/del
       end if
       i = llim
       df(i) = (f(i+1)-f(i))/del
       istart = ulim
       iend = llim
    else
       if (iseg == 1.and..not.periodic) then
          i = llim
          df(i) = f(i)/del
          i = llim+1
          df(i) = (f(i)-f(i-1))/del
       else
          i = llim
          df(i) = (f(i)-fl(2))/del
          i = llim+1
          df(i) = (f(i)-f(i-1))/del
       end if
       i = ulim
       df(i) = (f(i)-f(i-1))/del
       istart = llim
       iend = ulim
    end if

    ! 3rd order accurate upwind
    do i = istart-2*sgn, iend+sgn, -sgn
       df(i) = sgn*(f(i+sgn)-f(i))/del
    end do

  end subroutine first_order_upwind_zed

  subroutine second_order_centered_real (llim, f, del, df)

    implicit none

    integer, intent (in) :: llim
    real, dimension (llim:), intent (in) :: f
    real, intent (in) :: del
    real, dimension (llim:), intent (out) :: df

    integer :: i, n, istart, iend

    n = size(f)
    istart = llim
    iend = llim+n-1

    ! zero BC
    df(istart) = f(istart+1) / (2.*del)
    df(iend)   =-f(iend-1)   / (2.*del)

    ! 2nd order accurate centered
    do i = istart+1, iend-1
       df(i) = (f(i+1) - f(i-1)) / (2.*del)
    end do

  end subroutine second_order_centered_real

  subroutine second_order_centered_complex (llim, f, del, df)

    implicit none

    integer, intent (in) :: llim
    complex, dimension (llim:), intent (in) :: f
    real, intent (in) :: del
    complex, dimension (llim:), intent (out) :: df

    integer :: i, n, istart, iend

    n = size(f)
    istart = llim
    iend = llim+n-1

    ! zero BC
    df(istart) = f(istart+1) / (2.*del)
    df(iend)   =-f(iend-1)   / (2.*del)

    ! 2nd order accurate centered
    do i = istart+1, iend-1
       df(i) = (f(i+1) - f(i-1)) / (2.*del)
    end do

  end subroutine second_order_centered_complex

  subroutine four_point_triangle_real (llim, f, del, df)

    implicit none

    integer, intent (in) :: llim
    real, dimension (llim:), intent (in) :: f
    real, intent (in) :: del
    real, dimension (llim:), intent (out) :: df

    integer :: i, n, istart, iend

    n = size(f)
    istart = llim
    iend = llim+n-1

    ! zero BC
    i=istart
    df(i) = f(i+1) / (2.0*del)
    i=istart+1
    df(i) = (f(i+1)-f(i-1)) / (2.0*del)
    i=istart+2
    df(i) = (-2.*f(i+3)+9.*f(i+1)-9.*f(i-1)) / (18.0*del)

    i=iend
    df(i) = -f(i-1) / (2.0*del)
    i=iend-1
    df(i) = (f(i+1)-f(i-1)) / (2.0*del)
    i=iend-2
    df(i) = (9.*f(i+1)-9.*f(i-1)+2.*f(i-3)) / (18.0*del)

    ! 2nd order accurate centered
    do i = istart+3, iend-3
      df(i) = (-2.*f(i+3)+9.*f(i+1)-9.*f(i-1)+2.*f(i-3)) / (18.0*del)
    end do

  end subroutine four_point_triangle_real

  subroutine four_point_triangle_complex (llim, f, del, df)

    implicit none

    integer, intent (in) :: llim
    complex, dimension (llim:), intent (in) :: f
    real, intent (in) :: del
    complex, dimension (llim:), intent (out) :: df

    integer :: i, n, istart, iend

    n = size(f)
    istart = llim
    iend = llim+n-1

    ! zero BC
    i=istart
    df(i) = f(i+1) / (2.0*del)
    i=istart+1
    df(i) = (f(i+1)-f(i-1)) / (2.0*del)
    i=istart+2
    df(i) = (-2.*f(i+3)+9.*f(i+1)-9.*f(i-1)) / (18.0*del)

    i=iend
    df(i) = -f(i-1) / (2.0*del)
    i=iend-1
    df(i) = (f(i+1)-f(i-1)) / (2.0*del)
    i=iend-2
    df(i) = (9.*f(i+1)-9.*f(i-1)+2.*f(i-3)) / (18.0*del)

    ! 2nd order accurate centered
    do i = istart+3, iend-3
      df(i) = (-2.*f(i+3)+9.*f(i+1)-9.*f(i-1)+2.*f(i-3)) / (18.0*del)
    end do

  end subroutine four_point_triangle_complex

  subroutine fourth_order_centered_real (llim, f, del, df)

    implicit none

    integer, intent (in) :: llim
    real, dimension (llim:), intent (in) :: f
    real, intent (in) :: del
    real, dimension (llim:), intent (out) :: df

    integer :: i, n, istart, iend

    n = size(f)
    istart = llim
    iend = llim+n-1

    ! zero BC
    ! 2nd order accurate centered
    df(istart) = f(istart + 1) / (2.*del)
    df(iend)   =-f(iend   - 1) / (2.*del)

    ! 4th order accurate centered
    df(istart+1) = (f(istart+3) - 8.*f(istart+2) + 8.*f(istart)) / (12.*del)
    df(iend-1)   = (-8*f(iend)  + 8.*f(iend-2) - f(iend-3))      / (12.*del)

    ! 4th order accurate centered
    do i = istart+2, iend-2
       df(i) = (f(i+2)-8.*f(i+1) + 8.*f(i-1)-f(i-2)) / (12.*del)
    end do

  end subroutine fourth_order_centered_real

  subroutine fourth_order_centered_complex (llim, f, del, df)

    implicit none

    integer, intent (in) :: llim
    complex, dimension (llim:), intent (in) :: f
    real, intent (in) :: del
    complex, dimension (llim:), intent (out) :: df

    integer :: i, n, istart, iend

    n = size(f)
    istart = llim
    iend = llim+n-1

    ! zero BC
    ! 2nd order accurate centered
    df(istart) = f(istart + 1) / (2.*del)
    df(iend)   =-f(iend   - 1) / (2.*del)

    ! 4th order accurate centered
    df(istart+1) = (f(istart+3) - 8.*f(istart+2) + 8.*f(istart))/ (12.*del)
    df(iend-1)   = (-8*f(iend) + 8.*f(iend-2) - f(iend-3))      / (12.*del)

    ! 4th order accurate centered
    do i = istart+2, iend-2
       df(i) = (f(i+2)-8.*f(i+1) + 8.*f(i-1)-f(i-2)) / (12.*del)
    end do

  end subroutine fourth_order_centered_complex

  subroutine second_order_centered_zed_real (llim, iseg, nseg, f, del, sgn, fl, fr, periodic, df)

    implicit none

    integer, intent (in) :: llim, iseg, nseg
    real, dimension (llim:), intent (in) :: f
    integer, intent (in) :: sgn
    real, intent (in) :: del
    real, dimension (:), intent (in) :: fl, fr
    logical, intent (in) :: periodic
    real, dimension (llim:), intent (out) :: df

    integer :: i, ulim

    ulim = size(f)+llim-1

    i = llim
    if (iseg == 1 .and. sgn>0 .and..not.periodic) then
       ! sgn > 0 corresponds to negative advection speed
       ! upwind at boundary requires taking information from right
       df(i) = (f(i+1)-f(i))/del
    else
       df(i) = 0.5*(f(i+1)-fl(2))/del
    end if

    i = ulim
    if (iseg == nseg .and. sgn<0 .and..not.periodic) then
       ! sgn < 0 corresponds to positive advection speed
       ! upwind at boundary requires taking information from left
       df(i) = (f(i)-f(i-1))/del
    else
       df(i) = 0.5*(fr(1)-f(i-1))/del
    end if

    do i = llim+1, ulim-1
       df(i) = 0.5*(f(i+1)-f(i-1))/del
    end do

  end subroutine second_order_centered_zed_real

  subroutine second_order_centered_zed_complex (llim, iseg, nseg, f, del, sgn, fl, fr, periodic, df)

    implicit none

    integer, intent (in) :: llim, iseg, nseg
    complex, dimension (llim:), intent (in) :: f
    integer, intent (in) :: sgn
    real, intent (in) :: del
    complex, dimension (:), intent (in) :: fl, fr
    logical, intent (in) :: periodic
    complex, dimension (llim:), intent (out) :: df

    integer :: i, ulim

    ulim = size(f)+llim-1

    i = llim
    if (iseg == 1 .and. sgn>0 .and..not.periodic) then
       ! sgn > 0 corresponds to negative advection speed
       ! upwind at boundary requires taking information from right
       df(i) = (f(i+1)-f(i))/del
    else
       df(i) = 0.5*(f(i+1)-fl(2))/del
    end if

    i = ulim
    if (iseg == nseg .and. sgn<0 .and..not.periodic) then
       ! sgn < 0 corresponds to positive advection speed
       ! upwind at boundary requires taking information from left
       df(i) = (f(i)-f(i-1))/del
    else
       df(i) = 0.5*(fr(1)-f(i-1))/del
    end if

    do i = llim+1, ulim-1
       df(i) = 0.5*(f(i+1)-f(i-1))/del
    end do

  end subroutine second_order_centered_zed_complex

  subroutine second_order_centered_vpa (llim, f, del, df)

    implicit none

    integer, intent (in) :: llim
    complex, dimension (llim:), intent (in) :: f
    real, intent (in) :: del
    complex, dimension (llim:), intent (out) :: df

    integer :: i, ulim

    ulim = size(f)+llim-1

    i = llim
    df(i) = 0.5*f(i+1)/del

    i = ulim
    df(i) = -0.5*f(i-1)/del

    do i = llim+1, ulim-1
       df(i) = 0.5*(f(i+1)-f(i-1))/del
    end do

  end subroutine second_order_centered_vpa

  subroutine fd_cell_centres_zed (llim, f, del, sgn, fl, fr, df)

    implicit none

    integer, intent (in) :: llim
    complex, dimension (llim:), intent (in) :: f
    real, intent (in) :: del
    integer, intent (in) :: sgn
    complex, intent (in) :: fl, fr
    complex, dimension (llim:), intent (out) :: df

    integer :: i, ulim

    ulim = size(f)+llim-1

    if (sgn > 0) then
       ! if sgn > 0, then stream speed is negative
       ! so sweep from more positive to more negative zed
       i = ulim
       df(i) = (fr-f(i))/del
       do i = ulim-1, llim, -1
          df(i) = (f(i+1)-f(i))/del
       end do
    else
       ! if sgn < 0, then stream speed is positive
       ! so sweep from more negative to more positive zed
       i = llim
       df(i) = (f(i)-fl)/del
       do i = llim+1, ulim
          df(i) = (f(i)-f(i-1))/del
       end do
    end if

  end subroutine fd_cell_centres_zed

  ! cell_centres_zed takes f at z grid locations
  ! and returns f at cell centres
  ! (with possible offset due to upwinding)
  subroutine cell_centres_zed (llim, f, upwnd, sgn, fl, fr, fc)

    implicit none

    integer, intent (in) :: llim
    complex, dimension (llim:), intent (in) :: f
    real, intent (in) :: upwnd
    integer, intent (in) :: sgn
    complex, intent (in) :: fl, fr
    complex, dimension (llim:), intent (out) :: fc

    integer :: i, ulim

    ulim = size(f)+llim-1

    if (sgn > 0) then
       ! if sgn > 0, then stream speed is negative
       ! so sweep from more positive to more negative zed
       i = ulim
       fc(i) = 0.5*((1.-upwnd)*fr + (1.+upwnd)*f(i))
       do i = ulim-1, llim, -1
          fc(i) = 0.5*((1.-upwnd)*f(i+1) + (1.+upwnd)*f(i))
       end do
    else
       ! if sgn < 0, then stream speed is positive
       ! so sweep from more negative to more positive zed
       i = llim
       fc(i) = 0.5*((1.+upwnd)*f(i)+(1.-upwnd)*fl)
       do i = llim+1, ulim
          fc(i) = 0.5*((1.+upwnd)*f(i)+(1.-upwnd)*f(i-1))
       end do
    end if

  end subroutine cell_centres_zed

  subroutine fd_variable_upwinding_zed (llim, iseg, nseg, f, del, sgn, upwnd, fl, fr, periodic, df)

    implicit none

    integer, intent (in) :: llim, iseg, nseg
    complex, dimension (llim:), intent (in) :: f
    real, intent (in) :: del, upwnd
    integer, intent (in) :: sgn
    complex, dimension (:), intent (in) :: fl, fr
    logical, intent (in) :: periodic
    complex, dimension (llim:), intent (out) :: df

    integer :: i, istart, iend, ulim

    ! if upwnd is zero or if vpa=0, then use centered differences
    if (abs(upwnd) < epsilon(0.) .or. sgn == 0) then
       call second_order_centered_zed (llim, iseg, nseg, f, del, sgn, fl, fr, periodic, df)
    else
       ulim = size(f)+llim-1

       ! if sgn > 0, then stream speed is negative
       ! so sweep from more positive to more negative zed
       if (sgn > 0) then
          if (iseg == nseg.and..not.periodic) then
             i = ulim
             df(i) = (0.5*(upwnd-1.)*f(i-1)-upwnd*f(i))/del
          else
             i = ulim
             df(i) = (0.5*(upwnd-1.)*f(i-1)-upwnd*f(i)+0.5*(1.+upwnd)*fr(1))/del
          end if
          if (iseg == 1.and..not.periodic) then
             i = llim
             ! at left boundary, must upwind fully as no info for f(i-1)
             df(i) = (f(i+1)-f(i))/del
          else
             i = llim
             df(i) = (0.5*(1.+upwnd)*f(i+1)-upwnd*f(i)+0.5*(upwnd-1.)*fl(2))/del
          end if
          istart = ulim
          iend = llim
       else
          if (iseg == 1.and..not.periodic) then
             i = llim
             df(i) = (0.5*(1.-upwnd)*f(i+1)+upwnd*f(i))/del
          else
             i = llim
             df(i) = (0.5*(1.-upwnd)*f(i+1)+upwnd*f(i)-0.5*(1.+upwnd)*fl(2))/del
          end if
          if (iseg == nseg.and..not.periodic) then
             i = ulim
             ! if at rightmost zed, have no info for f(i+1) so must fully upwind
             df(i) = (f(i)-f(i-1))/del
          else
             i = ulim
             df(i) = (0.5*(1.-upwnd)*fr(1)+upwnd*f(i)-0.5*(1.+upwnd)*f(i-1))/del
          end if
          istart = llim
          iend = ulim
       end if

       ! mixed 2nd order centered and 1st order upwind scheme
       do i = istart-sgn, iend+sgn, -sgn
          df(i) = sgn*(0.5*(1.+upwnd)*f(i+sgn) - upwnd*f(i) + 0.5*(upwnd-1.)*f(i-sgn))/del
       end do

    end if

  end subroutine fd_variable_upwinding_zed

  subroutine fd_variable_upwinding_vpa (llim, f, del, sgn, upwnd, df)

    implicit none

    integer, intent (in) :: llim
    complex, dimension (llim:), intent (in) :: f
    real, intent (in) :: del, upwnd
    integer, intent (in) :: sgn
    complex, dimension (llim:), intent (out) :: df

    integer :: i, istart, iend, ulim

    ! if upwnd is zero or if z=0, then use centered differences
    if (abs(upwnd) < epsilon(0.) .or. sgn == 0) then
       call second_order_centered_vpa (llim, f, del, df)
    else
       ulim = size(f)+llim-1

       ! if sgn > 0, then stream speed is negative
       ! so sweep from more positive to more negative zed
       if (sgn > 0) then
          istart = ulim
          iend = llim
       else
          istart = llim
          iend = ulim
       end if

       ! zero_bc assumes that g -> zero beyond grid
       ! boundaries in vpa
       df(istart) = sgn*(0.5*(upwnd-1.0)*f(istart-sgn)-upwnd*f(istart))/del

       ! as do not have info beyond grid boundary at end of sweep
       ! use pure upwinding
       df(iend) = sgn*(f(iend+sgn)-f(iend))/del

       ! mixed centered and 1st order upwind scheme
       do i = istart-sgn, iend+sgn, -sgn
          df(i) = sgn*(0.5*(1.+upwnd)*f(i+sgn) - upwnd*f(i) + 0.5*(upwnd-1.)*f(i-sgn))/del
       end do

    end if

  end subroutine fd_variable_upwinding_vpa

  ! only good for equally-spaced grid-pts
  subroutine fd3pt_real (prof, profgrad, dr)

    implicit none

    real, dimension (:), intent (in) :: prof
    real, dimension (:), intent (out) :: profgrad
    real, intent (in) :: dr

    integer :: ix, npts
    real, dimension (:), allocatable :: aa, bb, cc

    npts = size(prof)
    allocate (aa(npts), bb(npts), cc(npts))

    aa = 1.0 ; bb = 4.0 ; cc = 1.0
    aa(1) = 0.0 ; bb(1) = 0.5 ; cc(1) = 0.5
    aa(npts) = 0.5 ; bb(npts) = 0.5 ; cc(npts) = 0.0

    do ix = 2, npts-1
       profgrad(ix) = 3.0 * (prof(ix+1) - prof(ix-1)) / dr
    end do
    profgrad(1) = (prof(2)-prof(1))/dr
    profgrad(npts) = (prof(npts)-prof(npts-1))/dr

    call tridag (aa, bb, cc, profgrad)

    deallocate (aa, bb, cc)

  end subroutine fd3pt_real

  subroutine fd3pt_real_array (prof, profgrad, dr)

    implicit none

    real, dimension (:), intent (in) :: prof, dr
    real, dimension (:), intent (out) :: profgrad

    integer :: ix, npts
    real :: a, b, c

    npts = size(prof)

    do ix = 2, npts-1
       profgrad(ix) = ((prof(ix)-prof(ix-1))*dr(ix)/dr(ix-1) &
            + (prof(ix+1)-prof(ix))*dr(ix-1)/dr(ix)) / (dr(ix-1)+dr(ix))
    end do
    ix = 1
    a = -(2.*dr(1) + dr(2))/(dr(1)*(dr(1)+dr(2)))
    b = (dr(1)+dr(2))/(dr(1)*dr(2))
    c = -dr(1)/(dr(2)*(dr(1)+dr(2)))
    profgrad(1) = a*prof(1)+b*prof(2)+c*prof(3)
    ix = npts
    a = dr(npts-1)/(dr(npts-2)*(dr(npts-2)+dr(npts-1)))
    b = -(dr(npts-1)+dr(npts-2))/(dr(npts-2)*dr(npts-1))
    c = (2.*dr(npts-1)+dr(npts-2))/(dr(npts-1)*(dr(npts-1)+dr(npts-2)))
    profgrad(npts) = a*prof(npts-2) + b*prof(npts-1) + c*prof(npts)

  end subroutine fd3pt_real_array

  subroutine fd3pt_complex_array (prof, profgrad, dr)

    implicit none

    complex, dimension (:), intent (in) :: prof
    real, dimension (:), intent (in) :: dr
    complex, dimension (:), intent (out) :: profgrad

    integer :: ix, npts
    real :: a, b, c

    npts = size(prof)

    do ix = 2, npts-1
       profgrad(ix) = ((prof(ix)-prof(ix-1))*dr(ix)/dr(ix-1) &
            + (prof(ix+1)-prof(ix))*dr(ix-1)/dr(ix)) / (dr(ix-1)+dr(ix))
    end do
    ix = 1
    a = -(2.*dr(1) + dr(2))/(dr(1)*(dr(1)+dr(2)))
    b = (dr(1)+dr(2))/(dr(1)*dr(2))
    c = -dr(1)/(dr(2)*(dr(1)+dr(2)))
    profgrad(1) = a*prof(1)+b*prof(2)+c*prof(3)
    ix = npts
    a = dr(npts-1)/(dr(npts-2)*(dr(npts-2)+dr(npts-1)))
    b = -(dr(npts-1)+dr(npts-2))/(dr(npts-2)*dr(npts-1))
    c = (2.*dr(npts-1)+dr(npts-2))/(dr(npts-1)*(dr(npts-1)+dr(npts-2)))
    profgrad(npts) = a*prof(npts-2) + b*prof(npts-1) + c*prof(npts)

  end subroutine fd3pt_complex_array

  ! boundary points are 2nd-order accurate (2-pt compact difference)
  ! next to boundary points are 4th-order accurate (2-pt centered compact difference)
  ! interior points are 6th-order accurate (4-pt centered compact difference)
  subroutine fd5pt_real (prof, profgrad, dr)

    implicit none

    real, dimension (:), intent (in) :: prof
    real, dimension (:), intent (out) :: profgrad
    real, intent (in) :: dr

    integer :: ix, npts
    real, dimension (:), allocatable :: aa, bb, cc

    npts = size(prof)
    allocate (aa(npts), bb(npts), cc(npts))

    aa = 1.0 ; bb = 3.0 ; cc = 1.0
    aa(1) = 0.0 ; bb(1) = 0.5 ; cc(1) = 0.5
    aa(2) = 1.0 ; bb(2) = 4.0 ; cc(2) = 1.0
    aa(npts-1) = 1.0 ; bb(npts-1) = 4.0 ; cc(npts-1) = 1.0
    aa(npts) = 0.5 ; bb(npts) = 0.5 ; cc(npts) = 0.0

    do ix = 3, npts-2
       profgrad(ix) = (7.*(prof(ix+1) - prof(ix-1)) + 0.25*(prof(ix+2)-prof(ix-2))) / (3.*dr)
    end do
    profgrad(1) = (prof(2)-prof(1))/dr
    profgrad(2) = 3.0*(prof(3) - prof(1))/dr
    profgrad(npts-1) = 3.0*(prof(npts) - prof(npts-2))/dr
    profgrad(npts) = (prof(npts)-prof(npts-1))/dr

    call tridag (aa, bb, cc, profgrad)

    deallocate (aa, bb, cc)

  end subroutine fd5pt_real

  ! boundary points are 2nd-order accurate (2-pt compact difference)
  ! next to boundary points are 4th-order accurate (2-pt centered compact difference)
  ! interior points are 6th-order accurate (4-pt centered compact difference)
  subroutine fd5pt_array (prof, profgrad, dr)

    implicit none

    real, dimension (:), intent (in) :: prof, dr
    real, dimension (:), intent (out) :: profgrad

    integer :: ix, npts
    real, dimension (:), allocatable :: aa, bb, cc

    npts = size(prof)
    allocate (aa(npts), bb(npts), cc(npts))

    aa = 1.0 ; bb = 3.0 ; cc = 1.0
    aa(1) = 0.0 ; bb(1) = 0.5 ; cc(1) = 0.5
    aa(2) = 1.0 ; bb(2) = 4.0 ; cc(2) = 1.0
    aa(npts-1) = 1.0 ; bb(npts-1) = 4.0 ; cc(npts-1) = 1.0
    aa(npts) = 0.5 ; bb(npts) = 0.5 ; cc(npts) = 0.0

    do ix = 3, npts-2
       profgrad(ix) = (7.*(prof(ix+1) - prof(ix-1)) + 0.25*(prof(ix+2)-prof(ix-2))) / (3.*dr(ix))
    end do
    profgrad(1) = (prof(2)-prof(1))/dr(1)
    profgrad(2) = 3.0*(prof(3) - prof(1))/dr(2)
    profgrad(npts-1) = 3.0*(prof(npts) - prof(npts-2))/dr(npts-1)
    profgrad(npts) = (prof(npts)-prof(npts-1))/dr(npts)

    call tridag (aa, bb, cc, profgrad)

    deallocate (aa, bb, cc)

  end subroutine fd5pt_array

  ! second derivative using centered differences
  ! second order accurate
  subroutine d2_3pt_real (f, d2f, dr)

    implicit none

    real, dimension (:), intent (in) :: f
    real, dimension (:), intent (in) :: dr
    real, dimension (:), intent (out) :: d2f

    real :: a, b, c, d
    integer :: i, n

    n = size(f)

    do i = 2, n-1
       a = 2./(dr(i-1)*(dr(i)+dr(i-1)))
       b = -2./(dr(i-1)*dr(i))
       c = 2./(dr(i)*(dr(i)+dr(i-1)))
       d2f(i) = a*f(i-1)+b*f(i)+c*f(i+1)
    end do
    i = 1
    a = (6.*dr(1)+4.*dr(2)+2.*dr(3)) &
         / (dr(1)*(dr(1)+dr(2))*(dr(1)+dr(2)+dr(3)))
    b = -(4.*(dr(1)+dr(2))+2.*dr(3)) &
         / (dr(1)*dr(2)*(dr(2)+dr(3)))
    c = (4.*dr(1)+2.*(dr(2)+dr(3))) &
         / ((dr(2)+dr(1))*dr(2)*dr(3))
    d = -(4.*dr(1)+2.*dr(2)) &
         / ((dr(3)+dr(2)+dr(1))*(dr(3)+dr(2))*dr(3))
    d2f(i) = a*f(1)+b*f(2)+c*f(3)+d*f(4)
    i = n
    a = -(4.*dr(n-1)+2.*dr(n-2)) &
         / (dr(n-3)*(dr(n-3)+dr(n-2))*(dr(n-3)+dr(n-2)+dr(n-1)))
    b = (4.*dr(n-1)+2.*(dr(n-2)+dr(n-3))) &
         / (dr(n-3)*dr(n-2)*(dr(n-2)+dr(n-1)))
    c = -(4.*(dr(n-1)+dr(n-2))+2.*dr(n-3)) &
         / (dr(n-1)*dr(n-2)*(dr(n-2)+dr(n-3)))
    d = (6.*dr(n-1)+4.*dr(n-2)+2.*dr(n-3)) &
         / (dr(n-1)*(dr(n-1)+dr(n-2))*(dr(n-1)+dr(n-2)+dr(n-3)))
    d2f(i) = a*f(n-3)+b*f(n-2)+c*f(n-1)+d*f(n)

!     ! FLAG -- this is a hack
!     ! do not anticipate needing 2nd derivatives
!     ! at first and last grid points
!     d2f(1) = d2f(2)
!     d2f(n) = d2f(n-1)

  end subroutine d2_3pt_real

  subroutine d2_3pt_complex (f, d2f, dr)

    implicit none

    complex, dimension (:), intent (in) :: f
    real, dimension (:), intent (in) :: dr
    complex, dimension (:), intent (out) :: d2f

    real :: a, b, c, d
    integer :: i, n

    n = size(f)

    do i = 2, n-1
       a = 2./(dr(i-1)*(dr(i)+dr(i-1)))
       b = -2./(dr(i-1)*dr(i))
       c = 2./(dr(i)*(dr(i)+dr(i-1)))
       d2f(i) = a*f(i-1)+b*f(i)+c*f(i+1)
    end do
    i = 1
    a = (6.*dr(1)+4.*dr(2)+2.*dr(3)) &
         / (dr(1)*(dr(1)+dr(2))*(dr(1)+dr(2)+dr(3)))
    b = -(4.*(dr(1)+dr(2))+2.*dr(3)) &
         / (dr(1)*dr(2)*(dr(2)+dr(3)))
    c = (4.*dr(1)+2.*(dr(2)+dr(3))) &
         / ((dr(2)+dr(1))*dr(2)*dr(3))
    d = -(4.*dr(1)+2.*dr(2)) &
         / ((dr(3)+dr(2)+dr(1))*(dr(3)+dr(2))*dr(3))
    d2f(i) = a*f(1)+b*f(2)+c*f(3)+d*f(4)
    i = n
    a = -(4.*dr(n-1)+2.*dr(n-2)) &
         / (dr(n-3)*(dr(n-3)+dr(n-2))*(dr(n-3)+dr(n-2)+dr(n-1)))
    b = (4.*dr(n-1)+2.*(dr(n-2)+dr(n-3))) &
         / (dr(n-3)*dr(n-2)*(dr(n-2)+dr(n-1)))
    c = -(4.*(dr(n-1)+dr(n-2))+2.*dr(n-3)) &
         / (dr(n-1)*dr(n-2)*(dr(n-2)+dr(n-3)))
    d = (6.*dr(n-1)+4.*dr(n-2)+2.*dr(n-3)) &
         / (dr(n-1)*(dr(n-1)+dr(n-2))*(dr(n-1)+dr(n-2)+dr(n-3)))
    d2f(i) = a*f(n-3)+b*f(n-2)+c*f(n-1)+d*f(n)

  end subroutine d2_3pt_complex

  subroutine tridag_real (aa, bb, cc, sol)

    implicit none

    real, dimension (:), intent (in) :: aa, bb, cc
    real, dimension (:), intent (in out) :: sol

    integer :: ix, npts
    real :: bet

    real, dimension (:), allocatable :: gam

    npts = size(aa)
    allocate (gam(npts))

    bet = bb(1)
    sol(1) = sol(1)/bet

    do ix = 2, npts
       gam(ix) = cc(ix-1)/bet
       bet = bb(ix) - aa(ix)*gam(ix)
       if (bet == 0.0) write (*,*) 'tridiagonal solve failed'
       sol(ix) = (sol(ix)-aa(ix)*sol(ix-1))/bet
    end do

    do ix = npts-1, 1, -1
       sol(ix) = sol(ix) - gam(ix+1)*sol(ix+1)
    end do

    deallocate (gam)

  end subroutine tridag_real

  subroutine tridag_complex (llim, aa, bb, cc, sol)

    implicit none

    integer, intent (in) :: llim
    real, dimension (llim:), intent (in) :: aa, bb, cc
    complex, dimension (llim:), intent (in out) :: sol

    integer :: ix, npts
    real :: bet

    real, dimension (:), allocatable :: gam

    npts = size(bb)
    allocate (gam(llim:llim+npts-1))

    bet = bb(llim)
    sol(llim) = sol(llim)/bet

    do ix = llim+1, llim+npts-1
       gam(ix) = cc(ix-1)/bet
       bet = bb(ix) - aa(ix)*gam(ix)
       if (bet == 0.0) write (*,*) 'tridiagonal solve failed'
       sol(ix) = (sol(ix)-aa(ix)*sol(ix-1))/bet
    end do

    do ix = llim+npts-2, llim, -1
       sol(ix) = sol(ix) - gam(ix+1)*sol(ix+1)
    end do

    deallocate (gam)

  end subroutine tridag_complex

end module finite_differences


! { dg-do run }
! PR fortran/24518
! MOD/MODULO of large arguments.
! The naive algorithm goes pear-shaped for large arguments, instead
! use fmod.
! Here we test only with constant arguments (evaluated with
! mpfr_fmod), as we don't want to cause failures on targets with a
! crappy libm.
program mod_large_1
  implicit none
  real :: r1
  r1 = mod (1e22, 1.7)
  if (abs(r1 - 0.995928764) > 1e-5) STOP 1
  r1 = modulo (1e22, -1.7)
  if (abs(r1 + 0.704071283) > 1e-5) STOP 2
end program mod_large_1


double precision function allencahn_fort_eval_bc(iface,t,x,y)
    implicit none

    integer iface
    double precision x,y,t

    integer bctype(0:3)
    common /comm_bc/ bctype

    integer normals(0:3,2)
    double precision q,grad(2), qn, a,b

    data normals /-1,1,0,0,0,0,-1,1/

    call allencahn_qexact_gradient(x,y,q,grad)

    !! q_n = grad q \cdot n
    qn = normals(iface,1)*grad(1) + normals(iface,2)*grad(2)

    !! bc_type is set in options .ini file as [multigrid] boundary_conditions
    if (bctype(iface) .eq. 1) then
        a = 1
        b = 0
    elseif (bctype(iface) .eq. 2) then
        a = 0
        b = 1
    endif

    allencahn_fort_eval_bc = a*q + b*qn
    !!allencahn_fort_eval_bc = 0

    return

end function allencahn_fort_eval_bc

double precision function allencahn_dirichlet(iface,t,x,y)
    implicit none

    integer iface
    double precision t,x,y

    allencahn_dirichlet = -1

end function allencahn_dirichlet


C Copyright 2021 Dennis Blondell Decker
C Date: 29 May 2021
C Purpose: Consecutive prime sum
C Tectonics: gfortran --ffixed-form -o euler050 euler050.f90 primesieve.f90

      PROGRAM EULER050
         PARAMETER (MX=1000)
C The gfortran compiler makes the program segmentation fault
C         PARAMETER (MX=1000000)
         LOGICAL SIEVE(MX)
         INTEGER PRIMES(MX), IARR(MX+1), ICUMARR(MX)
         EQUIVALENCE (IARR(2),ICURARR)
         EXTERNAL ERASTOTHENE

         DATA ICUMARR/MX*0/
         CALL ERASTOTHENE(SIEVE,MX)

         J=0
         DO 10 I=1,MX
            IF (SIEVE(I)) THEN
               J=J+1
               PRIMES(J)=I
            ENDIF
   10    CONTINUE
         MXPRIMES=J

C We treat this problem like a maximum sum subarray problem.
C Use Bentley's quadratic variation of Kandane's Algorithm.
C Instead of the maximum sum, we find the maximum length.
         IARR(1)=0
         DO 20 I=1,MXPRIMES
   20       ICUMARR(I)=ICUMARR(I-1)+PRIMES(I)

C         DO 25 I=1,10
C   25       PRINT *,I,PRIMES(I),ICUMARR(I),ICUMARR(I-1)

         MXSOFAR=0
         K=0
         L=0
         DO 40 I=1,MXPRIMES
            DO 30 J=I,MXPRIMES
               ISUM=ICUMARR(J)-ICUMARR(I-1)
C              ISUM IS SUM OF PRIMES(I:J)
C               IF (I.EQ.1.AND.J.EQ.6)
C     1         PRINT*,ISUM,ICUMARR(J),ICUMARR(I-1),ICUMARR(0),I,J,K,L
               IF (ISUM.LT.MX) THEN
                  IF (SIEVE(ISUM)) THEN
                     IF ((L-K).LT.(J-I)) THEN
                        K=I
                        L=J
                        MXSOFAR=ISUM
                     ENDIF
                  ENDIF
               ENDIF
   30       CONTINUE
   40    CONTINUE

         PRINT 50,MXSOFAR,L-K+1,(PRIMES(I),I=K,L)
   50    FORMAT ('Sum:',I0,' with ',I0,' primes:',1000(I7))
      END


      subroutine DSDIF ( K, N, T, BCOEF, NDERIV, BDIF )
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 DSDIF Krogh  Changes to use M77CON
c>> 1992-11-02 DSDIF C. L. Lawson, JPL
c>> 1988-03-16 C. L. Lawson, JPL
c
c     Constructs a divided difference table in BDIF(,), preparatory to
c     derivative calculation.
c     The subroutine, BSPLPP, given on pp. 140-141 of
c     A PRACTICAL GUIDE TO SPLINES by Carl De Boor, Springer-Verlag,
c     1978, has been recoded as separate subroutines: DSTOT (or DSTOP)
c     calling DSDIF and DSVALA.  This subroutine has the functionality
c     of lines 57-71 of BSPLPP in the book.
c     ------------------------------------------------------------------
c--D replaces "?": ?SDIF
c     ------------------------------------------------------------------
      integer I, ID, K, KMID, N, NDERIV
      double precision BCOEF(N), BDIF(N,NDERIV+1)
      double precision DIFF, FKMID, T(N+K), ZERO
      parameter(ZERO = 0.0D0)
c     ------------------------------------------------------------------
      do 10 I=1,N
         BDIF(I,1) = BCOEF(I)
   10 continue
      KMID = K
      do 20 ID=2,NDERIV+1
         KMID = KMID - 1
         FKMID = dble(KMID)
         do 20 I=ID,N
            DIFF = T(I + KMID) - T(I)
            if (DIFF .ne. ZERO) then
               BDIF(I,ID) = FKMID*(BDIF(I,ID-1) - BDIF(I-1,ID-1))/DIFF
            else
               BDIF(I,ID) = ZERO
            endif
   20       continue
      return
      end


submodule(forlab_stats) forlab_stats_randn

    implicit none

contains

    module function randn_0_sp(mean, std) result(random)
        real(sp), intent(in) :: mean, std
        real(sp) :: random

        real(sp) :: u, v, s

        do
            call random_number(u)
            call random_number(v)
            u = 2._sp*u - 1._sp
            v = 2._sp*v - 1._sp
            s = u*u + v*v
            if ((s > 0._sp) .and. (s < 1._sp)) exit
        end do

        random = mean + u*sqrt(-2.0_sp*log(s)/s)*std

    end function randn_0_sp

    module function randn_1_sp(mean, std, ndim) result(random)
        real(sp), intent(in) :: mean, std
        integer, intent(in) :: ndim
        real(sp) :: random(ndim)

        integer :: i

        do i = 1, ndim
            random(i) = randn_0_sp(mean, std)
        end do

    end function randn_1_sp
    module function randn_0_dp(mean, std) result(random)
        real(dp), intent(in) :: mean, std
        real(dp) :: random

        real(dp) :: u, v, s

        do
            call random_number(u)
            call random_number(v)
            u = 2._dp*u - 1._dp
            v = 2._dp*v - 1._dp
            s = u*u + v*v
            if ((s > 0._dp) .and. (s < 1._dp)) exit
        end do

        random = mean + u*sqrt(-2.0_dp*log(s)/s)*std

    end function randn_0_dp

    module function randn_1_dp(mean, std, ndim) result(random)
        real(dp), intent(in) :: mean, std
        integer, intent(in) :: ndim
        real(dp) :: random(ndim)

        integer :: i

        do i = 1, ndim
            random(i) = randn_0_dp(mean, std)
        end do

    end function randn_1_dp

end submodule forlab_stats_randn


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   fhn :        The FitzHugh - Nagumo Equation
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION a,b,c,x,y

       a=PAR(1)
       b=PAR(2)
       c=PAR(3)

       x=U(1)
       y=U(2)

       F(1)= c * ( x - x**3/3 + y )
       F(2)=-( x - a + b*y ) / c

      END SUBROUTINE FUNC
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T
!
! Initialize the equation parameters
       PAR(1)=0.
       PAR(2)=0.8
       PAR(3)=3.0

! Initialize the solution (assuming PAR(1)=0 )
       U(1)=0.
       U(2)=0.

      END SUBROUTINE STPNT
!----------------------------------------------------------------------
!----------------------------------------------------------------------
      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS
!----------------------------------------------------------------------
!----------------------------------------------------------------------


!     .................................................
!             ____  _       _   ____  _____   _
!            |  _ \| |     |_| |  _ \|  ___| |_|
!            | |_) | |___   _  | |_) | |___   _
!            |  _ /|  _  | | | |  _ /|___  | | |
!            | |   | | | | | | | |    ___| | | |
!            |_|   |_| |_| |_| |_|   |_____| |_|
!     .................................................
!     PhiPsi:     a general-purpose computational
!                 mechanics program written in Fortran.
!     Website:    http://phipsi.top
!     Author:     Shi Fang from Huaiyin Institute of
!                 Technology, HuaiAn, JiangSu, China
!     Contact me: shifang@hyit.edu.cn
!     ------------------------------------------------
!     Please cite the following papers:
!     (1)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based method with reduction technique
!        for modeling hydraulic fracture propagation
!        in formations containing frictional natural
!        fractures. Engineering Fracture Mechanics,
!        2017, 173: 64-90.
!     (2)Shi F, Wang X L, Liu C, Liu H, Wu H A. A
!        coupled extended finite element approach
!        for modeling hydraulic fracturing in
!        consideration of proppant. Journal of
!        Natural Gas Science and Engineering, 2016,
!        33: 885-897.
!     (3)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based numerical model to calculate
!        conductivity of propped fracture considering
!        proppant transport, embedment and crushing.
!        Journal of Petroleum Science and Engineering,
!        2018, 167: 615-626..

      SUBROUTINE Matrix_Inverse(a,c,n)
C     get inverse matrix

      !============================================================
      ! Inverse matrix
      ! Method: Based on Doolittle LU factorization for Ax=b
      ! Alex G. December 2009
      !-----------------------------------------------------------
      ! input ...
      ! a(n,n) - array of coefficients for matrix A
      ! n      - dimension
      ! output ...
      ! c(n,n) - inverse matrix of A
      ! comments ...
      ! the original matrix a(n,n) will be destroyed
      ! during the calculation
      !===========================================================
      implicit none
      integer,intent(in)::n
      double precision,intent(in):: a(n,n)
      double precision,intent(out):: c(n,n)
      double precision L(n,n), U(n,n), b(n), d(n), x(n)
      double precision coeff,tem_a(n,n)
      integer i, j, k

      tem_a = a
      ! step 0: initialization for matrices L and U and b
      ! Fortran 90/95 aloows such operations on matrices
      L=0.0D0
      U=0.0D0
      b=0.0D0

      ! step 1: forward elimination
      do k=1, n-1
          do i=k+1,n
              coeff=tem_a(i,k)/tem_a(k,k)
              L(i,k) = coeff
              do j=k+1,n
                  tem_a(i,j) = tem_a(i,j)-coeff*tem_a(k,j)
              end do
          end do
      end do

      ! Step 2: prepare L and U matrices
      ! L matrix is a matrix of the elimination coefficient
      ! + the diagonal elements are 1.0
      do i=1,n
		  L(i,i) = 1.0D0
      end do
      ! U matrix is the upper triangular part of A
      do j=1,n
          do i=1,j
              U(i,j) = tem_a(i,j)
          end do
      end do

      ! Step 3: compute columns of the inverse matrix C
      do k=1,n
          b(k)=1.0D0
          d(1) = b(1)
		! Step 3a: Solve Ld=b using the forward substitution
          do i=2,n
              d(i)=b(i)
              do j=1,i-1
                 d(i) = d(i) - L(i,j)*d(j)
              end do
          end do
		! Step 3b: Solve Ux=d using the back substitution
		  x(n)=d(n)/U(n,n)
          do i = n-1,1,-1
              x(i) = d(i)
              do j=n,i+1,-1
			      x(i)=x(i)-U(i,j)*x(j)
              end do
          x(i) = x(i)/u(i,i)
          end do
		! Step 3c: fill the solutions x(n) into column k of C
          do i=1,n
              c(i,k) = x(i)
          end do
		  b(k)=0.0D0
      end do

      return
      END SUBROUTINE Matrix_Inverse


SUBROUTINE tide_perm (dC20_perm)

! ----------------------------------------------------------------------
! SUBROUTINE: tide_perm.f90
! ----------------------------------------------------------------------
! Purpose:
!  Permanent Tide term
! ----------------------------------------------------------------------
! Input arguments
!
! Output arguments:
! - dC20_perm :		Permanent tide (time-independent) as C20 coefficient correction
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia            November 2015
! ----------------------------------------------------------------------

      USE mdl_precision
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN

! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: dC20_perm
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: k20
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Love numbers (Knm) : Table 6.3, IERS Conventions (2010)
! ----------------------------------------------------------------------
! Elastic Earth
      k20 = 0.29525D0
! Anelastic Earth
      k20 = 0.30190D0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Permanent tide (time-independent): C20 coefficient correction
      dC20_perm = 4.4228D-8 * (-0.31460D0) * k20
! ----------------------------------------------------------------------

END


      END FUNCTION func

      SUBROUTINE trapzd(func,a,b,s,n)
      IMPLICIT NONE
      INTEGER :: n
      REAL*8,INTENT(IN):: a,b
      EXTERNAL func
      INTEGER:: it,j
      REAL*8 :: del,sum,tnm,x,s,func
*      parameter (n=10000)
      it=2**(n-2)
      it = 50000
      tnm=float(it)
      del=(b-a)/tnm
      x=a+0.5*del
      sum=0.5*func(a)
*      write(*,*)' trap ',it,tnm,del,x
      do 11 j=1,it-1
      sum=sum+func(x)
      x=x+del
*     write(*,*)j,x,sum
  11  continue
      sum=sum+0.5*func(b)
      s=sum*del
      return

      END subroutine

      program main
      IMPLICIT NONE
      REAL*8 ::a,b,a0,e0,c0,m1,m2,p,r,q,l3,l1,sf,s,func
      INTEGER :: n
      EXTERNAL func
      WRITE (*,*) "a0= ,e0=, m1= ,m2= "
      READ(*,*) a0,e0,m1,m2
*      a0 = 5.
*      e0 = 0.5
*      m1 = 10.
*      m2 = 10.
*      a0=a0*7.0e+08
      p=-12./19.
      r=121./304.
      q=-870./2299.
      n=10
      c0=a0*(e0**p)*((1+r*(e0**2))**q)
      l3=1.9e+16
      l1=((m1*m2)/m1+m2)
      a=0.
      b=e0
      write(*,*) a,b,c0,l1,l3
      call trapzd(func,a,b,s,n)
      write(*,*) "trapezoidal : " , s
      sf=(12./19.)*(c0**4./l1)*s*l3
      write(*,*) "The time is(inMyrs) =", sf/3.16e+13
      stop
      end


!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module contains functions for interpolation in 8 node
!!      hexahedral element  (Langrange  interpolation)
module shape_hex8n
  integer, parameter, private :: kreal = kind(0.0d0)

contains
  subroutine ShapeFunc_hex8n(localcoord,func)
    real(kind=kreal) :: localcoord(3)
    real(kind=kreal) :: func(8)
    func(1) = 0.125d0*(1.d0-localcoord(1))*(1.d0-localcoord(2))*(1.d0-localcoord(3))
    func(2) = 0.125d0*(1.d0+localcoord(1))*(1.d0-localcoord(2))*(1.d0-localcoord(3))
    func(3) = 0.125d0*(1.d0+localcoord(1))*(1.d0+localcoord(2))*(1.d0-localcoord(3))
    func(4) = 0.125d0*(1.d0-localcoord(1))*(1.d0+localcoord(2))*(1.d0-localcoord(3))
    func(5) = 0.125d0*(1.d0-localcoord(1))*(1.d0-localcoord(2))*(1.d0+localcoord(3))
    func(6) = 0.125d0*(1.d0+localcoord(1))*(1.d0-localcoord(2))*(1.d0+localcoord(3))
    func(7) = 0.125d0*(1.d0+localcoord(1))*(1.d0+localcoord(2))*(1.d0+localcoord(3))
    func(8) = 0.125d0*(1.d0-localcoord(1))*(1.d0+localcoord(2))*(1.d0+localcoord(3))
  end subroutine

  subroutine ShapeDeriv_hex8n(localcoord, func)
    real(kind=kreal) :: localcoord(3)
    real(kind=kreal) :: func(8,3)
    func(1,1) = -0.125d0*(1.d0-localcoord(2))*(1.d0-localcoord(3))
    func(2,1) =  0.125d0*(1.d0-localcoord(2))*(1.d0-localcoord(3))
    func(3,1) =  0.125d0*(1.d0+localcoord(2))*(1.d0-localcoord(3))
    func(4,1) = -0.125d0*(1.d0+localcoord(2))*(1.d0-localcoord(3))
    func(5,1) = -0.125d0*(1.d0-localcoord(2))*(1.d0+localcoord(3))
    func(6,1) =  0.125d0*(1.d0-localcoord(2))*(1.d0+localcoord(3))
    func(7,1) =  0.125d0*(1.d0+localcoord(2))*(1.d0+localcoord(3))
    func(8,1) = -0.125d0*(1.d0+localcoord(2))*(1.d0+localcoord(3))

    func(1,2) = -0.125d0*(1.d0-localcoord(1))*(1.d0-localcoord(3))
    func(2,2) = -0.125d0*(1.d0+localcoord(1))*(1.d0-localcoord(3))
    func(3,2) =  0.125d0*(1.d0+localcoord(1))*(1.d0-localcoord(3))
    func(4,2) =  0.125d0*(1.d0-localcoord(1))*(1.d0-localcoord(3))
    func(5,2) = -0.125d0*(1.d0-localcoord(1))*(1.d0+localcoord(3))
    func(6,2) = -0.125d0*(1.d0+localcoord(1))*(1.d0+localcoord(3))
    func(7,2) =  0.125d0*(1.d0+localcoord(1))*(1.d0+localcoord(3))
    func(8,2) =  0.125d0*(1.d0-localcoord(1))*(1.d0+localcoord(3))

    func(1,3) = -0.125d0*(1.d0-localcoord(1))*(1.d0-localcoord(2))
    func(2,3) = -0.125d0*(1.d0+localcoord(1))*(1.d0-localcoord(2))
    func(3,3) = -0.125d0*(1.d0+localcoord(1))*(1.d0+localcoord(2))
    func(4,3) = -0.125d0*(1.d0-localcoord(1))*(1.d0+localcoord(2))
    func(5,3) =  0.125d0*(1.d0-localcoord(1))*(1.d0-localcoord(2))
    func(6,3) =  0.125d0*(1.d0+localcoord(1))*(1.d0-localcoord(2))
    func(7,3) =  0.125d0*(1.d0+localcoord(1))*(1.d0+localcoord(2))
    func(8,3) =  0.125d0*(1.d0-localcoord(1))*(1.d0+localcoord(2))
  end subroutine

end module


!Incomplete program....

Program MAIN
    implicit none;
    real ll, ul, sum1, sum2, sum;
!    F(x) = 1/(1 + x**2);
    F(X)=0.398862*((PI+(X/SQRT(200.0)))*EXP(-0.5*X*X))

    integer n, i;
    real h;
    real integral;

    ll = 0
    ul = 1
    n = 6
    h = (ul-ll) / n

    sum = F(ll) + F(ul);
    sum1 = 0;
    sum2 = 0;

    do i = 2 , n, 2
     sum1 = sum1 + F(ll + (i-1)*h)
    end do

    do i = 3 , n, 2
        sum2 = sum2 + F(ll + (i-1)*h)
    end do

   integral = h/3(sum + 2*sum2 + 4*sum1)

   print * , integral

end program MAIN


module mod_initgrid
  use mod_param, only:pi
  use mod_types
  implicit none
  private
  public initgrid,distribute_grid,save_grid
  contains
  subroutine initgrid(n,lo,hi,gt,gr,l,drc_g,drf_g,rc_g,rf_g)
    !
    ! initializes a non-uniform grid
    !
    implicit none
    integer, parameter :: CLUSTER_TWO_END   = 0, &
                          CLUSTER_ONE_END   = 1, &
                          CLUSTER_MIDDLE    = 2, &
                          CLUSTER_ONE_END_R = 3
    integer         , intent(in )                  :: n,lo,hi,gt
    real(rp)        , intent(in )                  :: gr,l
    real(rp)        , intent(out), dimension(1-1:) :: drc_g,drf_g,rc_g,rf_g
    real(rp) :: r0
    integer :: q
    procedure (), pointer :: gridpoint => null()
    select case(gt)
    case(CLUSTER_TWO_END)
      gridpoint => gridpoint_cluster_two_end
    case(CLUSTER_ONE_END)
      gridpoint => gridpoint_cluster_one_end
    case(CLUSTER_ONE_END_R)
      gridpoint => gridpoint_cluster_one_end_r
    case(CLUSTER_MIDDLE)
      gridpoint => gridpoint_cluster_middle
    case default
      gridpoint => gridpoint_cluster_two_end
    end select
    !
    ! step 1) determine coordinates of cell faces rf
    !
    do q=1,n
      r0  = (q-0._rp)/(1._rp*n)
      call gridpoint(gr,r0,rf_g(q))
      rf_g(q) = rf_g(q)*l
    enddo
    rf_g(0) = 0._rp
    !
    ! step 2) determine grid spacing between faces drf
    !
    do q=1,n
      drf_g(q) = rf_g(q)-rf_g(q-1)
    enddo
    drf_g(0  ) = drf_g(1)
    drf_g(n+1) = drf_g(n)
    !
    ! step 3) determine grid spacing between centers drc
    !
    do q=0,n
      drc_g(q) = .5_rp*(drf_g(q)+drf_g(q+1))
    enddo
    drc_g(n+1) = drc_g(n)
    !
    ! step 4) compute coordinates of cell centers rc and faces rf
    !
    rc_g(0)    = -drc_g(0)/2._rp
    rf_g(0)    = 0._rp
    do q=1,n+1
      rc_g(q) = rc_g(q-1) + drc_g(q-1)
      rf_g(q) = rf_g(q-1) + drf_g(q)
    enddo
  end subroutine initgrid
  !
  subroutine distribute_grid(lo,hi,grid_g,grid)
    implicit none
    integer  :: lo,hi
    real(rp), intent(in ), dimension(1-1 :) :: grid_g
    real(rp), intent(out), dimension(lo-1:) :: grid
    grid(lo-1:hi+1) = grid_g(lo-1:hi+1)
  end subroutine distribute_grid
  !
  subroutine save_grid(fname,ng,rf_g,rc_g,drf_g,drc_g)
    implicit none
    character(len=*), intent(in) :: fname
    integer         , intent(in) :: ng
    real(rp)        , intent(in), dimension(1-1:) :: rf_g,rc_g,drf_g,drc_g
    integer :: iunit,q,rlen
    !
    inquire(iolength=rlen) 1._rp
    open(newunit=iunit,file=trim(fname)//'.bin',status='replace',access='direct',recl=ng*4*rlen)
    write(iunit,rec=1) rf_g(1:ng),rc_g(1:ng),drf_g(1:ng),drc_g(1:ng)
    close(iunit)
    open(newunit=iunit,status='replace',file=trim(fname)//'.out')
    do q=0,ng+1
      write(iunit,'(5E15.7)') 0._rp,rf_g(q),rc_g(q),drf_g(q),drc_g(q)
    enddo
    close(iunit)
  end subroutine save_grid
  !
  ! grid stretching functions
  ! see e.g., Fluid Flow Phenomena -- A Numerical Toolkit, by P. Orlandi
  !           Pirozzoli et al. JFM 788, 614–639 (commented)
  !
  subroutine gridpoint_cluster_two_end(alpha,r0,r)
    !
    ! clustered at the two sides
    !
    implicit none
    real(rp), intent(in ) :: alpha,r0
    real(rp), intent(out) :: r
    if(alpha /= 0._rp) then
      r = 0.5_rp*(1._rp+tanh((r0-0.5_rp)*alpha)/tanh(alpha/2._rp))
      !r = 0.5_rp*(1._rp+erf( (r0-0.5_rp)*alpha)/erf( alpha/2._rp))
    else
      r = r0
    endif
  end subroutine gridpoint_cluster_two_end
  subroutine gridpoint_cluster_one_end(alpha,r0,r)
    !
    ! clustered at the lower side
    !
    implicit none
    real(rp), intent(in ) :: alpha,r0
    real(rp), intent(out) :: r
    if(alpha /= 0._rp) then
      r = 1.0_rp*(1._rp+tanh((r0-1.0_rp)*alpha)/tanh(alpha/1._rp))
      !r = 1.0_rp*(1._rp+erf( (r0-1.0_rp)*alpha)/erf( alpha/1._rp))
    else
      r = r0
    endif
  end subroutine gridpoint_cluster_one_end
  subroutine gridpoint_cluster_one_end_r(alpha,r0,r)
    !
    ! clustered at the lower side
    !
    implicit none
    real(rp), intent(in ) :: alpha,r0
    real(rp), intent(out) :: r
    if(alpha /= 0._rp) then
      r = 1._rp-1.0_rp*(1._rp+tanh((1._rp-r0-1.0_rp)*alpha)/tanh(alpha/1._rp))
      !r = 1._rp-1.0_rp*(1._rp+erf( (1._rp-r0-1.0_rp)*alpha)/erf( alpha/1._rp))
    else
      r = r0
    endif
  end subroutine gridpoint_cluster_one_end_r
  subroutine gridpoint_cluster_middle(alpha,r0,r)
    !
    ! clustered in the middle
    !
    implicit none
    real(rp), intent(in ) :: alpha,r0
    real(rp), intent(out) :: r
    if(alpha /= 0._rp) then
      if(    r0 <= 0.5_rp) then
        r = 0.5_rp*(1._rp-1._rp+tanh(2._rp*alpha*(r0-0._rp))/tanh(alpha))
        !r = 0.5_rp*(1._rp-1._rp+erf( 2._rp*alpha*(r0-0._rp))/erf( alpha))
      elseif(r0 >  0.5_rp) then
        r = 0.5_rp*(1._rp+1._rp+tanh(2._rp*alpha*(r0-1._rp))/tanh(alpha))
        !r = 0.5_rp*(1._rp+1._rp+erf( 2._rp*alpha*(r0-1._rp))/erf( alpha))
      endif
    else
      r = r0
    endif
  end subroutine gridpoint_cluster_middle
end module mod_initgrid


program quadratic
    implicit none
    real a,b,c,D,x1,x2
    a=3
    b=5
    c=1
    D=b*b-4*a*c
    x1=(-b+sqrt(D))/(2*a)
    x2=(-b-sqrt(D))/(2*a)
    print *,'X1 X2 = ',x1,x2
end


      subroutine ero_cfactor

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine predicts daily soil loss caused by water erosion
!!    using the modified universal soil loss equation

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    cvm(:)      |none          |natural log of USLE_C (the minimum value
!!                               |of the USLE C factor for the land cover)
!!    hru_km(:)   |km**2         |area of HRU in square kilometers
!!    peakr       |m^3/s         |peak runoff rate
!!    surfq(:)    |mm H2O        |surface runoff for the day in HRU
!!    usle_ei     |100(ft-tn in)/(acre-hr)|USLE rainfall erosion index
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    cklsp(:)    |
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Exp

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use basin_module
      use hru_module, only : usle_cfac, cvm_com, ihru
      use plant_module
      use organic_mineral_mass_module

      implicit none

      integer :: j       !none          |HRU number
      real :: c          !              |
      real :: rsd_frcov  !              |fraction of cover by residue
      real :: grcov_fr   !              |fraction of cover by biomass as function of lai
      real :: bio_frcov  !              |fraction of cover by biomass - adjusted for canopy height
      real :: cover      !kg/ha         |soil cover
      integer :: max     !              |   ??? should this be real??

      j = ihru

      !! HRU sediment calculations
      if (bsn_cc%cfac == 0) then
        cover = pl_mass(j)%ab_gr_com%m + rsd1(j)%tot_com%m
        if (pcom(j)%npl > 0) then
          c = Exp((-.2231 - cvm_com(j)) * Exp(-.00115 * cover) + cvm_com(j))
        else
          if (cover > 1.e-4) then
            c = Exp(-.2231 * Exp(-.00115 * cover))
          else
            c = .8
          end if
	    end if
      else
        rsd_frcov = Exp(-bsn_prm%rsd_covco * cover)
        grcov_fr = pcom(j)%lai_sum / (pcom(j)%lai_sum + Exp(1.748 - 1.748 * pcom(j)%lai_sum))
        bio_frcov = 1. - grcov_fr * Exp(-.01 * pcom(j)%cht_mx)
        c = Max(1.e-10, rsd_frcov * bio_frcov)
      end if

      usle_cfac(ihru) = c

      return
      end subroutine ero_cfactor


      SUBROUTINE dftcor(w,delta,a,b,endpts,corre,corim,corfac)
      REAL a,b,corfac,corim,corre,delta,w,endpts(8)
      REAL a0i,a0r,a1i,a1r,a2i,a2r,a3i,a3r,arg,c,cl,cr,s,sl,sr,t,t2,t4,
     *t6
      DOUBLE PRECISION cth,ctth,spth2,sth,sth4i,stth,th,th2,th4,tmth2,
     *tth4i
      th=w*delta
      if (a.ge.b.or.th.lt.0.d0.or.th.gt.3.1416d0)pause
     *'bad arguments to dftcor'
      if(abs(th).lt.5.d-2)then
        t=th
        t2=t*t
        t4=t2*t2
        t6=t4*t2
        corfac=1.-(11./720.)*t4+(23./15120.)*t6
        a0r=(-2./3.)+t2/45.+(103./15120.)*t4-(169./226800.)*t6
        a1r=(7./24.)-(7./180.)*t2+(5./3456.)*t4-(7./259200.)*t6
        a2r=(-1./6.)+t2/45.-(5./6048.)*t4+t6/64800.
        a3r=(1./24.)-t2/180.+(5./24192.)*t4-t6/259200.
        a0i=t*(2./45.+(2./105.)*t2-(8./2835.)*t4+(86./467775.)*t6)
        a1i=t*(7./72.-t2/168.+(11./72576.)*t4-(13./5987520.)*t6)
        a2i=t*(-7./90.+t2/210.-(11./90720.)*t4+(13./7484400.)*t6)
        a3i=t*(7./360.-t2/840.+(11./362880.)*t4-(13./29937600.)*t6)
      else
        cth=cos(th)
        sth=sin(th)
        ctth=cth**2-sth**2
        stth=2.d0*sth*cth
        th2=th*th
        th4=th2*th2
        tmth2=3.d0-th2
        spth2=6.d0+th2
        sth4i=1./(6.d0*th4)
        tth4i=2.d0*sth4i
        corfac=tth4i*spth2*(3.d0-4.d0*cth+ctth)
        a0r=sth4i*(-42.d0+5.d0*th2+spth2*(8.d0*cth-ctth))
        a0i=sth4i*(th*(-12.d0+6.d0*th2)+spth2*stth)
        a1r=sth4i*(14.d0*tmth2-7.d0*spth2*cth)
        a1i=sth4i*(30.d0*th-5.d0*spth2*sth)
        a2r=tth4i*(-4.d0*tmth2+2.d0*spth2*cth)
        a2i=tth4i*(-12.d0*th+2.d0*spth2*sth)
        a3r=sth4i*(2.d0*tmth2-spth2*cth)
        a3i=sth4i*(6.d0*th-spth2*sth)
      endif
      cl=a0r*endpts(1)+a1r*endpts(2)+a2r*endpts(3)+a3r*endpts(4)
      sl=a0i*endpts(1)+a1i*endpts(2)+a2i*endpts(3)+a3i*endpts(4)
      cr=a0r*endpts(8)+a1r*endpts(7)+a2r*endpts(6)+a3r*endpts(5)
      sr=-a0i*endpts(8)-a1i*endpts(7)-a2i*endpts(6)-a3i*endpts(5)
      arg=w*(b-a)
      c=cos(arg)
      s=sin(arg)
      corre=cl+c*cr-s*sr
      corim=sl+s*cr+c*sr
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/dftcor.for


	subroutine mkbutter3(delt,df,numah,nfilt,fmin,fmax,zfilt)
c  band-pass filter fmin to fmax
c generates 3-pole butterworth filter, BUT: zero phase
c  filters both ways: Multiplies filter by its complex congjgate
C output is:
C	zfilt  complex freq-domain transfer function
C	df	frequency spacing
C	nfilt	=2^l, number of points in zfilt
c  GAA
	complex zfilt(*)

	complex z0, zone
	data si/0.8660254/,co/0.5/
c find pwr of two .ge.numah
	l = 1
1	continue
	    l = l * 2
	    if (l.ge.numah) go to 2
	    go to 1
2	continue
c  make sure at least more than 2x points than data
	nfilt = l * 2
	df = 1./(float(nfilt-1)*delt)

	dfn = df/fmax
	dfn2 =df/fmin
	nfd2 = nfilt/2
	fn = dfn
	fn2 = dfn2
	zone = cmplx(1.,0.)
	do 10 i=2,nfd2
c low-pass stages
	    z0 = cmplx(1.,fn)
	    z0 = z0*cmplx(co,fn + si)*cmplx(co,fn - si)
	    zfilt(i) = zone/(z0*conjg(z0))
c modify for high-pass, also 2x 3pole
	    z0 = cmplx(1.,fn2)
	    z0  = z0*cmplx(co,fn2 + si)*cmplx(co,fn2 - si)
	    zfilt(i) = zfilt(i)*cmplx(fn2**6,0.)/(z0*conjg(z0))
	    zfilt(nfilt-i+2) = zfilt(i)
	    fn = dfn + fn
	    fn2 = dfn2 + fn2
10	continue
	zfilt(1) = cmplx(0.,0.)
	zfilt(nfd2 + 1) = cmplx(0.,0.)
	return
	end


C$Procedure      M2EUL ( Matrix to Euler angles )

      SUBROUTINE M2EUL (  R,  AXIS3,   AXIS2,   AXIS1,
     .                        ANGLE3,  ANGLE2,  ANGLE1  )

C$ Abstract
C
C     Factor a rotation matrix as a product of three rotations about
C     specified coordinate axes.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     ROTATION
C
C$ Keywords
C
C     ANGLE
C     MATRIX
C     ROTATION
C     TRANSFORMATION
C
C$ Declarations

      DOUBLE PRECISION      R      ( 3, 3 )

      INTEGER               AXIS3
      INTEGER               AXIS2
      INTEGER               AXIS1

      DOUBLE PRECISION      ANGLE3
      DOUBLE PRECISION      ANGLE2
      DOUBLE PRECISION      ANGLE1

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     R          I   A rotation matrix to be factored.
C     AXIS3,
C     AXIS2,
C     AXIS1      I   Numbers of third, second, and first rotation axes.
C     ANGLE3,
C     ANGLE2,
C     ANGLE1     O   Third, second, and first Euler angles, in radians.
C
C$ Detailed_Input
C
C     R              is a 3x3 rotation matrix that is to be factored as
C                    a product of three rotations about a specified
C                    coordinate axes.  The angles of these rotations are
C                    called `Euler angles'.
C
C     AXIS3,
C     AXIS2,
C     AXIS1          are the indices of the rotation axes of the
C                    `factor' rotations, whose product is R.  R is
C                    factored as
C
C                       R = [ ANGLE3 ]     [ ANGLE2 ]     [ ANGLE1 ]   .
C                                    AXIS3          AXIS2         AXIS1
C
C                    The axis numbers must belong to the set {1, 2, 3}.
C                    The second axis number MUST differ from the first
C                    and third axis numbers.
C
C                    See the $ Particulars section below for details
C                    concerning this notation.
C
C$ Detailed_Output
C
C     ANGLE3,
C     ANGLE2,
C     ANGLE1         are the Euler angles corresponding to the matrix
C                    R and the axes specified by AXIS3, AXIS2, and
C                    AXIS1.  These angles satisfy the equality
C
C                       R = [ ANGLE3 ]     [ ANGLE2 ]     [ ANGLE1 ]
C                                   AXIS3          AXIS2          AXIS1
C
C
C                    See the $ Particulars section below for details
C                    concerning this notation.
C
C                    The range of ANGLE3 and ANGLE1 is (-pi, pi].
C
C                    The range of ANGLE2 depends on the exact set of
C                    axes used for the factorization.  For
C                    factorizations in which the first and third axes
C                    are the same,
C
C                       R = [r]  [s]  [t] ,
C                              a    b    a
C
C                    the range of ANGLE2 is [0, pi].
C
C
C                    For factorizations in which the first and third
C                    axes are different,
C
C                       R = [r]  [s]  [t] ,
C                              a    b    c
C
C                    the range of ANGLE2 is [-pi/2, pi/2].
C
C                    For rotations such that ANGLE3 and ANGLE1 are not
C                    uniquely determined, ANGLE3 will always be set to
C                    zero; ANGLE1 is then uniquely determined.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)   If any of AXIS3, AXIS2, or AXIS1 do not have values in
C
C             { 1, 2, 3 },
C
C          then the error SPICE(BADAXISNUMBERS) is signaled.
C
C     2)   An arbitrary rotation matrix cannot be expressed using
C          a sequence of Euler angles unless the second rotation axis
C          differs from the other two.  If AXIS2 is equal to AXIS3 or
C          AXIS1, then then error SPICE(BADAXISNUMBERS) is signaled.
C
C     3)   If the input matrix R is not a rotation matrix, the error
C          SPICE(NOTAROTATION) is signaled.
C
C     4)   If ANGLE3 and ANGLE1 are not uniquely determined, ANGLE3
C          is set to zero, and ANGLE1 is determined.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     A word about notation:  the symbol
C
C        [ x ]
C             i
C
C     indicates a coordinate system rotation of x radians about the
C     ith coordinate axis.  To be specific, the symbol
C
C        [ x ]
C             1
C
C     indicates a coordinate system rotation of x radians about the
C     first, or x-, axis; the corresponding matrix is
C
C        +-                    -+
C        |  1      0       0    |
C        |                      |
C        |  0    cos(x)  sin(x) |.
C        |                      |
C        |  0   -sin(x)  cos(x) |
C        +-                    -+
C
C     Remember, this is a COORDINATE SYSTEM rotation by x radians; this
C     matrix, when applied to a vector, rotates the vector by -x
C     radians, not x radians.  Applying the matrix to a vector yields
C     the vector's representation relative to the rotated coordinate
C     system.
C
C     The analogous rotation about the second, or y-, axis is
C     represented by
C
C        [ x ]
C             2
C
C     which symbolizes the matrix
C
C        +-                    -+
C        | cos(x)   0   -sin(x) |
C        |                      |
C        |  0       1      0    |,
C        |                      |
C        | sin(x)   0    cos(x) |
C        +-                    -+
C
C     and the analogous rotation about the third, or z-, axis is
C     represented by
C
C        [ x ]
C             3
C
C     which symbolizes the matrix
C
C        +-                    -+
C        |  cos(x)  sin(x)   0  |
C        |                      |
C        | -sin(x)  cos(x)   0  |.
C        |                      |
C        |  0        0       1  |
C        +-                    -+
C
C
C     The input matrix is assumed to be the product of three
C     rotation matrices, each one of the form
C
C        +-                    -+
C        |  1      0       0    |
C        |                      |
C        |  0    cos(r)  sin(r) |     (rotation of r radians about the
C        |                      |      x-axis),
C        |  0   -sin(r)  cos(r) |
C        +-                    -+
C
C
C        +-                    -+
C        | cos(s)   0   -sin(s) |
C        |                      |
C        |  0       1      0    |     (rotation of s radians about the
C        |                      |      y-axis),
C        | sin(s)   0    cos(s) |
C        +-                    -+
C
C     or
C
C        +-                    -+
C        |  cos(t)  sin(t)   0  |
C        |                      |
C        | -sin(t)  cos(t)   0  |     (rotation of t radians about the
C        |                      |      z-axis),
C        |  0        0       1  |
C        +-                    -+
C
C     where the second rotation axis is not equal to the first or
C     third.  Any rotation matrix can be factored as a sequence of
C     three such rotations, provided that this last criterion is met.
C
C     This routine is related to the SPICELIB routine EUL2M, which
C     produces a rotation matrix, given a sequence of Euler angles.
C     This routine is a `right inverse' of EUL2M:  the sequence of
C     calls
C
C        CALL M2EUL ( R,  AXIS3,   AXIS2,   AXIS1,
C       .                 ANGLE3,  ANGLE2,  ANGLE1     )
C
C        CALL EUL2M (     ANGLE3,  ANGLE2,  ANGLE1,
C       .                 AXIS3,   AXIS2,   AXIS1,   R )
C
C     preserves R, except for round-off error.
C
C
C     On the other hand, the sequence of calls
C
C        CALL EUL2M (     ANGLE3,  ANGLE2,  ANGLE1,
C       .                 AXIS3,   AXIS2,   AXIS1,   R )
C
C        CALL M2EUL ( R,  AXIS3,   AXIS2,   AXIS1,
C       .                 ANGLE3,  ANGLE2,  ANGLE1     )
C
C
C     preserve ANGLE3, ANGLE2, and ANGLE1 only if these angles start
C     out in the ranges that M2EUL's outputs are restricted to.
C
C$ Examples
C
C     1)  Conversion of instrument pointing from a matrix representation
C         to Euler angles:
C
C         Suppose we want to find camera pointing in alpha, delta, and
C         kappa, given the inertial-to-camera coordinate transformation
C
C
C    +-                                                               -+
C    |  0.49127379678135830  0.50872620321864170  0.70699908539882417  |
C    |                                                                 |
C    | -0.50872620321864193 -0.49127379678135802  0.70699908539882428  |
C    |                                                                 |
C    |  0.70699908539882406 -0.70699908539882439  0.01745240643728360  |
C    +-                                                               -+
C
C
C         We want to find angles alpha, delta, kappa such that
C
C            TICAM  =  [ kappa ]  [ pi/2 - delta ]  [ pi/2 + alpha ] .
C                               3                 1                 3
C
C         We can use the following small program to do this computation:
C
C
C            PROGRAM EX1
C            IMPLICIT NONE
C
C            DOUBLE PRECISION      DPR
C            DOUBLE PRECISION      HALFPI
C            DOUBLE PRECISION      TWOPI
C
C            DOUBLE PRECISION      ALPHA
C            DOUBLE PRECISION      ANG1
C            DOUBLE PRECISION      ANG2
C            DOUBLE PRECISION      DELTA
C            DOUBLE PRECISION      KAPPA
C            DOUBLE PRECISION      TICAM  ( 3, 3 )
C
C
C            DATA TICAM /  0.49127379678135830D0,
C           .             -0.50872620321864193D0,
C           .              0.70699908539882406D0,
C           .              0.50872620321864170D0,
C           .             -0.49127379678135802D0,
C           .             -0.70699908539882439D0,
C           .              0.70699908539882417D0,
C           .              0.70699908539882428D0,
C           .              0.01745240643728360D0  /
C
C
C            CALL M2EUL ( TICAM, 3, 1, 3, KAPPA, ANG2, ANG1 )
C
C            DELTA = HALFPI() - ANG2
C            ALPHA = ANG1     - HALFPI()
C
C            IF ( KAPPA .LT. 0.D0 ) THEN
C               KAPPA = KAPPA + TWOPI()
C            END IF
C
C            IF ( ALPHA .LT. 0.D0 ) THEN
C               ALPHA = ALPHA + TWOPI()
C            END IF
C
C            WRITE (*,'(1X,A,F24.14)') 'Alpha (deg): ', DPR() * ALPHA
C            WRITE (*,'(1X,A,F24.14)') 'Delta (deg): ', DPR() * DELTA
C            WRITE (*,'(1X,A,F24.14)') 'Kappa (deg): ', DPR() * KAPPA
C
C            END
C
C
C         The program's output should be something like
C
C            Alpha (deg):       315.00000000000000
C            Delta (deg):         1.00000000000000
C            Kappa (deg):        45.00000000000000
C
C         possibly formatted a little differently, or degraded slightly
C         by round-off.
C
C
C     2)  Conversion of instrument pointing angles from a non-J2000,
C         not necessarily inertial frame to J2000-relative RA, Dec,
C         and Twist.
C
C         Suppose that we have pointing for some instrument expressed as
C
C            [ gamma ]  [ beta ]  [ alpha ]
C                     3         2          3
C
C         with respect to some coordinate system S.  For example, S
C         could be a spacecraft-fixed system.
C
C         We will suppose that the transformation from J2000
C         coordinates to system S coordinates is given by the rotation
C         matrix J2S.
C
C         The rows of J2S are the unit basis vectors of system S, given
C         in J2000 coordinates.
C
C         We want to express the pointing with respect to the J2000
C         system as the sequence of rotations
C
C            [ kappa ]  [ pi/2 - delta ]  [ pi/2 + alpha ] .
C                     3                 1                 3
C
C         First, we use subroutine EUL2M to form the transformation
C         from system S to instrument coordinates S2INST.
C
C            CALL EUL2M ( GAMMA, BETA, ALPHA, 3, 2, 3, S2INST )
C
C         Next, we form the transformation from J2000 to instrument
C         coordinates J2INST.
C
C            CALL MXM ( S2INST, J2S, J2INST )
C
C         Finally, we express J2INST using the desired Euler angles, as
C         in the first example:
C
C            CALL M2EUL ( J2INST, 3, 1, 3, TWIST, ANG2, ANG3 )
C
C            RA   =  ANG3 - HALFPI()
C            DEC  =  HALFPI() - ANG2
C
C         If we wish to make sure that RA, DEC, and TWIST are in
C         the ranges [0, 2pi), [-pi/2, pi/2], and [0, 2pi)
C         respectively, we may add the code
C
C            IF ( RA .LT. 0.D0 ) THEN
C               RA = RA + TWOPI()
C            END IF
C
C            IF ( TWIST .LT. 0.D0 ) THEN
C               TWIST = TWIST + TWOPI()
C            END IF
C
C         Note that DEC is already in the correct range, since ANG2
C         is in the range [0, pi] when the first and third input axes
C         are equal.
C
C         Now RA, DEC, and TWIST express the instrument pointing
C         as RA, Dec, and Twist, relative to the J2000 system.
C
C         A warning note:  more than one definition of RA, Dec, and
C         Twist is extant.  Before using this example in an application,
C         check that the definition given here is consistent with that
C         used in your application.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.2.1, 21-DEC-2006 (NJB)
C
C        Error corrected in header example:  input matrix
C        previously did not match shown outputs.  Offending
C        example now includes complete program.
C
C-    SPICELIB Version 1.2.0, 15-OCT-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in MXM and MTXM calls.  A short error message cited in
C        the Exceptions section of the header failed to match
C        the actual short message used; this has been corrected.
C
C-    SPICELIB Version 1.1.2, 13-OCT-2004 (NJB)
C
C        Fixed header typo.
C
C-    SPICELIB Version 1.1.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.1.0, 02-NOV-1990 (NJB)
C
C        Header upgraded to describe notation in more detail.  Argument
C        names were changed to describe the use of the arguments more
C        accurately.  No change in functionality was made; the operation
C        of the routine is identical to that of the previous version.
C
C-    SPICELIB Version 1.0.0, 03-SEP-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     matrix to euler angles
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.2.0, 26-AUG-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in MXM and MTXM calls.  A short error message cited in
C        the Exceptions section of the header  failed to match
C        the actual short message used; this has been corrected.
C
C-    SPICELIB Version 1.1.0, 02-NOV-1990 (NJB)
C
C        Argument names were changed to describe the use of the
C        arguments more accurately.  The axis and angle numbers
C        now decrease, rather than increase, from left to right.
C        The current names reflect the order of operator application
C        when the Euler angle rotations are applied to a vector:  the
C        rightmost matrix
C
C           [ ANGLE1 ]
C                     AXIS1
C
C        is applied to the vector first, followed by
C
C           [ ANGLE2 ]
C                     AXIS2
C
C        and then
C
C           [ ANGLE3 ]
C                     AXIS3
C
C        Previously, the names reflected the order in which the Euler
C        angle matrices appear on the page, from left to right.  This
C        naming convention was found to be a bit obtuse by a various
C        users.
C
C        No change in functionality was made; the operation of the
C        routine is identical to that of the previous version.
C
C        Also, the header was upgraded to describe the notation in more
C        detail.  The symbol
C
C           [ x ]
C                i
C
C        is explained at mind-numbing length.  An example was added
C        that shows a specific set of inputs and the resulting output
C        matrix.
C
C        The angle sequence notation was changed to be consistent with
C        Rotations required reading.
C
C          1-2-3  and  a-b-c
C
C        have been changed to
C
C          3-2-1  and  c-b-a.
C
C       Also, one `)' was changed to a `}'.
C
C       The phrase `first and third' was changed to `first or third'
C       in the $ Particulars section, where the criterion for the
C       existence of an Euler angle factorization is stated.
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               ISROT
      LOGICAL               RETURN

C
C     Local parameters
C

C
C     NTOL and DETOL are used to determine whether R is a rotation
C     matrix.
C
C     NTOL is the tolerance for the norms of the columns of R.
C
C     DTOL is the tolerance for the determinant of a matrix whose
C     columns are the unitized columns of R.
C
C
      DOUBLE PRECISION      NTOL
      PARAMETER           ( NTOL = 0.1D0 )

      DOUBLE PRECISION      DTOL
      PARAMETER           ( DTOL = 0.1D0 )

C
C     Local variables
C
      DOUBLE PRECISION      CHANGE ( 3, 3 )
      DOUBLE PRECISION      SIGN
      DOUBLE PRECISION      TMPMAT ( 3, 3 )
      DOUBLE PRECISION      TMPROT ( 3, 3 )

      INTEGER               C
      INTEGER               I
      INTEGER               NEXT   ( 3 )

      LOGICAL               DEGEN

C
C     Saved variables
C
      SAVE                  NEXT

C
C     Initial values
C
      DATA  NEXT / 2, 3, 1 /

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'M2EUL' )
      END IF

C
C     The first order of business is to screen out the goofy cases.
C
C     Make sure the axis numbers are all right:  They must belong to
C     the set {1, 2, 3}...
C
      IF (      (  ( AXIS3 .LT. 1 ) .OR. ( AXIS3 .GT. 3 )  )
     .     .OR. (  ( AXIS2 .LT. 1 ) .OR. ( AXIS2 .GT. 3 )  )
     .     .OR. (  ( AXIS1 .LT. 1 ) .OR. ( AXIS1 .GT. 3 )  )   ) THEN

         CALL SETMSG ( 'Axis numbers are #,  #,  #. ' )
         CALL ERRINT ( '#',  AXIS3                    )
         CALL ERRINT ( '#',  AXIS2                    )
         CALL ERRINT ( '#',  AXIS1                    )
         CALL SIGERR ( 'SPICE(BADAXISNUMBERS)'        )
         CALL CHKOUT ( 'M2EUL'                        )
         RETURN

C
C     ...and the second axis number must differ from its neighbors.
C
      ELSE IF ( ( AXIS3 .EQ. AXIS2 ) .OR. ( AXIS1 .EQ. AXIS2 ) ) THEN

         CALL SETMSG ( 'Middle axis matches neighbor: # # #.' )
         CALL ERRINT ( '#',  AXIS3                            )
         CALL ERRINT ( '#',  AXIS2                            )
         CALL ERRINT ( '#',  AXIS1                            )
         CALL SIGERR ( 'SPICE(BADAXISNUMBERS)'                )
         CALL CHKOUT ( 'M2EUL'                                )
         RETURN

C
C     R must be a rotation matrix, or we may as well forget it.
C
      ELSE IF (  .NOT. ISROT ( R, NTOL, DTOL )  ) THEN

         CALL SETMSG ( 'Input matrix is not a rotation.' )
         CALL SIGERR ( 'SPICE(NOTAROTATION)'             )
         CALL CHKOUT ( 'M2EUL'                           )
         RETURN

      END IF

C
C     AXIS3, AXIS2, AXIS1 and R have passed their tests at this
C     point.  We take the liberty of working with TMPROT, a version
C     of R that has unitized columns.
C
      DO I = 1, 3
         CALL VHAT ( R(1,I), TMPROT(1,I) )
      END DO

C
C     We now proceed to recover the promised Euler angles from
C     TMPROT.
C
C        The ideas behind our method are explained in excruciating
C        detail in the ROTATION required reading, so we'll be terse.
C        Nonetheless, a word of explanation is in order.
C
C        The sequence of rotation axes used for the factorization
C        belongs to one of two categories:  a-b-a or c-b-a.  We
C        wish to handle each of these cases in one shot, rather than
C        using different formulas for each sequence to recover the
C        Euler angles.
C
C        What we're going to do is use the Euler angle formula for the
C        3-1-3 factorization for all of the a-b-a sequences, and the
C        formula for the 3-2-1 factorization for all of the c-b-a
C        sequences.
C
C        How can we get away with this?  The Euler angle formulas for
C        each factorization are different!
C
C        Our trick is to apply a change-of-basis transformation to the
C        input matrix R.  For the a-b-a factorizations, we choose a new
C        basis such that a rotation of ANGLE3 radians about the basis
C        vector indexed by AXIS3 becomes a rotation of ANGLE3 radians
C        about the third coordinate axis, and such that a rotation of
C        ANGLE2 radians about the basis vector indexed by AXIS2 becomes
C        a rotation of ANGLE2 radians about the first coordinate axis.
C        So R can be factored as a 3-1-3 rotation relative to the new
C        basis, and the Euler angles we obtain are the exact ones we
C        require.
C
C        The c-b-a factorizations can be handled in an analogous
C        fashion.  We transform R to a basis where the original axis
C        sequence becomes a 3-2-1 sequence.  In some cases, the angles
C        we obtain will be the negatives of the angles we require.  This
C        will happen if and only if the ordered basis (here the e's are
C        the standard basis vectors)
C
C            { e        e        e      }
C               AXIS3    AXIS2    AXIS1
C
C        is not right-handed.  An easy test for this condition is that
C        AXIS2 is not the successor of AXIS3, where the ordering is
C        cyclic.
C

      IF ( AXIS3 .EQ. AXIS1 ) THEN

C
C        The axis order is a-b-a.  We're going to find a matrix CHANGE
C        such that
C
C                 T
C           CHANGE  R  CHANGE
C
C        gives us R in the a useful basis, that is, a basis in which
C        our original a-b-a rotation is a 3-1-3 rotation, but where the
C        rotation angles are unchanged. To achieve this pleasant
C        simplification, we set column 3 of CHANGE to to e(AXIS3),
C        column 1 of CHANGE to e(AXIS2), and column 2 of CHANGE to
C
C          (+/-) e(C),
C
C        (C is the remaining index) depending on whether
C        AXIS3-AXIS2-C is a right-handed sequence of axes:  if it
C        is, the sign is positive.  (Here e(1), e(2), e(3) are the
C        standard basis vectors.)
C
C        Determine the sign of our third basis vector, so that we can
C        ensure that our new basis is right-handed.  The variable NEXT
C        is just a little mapping that takes 1 to 2, 2 to 3, and 3 to
C        1.
C
         IF ( AXIS2 .EQ. NEXT(AXIS3) ) THEN
            SIGN =  1.D0
         ELSE
            SIGN = -1.D0
         END IF

C
C        Since the axis indices sum to 6,
C
         C = 6 - AXIS3 - AXIS2

C
C        Set up the entries of CHANGE:
C
         CALL CLEARD ( 9, CHANGE )

         CHANGE ( AXIS3, 3 ) =         1.D0
         CHANGE ( AXIS2, 1 ) =         1.D0
         CHANGE ( C,     2 ) =  SIGN * 1.D0

C
C        Transform TMPROT.
C
         CALL MXM  ( TMPROT,  CHANGE,  TMPMAT )
         CALL MTXM ( CHANGE,  TMPMAT,  TMPROT )

C
C        Now we're ready to find the Euler angles, using a
C        3-1-3 factorization.  In general, the matrix product
C
C           [ a1 ]   [ a2 ]   [ a3 ]
C                 3        1        3
C
C        has the form
C
C     +-                                                              -+
C     |         cos(a1)cos(a3)          cos(a1)sin(a3)  sin(a1)sin(a2) |
C     | -sin(a1)cos(a2)sin(a3)  +sin(a1)cos(a2)cos(a3)                 |
C     |                                                                |
C     |        -sin(a1)cos(a3)         -sin(a1)sin(a3)  cos(a1)sin(a2) |
C     | -cos(a1)cos(a2)sin(a3)  +cos(a1)cos(a2)cos(a3)                 |
C     |                                                                |
C     |         sin(a2)sin(a3)         -sin(a2)cos(a3)         cos(a2) |
C     +-                                                              -+
C
C
C        but if a2 is 0 or pi, the product matrix reduces to
C
C
C     +-                                                              -+
C     |         cos(a1)cos(a3)          cos(a1)sin(a3)               0 |
C     | -sin(a1)cos(a2)sin(a3)  +sin(a1)cos(a2)cos(a3)                 |
C     |                                                                |
C     |        -sin(a1)cos(a3)         -sin(a1)sin(a3)               0 |
C     | -cos(a1)cos(a2)sin(a3)  +cos(a1)cos(a2)cos(a3)                 |
C     |                                                                |
C     |                      0                       0         cos(a2) |
C     +-                                                              -+
C
C
C        In this case, a1 and a3 are not uniquely determined.  If we
C        arbitrarily set a1 to zero, we arrive at the matrix
C
C           +-                                         -+
C           |         cos(a3)         sin(a3)      0    |
C           | -cos(a2)sin(a3)  cos(a2)cos(a3)      0    |
C           |               0            0      cos(a2) |
C           +-                                         -+
C
C        We take care of this case first.  We test three conditions
C        that are mathematically equivalent, but may not be satisfied
C        simultaneously because of round-off:
C
C
         DEGEN =      (        (       TMPROT(1,3)    .EQ. 0.D0  )
     .                   .AND. (       TMPROT(2,3)    .EQ. 0.D0  )  )
     .           .OR. (        (       TMPROT(3,1)    .EQ. 0.D0  )
     .                   .AND. (       TMPROT(3,2)    .EQ. 0.D0  )  )
     .           .OR. (           ABS( TMPROT(3,3) )  .EQ. 1.D0     )

C
C        In the following block of code, we make use of the fact that
C
C           SIN ( ANGLE2 )   >  0
C                            -
C        in choosing the signs of the ATAN2 arguments correctly.  Note
C        that ATAN2(x,y) = -ATAN2(-x,-y).
C
C
         IF ( DEGEN ) THEN

            ANGLE3 = 0.D0
            ANGLE2 = ACOS  (  TMPROT(3,3)                 )
            ANGLE1 = ATAN2 (  TMPROT(1,2),   TMPROT(1,1)  )

         ELSE
C
C           The normal case.
C
            ANGLE3 = ATAN2 (  TMPROT(1,3),   TMPROT(2,3)  )
            ANGLE2 = ACOS  (  TMPROT(3,3)                 )
            ANGLE1 = ATAN2 (  TMPROT(3,1),  -TMPROT(3,2)  )

         END IF

      ELSE

C
C        The axis order is c-b-a.  We're going to find a matrix CHANGE
C        such that
C
C                 T
C           CHANGE  R  CHANGE
C
C        gives us R in the a useful basis, that is, a basis in which
C        our original c-b-a rotation is a 3-2-1 rotation, but where the
C        rotation angles are unchanged, or at worst negated.  To
C        achieve this pleasant simplification, we set column 1 of
C        CHANGE to to e(AXIS3), column 2 of CHANGE to e(AXIS2), and
C        column 3 of CHANGE to
C
C          (+/-) e(AXIS1),
C
C        depending on whether AXIS3-AXIS2-AXIS1 is a right-handed
C        sequence of axes:  if it is, the sign is positive.  (Here
C        e(1), e(2), e(3) are the standard basis vectors.)
C
C        We must be cautious here, because if AXIS3-AXIS2-AXIS1 is a
C        right-handed sequence of axes, all of the rotation angles will
C        be the same in our new basis, but if it's a left-handed
C        sequence, the third angle will be negated.  Let's get this
C        straightened out right now.  The variable NEXT is just a
C        little mapping that takes 1 to 2, 2 to 3, and 3 to 1.
C
         IF ( AXIS2 .EQ. NEXT(AXIS3) ) THEN
            SIGN =  1.D0
         ELSE
            SIGN = -1.D0
         END IF

C
C        Set up the entries of CHANGE:
C
         CALL CLEARD ( 9, CHANGE )

         CHANGE ( AXIS3, 1 ) =         1.D0
         CHANGE ( AXIS2, 2 ) =         1.D0
         CHANGE ( AXIS1, 3 ) =  SIGN * 1.D0

C
C        Transform TMPROT.
C
         CALL MXM  ( TMPROT,  CHANGE,  TMPMAT )
         CALL MTXM ( CHANGE,  TMPMAT,  TMPROT )

C
C        Now we're ready to find the Euler angles, using a
C        3-2-1 factorization.  In general, the matrix product
C
C           [ a1 ]   [ a2 ]   [ a3 ]
C                 1        2        3
C
C        has the form
C
C
C     +-                                                              -+
C     |         cos(a2)cos(a3)          cos(a2)sin(a3)        -sin(a2) |
C     |                                                                |
C     |        -cos(a1)sin(a3)          cos(a1)cos(a3)  sin(a1)cos(a2) |
C     | +sin(a1)sin(a2)cos(a3)  +sin(a1)sin(a2)sin(a3)                 |
C     |                                                                |
C     |         sin(a1)sin(a3)         -sin(a1)cos(a3)  cos(a1)cos(a2) |
C     | +cos(a1)sin(a2)cos(a3)  +cos(a1)sin(a2)sin(a3)                 |
C     +-                                                              -+
C
C
C        but if a2 is -pi/2 or pi/2, the product matrix reduces to
C
C
C     +-                                                              -+
C     |                      0                       0        -sin(a2) |
C     |                                                                |
C     |        -cos(a1)sin(a3)          cos(a1)cos(a3)               0 |
C     | +sin(a1)sin(a2)cos(a3)  +sin(a1)sin(a2)sin(a3)                 |
C     |                                                                |
C     |         sin(a1)sin(a3)         -sin(a1)cos(a3)               0 |
C     | +cos(a1)sin(a2)cos(a3)  +cos(a1)sin(a2)sin(a3)                 |
C     +-                                                              -+
C
C
C        In this case, a1 and a3 are not uniquely determined.  If we
C        arbitrarily set a1 to zero, we arrive at the matrix
C
C           +-                                              -+
C           |               0                 0    -sin(a2)  |
C           |        -sin(a3)           cos(a3)          0   |,
C           |  sin(a2)cos(a3)    sin(a2)sin(a3)          0   |
C           +-                                              -+
C
C
C        We take care of this case first.  We test three conditions
C        that are mathematically equivalent, but may not be satisfied
C        simultaneously because of round-off:
C
C
         DEGEN =      (        (       TMPROT(1,1)    .EQ. 0.D0  )
     .                   .AND. (       TMPROT(1,2)    .EQ. 0.D0  )  )
     .           .OR. (        (       TMPROT(2,3)    .EQ. 0.D0  )
     .                   .AND. (       TMPROT(3,3)    .EQ. 0.D0  )  )
     .           .OR. (           ABS( TMPROT(1,3) )  .EQ. 1.D0     )

C
C        In the following block of code, we make use of the fact that
C
C           COS ( ANGLE2 )   >  0
C                            -
C        in choosing the signs of the ATAN2 arguments correctly.  Note
C        that ATAN2(x,y) = -ATAN2(-x,-y).
C
C
         IF ( DEGEN ) THEN

            ANGLE3 =          0.D0
            ANGLE2 =          ASIN  ( -TMPROT(1,3)                 )
            ANGLE1 = SIGN  *  ATAN2 ( -TMPROT(2,1),   TMPROT(2,2)  )

         ELSE
C
C           The normal case.
C
            ANGLE3 =          ATAN2 (  TMPROT(2,3),   TMPROT(3,3)  )
            ANGLE2 =          ASIN  ( -TMPROT(1,3)                 )
            ANGLE1 = SIGN  *  ATAN2 (  TMPROT(1,2),   TMPROT(1,1)  )

         END IF

      END IF

      CALL CHKOUT ( 'M2EUL' )
      RETURN
      END