! **********************************************************************************
! *                      ROUTINES FOR NUMERICAL INTEGRATION                        *
! *      ----------------------------------------------------------------------    *
! *      Partial list of subroutines:                                              *
! *        Gauss_Legendre,       Laguerre,         Simpson,        Trapez,         *
! *        Gauss_Legendre1,      Laguerre1,        Lgroot,         Lgrecr,         *
! *        gaussq,               class,            gausq2,         readinputIntegr *
! **********************************************************************************
subroutine Gauss_Legendre (x1, x2, Np, wp, xp)
!------------------------------------------------------------------------------------
! The routine computes the weights and nodes for the Gauss-Legendre quadrature      !
! method.                                                                           !
!                                                                                !
! Input parameters:                                                                 !
! - x1, x2 (real variables) - lower and upper integration limits.                   !
! - Np (integer) - number of quadrature points.                                     !
!                                                                                !
! Output parameters:                                                                !
! - wp (real array) - weights.                                                      !
! - xp (real array) - quadrature points (nodes).                                    !
!                                                                                !
! The following parameters (specified in the group statement "Integration"          !
! from the input file "../INPUTFILES/Input.dat") control the integration            !
! process:                                                                          !
!                                                                                !
! - TypeIntegr (character array) - specifies the source of the numerical            !
!   integration routines. The permissive values are:                                !
!   - 'MET1' - routines from Numerical Recipes,                                     !
!   - 'MET2' - modified routines from Slatec library.                               !
!   The recommended value of the parameter TypeIntegr is 'MET1'.                    !
!                                                                                !
! - epsGauss (real) - tolerance for computing the roots of the Legendre polynomials.!
!   The accuracy of the T-matrix calculation strongly depends on epsGauss. The      !
!   value of this parameter should be set AS SMALL AS POSSIBLE. For double          !
!   precision arithmetic, epsGauss = 1.e-15,...,1.e-12.                             !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer       :: Np, i
  real(O)       :: x1, x2, wp(Np), xp(Np), epsGauss, epsLaguerre, xs, xd
  character(20) :: TypeIntegr
  real(O),allocatable :: work(:)
!
  call readinputIntegr ( TypeIntegr, epsGauss, epsLaguerre )
  call check_Integration (TypeIntegr)
  if (TypeIntegr(1:4) == 'MET1') then
    call Gauss_Legendre1 (x1, x2, Np, wp, xp, epsGauss)
  else if (TypeIntegr(1:4) == 'MET2') then
    allocate (work(Np))
    call gaussq (1, Np, work, xp, wp)
    xd = (x2 - x1) / 2._O
    xs = (x2 + x1) / 2._O
    do i = 1, Np
      wp(i) = xd * wp(i)
      xp(i) = xd * xp(i) + xs
    end do
    deallocate (work)
  end if
end subroutine Gauss_Legendre
! **********************************************************************************
subroutine Laguerre (n, x, a)
!------------------------------------------------------------------------------------
! The routine computes the weights and nodes for the Laguerre quadrature method.    !
!                                                                                !
! Input parameters:                                                                 !
! - n (integer) - number of quadrature points.                                      !
!                                                                                !
! Output parameters:                                                                !
! - x (real array) - quadrature points (nodes).                                     !
! - a (real array) - weights.                                                       !
!                                                                                !
! The following parameters (specified in the group statement "Integration"          !
! from the input file "../INPUTFILES/Input.dat") control the integration            !
! process:                                                                          !
!                                                                                !
! - TypeIntegr (character array) - specifies the source of the numerical            !
!   integration routines. The permissive values are:                                !
!   - 'MET1' - routines from Numerical Recipes,                                     !
!   - 'MET2' - modified routines from Slatec library.                               !
!   The recommended value of the parameter TypeIntegr is 'MET1'.                    !
!                                                                                !
! - epsLaguerre (real) - tolerance for computing the roots of the Laguerre          !
!   polynoms. The default value is 1.e-10.                                          !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer :: n
  real(O) :: x(n), a(n), epsGauss, epsLaguerre
  character(20) :: TypeIntegr
  real(O),allocatable :: work(:)
!
  call readinputIntegr ( TypeIntegr, epsGauss, epsLaguerre )
  call check_Integration (TypeIntegr)
  close (unit = iInput)
  if (TypeIntegr(1:4) == 'MET1') then
    call  Laguerre1 (n, x, a, epsLaguerre)
  else if (TypeIntegr(1:4) == 'MET2') then
    allocate (work(n))
    call gaussq (2, n, work, x, a)
    deallocate (work)
  end if
end subroutine Laguerre
! **********************************************************************************
subroutine readinputIntegr ( TypeIntegr, epsGauss, epsLaguerre )
  use parameters
  implicit none
  integer       :: ios
  real(O)       :: epsGauss, epsLaguerre
  character(20) :: TypeIntegr
  character(80) :: string
  logical       :: XFindPar
!
  open (unit = iInput, file = FileInput, status = "old", position = "rewind")
  TypeIntegr  = 'MET1'
  epsGauss    = 1.e-10_O
  epsLaguerre = 1.e-10_O
  string      = 'Integration'
  if (XFindPar (iInput, string)) then
    read (iInput, *, iostat = ios) TypeIntegr
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable TypeIntegr;')"
      stop
    end if
    read (iInput, *, iostat = ios) epsGauss
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable epsGauss;')"
      stop
    end if
    read (iInput, *, iostat = ios) epsLaguerre
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable epsLaguerre;')"
      stop
    end if
  else
    print "(/,2x,'Group name Integration not found;')"
    stop
  end if
  call check_Integration (TypeIntegr)
  close (unit = iInput)
end subroutine readinputIntegr
!***********************************************************************************
subroutine Simpson (a, b, N, x, w)
!------------------------------------------------------------------------------------
! The routine computes the weights and nodes for the Simpson quadrature method.     !
!                                                                                !
! Input parameters:                                                                 !
! - a, b (real variables) - lower and upper integration limits.                     !
! - N (integer) - number of quadrature points.                                      !
!                                                                                !
! Output parameters:                                                                !
! - w (real array) - weights.                                                       !
! - x (real array) - quadrature points (nodes).                                     !
!                                                                                !
! Note: The number of integration points must be an odd number.                     !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer  :: N, i
  real(O)  :: a, b, h, x(N), w(N), N1r, i1r
!
  N1r = real(N - 1,O)
  h   = (b - a) / N1r
  do i = 1, N
    i1r  = real(i - 1,O)
    x(i) = a + i1r * h
  end do
  if (mod(N - 1,2) == 0) then
    w(1) = h / 3._O
    w(N) = h / 3._O
    do i = 2, N - 1, 2
      w(i) = 4._O * h / 3._O
    end do
    do i = 3, N - 2, 2
      w(i) = 2._O * h / 3._O
    end do
  else
    print "(/,2x,'Warning in subroutine Simpson in module Integr:')"
    print "(  2x,'the number of integration points is an even number and therefore')"
    print "(  2x,'the last interval integration is performed with the trapez rule;')"
    w(1)   = h / 3._O
    w(N-1) = 5._O * h / 6._O
    w(N)   = h / 2._O
    do i = 2, N - 2, 2
      w(i) = 4._O * h / 3._O
    end do
    do i = 3, N - 3, 2
      w(i) = 2._O * h / 3._O
    end do
  end if
end subroutine Simpson
!***********************************************************************************
subroutine Trapez (a, b, N, x, w)
!------------------------------------------------------------------------------------
! The routine computes the weights and nodes for the trapez integration method.     !
!                                                                                !
! Input parameters:                                                                 !
! - a, b (real variables) - lower and upper integration limits.                     !
! - N (integer) - number of quadrature points.                                      !
!                                                                                !
! Output parameters:                                                                !
! - w (real array) - weights.                                                       !
! - x (real array) - quadrature points (nodes).                                     !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer  :: N, i
  real(O)  :: a, b, h, x(N), w(N), N1r, i1r
!
  N1r = real(N - 1,O)
  h   = (b - a) / N1r
  do i = 1, N
    i1r  = real(i - 1,O)
    x(i) = a + i1r * h
  end do
  w(1) = 0.5_O * h
  w(N) = 0.5_O * h
  do i = 2, N - 1
    w(i) = h
  end do
end subroutine Trapez
! **********************************************************************************
! *                  ROUTINES FOR COMPUTING THE NODES AND WEIGHTS                  *
! *              FOR GAUSSIAN-TYPE QUADRATURE RULES - NUMERICAL RECIPES            *
! **********************************************************************************
subroutine Gauss_Legendre1 (x1, x2, Np, wp, xp, epsGauss)
!-----------------------------------------------------------------------------------
! The significance of the input and ouput parameters is as in the routine          !
! Gauss_Legendre. The following parmeters control the computation:                 !
! - TolRootPol (real) - if epsGauss < TolRootPol, then epsGauss is setted to       !
!   TolRootPol. Default value: TolRootPol = MachEps.                               !
! - NIterPol (integer) - maximum number of iteration for computing the roots       !
!   with the desired accuracy. Default value: NIterPol = 100000.                   !
! These parameters are specified in the routine "DrvParameters" from the file      !
! '../TMATROUTINES/MachParam.f90'.                                                 !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer :: Np, i, j, M, iter
  real(O) :: x1, x2, wp(Np), xp(Np), xm, xl, z, p1, p2, p3, pp, z1,                 &
             jr, j1r, j2r, Npr, ir, epsGauss
  logical :: more
!
  if (epsGauss < TolRootPol) then
    epsGauss = TolRootPol
    print "(/,2x,'Warning in subroutine Gauss_Legendre in module Integr:')"
    print "(  2x,'the tolerance epsGauss is too low and epsGauss has been setted')"
    print "(  2x,'to TolRootPol, where TolRootPol =',1pe13.4,';')", TolRootPol
  end if
  Npr = real(Np,O)
  M   = int(0.5_O * (Npr + 1._O))
  xm  = 0.5_O * (x1 + x2)
  xl  = 0.5_O * (x2 - x1)
  do i = 1, M
    ir   = real(i,O)
    z    = cos(Pi * (ir - 0.25_O) / (Npr + 0.5_O))
    more =.true.
    iter = 0
    do while (more)
      iter = iter + 1
      p1   = 1._O
      p2   = 0._O
      do j = 1,Np
        p3  = p2
        p2  = p1
        jr  = real(j,O)
        j1r = real(j - 1,O)
        j2r = real(2 * j - 1,O)
        p1  = (j2r * z * p2 - j1r * p3) / jr
      end do
      pp = Npr * (z * p1 - p2) / (z * z - 1._O)
      z1 = z
      z  = z1 - p1 / pp
      if (abs(z - z1) <= epsGauss .or. iter == NIterPol) more = .false.
    end do
    if (abs(z - z1) > epsGauss ) then
      print "(/,2x,'Error in subroutine Gauss_Legendre in module Integr:')"
      print "(  2x,'the  root was not determined with the prescribed accuracy because ')"
      print "(  2x,'the tolerance epsGauss or the iteration number NIterPol specified ')"
      print "(  2x,'in the subroutine MachParam are too low;')"
      stop
    end if
    xp(i)      = xm - xl * z
    xp(Np+1-i) = xm + xl * z
    wp(i)      = 2._O * xl / ((1._O - z * z) * pp * pp)
    wp(Np+1-i) = wp(i)
  end do
end subroutine Gauss_Legendre1
! **********************************************************************************
subroutine Laguerre1 (n, x, a, epsLaguerre)
!-----------------------------------------------------------------------------------
! The significance of the input and ouput parameters is as in the routine          !
! Laquerre. The parameter NIterPol  specifies the maximum number of iteration      !
! for computing the roots with the desired accuracy. NIterPol is specified in      !
! the routine "DrvParameters" from the file '../TMATROUTINES/MachParam.f90' and    !
! the default value is NIterPol = 100000.                                          !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer :: n
  real(O) :: x(n), a(n), epsLaguerre
!
  integer :: i, exp, j
  real(O) :: csx, csa, r1, dpn, pn1, xt, nr, i2r, tmp
!
  nr  = real(n,O)
  csx = 0._O
  csa = 0._O
  do i = 1, n
    if (i == 1) xt = 3._O / (1._O + 2.4_O * nr)
    if (i == 2) xt = xt + 15._O / (1._O + 2.5_O * nr)
    if (i > 2) then
      i2r = real(i - 2,O)
      r1  = (1._O + 2.55_O * i2r) / (1.9_O * i2r)
      xt  = xt + r1 * (xt - x(i-2))
    end if
    call Lgroot (xt, n, dpn, pn1, epsLaguerre, exp)
    x(i) = xt
    tmp  = 1._O / dpn / pn1 / nr
    if (exp > 0) then
      do j = 1, 2 * exp
        tmp = tmp * 0.1_O
      end do
    end if
    a(i) = tmp
    csx  = csx + xt
    csa  = csa + a(i)
  end do
end subroutine Laguerre1
! **********************************************************************************
subroutine Lgroot (x, n, dpn, pn1, epsLaguerre, exp)
  use parameters
  use derived_parameters
  implicit none
  integer  :: n, exp
  real(O)  :: x, dpn, pn1, epsLaguerre
!
  integer  :: iter
  real(O)  :: p, d, dp
  logical  :: more
!
  iter  = 0
  more  = .true.
  do while (more)
    iter = iter + 1
    call Lgrecr (p, dp, pn1, x, n, exp)
    d = p / dp
    x = x - d
    if (abs(d / x) <= epsLaguerre .or. iter == NIterPol) more = .false.
  end do
  if (abs(d / x) > epsLaguerre ) then
    print "(/,2x,'Error in subroutine Laguerre in module Integr:')"
    print "(  2x,'the root was not determined with the prescribed accuracy because the')"
    print "(  2x,'tolerance  epsLaguerre  or the iteration number  NIterPol  specified')"
    print "(  2x,'in the subroutine MachParam are too low;')"
    stop
  end if
  dpn = dp
end subroutine Lgroot
! ******** *************************************************************************
subroutine Lgrecr (pn, dpn, pn1, x, n, exp)
  use parameters
  implicit none
  integer  :: n, exp
  real(O)  :: pn, dpn, pn1, x
!
  integer  :: j, dexp
  real(O)  :: p1, p, dp1, dp, q, dq, jr, j1r, j2r, big, low
!
  p1   = 1._O
  p    = x - 1._O
  dp1  = 0._O
  dp   = 1._O
  exp  = 0
  big  = 1.e+3_O
  low  = 1.e-3_O
  dexp = int(log10(big))
  do j = 2, n
    jr  = real(j,O)
    j1r = real(j - 1,O)
    j2r = real(2*j - 1,O)
    q   = (x - j2r) *  p / jr - j1r * p1 / jr
    dq  = (x - j2r) * dp / jr + p / jr - j1r * dp1 / jr
    if (q > big .or. dq > big) then
      q   =  q * low
      dq  = dq * low
      p   =  p * low
      dp  = dp * low
      exp = exp + dexp
    end if
    p1  = p
    p   = q
    dp1 = dp
    dp  = dq
  end do
  pn  = p
  dpn = dp
  pn1 = p1
end subroutine Lgrecr
! **********************************************************************************
! *         ROUTINES FOR COMPUTING THE NODES AND WEIGHTS FOR GAUSSIAN-TYPE         *
! *           QUADRATURE RULES - SIMPLIFIED VERSION FROM SLATEC LIBRARY            *
! **********************************************************************************
subroutine gaussq (kindt, n, b, t, w)
!-----------------------------------------------------------------------------------
! Input parameters:                                                                !
! - kindt (integer) - specifies the type of quadrature rule, i.e.,                 !
!   kindt = 1 for Legendre quadrature with w(x) = 1 on (-1, 1), and                !
!   kindt = 2 for the generalized Laguerre quadrature with w(x) = exp(-x) on       !
!   (0, +infinity).                                                                !
! - n (integer) - number of points used for the quadrature rule.                   !
! - b (real array) - scratch array of length n.                                    !
!                                                                                !
! Output parameters:                                                               !
! - t (real array) - quadrature nodes.                                             !
! - w (real array) - weights.                                                      !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer  :: kindt, n
  real(O)  :: b(n), t(n), w(n)
!
  integer  :: i
  real(O)  :: muzero
!
  call class (kindt, n, b, t, muzero)
  w(1) = 1._O
  do i = 2, n
    w(i) = 0._O
  end do
  call gausq2 (kindt, n, t, b, w)
  do i = 1, n
    w(i) = muzero * w(i) * w(i)
  end do
end subroutine gaussq
!***********************************************************************************
subroutine class (kindt, n, b, a, muzero)
  use parameters
  implicit none
  integer  :: kindt, n
  real(O)  :: a(n), b(n), muzero
!
  integer  :: nm1, i
  real(O)  :: abi
!
  nm1 = n - 1
  if (kindt == 1) then
    muzero = 2._O
    do i = 1, nm1
      a(i) = 0._O
      abi  = i
      b(i) = abi / sqrt(4._O * abi * abi - 1._O)
    end do
    a(n) = 0._O
  else if (kindt == 2) then
    muzero = 1._O
    do i = 1, nm1
      a(i) = 2._O * i - 1._O
      b(i) = real(i,O)
    end do
    a(n) = 2._O * n - 1
  end if
end subroutine class
!***********************************************************************************
subroutine gausq2 (kindt, n, d, e, z)
  use parameters
  use derived_parameters
  implicit none
  integer :: kindt, n
  real(O) :: d(n), e(n), z(n)
!
  integer :: i, j, k, l, m, ii, mml
  real(O) :: b, c, f, g, p, r, s
!
  e(n) = 0._O
  do l = 1, n
    j = 0
    do while (j < NIterPol)
      j = j + 1
      m = l - 1
      do while (m < n)
        m = m + 1
        if (m < n .and. abs(e(m)) <= MachEps * (abs(d(m)) + abs(d(m+1)))) exit
      end do
      p = d(l)
      if (m == l)  exit
      g   = (d(l+1) - p) / (2._O * e(l))
      r   = sqrt(g * g + 1._O)
      g   = d(m) - p + e(l) / (g + sign(r, g))
      s   = 1._O
      c   = 1._O
      p   = 0._O
      mml = m - l
      do ii = 1, mml
        i = m - ii
        f = s * e(i)
        b = c * e(i)
        if (abs(f) < abs(g)) then
          s = f / g
          r = sqrt(s * s + 1._O)
          e(i+1) = g * r
          c = 1._O / r
          s = s * c
        else
          c = g / f
          r = sqrt(c * c + 1._O)
          e(i+1) = f * r
          s = 1._O / r
          c = c * s
        end if
        g = d(i+1) - p
        r = (d(i) - g) * s + 2._O * c * b
        p = s * r
        d(i+1) = g + p
        g = c * r - b
        f = z(i+1)
        z(i+1) = s * z(i) + c * f
        z(i)   = c * z(i) - s * f
      end do
      d(l) = d(l) - p
      e(l) = g
      e(m) = 0._O
    end do
    if (j == NIterPol) then
      if (kindt == 1) then
        print "(/,2x,'Error in subroutine gausq2 in module Integr:')"
        print "(  2x,'the Legendre quadratures were not determined with the prescribed ')"
        print "(  2x,'accuracy, because the iteration number NIterPol specified in the')"
        print "(  2x,'subroutine MachParam is too low;')"
      else if (kindt == 2) then
        print "(/,2x,'Error in subroutine gausq2 in module Integr:')"
        print "(  2x,'the Laguerre quadratures were not determined with the prescribed ')"
        print "(  2x,'accuracy, because the iteration number NIterPol specified in the')"
        print "(  2x,'subroutine MachParam is too low;')"
      end if
      stop
    end if
  end do
  do ii = 2, n
    i = ii - 1
    k = i
    p = d(i)
    do j = ii, n
      if (d(j) < p) then
        k = j
        p = d(j)
      end if
    end do
    if (k /= i) then
      d(k) = d(i)
      d(i) = p
      p    = z(i)
      z(i) = z(k)
      z(k) = p
    end if
  end do
end subroutine gausq2


module subgenerator
  implicit none

  integer, parameter :: modulus = 1000000000
  integer :: s(0:54), r(0:54)

contains

subroutine initgen(seed)
  integer :: seed
  integer :: n, rnum

  s(0) = seed
  s(1) = 1

  do n = 2, 54
    s(n) = mod(s(n-2) - s(n-1), modulus)
    if (s(n) < 0) s(n) = s(n) + modulus
  end do

  do n = 0, 54
    r(n) = s(mod(34*(n+1), 55))
  end do

  do n = 1, 165
    rnum = subrand()
  end do

end subroutine initgen

integer function subrand()
  integer, save :: p1 = 0
  integer, save :: p2 = 31

  r(p1) = mod(r(p1) - r(p2), modulus)
  if (r(p1) < 0) r(p1) = r(p1) + modulus
  subrand = r(p1)
  p1 = mod(p1 + 1, 55)
  p2 = mod(p2 + 1, 55)

end function subrand
end module subgenerator

program subgen_test
  use subgenerator
  implicit none

  integer :: seed = 292929
  integer :: i

  call initgen(seed)
  do i = 1, 10
    write(*,*) subrand()
  end do

end program


      subroutine hencky_elasticity(matData,F,stre,cc,finite)

      implicit none

      integer          finite,
     *                 i, round
      double precision matData(*), F(3,*), stre(*), cc(6,*),
     *                 mu, K, Lamb, b(6), fact, h(6),
     *                 tau(6), dtaudb(6,6),
     *                 det_u, r1dJ, J, J2

      if (finite.eq.0) then
        call small_strain_elasticity(matData,F,stre,cc)
        return
      endif

      K    = matData(1)
      mu   = matData(2)

      call calcB(b,F)

      J    = det_u(F)

      J2   = J * J

      call log_s(tau,dtaudb,b,10)

      call set_s_f(tau,tau,mu)

      fact = K * .5d0 * (J2 - 1.d0) - mu / 1.5d0 * log(J)

      call unit_s_p(h)
      call set_s_af(tau,h,fact)

      call set_4_f(dtaudb,dtaudb,mu)

      call pzero(stre,6)
      call pzero(cc, 36)

      call taub2sigccPart1(stre,cc,tau,dtaudb,b,J)

      fact = K * J - mu / (J*1.5d0)

      do i=1, 3
        cc(i,1) = cc(i,1) + fact
        cc(i,2) = cc(i,2) + fact
        cc(i,3) = cc(i,3) + fact
      enddo

      call taub2sigccPart2(stre,cc)

      return

      end


real(kind=8) pure function get_max_speed(val,mitot,mjtot,nvar,aux,naux,nghost,hx,hy)

    use geoclaw_module, only: dry_tolerance, coordinate_system
    use geoclaw_module, only: grav, earth_radius, DEG2RAD

    implicit none

    ! Arguments
    integer, intent(in) :: mitot,mjtot,nvar,naux,nghost
    real(kind=8), intent(in) :: hx,hy
    real(kind=8), intent(in) :: val(nvar,mitot,mjtot), aux(naux,mitot,mjtot)

    ! Locals
    integer :: i,j
    real(kind=8) :: ymetric,hyphys,xmetric,hxphys,u,v,sig,sp_over_h

    sp_over_h = 0.d0   ! compute max speed over h, since dx may not equal dy
    if (coordinate_system == 2) then
        do j = nghost+1, mjtot-nghost
            ymetric = earth_radius*deg2rad
            hyphys = ymetric*hy

            do i = nghost+1, mitot-nghost
                xmetric = cos(aux(3,i,j)) * earth_radius * DEG2RAD
                hxphys = xmetric * hx
                if (val(1,i,j) > dry_tolerance) then
                    u  = val(2,i,j) / val(1,i,j)
                    v  = val(3,i,j) / val(1,i,j)
                else
                    u = 0.d0
                    v = 0.d0
                endif
                sig = sqrt(grav*val(1,i,j))
                sp_over_h = max((abs(u)+sig)/hxphys,(abs(v)+sig)/hyphys,sp_over_h)
            end do
        end do
    else  ! speeds in cartesian coords, no metrics needed
        do j = nghost+1, mjtot-nghost
            do i = nghost+1, mitot-nghost
                if (val(1,i,j) > dry_tolerance) then
                    u  = val(2,i,j) / val(1,i,j)
                    v  = val(3,i,j) / val(1,i,j)
                else
                    u = 0.d0
                    v = 0.d0
                endif
                sig = sqrt(grav*val(1,i,j))
                sp_over_h = max((abs(u)+sig)/hx,(abs(v)+sig)/hy,sp_over_h)
            end do
        end do
    endif

    get_max_speed = sp_over_h

end function get_max_speed


SUBROUTINE emb_2d_geom(iel,nx1,nx2,ny1,ny2,w1,s1,w2,h1,h2,coord,num)
! Used in p64
! This subroutine forms the nodal coordinates and numbering for a 2-d
! slope of 8-node quadrilaterals. Nodes numbering in the y-direction,
! elements numbered in the x-direction.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::w1,s1,w2,h1,h2
 INTEGER,INTENT(IN)::iel,nx1,nx2,ny1,ny2
 REAL(iwp),INTENT(OUT)::coord(:,:)
 INTEGER,INTENT(OUT)::num(:)
 REAL(iwp)::facx,facy,facb,facs,frh,zero=0.0_iwp,pt5=0.5_iwp,one=1.0_iwp
 INTEGER::nxe,nye,nc,nt,ip,iq
 nxe=nx1+nx2
 nye=ny1+ny2
 nt=nx1*ny1
 nc=(3*nye+2)*nx1+2*ny1
 facx=s1/ny1
 facy=h1/ny1
 facb=(w1+s1)/nx1
 facs=zero
 IF(ny2/=0)facs=h2/ny2
 frh=zero
 IF(nx2/=0)frh=w2/nx2
 IF(iel<=nt)THEN
   iq=(iel-1)/nx1+1
   ip=iel-(iq-1)*nx1
 ELSE
   iq=(iel-nt-1)/nxe+ny1+1
   ip=iel-nt-(iq-ny1-1)*nxe
 END IF
 IF(ip<=nx1)THEN
   num(1)=(ip-1)*(3*nye+2)+2*iq+1
   num(2)=num(1)-1
   num(3)=num(1)-2
   num(4)=(ip-1)*(3*nye+2)+2*nye+iq+1
   num(5)=ip*(3*nye+2)+2*iq-1
   num(6)=num(5)+1
   num(7)=num(5)+2
   num(8)=num(4)+1
   IF(iq<=ny1)THEN
     coord(1,1)=(ip-one)*(w1+iq*facx)/nx1
     coord(3,1)=(ip-one)*(w1+(iq-1)*facx)/nx1
     coord(5,1)=ip*(w1+(iq-1)*facx)/nx1
     coord(7,1)=ip*(w1+iq*facx)/nx1
     coord(1,2)=-iq*facy
     coord(3,2)=-(iq-1)*facy
     coord(5,2)=-(iq-1)*facy
     coord(7,2)=-iq*facy
   ELSE
     coord(1,1)=(ip-one)*facb
     coord(3,1)=(ip-one)*facb
     coord(5,1)=ip*facb
     coord(7,1)=ip*facb
     coord(1,2)=-h1-(iq-ny1)*facs
     coord(3,2)=-h1-(iq-ny1-1)*facs
     coord(5,2)=-h1-(iq-ny1-1)*facs
     coord(7,2)=-h1-(iq-ny1)*facs
   END IF
 ELSE
   num(1)=nc+(ip-nx1-1)*(3*ny2+2)+2*(iq-ny1)+1
   num(2)=num(1)-1
   num(3)=num(1)-2
   num(4)=nc+(ip-nx1-1)*(3*ny2+2)+2*ny2+iq-ny1+1
   num(5)=nc+(ip-nx1)*(3*ny2+2)+2*(iq-ny1)-1
   num(6)=num(5)+1
   num(7)=num(5)+2
   num(8)=num(4)+1
   coord(1,1)=w1+s1+(ip-nx1-1)*frh
   coord(3,1)=coord(1,1)
   coord(5,1)=w1+s1+(ip-nx1)*frh
   coord(7,1)=coord(5,1)
   coord(1,2)=-h1-(iq-ny1)*facs
   coord(3,2)=-h1-(iq-ny1-1)*facs
   coord(5,2)=-h1-(iq-ny1-1)*facs
   coord(7,2)=-h1-(iq-ny1)*facs
 END IF
 coord(2:6:2,:)=pt5*(coord(1:5:2,:)+coord(3:7:2,:))
 coord(8,:)=pt5*(coord(7,:)+coord(1,:))
RETURN
END SUBROUTINE emb_2d_geom


program test_qr_factorization
  use mod_orrb
  implicit none

  character(len=40) :: test_name
  character(len=*), parameter :: fmt="(A40, 'Time: ',ES8.2,', lbw: ',I3,', ubw: ', I3,', error: ',ES8.2, ', ', A10)"

  real(kind=dp) :: t0, t1
  integer(kind=int32) :: na, lbwa, ubwa
  type(error_info) :: error
  real(kind=dp), parameter :: tol=1e-15, c=2.5
  !

  real(kind=dp), dimension(:,:), allocatable :: a_d, a0_d
  complex(kind=dp), dimension(:,:), allocatable :: a_z, a0_z

  type(d_bv), allocatable :: bv_d
  type(z_bv), allocatable :: bv_z
  type(d_qr), allocatable :: swub_d
  type(z_qr), allocatable :: swub_z

  call initialize_errors
  print *
  print *, "--------------------------------"
  print *
  print *, "Real QR Factorization Tests"
  print *
  !
  ! full qr factorization
  !
  na=40; lbwa=3; ubwa=5
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a_d = general(bv_d,error)
  a0_d = a_d
  call cpu_time(t0)
  swub_d=qr_of(bv_d,error)
  call cpu_time(t1)
  a_d = general(swub_d%ub,error)
  a_d = swub_d%sw * a_d
  test_name = "Random Real QR Factorization"
  call d_output_result(test_name,a0_d,a_d,0, &
       swub_d%ub%lbw, min(ubwa+lbwa,na-1),swub_d%ub%ubw,t0,t1,c*tol,error)

  na=1; lbwa=0; ubwa=0
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a_d = general(bv_d,error)
  a0_d = a_d
  call cpu_time(t0)
  swub_d=qr_of(bv_d,error)
  call cpu_time(t1)
  a_d = general(swub_d%ub,error)
  a_d = swub_d%sw * a_d
  test_name = "Random Real QR Factorization, n=1"
  call d_output_result(test_name,a0_d,a_d,0, &
       swub_d%ub%lbw, min(ubwa+lbwa,na-1), swub_d%ub%ubw,t0,t1,c*tol,error)

  na=2; lbwa=1; ubwa=1
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a_d = general(bv_d,error)
  a0_d = a_d
  call cpu_time(t0)
  swub_d=qr_of(bv_d,error)
  call cpu_time(t1)
  a_d = general(swub_d%ub,error)
  a_d = swub_d%sw * a_d
  test_name = "Random Real QR Factorization, n=2"
  call d_output_result(test_name,a0_d,a_d,0, &
       swub_d%ub%lbw, min(ubwa+lbwa,na-1), swub_d%ub%ubw,t0,t1,c*tol,error)

  na=3; lbwa=1; ubwa=1
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a_d = general(bv_d,error)
  a0_d = a_d
  call cpu_time(t0)
  swub_d=qr_of(bv_d,error)
  call cpu_time(t1)
  a_d = general(swub_d%ub,error)
  a_d = swub_d%sw * a_d
  test_name = "Random Real QR Factorization, n=3"
  call d_output_result(test_name,a0_d,a_d,0, &
       swub_d%ub%lbw, min(ubwa+lbwa,na-1), swub_d%ub%ubw,t0,t1,c*tol,error)

  na=4; lbwa=2; ubwa=2
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a_d = general(bv_d,error)
  a0_d = a_d
  call cpu_time(t0)
  swub_d=qr_of(bv_d,error)
  call cpu_time(t1)
  a_d = general(swub_d%ub,error)
  a_d = swub_d%sw * a_d
  test_name = "Random Real QR Factorization, n=4"
  call d_output_result(test_name,a0_d,a_d,0, &
       swub_d%ub%lbw, min(ubwa+lbwa,na-1), swub_d%ub%ubw,t0,t1,c*tol,error)

  !
  print *
  print *, "--------------------------------"
  print *
  print *, "Complex QR Factorization Tests"
  print *

  na=40; lbwa=3; ubwa=5
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a_z = general(bv_z,error)
  a0_z = a_z
  call cpu_time(t0)
  swub_z=qr_of(bv_z,error)
  call cpu_time(t1)
  a_z = general(swub_z%ub,error)
  a_z = swub_z%sw * a_z
  test_name = "Random Complex QR Factorization"
  call z_output_result(test_name,a0_z,a_z,0, &
       swub_z%ub%lbw, min(ubwa+lbwa,na-1),swub_z%ub%ubw,t0,t1,c*tol,error)

  na=1; lbwa=0; ubwa=0
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a_z = general(bv_z,error)
  a0_z = a_z
  call cpu_time(t0)
  swub_z=qr_of(bv_z,error)
  call cpu_time(t1)
  a_z = general(swub_z%ub,error)
  a_z = swub_z%sw * a_z
  test_name = "Random Complex QR Factorization, n=1"
  call z_output_result(test_name,a0_z,a_z,0, &
       swub_z%ub%lbw, min(ubwa+lbwa,na-1), swub_z%ub%ubw,t0,t1,c*tol,error)

  na=2; lbwa=1; ubwa=1
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a_z = general(bv_z,error)
  a0_z = a_z
  call cpu_time(t0)
  swub_z=qr_of(bv_z,error)
  call cpu_time(t1)
  a_z = general(swub_z%ub,error)
  a_z = swub_z%sw * a_z
  test_name = "Random Complex QR Factorization, n=2"
  call z_output_result(test_name,a0_z,a_z,0, &
       swub_z%ub%lbw, min(ubwa+lbwa,na-1), swub_z%ub%ubw,t0,t1,c*tol,error)

  na=3; lbwa=1; ubwa=1
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a_z = general(bv_z,error)
  a0_z = a_z
  call cpu_time(t0)
  swub_z=qr_of(bv_z,error)
  call cpu_time(t1)
  a_z = general(swub_z%ub,error)
  a_z = swub_z%sw * a_z
  test_name = "Random Complex QR Factorization, n=3"
  call z_output_result(test_name,a0_z,a_z,0, &
       swub_z%ub%lbw, min(ubwa+lbwa,na-1), swub_z%ub%ubw,t0,t1,c*tol,error)

  na=4; lbwa=2; ubwa=2
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a_z = general(bv_z,error)
  a0_z = a_z
  call cpu_time(t0)
  swub_z=qr_of(bv_z,error)
  call cpu_time(t1)
  a_z = general(swub_z%ub,error)
  a_z = swub_z%sw * a_z
  test_name = "Random Complex QR Factorization, n=4"
  call z_output_result(test_name,a0_z,a_z,0, &
       swub_z%ub%lbw, min(ubwa+lbwa,na-1), swub_z%ub%ubw,t0,t1,c*tol,error)

contains

  subroutine d_output_result(name,a0,a1,lbw0,lbw1,ubw0,ubw1,t0,t1,bnd,error)
    character(len=*) :: name
    real(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: lbw0, lbw1, ubw0, ubw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (lbw0==lbw1 .and. ubw0==ubw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, lbw1, ubw1, berr, test_result
    end if
  end subroutine d_output_result

  subroutine z_output_result(name,a0,a1,lbw0,lbw1,ubw0,ubw1,t0,t1,bnd,error)
    character(len=*) :: name
    complex(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: lbw0, lbw1, ubw0, ubw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (lbw0==lbw1 .and. ubw0==ubw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, lbw1, ubw1, berr, test_result
    end if
  end subroutine z_output_result

end program test_qr_factorization


!--------------------------------------------------------------------------------------
!
!Copyright (C) 2014 TopCoder Inc., All Rights Reserved.
!
!--------------------------------------------------------------------------------------

!   This module computes the influence coefficient according to R2 for the regular part and
!  to R1 for the rankine part. It only perform the computation for the infinite depth case
!
!  R1 Distributions of sources and normal dipoles
!over a quadrilateral panel (Available in another contest (Dipoles, request permission) document paper 2
!http://community.topcoder.com/tc?
!module=DownloadDocument&docid=27516374 )
!
!  R2  A second order Ordinary Differential Equation for the frequency
!domain Green function http://www.iwwwfb.org/Abstracts/iwwwfb28/iwwwfb28_12.pdf
!
! Contest Code Acceleration of the Calculation of Influence Coefficients of Nemoh
!
!   @author yedtoss
!   @version 1.0

module COMPUTE_INFLUENCE_ODE

    USE ODE
    USE COM_VAR
    USE COMMON_TYPE
    implicit none

contains

    complex function influence_infinite_source_wave_part(w,y, param)
        ! This is the function representing the expression of the ODE of the green function
        ! See equation 11 of reference R2
        real r, w, Z
        complex y(0:10)
        TYPE(ParamsCommonInf) :: param
        complex tmp

        r = param%r
        Z = param%Z

        tmp = 2.*(1. + Z*w**2)/(sqrt(r**2 + Z**2)) + w*(w**2*Z + 3./4.)*y(1)

        tmp = tmp - (w**4*(r**2 + Z**2) + w**2*Z +1 )* y(0)
        if(abs(w) < tolerance) then
            tmp = 0
        else
            tmp = tmp/(w**2/4.)
        end if

        influence_infinite_source_wave_part = tmp
    end function

    complex function influence_infinite_dipoles_wave_part(w,y, param)
        ! This is the function representing the expression of the ODE of the derivative of the green function with
        ! respect to r
        ! See corresponding equation in Deployment guide

        real r, w, Z
        complex y(0:10)
        TYPE(ParamsCommonInf) :: param
        complex tmp

        r = param%r
        Z = param%Z

        tmp = -6.*r*(1. + Z*w**2)/((r**2 + Z**2)**(3./2.))
        tmp = tmp + w*(w**2*Z + 3./4.)*y(1)

        tmp = tmp - (w**4*(r**2 + Z**2) + 3.*w**2*Z + 3 )* y(0)

        if(abs(w) < tolerance) then
            tmp = 0
        else
            tmp = tmp/(w**2/4.)
        end if

        influence_infinite_dipoles_wave_part = tmp

    end function

    complex function influence_infinite_dipoles_wave_part_z(w,y, param)
        ! This is the function representing the expression of the ODE of the derivative of the green function with
        ! respect to z
        ! See corresponding equation in Deployment guide

        real r, w, z
        complex y(0:10)
        TYPE(ParamsCommonInf) :: param
        complex tmp

        r = param%r
        Z = param%Z

        tmp = (-8.*Z -(w**2)*(4.*Z**2 - 2.*r**2))/((r**2 + Z**2)**(3./2.))
        tmp = tmp + w*(w**2*Z + 3./4.)*y(1)

        tmp = tmp - (w**4*(r**2 + Z**2) + 3.*w**2*Z + 4 )* y(0)

        if(abs(w) < tolerance) then
            tmp = 0
        else
            tmp = tmp/(w**2/4.)
        end if

        influence_infinite_dipoles_wave_part_z = tmp

    end function

    real function compute_rankine_dipoles(ISP, IFP)

        ! Computing formula 2.14 with 2.15 as insight of
        ! Distributions of sources and normal dipoles over a quadrilateral panel

        INTEGER :: ISP ! source point

        INTEGER :: IFP !Field point

        INTEGER:: I, M(4)

        REAL:: s1, c1, s2, c2, nu_n, nu_n1, psi_n, psi_n1, delta_n, delta_n1, rn, rn_1, xx, yy, zz

        REAL ::  s3, c3

        REAL, PARAMETER :: PI=4.*ATAN(1.)

        !!$OMP CRITICAL
        !We are safe without a critical or atomic operation. Although we are
        ! using it's value, a value of 0 is safe and when it is 1 it is also safe
        IF(is_rankine_dipoles_computed == 1) THEN
            compute_rankine_dipoles = rankine_dipoles_cache(ISP, IFP)
            RETURN
        END IF
        !!$OMP END CRITICAL

        ! Getting index of the coordinate of the 4 vertices
        M(1) = M1(IFP)
        M(2) = M2(IFP)
        M(3) = M3 (IFP)
        M(4) = M4 (IFP)

        compute_rankine_dipoles = 0

        ! Getting centroid coordinate
        xx = XG(ISP) ! Source point x
        yy = YG(ISP) ! Source point y
        zz = ZG(ISP) ! Source point z

        DO I =1,4

            nu_n = Y(M(I)) ! y coordinate of vertice n
            nu_n1 = Y(modulo(M(I),4) +1) ! y coordinate of vertice n +1
            psi_n = X(M(I)) ! x coordinate of vertice n
            psi_n1 = X(modulo(M(I),4) +1) ! x coordinate of vertice n +1

            delta_n = nu_n1 - nu_n
            delta_n1 = Y(modulo(M(I+1),4) + 1) - nu_n1

            ! If both vertices are the same, it means we have a triangle instead of quadrilateral.
            ! We can thus skip this point
            if (abs(delta_n) < tolerance .and. abs(psi_n1 - psi_n) < tolerance) then
                CYCLE
            end if

            ! Spherical coordinate http://mathworld.wolfram.com/SphericalCoordinates.html
            ! Radial distance between vertice n and the field point
            rn = sqrt((xx - psi_n)**2 + (yy - nu_n)**2 + zz**2)
            ! Radial distance between vertice n+1 and the field point
            rn_1 = sqrt((xx - psi_n1)**2 + (yy - nu_n1)**2 + zz**2)

            s1 = delta_n* ((xx -psi_n)**2 + zz**2) - delta_n* (xx -psi_n) *(yy -nu_n)
            c1 = rn*zz* delta_n

            s2 = delta_n* ((xx -psi_n1)**2 + zz**2) - delta_n* (xx -psi_n1) *(yy -nu_n1)
            c2 = rn_1*zz* delta_n

            s3 = s1*c2 - s2*c1
            c3 = c1*c2 + s1*s2

            ! If c3 is near 0 the angle tends to pi/2
            if (abs(c3) < tolerance) then
                compute_rankine_dipoles = compute_rankine_dipoles + PI/2.
            else
                compute_rankine_dipoles = compute_rankine_dipoles + atan(s3/c3)
            end if

        END DO

        !!$OMP CRITICAL
        !We are safe without a critical or atomic operation. Although we are
        ! updating it's value, any thread updating it simulatenous will do so with the same value
        rankine_dipoles_cache(ISP, IFP) = compute_rankine_dipoles
        !!$OMP END CRITICAL

    end function

    real function compute_rankine_sources(ISP, IFP)

        ! Computing formula 3.10
        ! Distributions of sources and normal dipoles over a quadrilateral panel

        INTEGER :: ISP ! source point

        INTEGER :: IFP !Field point

        REAL:: s1, c1, s2, c2, nu_n, nu_n1, psi_n, psi_n1, delta_n, delta_n1, rn, rn_1, xx, yy, zz

        REAL ::  s3, c3,s ,c, theta_n, theta_n1, sn

        INTEGER:: I, M(4)

        REAL, PARAMETER :: PI=4.*ATAN(1.)

        !!$OMP CRITICAL
        !We are safe without a critical or atomic operation. Although we are
        ! using it's value, a value of 0 is safe and when it is 1 it is also safe
        IF(is_rankine_sources_computed == 1) THEN
            compute_rankine_sources = rankine_sources_cache(ISP, IFP)
            RETURN
        END IF
        !!$OMP END CRITICAL

        ! Getting index of the coordinate of the 4 vertices
        M(1) = M1(IFP)
        M(2) = M2(IFP)
        M(3) = M3 (IFP)
        M(4) = M4 (IFP)

        compute_rankine_sources = 0

        ! Getting centroid coordinate
        xx = XG(ISP) ! Source point x
        yy = YG(ISP) ! Source point y
        zz = ZG(ISP) ! Source point z

        DO I =1,4

            nu_n = Y(M(I)) ! y coordinate of vertice n
            nu_n1 = Y(modulo(M(I),4) +1) ! y coordinate of vertice n +1
            psi_n = X(M(I)) ! x coordinate of vertice n
            psi_n1 = X(modulo(M(I),4) +1) ! x coordinate of vertice n +1

            delta_n = nu_n1 - nu_n
            delta_n1 = Y(modulo(M(I+1),4) + 1) - nu_n1

            ! If both vertices are the same, it means we have a triangle instead of quadrilateral.
            ! We can thus skip this point
            if (abs(delta_n) < tolerance .and. abs(psi_n1 - psi_n) < tolerance) then
                CYCLE
            end if

            ! If delta_n is near 0 the angle tends to pi/2
            if (abs(delta_n) < tolerance) then
                theta_n = PI/2.
            else
                !http://stackoverflow.com/questions/2676719/calculating-the-angle-between-the-line-defined-by-two-points
                theta_n = atan(delta_n/(psi_n1 - psi_n))
            endif

            ! sn is the length between vertices n and vertices n+1. Note that z=0 because it is a flat panel
            sn = sqrt((psi_n1 - psi_n)**2 + (delta_n1- delta_n)**2)

            ! Spherical coordinate http://mathworld.wolfram.com/SphericalCoordinates.html
            ! Radial distance between vertice n and the field point
            rn = sqrt((xx - psi_n)**2 + (yy - nu_n)**2 + zz**2)
            ! Radial distance between vertice n+1 and the field point
            rn_1 = sqrt((xx - psi_n1)**2 + (yy - nu_n1)**2 + zz**2)

            ! Using intermediate variable s to avoid long expression or complicated multi line expressions
            s = (xx- psi_n)* sin(theta_n) - (yy - nu_n)*cos(theta_n)*log((rn + rn_1 + sn)/(rn + rn_1 - sn))

            compute_rankine_sources = compute_rankine_sources + s

        END DO

        compute_rankine_sources = compute_rankine_sources - zz*compute_rankine_dipoles(ISP, IFP)
        !!$OMP CRITICAL
        !We are safe without a critical or atomic operation. Although we are
        ! updating it's value, any thread updating it simulatenous will do so with the same value
        rankine_sources_cache(ISP, IFP) = compute_rankine_sources
        !!$OMP END CRITICAL
    end function

    subroutine compute_influence_infinite_sources(w, ZIJ)

        INTEGER :: ISP ! source point

        INTEGER :: IFP !Field point

        REAL:: r, G0, dG0, Z, w

        complex yi(0:10),t(50)
        COMPLEX, DIMENSION(:, :):: ZIJ ! influence coefficients
        COMPLEX:: Gn(IMX, IMX) ! Cache of green function

        TYPE(ParamsCommonInf) :: param

        DO ISP=1,IMX

            DO IFP=1,IMX

                Z = ZG(ISP) + ZG(IFP)
                r = sqrt((XG(ISP) - XG(IFP))**2 + (YG(ISP) - YG(IFP))**2 )

                G0 = cmplx(2./(sqrt(r**2 + Z**2)), 0.)
                dG0 = cmplx(0 , 0)

                yi(0) = G0
                yi(1) = dG0

                param%w = w
                param%Z = Z
                param%r = r

                !  Compute Wave part/ regular part of green function
                if(ISP <= IFP) then
                    ! A 3x4 runge kutta is enough for convergence
                    t = Equadifnc(influence_infinite_source_wave_part, 0., w, yi, 1, 2, 3, param )
                    Gn(ISP, IFP) = t(2)
                    Gn(IFP, ISP) = t(2)
                else
                    t(2) = Gn(IFP, ISP)
                end if

                !  Double integral done by multiplying by the area
                ZIJ(ISP, IFP) = t(2)* AIRE(IFP) +  compute_rankine_sources(ISP, IFP)

            END DO

        END DO
    end subroutine compute_influence_infinite_sources

    subroutine compute_influence_infinite_dipoles(w, ZIJ)
        ! This compute the influence coefficients containing the derivative of the green function
        !

        INTEGER :: ISP ! source point correspond to the collocation point

        INTEGER :: IFP !Field point correspond to the flat panel

        REAL:: r, G0, dG0, Z, w

        complex yi(0:10),t(50), yi1(0:10),t1(50), tmp
        COMPLEX, DIMENSION(:, :):: ZIJ ! influence coefficients
        COMPLEX, DIMENSION(IMX, IMX):: GR, GZ ! Cache of green function derivative with respect to r and z respectively

        TYPE(ParamsCommonInf) :: param

        DO ISP=1,IMX
            DO IFP=1,IMX

                Z = ZG(ISP) + ZG(IFP)
                r = sqrt((XG(ISP) - XG(IFP))**2 + (YG(ISP) - YG(IFP))**2 )
                if(abs(r) < tolerance .or. ISP == IFP) then
                    ZIJ(ISP, IFP) = 0.5
                    CYCLE
                end if

                G0 = cmplx(-2.*r/((r**2 + Z**2)**(3./2.)), 0.)
                dG0 = cmplx(0, 0)

                yi(0) = G0
                yi(1) = dG0

                param%w = w
                param%Z = Z
                param%r = r

                !  Compute Wave part/ regular part of green function derivative with respect to r
                if(ISP <= IFP) then
                    ! A 3x4 runge kutta is enough for convergence
                    t = Equadifnc(influence_infinite_dipoles_wave_part, 0., w, yi, 1, 2, 3, param )
                    GR(ISP, IFP) = t(2)
                    GR(IFP, ISP) = t(2)
                else
                    t(2) = GR(IFP, ISP)
                end if

                ! Compute Wave part/ regular part of green function derivative with respect to Z
                yi1(0) = cmplx((-2.*Z)/((r**2 + Z**2)**(3./2.)), 0.)
                yi1(1) = cmplx(0, 0)
                if (abs(ZN(IFP)) < tolerance) then
                    t1(2) = 0
                else
                    if(ISP <= IFP) then
                        ! A 3x4 runge kutta is enough for convergence
                        t1 = Equadifnc(influence_infinite_dipoles_wave_part_z, 0., w, yi1, 1, 2, 3, param )
                        GZ(ISP, IFP) = t1(2)
                        GZ(IFP, ISP) = t1(2)
                    else
                        t1(2) = GZ(IFP, ISP)
                    end if
                end if

                ! Compute coefficient transforming derivative in nM' to derivative in r and z
                tmp = cmplx(-XN(IFP)*(XG(ISP) - XG(IFP))/r -YN(IFP)*(YG(ISP) - YG(IFP))/r, 0)
                ! Double integral done by multiplying by the area
                ZIJ(ISP, IFP) = (t(2)*tmp + ZN(IFP)*t1(2))* AIRE(IFP) +  compute_rankine_dipoles(ISP, IFP)

            END DO
        END DO
    end subroutine compute_influence_infinite_dipoles
end module COMPUTE_INFLUENCE_ODE


!--------------------------------------------------
!PHY2063 Task1
!URN 6309823 - Penguin Lab Group 1B
!November 19th 2015
!--------------------------------------------------

program Task1
  implicit none

  integer,parameter ::  n=80
  real              ::  phi(-n:n,-n:n)
  real,parameter    ::  h=0.05,e0=8.854E-12,e_elec=1.602E-19,c=3E26,T=310
  real,parameter    ::  k=1.381E-23,ep_water=80.0*e0,r_dna=1
  integer           ::  i,j,flag,iter
  real              ::  x,y,phi_s,accuracy,oldval,a,b,kappa

! ep=effective permittivity, c=concentration, e0=permittivity of free space
! T=temperature, e_elec=charge on an electron, iter=# iterations
! k=Boltzman constant

! A NUMBER OF N ITTERATIONS HAS TO BE GIVEN AS DO THE BOUNDARY CONDITIONS PHI_S

! The second derivatives of the Poisson-Boltzmann equation in both x and y

! where h is the grid spacing of the array
! r_dna is the radius of each double helix

  OPEN(unit=12,file='Task1.dat')

  write(6,*)"The role of this program is to determine the electrostatic"
  write(6,*)"potential in the xy plane in the persence of a DNA double helix"
  write(6,*)"aligned with its axis along the z axis."
  write(6,*)" "
  write(6,*)"In this program the double helix is modelled as a very long rigid"
  write(6,*)"charged cylinder of radius r_DNA = 1nm, parllel to the z axis and"
  write(6,*)"at the origin in the xy plane."
  write(6,*)" "
  write(6,*)" "

! phi=0.0 is the initial guess for the Gauss-Seidel iteration

  phi=0.0
  phi_s=100
  do i=-n,n

!   This do loop conducts the Gaus-Seidel iteration
!   The Gauss-Seidel iteration starts with a guess at the solution
!   which should include the imposed BCs

    do j=-n,n

!     phi_s is a boundary condition value

      x=real(i)*h
      y=real(j)*h
      if(x**2+y**2<r_dna**2)phi(i,j)=phi_s
    enddo
  enddo

  kappa=sqrt((2*c*e_elec**2)/(ep_water*k*T))/1E9

  write(6,*)"Our calcualted value for the constant kappa =",kappa

! Starting from the initial guess, we now iteratively improve on our initial
! guess, using the equation we derived for phi(i;j) in terms of phi on the four
! neighbouring grid points.
!
! In each iteration, we need to loop over all interior points of the grid,
! calculating at each point the next estimate of the solution at point (i;j)
! from the current values at the four adjacent grid points.

  accuracy=1.0E-3
  do iter=1,10000
    flag=0
    do i=-n+1,n-1
      do j=-n+1,n-1
        x=real(i)*h
        y=real(j)*h

!       Each pre-iteration value phi(i,j) is stored in oldval

        oldval=phi(i,j)
        if(x**2+y**2<r_dna**2)then
        else
          a=phi(i+1,j)+phi(i-1,j)+phi(i,j+1)+phi(i,j-1)
          b=4.0+h**2.0*kappa**2
          phi(i,j)=a/b

!         After phi has been updated we check to see if it has changed by more
!         than accuracy.

!         If oldvalue has changed more than accuracy then we set flag=1
!         which means that we need annother iteration.

          if(abs(oldval-phi(i,j))>accuracy)flag=1
        endif
      enddo
    enddo
    if(flag==0)exit
  enddo

  write(6,*)"The number of iterations is",iter
  write(6,*)" "
  write(6,*)" "
  write(6,*)"The values of x,y and phi(i,j) are written to the file Task1.dat"
  write(6,*)" "
  write(6,*)" "
  write(6,*)"In order to view a 3D representation of the data open gnuplot in"
  write(6,*)"the terminal, type (splot 'Task1.dat') in the terminal."

! Note that when we loop over the array we need to avoid changing the values
! of phi elements at the boundaries because these need to remain at the values
! already set by the BC's. Thus the loops are from -n+1 to n-1.

! This do loop writes the values of x,y and phi to the file Task1.dat

  do i=-n+1,n-1
    do j=-n+1,n-1
      x=real(i)*h
      y=real(j)*h
      write(12,*)x,y,phi(i,j)
    end do
  end do
end program Task1


SUBROUTINE chillu(bctchillucum,day_max_temp,day_min_temp)
!
IMPLICIT NONE
!
! PARAMETER definitions
!
REAL,PARAMETER :: tmin = 0.0,tmax = 18.0,topt = 7.0,tdev = 30.0,daylim = 10.0,  &
                & daydev = -0.5
!
! Subroutine arguments
!
REAL :: bctchillucum,day_max_temp,day_min_temp
!
! Local variables
!
REAL :: relvern,tavg
!
!     + + + purpose + + +
!     calculates the vernalization effectiveness of a day. for fully
!     effective tmeperatures, a full day is returned. for temperatures
!     that are less than fully effective, a partial day or zero is
!     returned. if temperatures are above the upper temperature
!     threshold and insufficient chill days are accumulated, devernalization
!     occurs.

!     method taken from: ritchie, j.t. 1991. wheat phasic development in:
!     hanks, j. and ritchie, j.t. eds. modeling plant and soil systems.
!     agronomy monograph 31, pages 34-36.

!     + + + keywords + + +
!     vernalization chill units

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     bctchillucum - accumulated chilling units (days)
!     day_max_temp - daily maximum temperature (deg.c)
!     day_min_temp - daily minimum temperature (deg.c)

!     + + + local variables + + +

!     + + + local variable definitions + + +
!     tavg     - daily average temperature  (deg.c)
!     relvern  - relative vernalization effectiveness
!     tmin     - minimum temperature in vernalization function (deg.c)
!     tmax     - maximum temperature in vernalization function (deg.c)
!     topt     - optimum temperature in vernalization function (deg.c)
!     tdev     - temperature above which devernalization can occur (deg.c)
!     daylim   - vernalization days beyond which no devernalization can
!                occur (days)
!     daydev   - devernalization days subtracted for each degree c above
!                tdev (days)

      ! find average temperature
tavg = 0.5*(day_max_temp+day_min_temp)

IF ((tavg.GE.tmin).AND.(tavg.LE.tmax)) THEN
  IF (tavg.LE.topt) THEN
              ! full vernalization effectiveness
     relvern = 1.0
  ELSE
              ! reduced vernalization effectiveness
     relvern = (tmax-tavg)/(tmax-topt)
  END IF
ELSE IF ((day_max_temp.GT.tdev).AND.(bctchillucum.LT.daylim)) THEN
          ! devernalization
  relvern = daydev*(day_max_temp-tdev)
ELSE
  relvern = 0.0
END IF
!
bctchillucum = bctchillucum + relvern
!
END SUBROUTINE chillu

Project Documents/Source Code Original/Chillu.f90


MODULE constants
!
!   Define some constants
!
  INTEGER, PARAMETER       :: db     = SELECTED_REAL_KIND(8)
!
  DOUBLE PRECISION, PARAMETER :: vlight = 299792458.0_db         ! c
  DOUBLE PRECISION, PARAMETER :: vacimp = 376.73031346177066_db  ! \mu_0*c
  DOUBLE PRECISION, PARAMETER :: eev    = 510998.89613320108_db  ! m_e*c^2/e
  DOUBLE PRECISION, PARAMETER :: pi     = 3.1415926535897931_db
END MODULE constants


      double precision function psi(xp,yp)
      implicit none

      double precision xp,yp,pi
      common /compi/ pi

      psi = ((sin(pi*xp))**2 * (sin(pi*yp))**2) / pi

      return
      end


    Program dsygv_example

!     DSYGV Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_blas_damax_val, &
        nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: ddisna, dlansy, dsygv, dtrcon
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0_dp
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: anorm, bnorm, eps, r, rcond, rcondb, t1, t2, t3
      Integer :: i, ifail, info, k, lda, ldb, lwork, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), b(:, :), eerbnd(:), rcondz(:), &
        w(:), work(:), zerbnd(:)
      Real (Kind=dp) :: dummy(1)
      Integer, Allocatable :: iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, epsilon, max, nint
!     .. Executable Statements ..
      Write (nout, *) 'DSYGV Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldb = n
      Allocate (a(lda,n), b(ldb,n), eerbnd(n), rcondz(n), w(n), zerbnd(n), &
        iwork(n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call dsygv(1, 'Vectors', 'Upper', n, a, lda, b, ldb, w, dummy, lwork, &
        info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max((nb+2)*n, nint(dummy(1)))
      Allocate (work(lwork))

!     Read the upper triangular parts of the matrices A and B

      Read (nin, *)(a(i,i:n), i=1, n)
      Read (nin, *)(b(i,i:n), i=1, n)

!     Compute the one-norms of the symmetric matrices A and B

      anorm = dlansy('One norm', 'Upper', n, a, lda, work)
      bnorm = dlansy('One norm', 'Upper', n, b, ldb, work)

!     Solve the generalized symmetric eigenvalue problem
!     A*x = lambda*B*x (ITYPE = 1)

      Call dsygv(1, 'Vectors', 'Upper', n, a, lda, b, ldb, w, work, lwork, &
        info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) w(1:n)

        Write (nout, *)
        Flush (nout)

!       Normalize the eigenvectors, largest positive
        Do i = 1, n
          Call nagf_blas_damax_val(n, a(1,i), 1, k, r)
          If (a(k,i)<zero) Then
            a(1:n, i) = -a(1:n, i)
          End If
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, n, a, lda, &
          'Eigenvectors', ifail)

!       Call DTRCON to estimate the reciprocal condition
!       number of the Cholesky factor of B.  Note that:
!       cond(B) = 1/rcond**2

        Call dtrcon('One norm', 'Upper', 'Non-unit', n, b, ldb, rcond, work, &
          iwork, info)

!       Print the reciprocal condition number of B

        rcondb = rcond**2
        Write (nout, *)
        Write (nout, *) 'Estimate of reciprocal condition number for B'
        Write (nout, 110) rcondb
        Flush (nout)

!       Get the machine precision, eps, and if rcondb is not less
!       than eps**2, compute error estimates for the eigenvalues and
!       eigenvectors

        eps = epsilon(1.0E0_dp)
        If (rcond>=eps) Then

!         Call DDISNA to estimate reciprocal condition
!         numbers for the eigenvectors of (A - lambda*B)

          Call ddisna('Eigenvectors', n, n, w, rcondz, info)

!         Compute the error estimates for the eigenvalues and
!         eigenvectors

          t1 = eps/rcondb
          t2 = anorm/bnorm
          t3 = t2/rcond
          Do i = 1, n
            eerbnd(i) = t1*(t2+abs(w(i)))
            zerbnd(i) = t1*(t3+abs(w(i)))/rcondz(i)
          End Do

!         Print the approximate error bounds for the eigenvalues
!         and vectors

          Write (nout, *)
          Write (nout, *) 'Error estimates for the eigenvalues'
          Write (nout, 110) eerbnd(1:n)
          Write (nout, *)
          Write (nout, *) 'Error estimates for the eigenvectors'
          Write (nout, 110) zerbnd(1:n)
        Else
          Write (nout, *)
          Write (nout, *) 'B is very ill-conditioned, error ', &
            'estimates have not been computed'
        End If
      Else If (info>n .And. info<=2*n) Then
        i = info - n
        Write (nout, 120) 'The leading minor of order ', i, &
          ' of B is not positive definite'
      Else
        Write (nout, 130) 'Failure in DSYGV. INFO =', info
      End If

100   Format (3X, (6F11.4))
110   Format (4X, 1P, 6E11.1)
120   Format (1X, A, I4, A)
130   Format (1X, A, I4)
    End Program


      MODULE m_angle
      CONTAINS
      REAL ELEMENTAL FUNCTION angle(x,y)

c----------------------------------------------
c     calculates an angle of a vector
c     given by rectangular coordinates (x,y)
c-----------------------------------------------

      USE m_constants
      IMPLICIT NONE

      REAL, INTENT (IN) :: x,y

      IF (x.NE.0.0) THEN
         IF (y.NE.0.0) THEN
            IF (y.GT.0.0) THEN
               IF (x.LT.0.0) angle = pi_const - ATAN(y/abs(x))
               IF (x.GT.0.0) angle = ATAN(y/x)
            ELSE
               IF (x.GT.0.0) angle = - ATAN(abs(y)/x)
               IF (x.LT.0.0) angle = - pi_const
     +                                  + ATAN(abs(y)/abs(x))
            END IF
         ELSE
            IF (x.LT.0.0) angle = -pi_const
            IF (x.GT.0.0) angle = 0.0
         END IF
      ELSE
         IF (y.LT.0.0) angle = -pi_const/2.
         IF (y.EQ.0.0) angle = 0.0
         IF (y.GT.0.0) angle = pi_const/2.
      END IF

      END FUNCTION angle
      END MODULE m_angle


!-----------------------------------------------------------------------
! Saturation specific humidity
!-----------------------------------------------------------------------
subroutine QSAT(water,P,T,Qs)

use Constants, only : &
  eps,               &! Ratio of molecular weights of water and dry air
  e0,                &! Saturation vapour pressure at Tm (Pa)
  Tm                  ! Melting point (K)

implicit none

logical, intent(in) :: &
  water               ! Saturation wrt water if TRUE

real, intent(in) :: &
  P,                 &! Air pressure (Pa)
  T                   ! Temperature (K)

real, intent(out) :: &
  Qs                  ! Saturation specific humidity

real :: &
  Tc,                &! Temperature (C)
  es                  ! Saturation vapour pressure (Pa)

Tc = T - Tm
if (Tc > 0 .or. water) then
  es = e0*exp(17.5043*Tc / (241.3 + Tc))
else
  es = e0*exp(22.4422*Tc / (272.186 + Tc))
end if
Qs = eps*es / P

end subroutine QSAT


c     Subroutine to convert from stnpres to sealevel pressure
c     AJ_Kettle, Nov07/2017

      SUBROUTINE slpres_from_stnpres(f_p_hpa,f_e_hpa,f_hght_m,f_airt_c,
     +   f_slpres_hpa)

      IMPLICIT NONE
c************************************************************************
      INTEGER             :: i,j,k,ii,jj,kk

c     Inputs
      REAL                :: f_p_hpa
      REAL                :: f_e_hpa
      REAL                :: f_hght_m
      REAL                :: f_airt_c

c     Output
      REAL                :: f_slpres_hpa

c     INTERNAL CONSTANTS
      REAL                :: f_grav_ms2
      REAL                :: f_gasconstant_jkgk
      REAL                :: f_airt_k
      REAL                :: f_alapse_km
      REAL                :: f_ccoef_khpa
c************************************************************************
      f_grav_ms2          =9.80665
      f_gasconstant_jkgk  =287.05
      f_airt_k            =273.15+f_airt_c
      f_alapse_km         =0.0065
      f_ccoef_khpa        =0.12

      f_slpres_hpa=f_p_hpa*
     +  EXP(
     +       (f_grav_ms2*f_hght_m/f_gasconstant_jkgk)/
     +       (f_airt_k+f_alapse_km*f_hght_m/2.0+f_e_hpa*f_ccoef_khpa)
     +     )

c************************************************************************
      RETURN
      END


Subroutine zprota(xn1, xn2, xn3, theta, v1, v2, v3)
  Implicit Double Precision (A-H, O-Z)
  Save
  vx = v1
  vy = v2
  vz = v3
  c = cos(theta)
  omc = 1D0 - c
  s = sin(theta)
  a11 = xn1**2*omc + c
  a12 = xn1*xn2*omc - s*xn3
  a13 = xn1*xn3*omc + s*xn2
  a21 = xn1*xn2*omc + s*xn3
  a22 = xn2**2*omc + c
  a23 = xn2*xn3*omc - s*xn1
  a31 = xn1*xn3*omc - s*xn2
  a32 = xn3*xn2*omc + s*xn1
  a33 = xn3**2*omc + c
  v1 = vx*a11 + vy*a12 + vz*a13
  v2 = vx*a21 + vy*a22 + vz*a23
  v3 = vx*a31 + vy*a32 + vz*a33
  Return
End Subroutine zprota


MODULE polint_module

  implicit none

  PRIVATE
  PUBLIC :: polint, dpolint

CONTAINS

  SUBROUTINE polint( xa,ya,n,x,y,dy )

    implicit none
    integer,intent(IN)  :: n
    real(8),intent(IN)  :: xa(n),ya(n),x
    real(8),intent(OUT) :: y,dy
    integer :: i,m
    real(8) :: a,b,f0nm,f0nm_0
    real(8),allocatable :: f0(:)

    allocate( f0(n) )
    f0(:) = ya(:)

    f0nm = ya(1)

    do m=1,n-1
       do i=1,n-m
          a = x-xa(i)
          b = x-xa(i+m)
          f0(i) = ( b*f0(i) - a*f0(i+1) )/( b - a )
       end do
       f0nm_0 = f0nm
       f0nm   = sum( f0(1:n-m) )/(n-m)
    end do
    y  = f0(1)
    dy = f0nm - f0nm_0

    deallocate( f0 )

    return
  END SUBROUTINE polint

  SUBROUTINE dpolint( xa,ya,n,x,y,dy )

    implicit none
    integer,intent(IN)  :: n
    real(8),intent(IN)  :: xa(n),ya(n),x
    real(8),intent(OUT) :: y,dy
    integer :: i,m
    real(8) :: a,b,f1nm,f1nm_0
    real(8),allocatable :: f0(:),f1(:)

    allocate( f0(n),f1(n) )
    f0(:) = ya(:)
    f1(:) = 0.0d0

    f1nm = ( ya(2)-ya(1) )/( xa(2)-xa(1) )

    do m=1,n-1
       do i=1,n-m
          a = x-xa(i)
          b = x-xa(i+m)
          f1(i) = ( f0(i) - f0(i+1) + b*f1(i) -a*f1(i+1) )/( b - a )
          f0(i) = ( b*f0(i) - a*f0(i+1) )/( b - a )
       end do
       f1nm_0 = f1nm
       f1nm   = sum( f1(1:n-m) )/(n-m)
    end do

    y  = f1(1)
    dy = f1nm - f1nm_0

    deallocate( f0,f1 )

    return
  END SUBROUTINE dpolint

END MODULE polint_module


module Mod_BlasiusProfile
   use typre
   implicit none

   !Using: http://www.calpoly.edu/~kshollen/ME347/Handouts/Blasius.pdf

   type :: BlasiusProfileGenerator
      real(rp) :: UFree = 1.0_rp, nu = 1.0_rp, X = 1.0_rp

      real(rp) :: sqrtUdivNuX   !sqrt(U/nu*x)

      real(rp) :: EtaTable(17) = (/   0.0,  0.5, 1.0, 1.5, 2.0, 2.5, 3.0, 3.5, 4.0, 4.5, 5.0, 5.5, 6.0, 6.5, 7.0, 7.5, 8.0 /)
      real(rp) :: FTable(17)   = (/ 0.0000, 0.1659, 0.3298, 0.4868, 0.6298, 0.7513, 0.8461, 0.9131, 0.9555, 0.9795, 0.9916, 0.9969, 0.9990, 0.9997, 0.9999, 1.0000, 1.0000 /)
contains

      procedure :: SetUFree
      procedure :: SetNu
      procedure :: SetDistanceXFromPlateStartingPoint
      procedure :: GetU

   end type

contains

   subroutine SetUFree(a,UFree)
      class(BlasiusProfileGenerator) :: a
      real(rp) :: UFree

      a%UFree = UFree;
      call ComputeSqrtUdivNux(a)
   end subroutine

   subroutine SetNu(a,nu)
      class(BlasiusProfileGenerator) :: a
      real(rp) :: nu

      a%nu = nu
      call ComputeSqrtUdivNux(a)
   end subroutine

   subroutine SetDistanceXFromPlateStartingPoint(a,X)
      class(BlasiusProfileGenerator) :: a
      real(rp) :: X

      a%X = X;
      call ComputeSqrtUdivNux(a)
   end subroutine

   subroutine ComputeSqrtUdivNux(a)
      class(BlasiusProfileGenerator) :: a

      a%sqrtUdivNuX = sqrt(a%UFree/(a%nu*a%X))
   end subroutine

   subroutine GetU(a,y,U)
      class(BlasiusProfileGenerator) :: a
      real(rp) :: y,u

      real(rp) :: eta
      integer(ip) :: pos

      real(rp) :: eta0,eta1,etadist,coeff0,coeff1,Fval0,Fval1

      eta = y*a%sqrtUdivNuX

      if (eta > 8) then
         U = a%UFree;
      elseif (eta < 0.0_rp) then
         U = 0.0_rp
      else
         pos = floor(eta/0.5_rp)+1

         etadist = a%EtaTable(pos+1)- a%EtaTable(pos)
         eta0 = a%EtaTable(pos)
         eta1 = a%EtaTable(pos+1)

         coeff0 = 1.0_rp-(eta-eta0)/etadist
         coeff1 = 1.0_rp-coeff0

         Fval0 = a%FTable(pos)
         Fval1 = a%Ftable(pos+1)

         U = a%UFree*(coeff0*Fval0+coeff1*Fval1)

      endif
   end subroutine

end module


    Program dgelsy_example

!     DGELSY Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: dgelsy
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: rcond
      Integer :: i, info, lda, lwork, m, n, rank
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), b(:), work(:)
      Integer, Allocatable :: jpvt(:)
!     .. Executable Statements ..
      Write (nout, *) 'DGELSY Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n
      lda = m
      lwork = 3*n + nb*(n+1)
      Allocate (a(lda,n), b(m), work(lwork), jpvt(n))

!     Read A and B from data file

      Read (nin, *)(a(i,1:n), i=1, m)
      Read (nin, *) b(1:m)

!     Initialize JPVT to be zero so that all columns are free

      jpvt(1:n) = 0

!     Choose RCOND to reflect the relative accuracy of the input data

      rcond = 0.01_dp

!     Solve the least squares problem min( norm2(b - Ax) ) for the x
!     of minimum norm.

      Call dgelsy(m, n, 1, a, lda, b, m, jpvt, rcond, rank, work, lwork, info)

!     Print solution

      Write (nout, *) 'Least squares solution'
      Write (nout, 100) b(1:n)

!     Print the effective rank of A

      Write (nout, *)
      Write (nout, *) 'Tolerance used to estimate the rank of A'
      Write (nout, 110) rcond
      Write (nout, *) 'Estimated rank of A'
      Write (nout, 120) rank

100   Format (1X, 7F11.4)
110   Format (3X, 1P, E11.2)
120   Format (1X, I6)
    End Program


      PROGRAM xgamdev
C     driver for routine gamdev
      INTEGER N,NPTS,ISCAL,LLEN
      PARAMETER(N=20,NPTS=10000,ISCAL=200,LLEN=50)
      INTEGER i,ia,idum,j,k,klim
      REAL gamdev,dist(21)
      CHARACTER text(50)*1
      idum=-13
10    do 11 j=1,21
        dist(j)=0.0
11    continue
      write(*,*) 'Order of Gamma distribution (n=1..20); -1 to END.'
      read(*,*) ia
      if (ia.le.0) goto 99
      if (ia.gt.20) goto 10
      do 12 i=1,NPTS
        j=int(gamdev(ia,idum))+1
        if ((j.ge.1).and.(j.le.21)) dist(j)=dist(j)+1
12    continue
      write(*,'(1x,a,i2,a,i6,a)') 'Gamma-distribution deviate, order ',
     *     ia,' of ',NPTS,' points'
      write(*,'(1x,t6,a,t14,a,t23,a)') 'x','p(x)','graph:'
      do 15 j=1,20
        dist(j)=dist(j)/NPTS
        do 13 k=1,50
          text(k)=' '
13      continue
        klim=int(ISCAL*dist(j))
        if (klim.gt.LLEN) klim=LLEN
        do 14 k=1,klim
          text(k)='*'
14      continue
        write(*,'(1x,f7.2,f10.4,4x,50a1)')
     *       float(j),dist(j),(text(k),k=1,50)
15    continue
      goto 10
99    END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xgamdev.for


      program drdilu
c>> 2001-05-22 DRDILU Krogh Minor change for making .f90 version.
c>> 1994-12-21 DRDILU  Krogh  Latest version.
c--D replaces "?": DR?ILU, ?ILUP
c Demonstration driver for DILUP.
c Given table of sin(x), x = 0, .5, 1., ..., interpolates for x =
c -.1, .1, and, 8.3 using polynomial degrees 2, 3, 4, ..., 10.  Errors
c are estimated in all cases.
c
      integer NTAB, NX, NDEG1, NDEG2
      parameter (NTAB=40, NX=3, NDEG1=2, NDEG2=10)
      double precision XT(2), YT(NTAB), X(NX), Y, EOPT(1), H, ANS
      parameter (H = .5D0)
      integer I, NDEG, IOPT(3), LUP
      data X / -.1D0, .1D0, 8.3D0 /
c                       Set IOPT to get an error estimate.
      data IOPT / 0, 1, 0 /
      data LUP / 3 /
c
c Compute the XT and YT tables
      XT(1) = 0.D0
      XT(2) = H
      do 10 I = 1, NTAB
         YT(I) = sin(dble(I-1) * H)
   10 continue
      print *, 'IOP(1) NDEG    X         Y     Est. Error True Error'
      do 30 I = 1, NX
         ANS = sin(X(I))
         do 20 NDEG = NDEG1, NDEG2
            call DILUP (X(I), Y, NTAB, XT, YT, NDEG, LUP, IOPT, EOPT)
            print '(I5, I5, F9.4, F12.8, 1P,E10.2, E11.2)',
     1       IOPT(1), NDEG, X(I), Y, EOPT(1), Y - ANS
   20    continue
      print *
   30 continue
      stop
      end


program main

        implicit none

        integer :: c = 1, i;

        integer :: maximum = 10000000

        ! c is the count of how many number chains arrive at 89

        do i = 1, MAXIMUM

                if(number_chain(i) == 89) then
                        call inc(c, 1)
                endif

        enddo

        print*, c

contains

        ! Increment a number i by the value x.
        ! This is here because I miss +=
        subroutine inc(base, offset)

                integer, intent (in):: offset
                integer, intent (out):: base

                base = base + offset
                return

        end subroutine inc

        function number_chain(r)

                integer, intent (in) :: r

                integer :: i
                integer :: sumx, number_chain
                i = r

                outer: do

                        sumx = 0

                        inner: do while (i /= 0)
                                call inc(sumx, mod(i, 10) ** 2)
                                i = i / 10
                        end do inner

                        i = sumx

                        if(sumx == 1 .OR. sumx == 89) then
                                number_chain = sumx;
                                exit
                        endif

                end do outer

                return

        end function number_chain

end program main


      PROGRAM xmnewt
C     driver for routine mnewt
      INTEGER NTRIAL,N,NP
      REAL TOLX,TOLF
      PARAMETER(NTRIAL=5,TOLX=1.0E-6,N=4,TOLF=1.0E-6,NP=15)
      INTEGER i,j,k,kk
      REAL xx,fjac(NP,NP),fvec(NP),x(NP)
      do 15 kk=-1,1,2
        do 14 k=1,3
          xx=0.2001*k*kk
          write(*,'(/1x,a,i2)') 'Starting vector number',k
          do 11 i=1,N
            x(i)=xx+0.2*i
            write(*,'(1x,t5,a,i1,a,f5.2)') 'X(',i,') = ',x(i)
11        continue
          do 13 j=1,NTRIAL
            call mnewt(1,x,N,TOLX,TOLF)
            call usrfun(x,n,NP,fvec,fjac)
            write(*,'(/1x,t5,a,t14,a,t29,a/)') 'I','X(I)','F'
            do 12 i=1,N
              write(*,'(1x,i4,2e15.6)') i,x(i),fvec(i)
12          continue
            write(*,'(/1x,a)') 'press RETURN to continue...'
            read(*,*)
13        continue
14      continue
15    continue
      END
      SUBROUTINE usrfun(x,n,np,fvec,fjac)
      INTEGER i,n,np
      REAL fjac(np,np),fvec(np),x(np)
      fjac(1,1)=-2.0*x(1)
      fjac(1,2)=-2.0*x(2)
      fjac(1,3)=-2.0*x(3)
      fjac(1,4)=1.0
      do 11 i=1,n
        fjac(2,i)=2.0*x(i)
11    continue
      fjac(3,1)=1.0
      fjac(3,2)=-1.0
      fjac(3,3)=0.0
      fjac(3,4)=0.0
      fjac(4,1)=0.0
      fjac(4,2)=1.0
      fjac(4,3)=-1.0
      fjac(4,4)=0.0
      fvec(1)=-x(1)**2-x(2)**2-x(3)**2+x(4)
      fvec(2)=x(1)**2+x(2)**2+x(3)**2+x(4)**2-1.0
      fvec(3)=x(1)-x(2)
      fvec(4)=x(2)-x(3)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xmnewt.for


subroutine fibonacci(n, a_out)
  implicit none
  integer, intent(in) :: n
  real*8, dimension(n) :: a_out

  integer :: i

  do i = 1, n
    if (i.eq.1) then
      a_out(i) = 1.0
    elseif (i.eq.2) then
      a_out(i) = 1.0
    else
      a_out(i) = a_out(i-1) + a_out(i-2)
    end if
  end do

  return

end subroutine fibonacci


      function rs(chd,radius,rsmax)
c
c  purpose:  convert a charge density value to the equivalent r_s
c            where   4*pi*(r_s)**3*chd/3 = 1,
c            i.e. r_s is the radius of a sphere containing exactly one
c                 electron in a homogeneous electron gas of density chd.
c
c            charge density may be of the form n(r) (radius = 0.d0)
c            or 4*pi*r**2*n(r), in which case radius is the r-value.
c
c  method:   check that chd is not zero or -ve; if it is, rs is set to
c            rsmax (rsmax = 1.d3 => charge density around 2.4d-10 e/(au^3))
c
c   calls:  system function datan
c
c written:  philip sterne, sterne1@llnl.gov
c date:     April 21, 1998
c changes:  none
c comments:
c
      implicit none
c
c  input variables
c
      real*8 chd        ! charge density - either n(r) or 4*pi*r**2*n(r)
      real*8 radius     ! radius r if input chd is 4*pi*r**2*n(r)
      real*8 rsmax      ! maximum allowable r_s value (very low cd limit)
c
c  output variables
c
      real*8 rs         ! r_s value for this charge density
c
c  internal variables and functions
c
      real*8 pi         ! pi
      real*8 chdmin     ! minimum charge density - corresponds to rsmax
c
c  set rsmax and chdmin values for vanishingly small charge densities
c
      rs = rsmax
      pi = 4.d0*datan(1.d0)
      if(radius.eq.0.d0) then
         chdmin = 3.d0/(4.d0*pi*rsmax**3)
         if(chd.gt.chdmin) rs = (3.d0/(4.d0*pi*chd))**(1.d0/3.d0)
      else
         chdmin = 3.d0*radius**2/(rsmax**3)
         if(chd.gt.chdmin) rs = (3.d0*radius**2/chd)**(1.d0/3.d0)
      endif
c
      return
      end


program rationals
use rationals_mod
implicit none
type(rational) :: a, b, c, d

a = rational(2, 3)
call rat_print(a)
b = rational(1, 5)
call rat_print(b)
d = a + b
call rat_print(d)
a = rational(1, 4)
b = rational(1, 4)
d = a + b
call rat_print(d)

a = rational(-2, 4)
b = rational(1, 4)
d = a + b
call rat_print(d)

a = rational(2, -4)
b = rational(1, 4)
d = a + b
call rat_print(d)

a = rational(2, -4)
b = rational(1, 4)
d = a*b
call rat_print(d)

a = rational(2, -4)
d = 3*a
call rat_print(d)

c = rational(3, 0)
call rat_print(c)

end program rationals


      SUBROUTINE zroots(a,m,roots,polish)
      INTEGER m,MAXM
      REAL EPS
      COMPLEX a(m+1),roots(m)
      LOGICAL polish
      PARAMETER (EPS=1.e-6,MAXM=101)
CU    USES laguer
      INTEGER i,j,jj,its
      COMPLEX ad(MAXM),x,b,c
      do 11 j=1,m+1
        ad(j)=a(j)
11    continue
      do 13 j=m,1,-1
        x=cmplx(0.,0.)
        call laguer(ad,j,x,its)
        if(abs(aimag(x)).le.2.*EPS**2*abs(real(x))) x=cmplx(real(x),0.)
        roots(j)=x
        b=ad(j+1)
        do 12 jj=j,1,-1
          c=ad(jj)
          ad(jj)=b
          b=x*b+c
12      continue
13    continue
      if (polish) then
        do 14 j=1,m
          call laguer(a,m,roots(j),its)
14      continue
      endif
      do 16 j=2,m
        x=roots(j)
        do 15 i=j-1,1,-1
          if(real(roots(i)).le.real(x))goto 10
          roots(i+1)=roots(i)
15      continue
        i=0
10      roots(i+1)=x
16    continue
      return
      END

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


program main

    use open_linalg_m, only: solve

    real :: a(2, 2) = reshape([1.0, 3.0, 2.0, 4.0], [2, 2]), &
            b(2, 1) = reshape([7.0, 15.0], [2, 1])

    b = solve(a, b)
    print 100, b

100 format(*(f6.2))

end program main

!   1.00  3.00


c
c THis subprogram is to find the mean and rms of the qv,
c Qc, S, and Temperature
c

	subroutine mean_rms(m1,m4,TH1,Th2,TH3,Th4,Th1_mean,TH2_mean,
     $        TH3_mean,Th4_mean,Th1_rms,Th2_rms,TH3_rms,TH4_rms,ip,
     $          mip,igrid)

	integer*4 igrid
        real*8 Th1(igrid),Th2(igrid),Th3(igrid),Th4(igrid)
	real*8 th1_mean(0:mip),th2_mean(0:mip),th3_mean(0:mip)
     $        ,th4_mean(0:mip)
	real*8 th1_rms(0:mip),th2_rms(0:mip),th3_rms(0:mip),
     $         th4_rms(0:mip)

	sum1=0.
	sum2=0.
	sum3=0.
	sum4=0.

	DO i=m1,m4
	sum1=sum1+TH1(i)
	sum2=sum2+TH2(i)
	sum3=sum3+Th3(i)
	sum4=sum4+TH4(i)
	end do

	N=m4-m1+1
	th1_mean(ip)=sum1/float(N)
	th2_mean(ip)=sum2/float(n)
	th3_mean(ip)=sum3/float(N)
	th4_mean(ip)=sum4/float(N)

	prim1=0.
	prim2=0.
	prim3=0.
	prim4=0.

	Do i=m1,m4
	prim1=prim1+(TH1(i)-th1_mean(ip))**2.
	prim2=prim2+(TH2(i)-th2_mean(ip))**2.
	prim3=prim3+(TH3(i)-TH3_mean(ip))**2.
	prim4=prim4+(TH4(i)-TH4_mean(ip))**2.
	end do

	TH1_rms(ip)=(prim1/float(n))**.5
	TH2_rms(ip)=(prim2/float(n))**.5
	TH3_rms(ip)=(prim3/float(n))**.5
	Th4_rms(ip)=(prim4/float(n))**.5
c	write(*,*)'mean and rms'
c	write(*,*)th1_mean(ip),Th2_mean(ip),Th3_mean(ip),Th4_mean(ip)
c	write(*,*)TH1_rms(ip),TH2_rms(ip),Th3_rms(ip),Th4_rms(ip)
	return
	end


subroutine line_gs_solver(phi, ap_phi, aw_phi, ae_phi, as_phi, an_phi, b_phi, f_phi, nx, ny, alpha, xi, xf)
use kind_parameters
implicit none

integer, intent(in):: nx, ny, xi, xf
real(kind=dp), intent(inout), dimension(nx,xi-1:xf+1):: phi
real(kind=dp), intent(in), dimension(nx,xi-1:xf+1):: ap_phi, aw_phi, ae_phi, as_phi, an_phi, b_phi, f_phi
real(kind=dp), intent(in):: alpha

integer:: i, j, N
real(kind=dp):: alpha_inv
real(kind=dp), allocatable:: a(:,:), b(:)
!real(kind=dp):: dx(nx), dy(ny), delx(-2:nx+2), dely(-2:ny+2)

alpha_inv = 1.0d0/alpha

!	Sweep from bottom to top
!	Implicit in X

N = nx-2
allocate(a(N,3), b(N))

a(1,1) = 0.0d0
a(nx-2,3) = 0.0d0

do j = xi,xf

        a(1,2) = ap_phi(2,j)*alpha_inv
        a(1,3) = -ae_phi(2,j)
        b(1) = as_phi(2,j)*phi(2,j-1) + an_phi(2,j)*phi(2,j+1) + phi(2,j)*ap_phi(2,j)*(alpha_inv-1.0d0) + aw_phi(2,j)*phi(1,j) + b_phi(2,j) + f_phi(2,j)

        do i=3,nx-2

            a(i-1,1) = -aw_phi(i,j)
            a(i-1,2) = ap_phi(i,j)*alpha_inv
            a(i-1,3) = -ae_phi(i,j)
            b(i-1) = an_phi(i,j)*phi(i,j+1) + as_phi(i,j)*phi(i,j-1) + ap_phi(i,j)*(alpha_inv-1.0d0)*phi(i,j) + b_phi(i,j) + f_phi(i,j)

        end do

        a(nx-2,1) = -aw_phi(nx-1,j)
        a(nx-2,2) = ap_phi(nx-1,j)*alpha_inv
        b(nx-2) = as_phi(nx-1,j)*phi(nx-1,j-1) + an_phi(nx-1,j)*phi(nx-1,j+1) + ap_phi(nx-1,j)*phi(nx-1,j)*(alpha_inv-1.0d0) + ae_phi(nx-1,j)*phi(nx,j) + b_phi(nx-1,j) + f_phi(nx-1,j)

        call tdma(a, b, N)

        do i = 1,N

            phi(i+1,j) = b(i)

        end do

end do

call exchange_data(phi, nx, xi, xf)

!	Sweep from top to bottom
!	Implicit in X

do j = xf,xi,-1

        a(1,2) = ap_phi(2,j)*alpha_inv
        a(1,3) = -ae_phi(2,j)
        b(1) = as_phi(2,j)*phi(2,j-1) + an_phi(2,j)*phi(2,j+1) + phi(2,j)*ap_phi(2,j)*(alpha_inv-1.0d0) + aw_phi(2,j)*phi(1,j) + b_phi(2,j)+ f_phi(2,j)

        do i=3,nx-2

            a(i-1,1) = -aw_phi(i,j)
            a(i-1,2) = ap_phi(i,j)*alpha_inv
            a(i-1,3) = -ae_phi(i,j)
            b(i-1) = an_phi(i,j)*phi(i,j+1) + as_phi(i,j)*phi(i,j-1) + ap_phi(i,j)*(alpha_inv-1.0d0)*phi(i,j) + b_phi(i,j) + f_phi(i,j)

        end do

        a(nx-2,1) = -aw_phi(nx-1,j)
        a(nx-2,2) = ap_phi(nx-1,j)*alpha_inv
        b(nx-2) = as_phi(nx-1,j)*phi(nx-1,j-1) + an_phi(nx-1,j)*phi(nx-1,j+1) + ap_phi(nx-1,j)*phi(nx-1,j)*(alpha_inv-1.0d0) + ae_phi(nx-1,j)*phi(nx,j) + b_phi(nx-1,j) + f_phi(nx-1,j)

        call tdma(a, b, N)

        do i = 1,N

            phi(i+1,j) = b(i)

        end do

end do

deallocate(a,b)

call exchange_data(phi, nx, xi, xf)

end subroutine


*$ Section 1: Special Functions
*  ----------------------------

*+ fun_gammp

       real function fun_gammp( a, x, istat )
C      --------------------------------------
C
C Returns the incomplete gamma function P(a,x) by argument
C
C Given:
C   parameters for the function
       real*4       a, x
C Updated:
C   error return
       integer      istat
C
C The incomplete Gamma function P(a,x) is defined by:
C \[
C   P(a,x) = \frac{1}{\Gamma(a)} \int_{0}^{x} e^{-t}t^{a-1} dt
C \]
C for $a > 0$.

C ISTAT should be zero on entry.  The values set by this routine are:
C     ILL_INPUTS         == illegal ranges on input data.
C     ILL_PRECISION      == unable to calculate function to sufficient
C                           precision.  This error can be returned from
C                           one of the internal routines and results from
C                           a to large or not enough iterations within
C                           the respective routine.  This error MUST
C                           be reported.
C
C P. Alexander, MRAO, Cambridge.
C Ref: Numerical Recipes, Press et al., Cambridge. pg. 160.
C-

       include '../include/utilities_errors.inc'

C local variables
       real*4    gamser, gammcf, gln

       if (istat.ne.0) return

       if (x.lt.0.0 .or. a.le.0.0) then
         istat = ill_inputs
         fun_gammp = 0.0
       else
         if (x.lt.a+1.0) then
C .. use series representation
           call fun_gser(gamser,a,x,gln,istat)
           fun_gammp = gamser
         else
C .. use continued fraction
           call fun_gcf(gammcf,a,x,gln,istat)
C .. take complement
           fun_gammp = 1.0 - gammcf
         end if
       end if
       call utl_err( istat,'fun_gammp','Failed' )
       end


	PROGRAM TEST
C
	DO N = 1,100
	  Y = (-50. +N)/10.
	  DL = ALOG(COSH(Y))
	  PRINT*,N,Y,DL
	  WRITE(33,*) N,Y,DL
	ENDDO
	STOP
	END


subroutine sldsup_GetPhysicalParameters_lin(a,ndime,sz,densi,K,G,C_dev,D,D_dev,Dv_scalar,id,ielem)
   use typre
   use Mod_SUPSolids_lin
   implicit none
   class(SUPSolidsProblem_lin), target :: a
   integer(ip),intent(in) :: ndime,sz
   real(rp),   intent(out):: densi,K,G,Dv_scalar
   real(rp),   intent(out):: C_dev(sz,sz),D(sz,sz),D_dev(sz,sz),id(sz,sz)
   integer(ip),optional   :: ielem
   real(rp)               :: D_vol(sz,sz)
   real(rp)               :: D_aux(sz,1)
   real(rp)               :: ii_tt(sz,sz),iv(sz,sz)

   densi = a%densi
   K     = a%bulkMod
   G     = a%mu

   call get4thIITensor(ndime,sz,ii_tt)
   call get4thIIVolumetricTensor(ndime,sz,iv)

   !Also known as P
   id = ii_tt - iv

   C_dev = (2.0_rp*G)*id

   D_vol = (ndime/K)*iv
   D_dev = (1.0_rp/(2.0_rp*G))*id

   D     = D_vol + D_dev

   if(ndime==2) then
       Dv_scalar= 16.0_rp/(27.0_rp*K)
   else
       Dv_scalar= 1.0_rp/K
   endif

end subroutine


! Fundamental constants taken from NIST's 2010 CODATA recommended values

module fundamental_constants_module

  use bl_types

  implicit none

  ! newton's gravitational constant
  real(kind=dp_t), parameter :: Gconst = 6.67428e-8_dp_t      ! cm^3/g/s^2
! new value; if uncommented initial models will need to be re-HSE'ed
!  real(kind=dp_t), parameter :: Gconst = 6.67384e-8_dp_t      ! cm^3/g/s^2

  ! boltzmann's constant
  real(kind=dp_t), parameter :: k_B    = 1.3806488e-16_dp_t   ! erg/K

  ! planck's constant over 2pi
  real(kind=dp_t), parameter :: hbar   = 1.054571726e-27_dp_t ! erg s

  ! planck's constant
  real(kind=dp_t), parameter :: hplanck = 6.62606957e-27_dp_t ! erg s

  ! avogradro's Number
  real(kind=dp_t), parameter :: n_A    = 6.02214129e23_dp_t   ! mol^-1

  ! convert eV to erg
  real(kind=dp_t), parameter :: ev2erg = 1.602176487e-12_dp_t

  ! convert MeV to eV
  real(kind=dp_t), parameter :: MeV2eV = 1.0e6_dp_t

  ! mass of proton
  real(kind=dp_t), parameter :: m_p     = 1.672621777e-24_dp_t ! g

  ! mass of neutron
  real(kind=dp_t), parameter :: m_n      = 1.674927351e-24_dp_t ! g

  ! mass of electron
  real(kind=dp_t), parameter :: m_e     = 9.10938291e-28_dp_t  ! g

  ! speed of light in vacuum
  real(kind=dp_t), parameter :: c_light = 2.99792458e10_dp_t   ! cm/s

  ! electron charge
  ! NIST: q_e = 1.602176565e-19 C
  !
  ! C is the SI unit Coulomb; in cgs we have the definition:
  !     1 C = 0.1 * |c_light| * 1 statC
  ! where statC is the cgs unit statCoulomb; 1 statC = 1 erg^1/2 cm^1/2
  ! and |c_light| is the speed of light in cgs (but without units)
  real(kind=dp_t), parameter :: q_e     = 4.80320451e-10_dp_t  ! erg^1/2 cm^1/2

  ! stefan-boltzmann constant
  real(kind=dp_t), parameter :: sigma_SB = 5.670373e-5_dp_t    ! erg/s/cm^2/K^4

  ! radiation constant
  real(kind=dp_t), parameter :: a_rad = 4.0_dp_t*sigma_SB/c_light

  ! Hubble constant (in s^{-1}, converted from 100 (km/s)/Mpc by dividing by 3.08568025e19km/Mpc)
  real(kind=dp_t), parameter :: Hubble_const = 32.407764868e-19

end module fundamental_constants_module


      SUBROUTINE DLESUM(X,N,A,SUM)
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 DLESUM Krogh  Changes to use M77CON
C>> 1994-04-20 DLESUM CLL  Edited to make DP & SP files similar.
C>> 1992-03-13 DLESUM FTK  Removed implicit statements.
C>> 1985-08-02 DLESUM Lawson  Initial code.
C
C     THIS SUBROUTINE EVALUATES THE SUM OF
C          A(J) * P(J) FOR J = 0,...,N,
C     WHERE P(J)'S  ARE LEGENDRE POLYNOMIALS OF DEGREE J.
C
C     THE RECURSION FORMULA IS :
C     B(K) = X+B(K+1)*(2*K+1)/(K+1)-B(K+2)*(K+1)/(K+2)+A(K)
C
C     C.L.LAWSON & S.CHAN, JPL, 1983 JUNE 9
C
C     -------------------------------------------------------------
C     SUBROUTINE ARGUMENTS
C     --------------------
C     X     ARGUMENT OF LEG POLYS, X SHOULD BE NON-NEGATIVE.
C     N     SUM IS TO INCLUDE LEGENDRE POLYS OF DEGREE ZERO
C           THRU N.
C     A()   A,...,A(N) CONTAIN COEFFS TO BE USED IN
C           FORMING THE SUM.
C     SUM   SUM OF COMBINATION
C
C     -------------------------------------------------------------
c--D replaces "?": ?LESUM
C     -------------------------------------------------------------
      INTEGER K,N
      DOUBLE PRECISION A(0:N),B,B1,B2,C1,C2,C3
      DOUBLE PRECISION ONE,SUM,TWO,X,ZERO
      DATA ZERO,ONE,TWO / 0.D0, 1.D0, 2.D0 /
C     -------------------------------------------------------------
      IF (N .lt. 0) then
         SUM = ZERO
         RETURN
      endif
C
      C1 = DBLE(N+1)
      C3 = C1 + C1 - ONE
      B1 = ZERO
      B  = A(N)
C
      DO 10 K = N-1,0,-1
C
C     C1 = K + 1, C3 = 2K + 1
C
        C2 = C1
        C1 = C1 - ONE
        C3 = C3 - TWO
        B2 = B1
        B1 = B
        B  = X * B1 * C3 / C1  -  B2 * C1 / C2  +  A(K)
  10  CONTINUE
      SUM = B
      RETURN
      END


      subroutine krnlcolumnupdate( m, n, A, ldA, cvec, svec )

      implicit none

*
*     PURPOSE
*     =======
*
*     Applies a decreasing sequence of n - 1 column rotations to a
*     rectangular m-by-n matrix A.
*
*     More specifically, the following update of A is performed:
*
*       A := A * G(k) * G(k-1) * ... * G(2)
*
*     where G(k) for k = 2, 3, ..., n affects only columns k - 1 and k
*     in the following way. Let x denote column k - 1 and y denote
*     column k. Furthermore, define c = cvec(k) and s = svec(k). Then
*     the effect of A * G(k) is equivalent to the update
*
*       [ x y ] := [ x y ] * [ c -s ]
*                            [ s  c ].
*
*
*     ARGUMENTS
*     =========
*
*     m             (input) INTEGER
*
*                   The number of rows in A.
*
*     n             (input) INTEGER
*
*                   The number of columns in A.
*
*     A             (input/output) DOUBLE PRECISION array
*                   dimension ldA-by-n
*
*                   The matrix A.
*
*     ldA           (input) INTEGER
*
*                   The column stride of A.
*
*     cvec          (input) DOUBLE PRECISION array
*                   dimension n
*
*                   cvec(k) is the c-parameter of G(k).
*
*     svec          (input) DOUBLE PRECISION array
*                   dimension m
*
*                   svec(k) is the s-parameter of G(k).
*

*
*     Scalar arguments.
*
      integer m, n, ldA

*
*     Array arguments.
*
      double precision A( ldA, * ), cvec( * ), svec( * )

*
*     Local scalars.
*
      integer i, j
      double precision c, s, x, y

      do j = n, 2, -1
         c = cvec( j )
         s = svec( j )
         do i = 1, m
            x = A( i, j - 1 )
            y = A( i, j     )
            A( i, j - 1 ) = c * x - s * y
            A( i, j     ) = s * x + c * y
         end do
      end do

      end subroutine


PROGRAM test_selected_kinds
!
!  Purpose:
!    To determine selected real kinds.
!
IMPLICIT NONE
INTEGER :: kind_number     ! Resulting kind number

! Display kind numbers
kind_number = SELECTED_REAL_KIND(p=6,r=37)
WRITE (*,*) 'SELECTED_REAL_KIND(p=6,r=37) = ', kind_number
kind_number = SELECTED_REAL_KIND(p=12)
WRITE (*,*) 'SELECTED_REAL_KIND(p=12) = ',   kind_number
kind_number = SELECTED_REAL_KIND(r=100)
WRITE (*,*) 'SELECTED_REAL_KIND(r=100) = ',  kind_number
kind_number = SELECTED_REAL_KIND(13,200)
WRITE (*,*) 'SELECTED_REAL_KIND(13,200) = ', kind_number
kind_number = SELECTED_REAL_KIND(13)
WRITE (*,*) 'SELECTED_REAL_KIND(13) = ',     kind_number
kind_number = SELECTED_REAL_KIND(p=17)
WRITE (*,*) 'SELECTED_REAL_KIND(p=17) = ',   kind_number

END PROGRAM test_selected_kinds


PROGRAM SELECTION

  IMPLICIT NONE

  INTEGER :: intArray(10) = (/ 4, 9, 3, -2, 0, 7, -5, 1, 6, 8 /)

  WRITE(*,"(A,10I5)") "Unsorted array:", intArray
  CALL Selection_sort(intArray)
  WRITE(*,"(A,10I5)") "Sorted array  :", intArray

CONTAINS

  SUBROUTINE Selection_sort(a)
    INTEGER, INTENT(IN OUT) :: a(:)
    INTEGER :: i, minIndex, temp

    DO i = 1, SIZE(a)-1
       minIndex = MINLOC(a(i:), 1) + i - 1
       IF (a(i) > a(minIndex)) THEN
          temp = a(i)
          a(i) = a(minIndex)
          a(minIndex) = temp
       END IF
    END DO
  END SUBROUTINE Selection_sort

END PROGRAM SELECTION


program serial
      implicit none

      integer, parameter             :: width=1000
      integer, parameter             :: height=1000
      double precision, parameter    :: temp_tolerance=0.01

      integer                        :: i, j, iteration=1
      double precision               :: worst_dt=100.0
      real                           :: start_time, stop_time

      double precision, dimension(0:height+1,0:width+1) :: temperature, temperature_previous

      call cpu_time(start_time)

      call initialize(temperature_previous)

      do while ( worst_dt > temp_tolerance )

         do j=1,width
            do i=1,height
               temperature(i,j)=0.25*(temperature_previous(i+1,j)+temperature_previous(i-1,j)+ &
                                      temperature_previous(i,j+1)+temperature_previous(i,j-1) )
            enddo
         enddo

         worst_dt=0.0

         do j=1,width
            do i=1,height
               worst_dt = max( abs(temperature(i,j) - temperature_previous(i,j)), worst_dt )
               temperature_previous(i,j) = temperature(i,j)
            enddo
         enddo

         if( mod(iteration,100).eq.0 ) then
            call track_progress(temperature, iteration)
         endif

         iteration = iteration+1

      enddo

      call cpu_time(stop_time)

      print*, 'Max error at iteration ', iteration-1, ' was ',worst_dt
      print*, 'Total time was ',stop_time-start_time, ' seconds.'

end program serial

subroutine initialize( temperature_previous )
      implicit none

      integer, parameter             :: width=1000
      integer, parameter             :: height=1000
      integer                        :: i,j

      double precision, dimension(0:height+1,0:width+1) :: temperature_previous

      temperature_previous = 0.0

      do i=0,height+1
         temperature_previous(i,0) = 0.0
         temperature_previous(i,width+1) = (100.0/height) * i
      enddo

      do j=0,width+1
         temperature_previous(0,j) = 0.0
         temperature_previous(height+1,j) = ((100.0)/width) * j
      enddo

end subroutine initialize

subroutine track_progress(temperature, iteration)
      implicit none

      integer, parameter             :: width=1000
      integer, parameter             :: height=1000
      integer                        :: i,iteration

      double precision, dimension(0:height+1,0:width+1) :: temperature

      print *, '---------- Iteration number: ', iteration, ' ---------------'
      do i=5,0,-1
         write (*,'("("i4,",",i4,"):",f6.2,"  ")',advance='no') &
                   height-i,width-i,temperature(height-i,width-i)
      enddo
      print *
end subroutine track_progress


program test_interp2
!! Need program statement for FORD
use phys_consts, only: wp,pi
use interpolation, only : interp2
use h5fortran, only : hdf5_file

implicit none (type, external)

type(hdf5_file) :: hout
integer, parameter :: lx1=50, lx2=100, lx1i=500, lx2i=1000
!integer, parameter :: lx1=1000, lx2=1000
!integer, parameter :: lx1i=8000, lx2i=8000
real(wp), parameter :: stride=0.5_wp

real(wp), allocatable, dimension(:,:) ::  f, fi
real(wp), allocatable, dimension(:) :: x1ilist, x2ilist, filist, x1, x2, x1i, x2i

integer :: ix1,ix2,ik

allocate(x1(lx1), x2(lx2), f(lx1,lx2),x1i(lx1i), x2i(lx2i), fi(lx1i,lx2i))
allocate(x1ilist(1:lx1i*lx2i), x2ilist(1:lx1i*lx2i), filist(1:lx1i*lx2i))

!grid for original data
x1=[ ((real(ix1,wp)-1._wp)*stride, ix1=1,lx1) ]
x2=[ ((real(ix2,wp)-1._wp)*stride, ix2=1,lx2) ]

!center grid points at zero
x1=x1-sum(x1)/size(x1,1)
x2=x2-sum(x2)/size(x2,1)

!test function
do ix2=1,lx2
  f(:,ix2)=sin(2._wp*pi/5._wp*x1)*cos(2._wp*pi/50._wp*x2(ix2))
end do

!> grid for interpolated data
x1i=[ ((real(ix1,wp)-1)*stride/(lx1i/lx1), ix1=1,lx1i) ]
x2i=[ ((real(ix2,wp)-1)*stride/(lx2i/lx2), ix2=1,lx2i) ]

!> center grid points at zero
x1i=x1i-sum(x1i)/size(x1i,1)
x2i=x2i-sum(x2i)/size(x2i,1)

!> try a 2d interpolation
!fi=interp2_plaid(x1,x2,f,x1i,x2i)
do ix2=1,lx2i
  do ix1=1,lx1i
    ik=(ix2-1)*lx1i+ix1
    x1ilist(ik)=x1i(ix1)
    x2ilist(ik)=x2i(ix2)
  end do
end do
filist=interp2(x1,x2,f,x1ilist,x2ilist)
fi=reshape(filist,[lx1i,lx2i])

!! dump results to a file so we can check things
call hout%initialize("input2d.h5", status="replace", action="write")

call hout%write("/lx1", lx1)
call hout%write("/lx2", lx2)
call hout%write("/x1", x1)
call hout%write("/x2", x2)
call hout%write("/f", f)

call hout%finalize()

call hout%initialize("output2d.h5", status="replace", action="write")

call hout%write("/lx1", lx1i)
call hout%write("/lx2", lx2i)
call hout%write("/x1", x1i)
call hout%write("/x2", x2i)
call hout%write("/f", fi)

call hout%finalize()

end program

!> has no problem with > 2GB output files
! block
!   integer :: u
!   open(newunit=u,file='input2d.dat',status='replace',form='unformatted',access='stream', action='write')
!   write(u) lx1,lx2
!   write(u) x1,x2,f
!   close(u)
! end block

! block
!   integer :: u
!   open(newunit=u,file='output2d.dat',status='replace',form='unformatted',access='stream', action='write')
!   write(u) lx1i,lx2i
!   write(u) x1i,x2i,fi   !since only interpolating in x1
!   close(u)
! end block