! Copyright (C) 2021  Nguyen Ngoc Sang, <https://github.com/SangVn>

!*************************************************!
!         https://www.facebook.com/VnCFD          !
!        https://vncfdgroup.wordpress.com         !
!*************************************************!

!compiler: python3 -m numpy.f2py -c functions.f95 fluxes.f95 -m fortranlib

!*************************************************!
!              CELL-FACE TOPO                     !
! node(i,j+1)+----------------+node(i+1,j+1)      !
!            |  cell*(i,j)    |                   !
! node(i,j)  +----------------+node(i+1,j)        !
!*************************************************!
subroutine cell_topo(node_X, cell_X, all_cell_half_size, cell_volume, n, m)
  implicit none
  integer, intent(in) :: n, m
  real(8), intent(in) :: node_X(n, m, 2)
  real(8), intent(out) :: cell_X(n-1, m-1, 2)
  real(8), intent(out) :: all_cell_half_size(n+1, m+1, 2)
  real(8), intent(out) :: cell_volume(n-1, m-1)
  !integer :: i,j

! cell_X(i,j) = (node(i,j)+node(i+1,j)+node(i,j+1)+node(i+1,j+1))/4
  cell_X(1:n-1,1:m-1,:) = 0.25*(node_X(1:n-1,1:m-1,:)+node_X(1:n-1,2:m,:)+node_X(2:n,1:m-1,:)+node_X(2:n,2:m,:))

! cell_volume(i,j) = abs(0.5*cross_product(node(i,j)-node(i+1,j+1), node(i,j+1)-node(i+1,j)))
  cell_volume(1:n-1,1:m-1) = 0.5*abs((node_X(1:n-1,1:m-1,1)-node_X(2:n,2:m,1))*(node_X(1:n-1,2:m,2)-node_X(2:n,1:m-1,2))&
                                  -(node_X(1:n-1,1:m-1,2)-node_X(2:n,2:m,2))*(node_X(1:n-1,2:m,1)-node_X(2:n,1:m-1,1)))

! cell_half_size(i,j)[1] = 0.25*norm2(node(i,j)-node(i+1,j) + node(i,j+1)-node(i+1,j+1))
  all_cell_half_size(1,:,:) = 0.0
  all_cell_half_size(n+1,:,:) = 0.0
  all_cell_half_size(2:n,2:m,1) = 0.25*norm2(node_X(1:n-1,1:m-1,:)-node_X(2:n,1:m-1,:)+node_X(1:n-1,2:m,:)-node_X(2:n,2:m,:), dim=3)

! cell_half_size(i,j)[2] = 0.25*norm2(node(i,j)-node(i,j+1) + node(i+1,j)-node(i+1,j+1))
  all_cell_half_size(:,1,:) = 0.0
  all_cell_half_size(:,m+1,:) = 0.0
  all_cell_half_size(2:n,2:m,2) = 0.25*norm2(node_X(1:n-1,1:m-1,:)-node_X(1:n-1,2:m,:)+node_X(2:n,1:m-1,:)-node_X(2:n,2:m,:), dim=3)

end subroutine cell_topo

!*************************************************!
!       ______+______jface______+_____            !
!             |                 |                 !
!             |iface  ^n        |--->n            !
!       ______+_______|_________+_____            !
!*************************************************!
subroutine face_topo(node_x, iface_X, iface_normal, iface_area, jface_X, jface_normal, jface_area, n, m)
  implicit none
  integer, intent(in) :: n,m
  real(8), intent(in) :: node_X(n, m, 2)
  real(8), intent(out) :: iface_X(n, m-1, 2), iface_normal(n, m-1, 2), iface_area(n, m-1)
  real(8), intent(out) :: jface_X(n-1, m, 2), jface_normal(n-1, m, 2), jface_area(n-1, m)

  iface_X(1:n,1:m-1,:) = 0.5*(node_X(1:n,1:m-1,:)+node_X(1:n,2:m,:))
  iface_area(1:n,1:m-1) = norm2(node_X(1:n,1:m-1,:)-node_X(1:n,2:m,:), dim=3)
  iface_normal(1:n,1:m-1,1) = (-node_X(1:n,1:m-1,2)+node_X(1:n,2:m,2))/iface_area(1:n,1:m-1)
  iface_normal(1:n,1:m-1,2) = ( node_X(1:n,1:m-1,1)-node_X(1:n,2:m,1))/iface_area(1:n,1:m-1)

  jface_X(1:n-1,1:m,:) = 0.5*(node_X(1:n-1,1:m,:)+node_X(2:n,1:m,:))
  jface_area(1:n-1,1:m) = norm2(node_X(1:n-1,1:m,:)-node_X(2:n,1:m,:), dim=3)
  jface_normal(1:n-1,1:m,1) = ( node_X(1:n-1,1:m,2)-node_X(2:n,1:m,2))/jface_area(1:n-1,1:m)
  jface_normal(1:n-1,1:m,2) = (-node_X(1:n-1,1:m,1)+node_X(2:n,1:m,1))/jface_area(1:n-1,1:m)

end subroutine face_topo

!*************************************************!
!               JACOBIAN MATRIX                   !
!*************************************************!
subroutine jacobian_inverse(jacob, jacob_inv)
  implicit none
  real(8), intent(in) :: jacob(2,2)
  real(8), intent(out) :: jacob_inv(2,2)
  real(8) :: det
  det = jacob(1,1)*jacob(2,2)-jacob(1,2)*jacob(2,1)
  jacob_inv(1,:) = (/jacob(2,2), -jacob(1,2)/)/det
  jacob_inv(2,:) = (/-jacob(2,1), jacob(1,1)/)/det
end subroutine jacobian_inverse

subroutine interpolation(fl, dl, fr, dr, f)
  implicit none
  real(8), intent(in) :: fl, dl, fr, dr
  real(8), intent(out) :: f
  f = (fl*dr+fr*dl)/(dl+dr)
end subroutine interpolation

subroutine extrapolation(f1, d1, f2, d2, f)
  implicit none
  real(8), intent(in) :: f1, d1, f2, d2
  real(8), intent(out) :: f
  f = f1 +(f1-f2)*d1/d2
end subroutine extrapolation

subroutine cell_jacobian(node_X, cell_J, cell_J_inv, n, m)
  implicit none
  integer, intent(in) :: n, m
  real(8), intent(in) :: node_X(n,m,2)
  real(8), intent(out) :: cell_J(n-1,m-1,2,2), cell_J_inv(n-1,m-1,2,2)
  real(8) :: jacob(2,2), dksi(2), deta(2)
  integer :: i,j

  !cell jacobian
  do i=1,n-1
    do j=1,m-1
      dksi = node_X(i+1,j,:) - node_X(i,j,:) + node_X(i+1,j+1,:) - node_X(i,j+1,:)
      deta = node_X(i,j+1,:) - node_X(i,j,:) + node_X(i+1,j+1,:) - node_X(i+1,j,:)
      jacob(:,1) = dksi/norm2(dksi)
      jacob(:,2) = deta/norm2(deta)
      cell_J_inv(i,j,:,:) = jacob
      call jacobian_inverse(jacob, cell_J(i,j,:,:))
    end do
  end do
end subroutine cell_jacobian

subroutine face_jacobian(node_X, cell_X, iface_J, jface_J, n, m)
  implicit none
  integer, intent(in) :: n, m
  real(8), intent(in) :: node_X(n,m,2), cell_X(n-1,m-1,2)
  real(8), intent(out) :: iface_J(n,m-1,2,2), jface_J(n-1,m,2,2)
  real(8) :: jacob(2,2), dksi(2), deta(2), side_X(2), dXl(2), dXr(2), dl, dr
  integer :: i,j

  !inner iface jacobian
  do i=2,n-1
    do j=1,m-1
      deta = node_X(i,j+1,:) - node_X(i,j,:)
      side_X = 0.5*(node_X(i,j+1,:) + node_X(i,j,:))
      dXl = side_X - cell_X(i-1,j,:)
      dXr = cell_X(i,j,:) - side_X
      dl = norm2(dXl)
      dr = norm2(dXr)
      dXl = dXl/dl !unit vector
      dXr = dXr/dr !unit vector
      ! interpolation: f = (fl*dr+fr*dl)/(dl+dr)
      dksi = (dXl*dr + dXr*dl)/(dl+dr)
      jacob(1,:) = dksi
      jacob(2,:) = deta/norm2(deta)
      call jacobian_inverse(jacob, iface_J(i,j,:,:))
    end do
  end do
  !boundary iface jacobian
  !i=1
  do j=1,m-1
    dksi = cell_X(1,j,:)-0.5*(node_X(1,j+1,:) + node_X(1,j,:))
    deta = node_X(1,j+1,:) - node_X(1,j,:)
    jacob(1,:) = dksi/norm2(dksi)
    jacob(2,:) = deta/norm2(deta)
    call jacobian_inverse(jacob, iface_J(1,j,:,:))
  end do
  !i=n
  do j=1,m-1
    dksi = 0.5*(node_X(n,j+1,:) + node_X(n,j,:)) - cell_X(n-1,j,:)
    deta = node_X(n,j+1,:) - node_X(n,j,:)
    jacob(1,:) = dksi/norm2(dksi)
    jacob(2,:) = deta/norm2(deta)
    call jacobian_inverse(jacob, iface_J(n,j,:,:))
  end do

  !inner jface jacobian
  do i=1,n-1
    do j=2,m-1
      dksi = node_X(i+1,j,:) - node_X(i,j,:)
      side_X = 0.5*(node_X(i+1,j,:) + node_X(i,j,:))
      dXl = side_X - cell_X(i,j-1,:)
      dXr = cell_X(i,j,:) - side_X
      dl = norm2(dXl)
      dr = norm2(dXr)
      dXl = dXl/dl !unit vector
      dXr = dXr/dr !unit vector
      ! interpolation: f = (fl*dr+fr*dl)/(dl+dr)
      deta = (dXl*dr + dXr*dl)/(dl+dr)
      jacob(1,:) = dksi/norm2(dksi)
      jacob(2,:) = deta
      call jacobian_inverse(jacob, jface_J(i,j,:,:))
    end do
  end do

  !boundary jface jacobian
  !j=1
  do i=1,n-1
    deta = cell_X(i,1,:)-0.5*(node_X(i+1,1,:) + node_X(i,1,:))
    dksi = node_X(i+1,1,:) - node_X(i,1,:)
    jacob(1,:) = dksi/norm2(dksi)
    jacob(2,:) = deta/norm2(deta)
    call jacobian_inverse(jacob, jface_J(i,1,:,:))
  end do
  !j=m
  do i=1,n-1
    deta = 0.5*(node_X(i+1,m,:) + node_X(i,m,:)) - cell_X(i,m-1,:)
    dksi = node_X(i+1,m,:) - node_X(i,m,:)
    jacob(1,:) = dksi/norm2(dksi)
    jacob(2,:) = deta/norm2(deta)
    call jacobian_inverse(jacob, jface_J(i,m,:,:))
  end do
end subroutine face_jacobian

!*************************************************!
!              CONVERT VARIABLES                  !
! P=(rho, u, v, p), U=(rho, rho*u, rho*v, rho*e)  !
!*************************************************!
subroutine P2U(cell_P, cell_U, n, m)
  implicit none
  integer, intent(in) :: n, m
  real(8), intent(in) :: cell_P(n, m, 4)
  real(8), intent(inout) :: cell_U(n, m, 4)

  cell_U(:,:,1) = cell_P(:,:,1)
  cell_U(:,:,2) = cell_P(:,:,1)*cell_P(:,:,2)
  cell_U(:,:,3) = cell_P(:,:,1)*cell_P(:,:,3)
  cell_U(:,:,4) = cell_P(:,:,4)*2.5 + 0.5*(cell_P(:,:,2)**2+cell_P(:,:,3)**2)
  !1/(gamm-1.0) = 2.5

end subroutine P2U

subroutine U2P(cell_U, all_cell_P, n, m)
  implicit none
  integer, intent(in) :: n, m
  real(8), intent(in) :: cell_U(n, m, 4)
  real(8), intent(inout) :: all_cell_P(n+2, m+2, 4)

  all_cell_P(2:n+1,2:m+1,1) = cell_U(:,:,1)
  all_cell_P(2:n+1,2:m+1,2) = cell_U(:,:,2)/cell_U(:,:,1)
  all_cell_P(2:n+1,2:m+1,3) = cell_U(:,:,3)/cell_U(:,:,1)
  all_cell_P(2:n+1,2:m+1,4) = (cell_U(:,:,4) - 0.5*(cell_U(:,:,2)**2+cell_U(:,:,3)**2)/cell_U(:,:,1))*0.4
  !(gamm-1.0) = 0.4

end subroutine U2P

subroutine  P2F(P, normal, area, F)
  implicit none
  real(8), intent(in) :: P(4), normal(2), area
  real(8), intent(out) :: F(4)
  real(8) :: Vn
  Vn = dot_product(normal, P(2:3))
  F(1) = P(1)*Vn
  F(2) = F(1)*P(2)+P(4)*normal(1)
  F(3) = F(1)*P(3)+P(4)*normal(2)
  F(4) = F(1)*(P(4)/P(1)*3.5 + 0.5*(P(2)*P(2)+P(3)*P(3))) !rho*vn*(p/rho*(gamma/gamma-1) + 0.5*V*V)
  F = F*area
end subroutine P2F

!***************************************!
!         BOUNDARY CONDITIONS           !
!***************************************!
subroutine bc_symmetry(face_normal, icell_P, side_P, n)
  implicit none
  integer, intent(in) :: n
  real(8), intent(in) :: face_normal(n,2), icell_P(n,4)
  real(8), intent(out) :: side_P(n,4)
  real(8) :: V_in(2), Vn, V_bd(2)
  integer :: i

  do i=1,n
    V_in = icell_P(i,2:3)
    Vn = dot_product(face_normal(i,:), V_in)
    V_bd = V_in - Vn*face_normal(i,:)
    side_P(i,:) = (/ icell_P(i,1), V_bd(1), V_bd(2), icell_P(i,4) /)
  end do
end subroutine bc_symmetry

subroutine bc_inflow(face_normal, icell_P, P_freestream, side_P, n)
  implicit none
  integer, intent(in) :: n
  real(8), intent(in) :: face_normal(n,2), icell_P(n,4), P_freestream(4)
  real(8), intent(out) :: side_P(n,4)
  real(8), parameter :: k = 1.4, km1 = 0.4, km1_inv = 2.5
  real(8) :: a_out, Vn_out, a_in, Vn_in, R_plus, R_minus, a_bound, Vn_bound
  real(8) :: R_bound, rho_bound, V_bound(2), p_bound
  integer :: i

  do i=1,n
    a_out = sqrt(k*P_freestream(4)/P_freestream(1))
    Vn_out = dot_product(face_normal(i,:), P_freestream(2:3))
    if (abs(Vn_out) > a_out) then
      side_P(i,:) = P_freestream(:)
    else
      a_in = sqrt(k*icell_P(i,4)/icell_P(i,1))
      Vn_in = dot_product(face_normal(i,:), icell_P(i,2:3))
      R_plus = Vn_out + 2.0*a_out*km1_inv
      R_minus = Vn_in - 2.0*a_in*km1_inv
      a_bound = 0.25*km1*(R_plus-R_minus)
      Vn_bound = 0.5*(R_plus+R_minus)
      R_bound = P_freestream(4)/(P_freestream(1)**k)
      rho_bound = (a_bound**2/(k*R_bound))**km1_inv
      V_bound = P_freestream(2:3) + (Vn_bound-Vn_out)*face_normal(i,:)
      p_bound = R_bound*(rho_bound**k)

      side_P(i,:) = (/ rho_bound, V_bound(1), V_bound(2), p_bound /)
    end if
  end do

end subroutine bc_inflow

subroutine bc_outflow(face_normal, icell_P, pressure_exit, opt, side_P, n)
  implicit none
  integer, intent(in) :: opt, n
  real(8), intent(in) :: face_normal(n,2), icell_P(n,4), pressure_exit
  real(8), intent(out) :: side_P(n,4)
  real(8), parameter :: k = 1.4, km1 = 0.4, km1_inv = 2.5
  real(8) :: a_in, Vn_in, R_plus, a_bound, Vn_bound, rho_bound, V_bound(2), p_bound = 0.0
  integer :: i

  if (opt==1) then
    p_bound = pressure_exit
  end if

  do i=1,n
    a_in = sqrt(k*icell_P(i,4)/icell_P(i,1))
    Vn_in = dot_product(face_normal(i,:), icell_P(i,2:3))
    if (abs(Vn_in) > a_in) then
      side_P(i,:) = icell_P(i,:)
    else
      if (opt==2) then
        p_bound = 0.5*(pressure_exit+icell_P(i,4))
      end if
      rho_bound = icell_P(i,1)*(p_bound/icell_P(i,4))**(1.0/k)
      a_bound = sqrt(k*p_bound/rho_bound)
      R_plus = Vn_in + 2*a_in*km1_inv
      Vn_bound = R_plus - 2*a_bound*km1_inv
      V_bound = icell_P(i,2:3) + (Vn_bound-Vn_in)*face_normal(i,:)

      side_P(i,:) = (/ rho_bound, V_bound(1), V_bound(2), p_bound /)
    end if
  end do

end subroutine bc_outflow

subroutine bound_flux_p2f(face_normal, face_area, side_P, cell_res, n)
  implicit none
  integer, intent(in) :: n
  real(8), intent(in) :: face_normal(n, 2), face_area(n), side_P(n,4)
  real(8), intent(out) :: cell_res(n, 4)
  integer :: i

  do i=1,n
    call P2F(side_P(i,:), face_normal(i,:), face_area(i), cell_res(i,:))
  end do
end subroutine bound_flux_p2f

!***************************************!
!          GLOBAL TIME STEP             !
!***************************************!
subroutine eu_time_step(cell_P, cell_half_size, dt_min, n, m)
  implicit none
  integer, intent(in) :: n, m
  real(8), intent(in) ::  cell_P(n, m, 4), cell_half_size(n, m, 2)
  real(8), intent(out) :: dt_min
  real(8) :: dt, v, a
  integer :: i, j

  dt_min = 1000.0
  do i=1,n
    do j=1,m
      v = norm2(cell_P(i,j,2:3)) !air speed
      a = sqrt(1.4*cell_P(i,j,4)/cell_P(i,j,1))
      dt = min(cell_half_size(i,j,1), cell_half_size(i,j,2))/(v+a)
      dt_min = min(dt_min, dt)
    end do
  end do
  dt_min = dt_min*2

end subroutine eu_time_step

subroutine ns_time_step(cell_P, cell_half_size, dt_min, n, m)
  implicit none
  integer, intent(in) :: n, m
  real(8), intent(in) ::  cell_P(n, m, 4), cell_half_size(n, m, 2)
  real(8), intent(out) :: dt_min
  real(8), parameter :: Pr = 0.72, Rgas=287.052873836, c_mu=1.506196284597745e-06
  real(8) :: dt, v, a, dd, T, mu, tau_conv(2), tau_diff(2), tau_inv(2)
  integer :: i, j

  dt_min = 1000.0
  do i=1,n
    do j=1,m
      v = norm2(cell_P(i,j,2:3)) !air speed
      a = sqrt(1.4*cell_P(i,j,4)/cell_P(i,j,1))
      tau_conv = 2*cell_half_size(i,j,:)/(a+v)

      T = cell_P(i,j,4)/(Rgas*cell_P(i,j,1))
      mu = c_mu*(T**1.5)/(T+122.0)
      dd = mu/(Pr*cell_P(i,j,1))

      tau_diff = (2*cell_half_size(i,j,:))**2/dd
      tau_inv = (1.0 + sqrt(1.0+tau_diff/tau_conv))**2/tau_diff
      dt = 1.0/sum(tau_inv)

      dt_min = min(dt_min, dt)
    end do
  end do

end subroutine ns_time_step

!***************************************!
!     CALCULATION - MISCLOSURE          !
!***************************************!
subroutine misclosure_rho(cell_rho_prev, cell_rho, sum_dr, n, m)
  implicit none
  integer, intent(in) :: n, m
  real(8), intent(in) :: cell_rho_prev(n, m), cell_rho(n, m)
  real(8), intent(out) :: sum_dr
  real(8) :: dr
  integer :: i, j

  sum_dr = 1.0e-16
  do i=1,n
    do j=1,m
      if (cell_rho(i,j) == cell_rho_prev(i,j)) then
        dr = 0.0
      else
        dr = abs(cell_rho(i,j)-cell_rho_prev(i,j))/min(cell_rho(i,j),cell_rho_prev(i,j))
      end if

      sum_dr = sum_dr + dr
    end do
  end do

end subroutine misclosure_rho


*> \brief zabs tests the robustness and precision of the intrinsic ABS for double complex
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \author Weslley S. Pereira, University of Colorado Denver, U.S.
*
*> \verbatim
*>
*> Real values for test:
*> (1) x = 2**m, where m = MINEXPONENT-DIGITS, ..., MINEXPONENT-1. Stop on the first success.
*>     Mind that not all platforms might implement subnormal numbers.
*> (2) x = 2**m, where m = MINEXPONENT, ..., 0. Stop on the first success.
*> (3) x = OV, where OV is the overflow threshold. OV^2 overflows but the norm is OV.
*> (4) x = 2**m, where m = MAXEXPONENT-1, ..., 1. Stop on the first success.
*>
*> Tests:
*> (a) y = x + 0 * I, |y| = x
*> (b) y = 0 + x * I, |y| = x
*> (c) y = (3/4)*x + x * I, |y| = (5/4)*x whenever (3/4)*x and (5/4)*x can be exactly stored
*> (d) y = (1/2)*x + (1/2)*x * I, |y| = (1/2)*x*sqrt(2) whenever (1/2)*x can be exactly stored
*>
*> Special cases:
*>
*> (i) Inf propagation
*>    (1) y = Inf + 0 * I, |y| is Inf.
*>    (2) y =-Inf + 0 * I, |y| is Inf.
*>    (3) y = 0 + Inf * I, |y| is Inf.
*>    (4) y = 0 - Inf * I, |y| is Inf.
*>    (5) y = Inf + Inf * I, |y| is Inf.
*>
*> (n) NaN propagation
*>    (1) y = NaN + 0 * I, |y| is NaN.
*>    (2) y = 0 + NaN * I, |y| is NaN.
*>    (3) y = NaN + NaN * I, |y| is NaN.
*>
*> \endverbatim
*
*> \ingroup auxOTHERauxiliary
*
*  =====================================================================
      program zabs
*
*  -- LAPACK test routine --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..

*     ..
*     .. Local parameters ..
      logical           debug
      parameter       ( debug = .false. )
      integer           N, nNaN, nInf
      parameter       ( N = 4, nNaN = 3, nInf = 5 )
      double precision  threeFourth, fiveFourth, oneHalf
      parameter       ( threeFourth = 3.0d0 / 4,
     $                  fiveFourth = 5.0d0 / 4,
     $                  oneHalf = 1.0d0 / 2 )
*     ..
*     .. Local Variables ..
      integer           i, min, Max, m, subnormalTreatedAs0,
     $                  caseAFails, caseBFails, caseCFails, caseDFails
      double precision  X( N ), R, answerC,
     $                  answerD, aInf, aNaN, relDiff, b,
     $                  eps, blueMin, blueMax, Xj, stepX(N), limX(N)
      double complex    Y, cInf( nInf ), cNaN( nNaN )
*
*     .. Intrinsic Functions ..
      intrinsic         ABS, DBLE, RADIX, CEILING, TINY, DIGITS, SQRT,
     $                  MAXEXPONENT, MINEXPONENT, FLOOR, HUGE, DCMPLX,
     $                  EPSILON

*
*     .. Initialize error counts ..
      subnormalTreatedAs0 = 0
      caseAFails = 0
      caseBFails = 0
      caseCFails = 0
      caseDFails = 0
*
*     .. Initialize machine constants ..
      min = MINEXPONENT(0.0d0)
      Max = MAXEXPONENT(0.0d0)
      m = DIGITS(0.0d0)
      b = DBLE(RADIX(0.0d0))
      eps = EPSILON(0.0d0)
      blueMin = b**CEILING( (min - 1) * 0.5d0 )
      blueMax = b**FLOOR( (Max - m + 1) * 0.5d0 )
*
*     .. Vector X ..
      X(1) = TINY(0.0d0) * b**( DBLE(1-m) )
      X(2) = TINY(0.0d0)
      X(3) = HUGE(0.0d0)
      X(4) = b**( DBLE(Max-1) )
*
*     .. Then modify X using the step ..
      stepX(1) = 2.0
      stepX(2) = 2.0
      stepX(3) = 0.0
      stepX(4) = 0.5
*
*     .. Up to the value ..
      limX(1) = X(2)
      limX(2) = 1.0
      limX(3) = 0.0
      limX(4) = 2.0
*
*     .. Inf entries ..
      aInf = X(3) * 2
      cInf(1) = DCMPLX( aInf, 0.0d0 )
      cInf(2) = DCMPLX(-aInf, 0.0d0 )
      cInf(3) = DCMPLX( 0.0d0, aInf )
      cInf(4) = DCMPLX( 0.0d0,-aInf )
      cInf(5) = DCMPLX( aInf,  aInf )
*
*     .. NaN entries ..
      aNaN = aInf / aInf
      cNaN(1) = DCMPLX( aNaN, 0.0d0 )
      cNaN(2) = DCMPLX( 0.0d0, aNaN )
      cNaN(3) = DCMPLX( aNaN,  aNaN )

*
*     .. Tests ..
*
      if( debug ) then
        print *, '# X :=', X
        print *, '# Blue min constant :=', blueMin
        print *, '# Blue max constant :=', blueMax
      endif
*
      Xj = X(1)
      if( Xj .eq. 0.0d0 ) then
        subnormalTreatedAs0 = subnormalTreatedAs0 + 1
        if( debug .or. subnormalTreatedAs0 .eq. 1 ) then
            print *, "!! fl( subnormal ) may be 0"
        endif
      else
        do 100 i = 1, N
            Xj = X(i)
            if( Xj .eq. 0.0d0 ) then
                subnormalTreatedAs0 = subnormalTreatedAs0 + 1
                if( debug .or. subnormalTreatedAs0 .eq. 1 ) then
                    print *, "!! fl( subnormal ) may be 0"
                endif
            endif
 100    continue
      endif
*
*     Test (a) y = x + 0 * I, |y| = x
      do 10 i = 1, N
        Xj = X(i)
        if( Xj .eq. 0.0d0 ) then
            subnormalTreatedAs0 = subnormalTreatedAs0 + 1
            if( debug .or. subnormalTreatedAs0 .eq. 1 ) then
                print *, "!! [a] fl( subnormal ) may be 0"
            endif
        else
            do while( Xj .ne. limX(i) )
                Y = DCMPLX( Xj, 0.0d0 )
                R = ABS( Y )
                if( R .ne. Xj ) then
                    caseAFails = caseAFails + 1
                    if( caseAFails .eq. 1 ) then
                        print *, "!! Some ABS(x+0*I) differ from ABS(x)"
                    endif
                    WRITE( 0, FMT = 9999 ) 'a',i, Xj, '(1+0*I)', R, Xj
                endif
                Xj = Xj * stepX(i)
            end do
        endif
  10  continue
*
*     Test (b) y = 0 + x * I, |y| = x
      do 20 i = 1, N
        Xj = X(i)
        if( Xj .eq. 0.0d0 ) then
            subnormalTreatedAs0 = subnormalTreatedAs0 + 1
            if( debug .or. subnormalTreatedAs0 .eq. 1 ) then
                print *, "!! [b] fl( subnormal ) may be 0"
            endif
        else
            do while( Xj .ne. limX(i) )
                Y = DCMPLX( 0.0d0, Xj )
                R = ABS( Y )
                if( R .ne. Xj ) then
                    caseBFails = caseBFails + 1
                    if( caseBFails .eq. 1 ) then
                        print *, "!! Some ABS(0+x*I) differ from ABS(x)"
                    endif
                    WRITE( 0, FMT = 9999 ) 'b',i, Xj, '(0+1*I)', R, Xj
                endif
                Xj = Xj * stepX(i)
            end do
        endif
  20  continue
*
*     Test (c) y = (3/4)*x + x * I, |y| = (5/4)*x
      do 30 i = 1, N
        if( i .eq. 3 ) go to 30
        if( i .eq. 1 ) then
            Xj = 4*X(i)
        else
            Xj = X(i)
        endif
        if( Xj .eq. 0.0d0 ) then
            subnormalTreatedAs0 = subnormalTreatedAs0 + 1
            if( debug .or. subnormalTreatedAs0 .eq. 1 ) then
                print *, "!! [c] fl( subnormal ) may be 0"
            endif
        else
            do while( Xj .ne. limX(i) )
                answerC = fiveFourth * Xj
                Y = DCMPLX( threeFourth * Xj, Xj )
                R = ABS( Y )
                if( R .ne. answerC ) then
                    caseCFails = caseCFails + 1
                    if( caseCFails .eq. 1 ) then
                        print *,
     $              "!! Some ABS(x*(3/4+I)) differ from (5/4)*ABS(x)"
                    endif
                    WRITE( 0, FMT = 9999 ) 'c',i, Xj, '(3/4+I)', R,
     $                                      answerC
                endif
                Xj = Xj * stepX(i)
            end do
        endif
  30  continue
*
*     Test (d) y = (1/2)*x + (1/2)*x * I, |y| = (1/2)*x*sqrt(2)
      do 40 i = 1, N
        if( i .eq. 1 ) then
            Xj = 2*X(i)
        else
            Xj = X(i)
        endif
        if( Xj .eq. 0.0d0 ) then
            subnormalTreatedAs0 = subnormalTreatedAs0 + 1
            if( debug .or. subnormalTreatedAs0 .eq. 1 ) then
                print *, "!! [d] fl( subnormal ) may be 0"
            endif
        else
            do while( Xj .ne. limX(i) )
                answerD = (oneHalf * Xj) * SQRT(2.0d0)
                if( answerD .eq. 0.0d0 ) then
                    subnormalTreatedAs0 = subnormalTreatedAs0 + 1
                    if( debug .or. subnormalTreatedAs0 .eq. 1 ) then
                        print *, "!! [d] fl( subnormal ) may be 0"
                    endif
                else
                    Y = DCMPLX( oneHalf * Xj, oneHalf * Xj )
                    R = ABS( Y )
                    relDiff = ABS(R-answerD)/answerD
                    if( relDiff .ge. (0.5*eps) ) then
                        caseDFails = caseDFails + 1
                        if( caseDFails .eq. 1 ) then
                            print *,
     $                "!! Some ABS(x*(1+I)) differ from sqrt(2)*ABS(x)"
                        endif
                        WRITE( 0, FMT = 9999 ) 'd',i, (oneHalf*Xj),
     $                                  '(1+1*I)', R, answerD
                    endif
                endif
                Xj = Xj * stepX(i)
            end do
        endif
  40  continue
*
*     Test (e) Infs
      do 50 i = 1, nInf
        Y = cInf(i)
        R = ABS( Y )
        if( .not.(R .gt. HUGE(0.0d0)) ) then
            WRITE( *, FMT = 9997 ) 'i',i, Y, R
        endif
  50  continue
*
*     Test (f) NaNs
      do 60 i = 1, nNaN
        Y = cNaN(i)
        R = ABS( Y )
        if( R .eq. R ) then
            WRITE( *, FMT = 9998 ) 'n',i, Y, R
        endif
  60  continue
*
*     If anything was written to stderr, print the message
      if( (caseAFails .gt. 0) .or. (caseBFails .gt. 0) .or.
     $    (caseCFails .gt. 0) .or. (caseDFails .gt. 0) )
     $      print *, "# Please check the failed ABS(a+b*I) in [stderr]"
*
*     .. Formats ..
 9997 FORMAT( '[',A1,I1, '] ABS(', (ES8.1,SP,ES8.1,"*I"), ' ) = ',
     $        ES8.1, ' differs from Inf' )
*
 9998 FORMAT( '[',A1,I1, '] ABS(', (ES8.1,SP,ES8.1,"*I"), ' ) = ',
     $        ES8.1, ' differs from NaN' )
*
 9999 FORMAT( '[',A1,I1, '] ABS(', ES24.16E3, ' * ', A7, ' ) = ',
     $         ES24.16E3, ' differs from ', ES24.16E3 )
*
*     End of zabs
*
      END


PROGRAM test
IMPLICIT NONE

INTEGER, PARAMETER :: STUDENT_COUNT = 7
INTEGER, PARAMETER :: MAX_VACANCY = 3

INTEGER, DIMENSION(STUDENT_COUNT, MAX_VACANCY) :: VACANCY
INTEGER, DIMENSION(STUDENT_COUNT) :: schedule = 0
INTEGER :: solutionCount = 0

VACANCY = transpose(reshape( &
                 (/2,4,0, &
                   1,6,0, &
                   3,7,0, &
                   5,0,0, &
                   1,4,6, &
                   2,5,0, &
                   3,6,7/), &
                 (/MAX_VACANCY, STUDENT_COUNT/)))

!write(*,*) VACANCY(2,3)

CALL assignStudent(1)
WRITE(*,*) "Solutions: ", solutionCount

CONTAINS

RECURSIVE SUBROUTINE assignStudent(studentIndex)
    INTEGER, INTENT(IN) :: studentIndex
    INTEGER :: i, j, vc

    TEST_VACANCY: DO i = 1,MAX_VACANCY
        vc = VACANCY(studentIndex, i)
        IF (vc == 0) EXIT TEST_VACANCY
        ! sanity check
        DO j = 1,studentIndex - 1
            ! DOW is occupied
            IF (schedule(j) == vc) CYCLE TEST_VACANCY
        END DO
        ! so far, so good
        schedule(studentIndex) = vc
        IF (studentIndex >= STUDENT_COUNT) THEN
            ! the solution is complete
            DO j = 1, STUDENT_COUNT
                write(*,"(I4)",advance="no") schedule(j)
            END DO
            write(*,*)
            solutionCount = solutionCount + 1
            CYCLE TEST_VACANCY
        END IF
        ! the solution is not complete
        ! go to next level
        CALL assignStudent(studentIndex + 1)
    END DO TEST_VACANCY
END SUBROUTINE assignStudent

END PROGRAM test


program arraytest
  implicit none

  ! index variable needs to be declared
  integer :: i, j, k
  integer :: len = 9
  ! Here we explicitly say the array is indexed from 0-9
  real, dimension(0:9) :: arr
  real :: sum = 0

  ! Here by default the array is indexed from 1 to 10
  real, dimension(10) :: arr2

  ! We really do need to pre-declare all our data.
  real, dimension(10, 10) :: d, e, f

  do i = 0, len
     arr(i) = i
     arr2(i+1) = i+1
  end do
  print*, "Array filled with", arr

  do i = 0, len
     sum = sum + arr(i)
  end do
  print*, "Sum of array:", sum

  sum = 0
  do i = 0, 10
     sum = sum + arr2(i)
  end do
  print*, "Array 2 sum:", sum

  ! Loops can be nested of course
  do i = 1, 10
     do j = 1, 10
        d(i, j) = 0
        do k = 1, 10
           d(i, j) = d(i, j) + e(i, k) + f(k, i)

           ! Break
           if (d(i,j) < 0) then
              print*, "Breaking"
              exit
           end if
        end do
     end do
  end do

  print*, d

end program arraytest


program rk_2
  use tools

  implicit none
  real(dp) :: x0, y0, h, x_point

  x0 = 1.5; y0 = 0.0; h = 0.05
  x_point = 2.0 !the value of x at which y is to be calculated

  write (*, form_header3) 'itn', 'x', 'y'
  write (*, line3) '-------', '-------', '-------'

  call rungkut_2(x0, y0, x_point, h)

  print *, ''
  print *, 'result:'
  write (*, form_result2r) x0, '-- given value of x'
  write (*, form_result2r) y0, '-- the required value of y'
end program rk_2


!Module for parameters. For this particular program only two parameters are required, but a separate module is created for
!clarity and possible future additions.

module param_mod
      integer,parameter::rk=selected_real_kind(24,1000)
      real(rk),parameter::G=6.674E-11
end module param_mod


      SUBROUTINE STRI31
C
C     ROUTINE TO RECOVER CTRIA3 ELEMENT FORCES, STRAINS, AND STRESSES.
C     PHASE 1.
C
C     WAS NAMED T3ST1D/S IN UAI CODE
C
C                 EST  LISTING
C
C        WORD     TYP       DESCRIPTION
C     ----------------------------------------------------------------
C     ECT:
C         1        I   ELEMENT ID, EID
C         2-4      I   SIL LIST, GRIDS 1,2,3
C         5-7      R   MEMBRANE THICKNESSES T, AT GRIDS 1,2,3
C         8        R   MATERIAL PROPERTY ORIENTAION ANGLE, THETA
C               OR I   COORD. SYSTEM ID (SEE TM ON CTRIA3 CARD)
C         9        I   TYPE FLAG FOR WORD 8
C        10        R   GRID OFFSET, ZOFF
C    EPT:
C        11        I   MATERIAL ID FOR MEMBRANE, MID1
C        12        R   ELEMENT THICKNESS,T (MEMBRANE, UNIFORMED)
C        13        I   MATERIAL ID FOR BENDING, MID2
C        14        R   MOMENT OF INERTIA FACTOR, I (BENDING)
C        15        I   MATERIAL ID FOR TRANSVERSE SHEAR, MID3
C        16        R   TRANSV. SHEAR CORRECTION FACTOR, TS/T
C        17        R   NON-STRUCTURAL MASS, NSM
C        18-19     R   STRESS FIBER DISTANCES, Z1,Z2
C        20        I   MATERIAL ID FOR MEMBRANE-BENDING COUPLING, MID4
C        21        R   MATERIAL ANGLE OF ROTATION, THETA
C               OR I   COORD. SYSTEM ID (SEE MCSID ON PSHELL CARD)
C                      (DEFAULT FOR WORD 8)
C        22        I   TYPE FLAG FOR WORD 21 (DEFAULT FOR WORD 9)
C        23        I   INTEGRATION ORDER FLAG
C        24        R   STRESS ANGLE OF RATATION, THETA
C               OR I   COORD. SYSTEM ID (SEE SCSID ON PSHELL CARD)
C        25        I   TYPE FLAG FOR WORD 24
C        26        R   OFFSET, ZOFF1 (DEFAULT FOR WORD 10)
C    BGPDT:
C        27-38   I/R   CID,X,Y,Z  FOR GRIDS 1,2,3
C    ETT:
C        39        I   ELEMENT TEMPERATURE
C
C
C     ****************        RESIDES IN COMMON BLOCK SDR2X5 (AFTER EST)
C     PH1OUT DATA BLOCK       TOTAL NO. OF WORDS = 713
C     ****************
C
C     PH1OUT( 1)    = ELID, ELEMENT ID
C     PH1OUT( 2- 4) = SIL NUMBERS
C     PH1OUT( 5- 7) = ARRAY IORDER
C     PH1OUT( 8)    = TSUB0, REFERENCE TEMP.
C     PH1OUT( 9-10) = Z1 & Z2, FIBER DISTANCES
C     PH1OUT(11)    = ID OF THE ORIGINAL PCOMPI PROPERTY ENTRY
C     PH1OUT(12)    = DUMMY WORD (FOR ALLIGNMENT)
C
C     PH1RST( 1)    = AVGTHK, AVERAGE THICKNESS
C     PH1RST( 2)    = MOMINR, MOMENT OF INER. FACTOR
C     PH1RST( 3-38) = 6X6 MATERIAL PROPERTY MATRIX (NO SHEAR)
C     PH1RST(39-41) = THERMAL EXPANSION COEFFICIENTS FOR MEMBRANE
C     PH1RST(42-44) = THERMAL EXPANSION COEFFICIENTS FOR BENDING
C     PH1RST(45-47) = CORNER NODE THICKNESSES
C     PH1RST(48)    = OFFSET OF ELEMENT FROM GP PLANE
C     PH1RST(49-57) = 3X3 USER-TO-MATERIAL COORD. TRNASF. MATRIX UEM
C     PH1RST(58-66) = 3X3 ELEM-TO-STRESS/STRAIN TRANSF. TENSOR TES
C     PH1RST(67-93) = THREE 3X3 GLOBAL-TO-ELEM COORD. TRANSFORMATION
C                     NODAL MATRICES TEG, ONE FOR EACH NODE
C
C     THE FOLLOWING IS REPEATED FOR EACH EVALUATION POINT (4 TIMES, AT
C     THE CENTER OF THE ELEMENT AND AT 3 STANDARD TRIANGULAR POINTS).
C     THE CHOICE OF THE FINAL STRESS/FORCE OUTPUT POINTS IS MADE AT THE
C     SUBCASE LEVEL (PHASE 2).
C
C              1             ELEMENT THICKNESS AT THIS POINT
C            2 - 5           OUT-OF-PLANE-SHEAR-FORCE/STRAIN MATRIX
C            6 - 8           ELEMENT SHAPE FUNCTION VALUES
C          8+1 - 8+8*NDOF    STRAIN RECOVERY MATRIX
C
C
C     *****************      RESIDES IN COMMON BLOCK SDR2X6
C     IELOUT DATA BLOCK      CONTAINS DATA FOR GPSRN
C     *****************      (TOTAL NO OF WORDS =  77)
C
C              1             ELEMENT ID
C              2             AVERAGE THICKNESS
C
C     THE FOLLOWING IS REPEATED FOR EACH NODE.
C
C         WORD  1            SIL NUMBER
C         WORD  2-10         [TSB] FOR Z1
C         WORD 11-19         [TSB] FOR Z2
C         WORD 20-22         NORMAL VECTOR IN BASIC COORD. SYSTEM
C         WORD 23-25         GRID COORDS   IN BASIC COORD. SYSTEM
C
C
      LOGICAL         MEMBRN,BENDNG,SHRFLX,MBCOUP,NORPTH,
     1                SHEART,NOALFA,USERST
      INTEGER         NPHI(100),NEST(39),SIL(3),SILO,IGPDT(4,3),ELID,
     1                NECPT(4),MID(4),PIDO,SCSID,FLAGS,HUNMEG,ITHERM,
     2                NAME(2),INDEX(2,3),SYSBUF,NOUT,NOGO,PREC
      REAL            RELOUT(300),GPTH(3),BGPDT(4,3),ECPT(4),
     1                KHEAT,HTCP,TSUB0,GSUBE,ELTEMP,Z1O,Z2O
      REAL            PH1RST,DGPTH(3),TH,AVGTHK,GPNORM(4,3),
     1                EPNORM(4,3),EGPDT(4,3),CENTE(3),OFFSET,ALPHA(6),
     2                GI(36),RHO,JOG,JOK,K11,K22,ZZ(4),AIC(18),
     3                EGNOR(4),TSS,LX,LY,EDGLEN(3),MOMINR,TS,REALI,TSI,
     4                TEU(9),TES(9),TEB(9),TBG(9),TUS(9),TEM(9),TSB(9),
     5                TSM(9),TUB(9),TUM(9),THETAM,THETAS,UEM(9),VEM(4),
     6                DETERM,BDUM(3),SHPT(3),BTERMS(6),BMAT1(486),
     7                BMATRX(162),BMTRX(36),DRKCE(33)
      COMMON /SYSTEM/ SYSBUF,NOUT,NOGO,IDUM(51),PREC,ITHERM
      COMMON /SDR2X5/ EST(100),
     1                ELID,SILO(3),IORDER(3),TSUB0,Z1O,Z2O,PIDO,IDUMAL,
     1                PH1RST(701)
      COMMON /SDR2X6/ IELOUT(300)
      COMMON /MATIN / MATID,INFLAG,ELTEMP,DUMMY,SINMAT,COSMAT
      COMMON /HMTOUT/ KHEAT(7),TYPE
      COMMON /TERMS / MEMBRN,BENDNG,SHRFLX,MBCOUP,NORPTH
      EQUIVALENCE     (EST( 1),NEST(1) ), (EST( 2),SIL(1)),
     1                (EST( 5),GPTH(1) ), (EST(10),ZOFF  ),
     2                (EST(12),ELTH    ), (EST(23),INT   ),
     3                (EST(26),ZOFF1   ), (EST(39),TEMPEL),
     4                (EST(27),BGPDT(1,1), IGPDT(1,1))
      EQUIVALENCE     (NPHI( 1),ELID   ), (NPHI (27),DRKCE(1) ),
     1                (NECPT(1),ECPT(1)), (IELOUT(1),RELOUT(1)),
     2                (HTCP,KHEAT(4))
      DATA    HUNMEG, ISTART / 100000000, 93 /,  EPS / 1.0E-17 /
      DATA    NAME  / 4HTRIA , 4H3           /
C
C     INITIALIZE
C
      NNODE  = 3
      MOMINR = 0.0
      TS     = 0.0
      ELTEMP = TEMPEL
      ELID   = NEST(1)
      Z1O    = EST(18)
      Z2O    = EST(19)
      PIDO   = NEST(11) - HUNMEG
      MCSID  = NEST(21)
      SCSID  = NEST(24)
      FLAGS  = NEST(25)
      USERST = SCSID.LT.0 .AND. FLAGS.EQ.1
      NOALFA = .FALSE.
      SHEART = .TRUE.
      OFFSET = ZOFF
      IF (ZOFF .EQ. 0.0) OFFSET = ZOFF1
C
C     START FILLING IN THE DATA BLOCKS
C
      IELOUT(1) = ELID
      DO 20 I = 1,3
      IELOUT(3+(I-1)*25) = SIL(I)
      DO 10 J = 1,3
      RELOUT(25*I+J-1) = BGPDT(J+1,I)
   10 CONTINUE
   20 CONTINUE
C
C     SET UP THE ELEMENT FORMULATION
C
      CALL T3SETS (IERR,SIL,IGPDT,ELTH,GPTH,DGPTH,EGPDT,GPNORM,EPNORM,
     1             IORDER,TEB,TUB,CENTE,AVGTHK,LX,LY,EDGLEN,ELID)
      IF (IERR .NE. 0) GO TO 600
      CALL GMMATS (TEB,3,3,0, TUB,3,3,1, TEU)
      DO 30 I = 1,3
      SILO(I) = SIL(I)
   30 CONTINUE
C
C     SET THE NUMBER OF DOF'S
C
      NNOD2 = NNODE*NNODE
      NDOF  = NNODE*6
      NPART = NDOF*NDOF
      ND2   = NDOF*2
      ND6   = NDOF*6
      ND7   = NDOF*7
      ND8   = NDOF*8
      ND9   = NDOF*9
C
C     PASS THE LOCATION OF THE ELEMENT CENTER FOR TRANSFORMATIONS.
C
      DO 40 IEC = 2,4
      ECPT(IEC) = CENTE(IEC-1)
   40 CONTINUE
C
C     STRESS TRANSFORMATIONS
C
      IF (.NOT.USERST) GO TO 50
      EST (24) = 0.0
      NEST(25) = 0
   50 CALL SHCSGS (*620,NEST(25),NEST(24),EST(24),NEST(25),NEST(24),
     1             EST(24),NECPT,TUB,SCSID,THETAS,TUS)
      CALL GMMATS (TEU,3,3,0, TUS,3,3,0, TES)
C
C     OBTAIN MATERIAL INFORMATION
C
C     SET MATERIAL FLAGS
C     0.83333333 = 5.0/6.0
C
      IF (NEST(13) .NE.   0) MOMINR = EST(14)
      IF (NEST(13) .NE.   0) TS = EST(16)
      IF ( EST(16) .EQ. 0.0) TS = 0.83333333
      IF (NEST(13).EQ.0 .AND. NEST(11).GT.HUNMEG) TS = 0.83333333
C
      MID(1) = NEST(11)
      MID(2) = NEST(13)
      MID(3) = NEST(15)
      MID(4) = NEST(20)
C
      MEMBRN = MID(1).GT.0
      BENDNG = MID(2).GT.0 .AND. MOMINR.GT.0.0
      SHRFLX = MID(3).GT.0
      MBCOUP = MID(4).GT.0
      NORPTH = .FALSE.
C
C     SET UP TRANSFORMATION MATRIX FROM MATERIAL TO ELEMENT COORD. SYSTM
C
      CALL SHCSGS (*610,NEST(9),NEST(8),NEST(8),NEST(21),NEST(20),
     1             NEST(20),NECPT,TUB,MCSID,THETAM,TUM)
C
C     BRANCH ON FORMULATION TYPE, HEAT
C
      IF (ITHERM .NE. 0) GO TO 500
C
C     FETCH MATERIAL PROPERTIES
C
      CALL GMMATS (TEU,3,3,0, TUM,3,3,0, TEM)
      CALL GMMATS (TES,3,3,1, TEM,3,3,0, TSM)
      CALL SHGMGS (*630,ELID,TSM,MID,TS,NOALFA,GI,RHO,GSUBE,TSUB0,
     1             EGNOR,ALPHA)
C
C     TURN OFF THE COUPLING FLAG WHEN MID4 IS PRESENT WITH ALL
C     CALCULATED ZERO TERMS.
C
      IF (.NOT.MBCOUP) GO TO 70
      DO 60 I = 28,36
      IF (ABS(GI(I)) .GT. EPS) GO TO 70
   60 CONTINUE
      MBCOUP = .FALSE.
   70 CONTINUE
C
C     CONTINUE FILLING IN THE DATA BLOCKS
C
      PH1RST( 1) = AVGTHK
      PH1RST( 2) = MOMINR
      PH1RST(48) = OFFSET
      RELOUT( 2) = AVGTHK
C
C     PUT NORMALS IN IELOUT, GRID THICKNESS IN PH1OUT
C
      DO 80 I = 1,NNODE
      IO  = IORDER(I)
      IOP = (IO-1)*25 + 21
      RELOUT(IOP+1) = GPNORM(2,I)
      RELOUT(IOP+2) = GPNORM(3,I)
      RELOUT(IOP+3) = GPNORM(4,I)
      PH1RST(44+IO) = DGPTH(I)
   80 CONTINUE
C
C     CALCULATE [TSB] AND STORE IT IN IELOUT.
C
      CALL GMMATS (TES,3,3,1, TEB,3,3,0, TSB)
      ND25 = NNODE*25
      DO 100 IP2 = 3,ND25,25
      DO 90 IX = 1,9
      RELOUT(IP2+IX  ) = TSB(IX)
      RELOUT(IP2+IX+9) = TSB(IX)
   90 CONTINUE
  100 CONTINUE
C
C     STORE ALPHA IN PH1RST(39-44)
C
      DO 110 IALF = 1,6
      PH1RST(38+IALF) = ALPHA(IALF)
  110 CONTINUE
C
C     STORE UEM IN PH1RST(49-57)
C     STORE TES IN PH1RST(58-66)
C
      CALL SHSTTS (TEM,UEM,VEM)
      DO 120 LL = 1,9
      PH1RST(48+LL) = UEM(LL)
      PH1RST(57+LL) = TES(LL)
  120 CONTINUE
C
C     STORE THE 6X6 [G] IN PH1RST
C
      DO 130 IG = 3,38
      PH1RST(IG) = 0.0
  130 CONTINUE
C
      IF (.NOT.MEMBRN) GO TO 160
      DO 150 IG = 1,3
      IG1 = (IG-1)*6 + 2
      IG2 = (IG-1)*3
      DO 140 JG = 1,3
      PH1RST(IG1+JG) = GI(IG2+JG)
  140 CONTINUE
  150 CONTINUE
C
  160 IF (.NOT.BENDNG) GO TO 210
      DO 180 IG = 1,3
      IG1 = (IG-1)*6 + 23
      IG2 = (IG-1)*3 +  9
      DO 170 JG = 1,3
      PH1RST(IG1+JG) = GI(IG2+JG)*MOMINR
  170 CONTINUE
  180 CONTINUE
C
      IF (.NOT.MBCOUP) GO TO 210
      DO 200 IG = 1,3
      IG3 = (IG-1)*3
      IG1 =  IG3 +  5
      IG2 =  IG3 + 27
      IG3 =  IG3 + 20
      DO 190 JG = 1,3
      PH1RST(IG1+JG) = GI(IG2+JG)
      PH1RST(IG3+JG) = GI(IG2+JG)
  190 CONTINUE
  200 CONTINUE
  210 CONTINUE
C
C     CALCULATE [TEG] FOR EACH NODE AND STORE IT IN PH1RST
C
      DO 220 I = 1,NNODE
      IP = 67 + (I-1)*9
      CALL TRANSS (IGPDT(1,I),TBG)
      CALL GMMATS (TEB,3,3,0, TBG,3,3,0, PH1RST(IP))
  220 CONTINUE
C
C     GET THE GEOMETRY CORRECTION TERMS
C
      IF (.NOT.BENDNG) GO TO 230
      CALL T3GEMS (IERR,EGPDT,IORDER,GI(10),GI(19),LX,LY,EDGLEN,SHRFLX,
     1             AIC,JOG,JOK,K11,K22)
      IF (IERR .NE. 0) GO TO 600
C
C     REDUCED INTEGRATION
C
  230 IF (INT .NE. 0) GO TO 260
C
C     DETERMINE THE AVERAGE [B] FOR OUT-OF-PLANE SHEAR
C
      DO 240 IPT = 1,3
      KPT = (IPT-1)*ND9 + 1
      CALL T3BMGS (IERR,SHEART,IPT,IORDER,EGPDT,DGPTH,AIC,TH,DETJAC,
     1             SHPT,BTERMS,BMAT1(KPT))
      IF (IERR .NE. 0) GO TO 600
  240 CONTINUE
C
      DO 250 I = 1,NDOF
      BMTRX(I     ) = BMAT1(I+ND6) +BMAT1(I+ND6+ND9) +BMAT1(I+ND6+2*ND9)
      BMTRX(I+NDOF) = BMAT1(I+ND7) +BMAT1(I+ND7+ND9) +BMAT1(I+ND7+2*ND9)
  250 CONTINUE
C
C     STRAIN/STRESS EVALUATION LOOP
C
C     PRESET THE PH1RST COUNTER TO THE START OF THE REPEATED SECTION
C     WHICH WILL NOW BE FILLED.
C
  260 ICOUNT =  ISTART
C
      DO 400 IPT = 4,7
C
      CALL T3BMGS (IERR,SHEART,IPT,IORDER,EGPDT,DGPTH,AIC,TH,DETJAC,
     1             SHPT,BTERMS,BMATRX)
      IF (IERR .NE. 0) GO TO 600
C
      IF (INT .NE. 0) GO TO 310
      DO 300 IX = 1,NDOF
      BMATRX(IX+ND6) = BMTRX(IX     )
      BMATRX(IX+ND7) = BMTRX(IX+NDOF)
  300 CONTINUE
C
C     FINISH FILLING IN THE DATA BLOCKS
C
C     STORE THICKNESS
C
  310 PH1RST(ICOUNT+1) = TH
C
C     STORE [G3]
C
      IF (.NOT.BENDNG) GO TO 330
      REALI = MOMINR*TH*TH*TH/12.0
      TSI   = TS*TH
      TSS   = 1.0/(2.0*12.0*REALI)
C
      ZZ(1) = (JOG/TSI)* GI(22) + TSS*JOK*K22
      ZZ(2) =-(JOG/TSI)*(GI(20) + GI(21))/2.0
      ZZ(3) = ZZ(2)
      ZZ(4) = (JOG/TSI)* GI(19) + TSS*JOK*K11
C
      CALL INVERS (2,ZZ,2,BDUM,0,DETERM,ISING,INDEX)
      IF (ISING .NE. 1) GO TO 600
C
      DO 320 IG = 1,4
      PH1RST(ICOUNT+1+IG) = ZZ(IG)
  320 CONTINUE
      GO TO 350
C
  330 DO 340 IG = 1,4
      PH1RST(ICOUNT+1+IG) = 0.0
  340 CONTINUE
C
C     STORE SHAPE FUNCTION VALUES
C
  350 DO 360 I = 1,NNODE
      PH1RST(ICOUNT+5+I) = SHPT(I)
  360 CONTINUE
C
C     STORE THE STRAIN RECOVERY MATRIX
C
      DO 370 IPH = 1,ND8
      PH1RST(ICOUNT+8+IPH) = BMATRX(IPH)
  370 CONTINUE
C
C     END OF THE EVALUATION LOOP
C
C     INCREMENT THE PH1RST COUNTER
C
      ICOUNT = ICOUNT + 8 + 8*NDOF
C
  400 CONTINUE
      GO TO 700
C
C
C     BEGINNING OF HEAT FORCE RECOVERY
C
  500 CONTINUE
C
C     SET UP FOR THE UNIVERSAL PHASE 2 HEAT RECOVERY
C
      NPHI(22) = 2
      NPHI(23) = NNODE
      NPHI(24) = NAME(1)
      NPHI(25) = NAME(2)
C
      SHEART = .FALSE.
      IPT = 4
      CALL T3BMGS (IERR,SHEART,IPT,IORDER,EGPDT,DGPTH,AIC,TH,DETJAC,
     1             SHPT,BTERMS,BMATRX)
      IF (IERR .NE. 0) GO TO 600
C
      MATID  = NEST(11)
      INFLAG = 2
      THETAS = THETAS - THETAM
      SINMAT = SIN(THETAS)
      COSMAT = COS(THETAS)
      CALL HMAT (ELID)
C
      DRKCE(1) = KHEAT(1)
      DRKCE(2) = KHEAT(2)
      DRKCE(3) = KHEAT(2)
      DRKCE(4) = KHEAT(3)
C
      TES(3) = TES(4)
      TES(4) = TES(5)
      CALL GMMATS (TES,2,2,1, BTERMS,2,NNODE,0, DRKCE(10))
C
      GO TO 700
C
C
C     FATAL ERRORS
C
C     CTRIA3 ELEMENT HAS ILLEGAL GEOMETRY OR CONNECTIONS
C
  600 J = 224
      GO TO 640
C
C     THE X-AXIS OF THE MATERIAL COORDINATE SYSTEM HAS NO PROJECTION
C     ON THE PLANE OF THE CTRIA3 ELEMENT
C
  610 J = 225
      NEST(2) = MCSID
      GO TO 640
C
C     THE X-AXIS OF THE STRESS COORDINATE SYSTEM ID HAS NO PROJECTION
C     ON THE PLANE OF THE CTRIA3 ELEMENT
C
  620 J = 227
      NEST(2) = SCSID
      GO TO 640
C
C     ILLEGAL DATA DETECTED ON MATERIAL ID REFERENCED BY CTRIA3 ELEMENT
C     FOR MID3 APPLICATION
C
  630 J = 226
      NEST(2) = MID(3)
C
  640 CALL MESAGE (30,J,NEST(1))
      NOGO = 1
C
  700 CONTINUE
      RETURN
      END


*DECK DQAWC
      SUBROUTINE DQAWC (F, A, B, C, EPSABS, EPSREL, RESULT, ABSERR,
     +   NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK)
C***BEGIN PROLOGUE  DQAWC
C***PURPOSE  The routine calculates an approximation result to a
C            Cauchy principal value I = INTEGRAL of F*W over (A,B)
C            (W(X) = 1/((X-C), C.NE.A, C.NE.B), hopefully satisfying
C            following claim for accuracy
C            ABS(I-RESULT).LE.MAX(EPSABE,EPSREL*ABS(I)).
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A2A1, J4
C***TYPE      DOUBLE PRECISION (QAWC-S, DQAWC-D)
C***KEYWORDS  AUTOMATIC INTEGRATOR, CAUCHY PRINCIPAL VALUE,
C             CLENSHAW-CURTIS METHOD, GLOBALLY ADAPTIVE, QUADPACK,
C             QUADRATURE, SPECIAL-PURPOSE
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C        Computation of a Cauchy principal value
C        Standard fortran subroutine
C        Double precision version
C
C
C        PARAMETERS
C         ON ENTRY
C            F      - Double precision
C                     Function subprogram defining the integrand
C                     Function F(X). The actual name for F needs to be
C                     declared E X T E R N A L in the driver program.
C
C            A      - Double precision
C                     Under limit of integration
C
C            B      - Double precision
C                     Upper limit of integration
C
C            C      - Parameter in the weight function, C.NE.A, C.NE.B.
C                     If C = A or C = B, the routine will end with
C                     IER = 6 .
C
C            EPSABS - Double precision
C                     Absolute accuracy requested
C            EPSREL - Double precision
C                     Relative accuracy requested
C                     If  EPSABS.LE.0
C                     and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     the routine will end with IER = 6.
C
C         ON RETURN
C            RESULT - Double precision
C                     Approximation to the integral
C
C            ABSERR - Double precision
C                     Estimate or the modulus of the absolute error,
C                     Which should equal or exceed ABS(I-RESULT)
C
C            NEVAL  - Integer
C                     Number of integrand evaluations
C
C            IER    - Integer
C                     IER = 0 Normal and reliable termination of the
C                             routine. It is assumed that the requested
C                             accuracy has been achieved.
C                     IER.GT.0 Abnormal termination of the routine
C                             the estimates for integral and error are
C                             less reliable. It is assumed that the
C                             requested accuracy has not been achieved.
C            ERROR MESSAGES
C                     IER = 1 Maximum number of subdivisions allowed
C                             has been achieved. One can allow more sub-
C                             divisions by increasing the value of LIMIT
C                             (and taking the according dimension
C                             adjustments into account). However, if
C                             this yields no improvement it is advised
C                             to analyze the integrand in order to
C                             determine the integration difficulties.
C                             If the position of a local difficulty
C                             can be determined (e.g. SINGULARITY,
C                             DISCONTINUITY within the interval) one
C                             will probably gain from splitting up the
C                             interval at this point and calling
C                             appropriate integrators on the subranges.
C                         = 2 The occurrence of roundoff error is detec-
C                             ted, which prevents the requested
C                             tolerance from being achieved.
C                         = 3 Extremely bad integrand behaviour occurs
C                             at some points of the integration
C                             interval.
C                         = 6 The input is invalid, because
C                             C = A or C = B or
C                             (EPSABS.LE.0 and
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28))
C                             or LIMIT.LT.1 or LENW.LT.LIMIT*4.
C                             RESULT, ABSERR, NEVAL, LAST are set to
C                             zero.  Except when LENW or LIMIT is
C                             invalid, IWORK(1), WORK(LIMIT*2+1) and
C                             WORK(LIMIT*3+1) are set to zero, WORK(1)
C                             is set to A and WORK(LIMIT+1) to B.
C
C         DIMENSIONING PARAMETERS
C            LIMIT - Integer
C                    Dimensioning parameter for IWORK
C                    LIMIT determines the maximum number of subintervals
C                    in the partition of the given integration interval
C                    (A,B), LIMIT.GE.1.
C                    If LIMIT.LT.1, the routine will end with IER = 6.
C
C           LENW   - Integer
C                    Dimensioning parameter for WORK
C                    LENW must be at least LIMIT*4.
C                    If LENW.LT.LIMIT*4, the routine will end with
C                    IER = 6.
C
C            LAST  - Integer
C                    On return, LAST equals the number of subintervals
C                    produced in the subdivision process, which
C                    determines the number of significant elements
C                    actually in the WORK ARRAYS.
C
C         WORK ARRAYS
C            IWORK - Integer
C                    Vector of dimension at least LIMIT, the first K
C                    elements of which contain pointers
C                    to the error estimates over the subintervals,
C                    such that WORK(LIMIT*3+IWORK(1)), ... ,
C                    WORK(LIMIT*3+IWORK(K)) form a decreasing
C                    sequence, with K = LAST if LAST.LE.(LIMIT/2+2),
C                    and K = LIMIT+1-LAST otherwise
C
C            WORK  - Double precision
C                    Vector of dimension at least LENW
C                    On return
C                    WORK(1), ..., WORK(LAST) contain the left
C                     end points of the subintervals in the
C                     partition of (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) contain
C                     the right end points,
C                    WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) contain
C                     the integral approximations over the subintervals,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
C                     contain the error estimates.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DQAWCE, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DQAWC
C
      DOUBLE PRECISION A,ABSERR,B,C,EPSABS,EPSREL,F,RESULT,WORK
      INTEGER IER,IWORK,LAST,LENW,LIMIT,LVL,L1,L2,L3,NEVAL
C
      DIMENSION IWORK(*),WORK(*)
C
      EXTERNAL F
C
C         CHECK VALIDITY OF LIMIT AND LENW.
C
C***FIRST EXECUTABLE STATEMENT  DQAWC
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      IF(LIMIT.LT.1.OR.LENW.LT.LIMIT*4) GO TO 10
C
C         PREPARE CALL FOR DQAWCE.
C
      L1 = LIMIT+1
      L2 = LIMIT+L1
      L3 = LIMIT+L2
      CALL DQAWCE(F,A,B,C,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,NEVAL,IER,
     1  WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST)
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      LVL = 0
10    IF(IER.EQ.6) LVL = 1
      IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'DQAWC',
     +   'ABNORMAL RETURN', IER, LVL)
      RETURN
      END


program NitcheStrickland
!> @file NitscheStrickland.f90
!> Driver program for a planar SWE problem defined by a symmetric vortex and zero initial divergence.
!> @author Peter Bosler, Sandia National Laboratories, Center for Computing Research
!>
!> Demonstrates flow interaction with topography.@n
!> Demontstrates the use of @ref PlanarSWE, @ref SWEPlaneSolver, and @ref PSEDirectSum. @n
!> Driver program based on the setup of an isentropic gas dymanics problem from Nitsche and Strickland (2002).@n
!> Intial conditions are a symmetric vortex located at the origin, uniform fluid depth and zero initial divergence.
!>
!> Users may alter the source code to change the bottom topography function (each change requires a new compilation).@n
!>
!> Other input is supplied via namelist file.
!>
!> @image html NS2002WithTopo.png "Flow interaction with topography. A vortex interacting with a mountain generates gravity waves."
!>
!> For a complete description of the problem that this application is based upon, see @n
!> [M. Nitsche and J. Strickland, Extension of the gridless vortex method into the compressible flow regime. <i> J. Turb. </i> 3 (2002)](http://www.math.unm.edu/~nitsche/webhome/preprints.html)
!>
use NumberKindsModule
use LoggerModule
use PlanarSWEModule
use ParticlesModule
use FieldModule
use MPISetupModule
use SWEPlaneSolverModule
use PSEDirectSumModule
use BIVARRemeshModule

implicit none

include 'mpif.h'

!
!	computing environment
!
type(Logger) :: exeLog
character(len=MAX_STRING_LENGTH) :: logstring
character(len=15) :: logKey = "NS2002"
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL
character(len=MAX_STRING_LENGTH) :: namelistFilename
integer(kint) :: mpiErrCode
real(kreal) :: programStart, programEnd
!
!	mesh variables
!
type(SWEMesh) :: mesh
integer(kint) :: meshSeed
integer(kint) :: faceKind
integer(kint) :: initNest
integer(kint) :: maxNest
integer(kint) :: amrLimit
real(kreal), parameter :: meshRadius = 10.0_kreal
real(kreal) :: f0
real(kreal) :: beta
real(kreal), parameter :: g = 1.0_kreal
character(len=MAX_STRING_LENGTH) :: meshString

namelist /meshDefine/ faceKind, initNest, maxNest, amrLimit, f0, beta
!
!	timestepping
!
type(SWESolver) :: timekeeper
real(kreal) :: dt
real(kreal) :: tfinal
real(kreal) :: t
integer(kint) :: timeJ, nTimesteps
type(PSE) :: pseSetup

!
!	remeshing
!
integer(kint) :: remeshInterval
integer(kint) :: remeshCounter
type(SWEMesh) :: tempMesh

namelist /timestepping/ dt, tfinal, remeshInterval
!
!	I/O variables
!
character(len=MAX_STRING_LENGTH) :: outputDir, outputRoot, vtkFile, matlabFile, vtkRoot
integer(kint) :: frameOut, frameCounter
namelist /fileIO/ outputDir, outputRoot, frameOut

!--------------------------------
!	initialize : setup computing environment
!--------------------------------
call MPI_INIT(mpiErrCode)
call MPI_COMM_SIZE(MPI_COMM_WORLD, numProcs, mpiErrCode)
call MPI_COMM_RANK(MPI_COMM_WORLD, procRank, mpiErrCode)
programStart = MPI_WTIME()

print *, "hello from proc ", procRank

call InitLogger(exeLog, procRank)

call ReadNamelistFile(procRank)

!--------------------------------
!	initialize : setup problem / build mesh
!--------------------------------

call New(mesh, meshSeed, initNest, maxNest, amrLimit, meshRadius, f0, beta, g)
call SetInitialVorticityOnMesh( mesh, initVorticity )
call SetInitialDivergenceOnMesh( mesh, initDivergence)
call SetInitialVelocityOnMesh(mesh, initVelocity )
call SetInitialHOnMesh( mesh, initH )
call SetBottomHeightOnMesh( mesh, bottomTopo)
call SetInitialPotVortOnMesh( mesh )

call New(pseSetup, mesh%mesh)
mesh%pseEps = pseSetup%eps

call New(timekeeper, mesh, bottomTopo)
nTimesteps = floor(tfinal/dt)
t = 0.0_kreal
frameCounter = 1

if ( procRank == 0 ) then
	call LogStats(mesh, exeLog)

	if ( meshSeed == TRI_HEX_SEED ) then
		write(meshString, '(A,I1,A)') '_triHex', initNest, '_'
	elseif ( meshSeed == QUAD_RECT_SEED ) then
		write(meshString, '(A,I1,A)') '_quadRect', initNest, '_'
	endif

	write(vtkRoot,'(4A)') trim(outputDir), '/vtkOut/', trim(outputRoot), trim(meshString)
	write(vtkFile,'(A,I0.4,A)') trim(vtkRoot), 0, '.vtk'

	call OutputToVTKFile(mesh, vtkFile)
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, trim(logkey)//" t = ", t)
endif

!--------------------------------
!	run : evolve the problem in time (currently no remeshing)
!--------------------------------
remeshCounter = 0
!print *, "proc ", procRank, ": starting time stepping loop."
do timeJ = 0, nTimesteps - 1
	!
	!	remesh
	!
	if (mod(timeJ+1, remeshInterval) == 0) then
		call MPI_BARRIER(MPI_COMM_WORLD, mpiErrCode)
!		print *, "proc ", procRank, ": entering remesh."
		remeshCounter = remeshCounter + 1
		call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logkey)//" remesh ", remeshCounter)
		call New(tempMesh, meshSeed, initNest, maxNest, amrLimit, meshRadius, f0, beta, g)
		call SetFieldN(tempMesh)

		if (procRank == 0 ) then
			call OutputToVTKFile(tempMesh, trim(outputDir)//"/vtkOut/preInterp.vtk")
		endif

		print *, "proc ", procRank, ": new mesh built."

		call SetBottomHeightOnMesh(tempMesh, bottomTopo)
		call DirectRemeshPlanarSWE(mesh, tempMesh, .FALSE.)

		if (procRank == 0 ) then
			call OutputToVTKFile(tempMesh, trim(outputDir)//"/vtkOut/postInterp.vtk")
		endif

		call Copy(mesh, tempMesh)

!		call StartSection(exeLog, "post copy")
!		call LogStats(mesh, exeLog)
!		call EndSection(exeLog)

		call Delete(tempMesh)

		call Delete(timekeeper)

		call Delete(pseSetup)
		call New(pseSetup, mesh%mesh)
		mesh%pseEps = pseSetup%eps

		call New(timekeeper, mesh, bottomTopo)
!		call LogStats(timekeeper, exeLog)
	endif

	call Timestep( timekeeper, mesh, dt, bottomTopo)
!	if (timeJ + 1 == remeshInterval) then
!		call LogStats(timekeeper, exeLog)
!		call StartSection(exeLog, "post timestep")
!		call LogStats(mesh, exeLog)
!		call EndSection(exeLog)
!	endif

	t = real(timeJ+1,kreal) * dt
	mesh%mesh%t = t

	if ( procRank == 0 .AND. mod(timeJ+1, frameOut) == 0 ) then
		write(vtkFile,'(A,I0.4,A)') trim(vtkRoot), frameCounter, '.vtk'

		call OutputToVTKFile( mesh, vtkFile )

		frameCounter = frameCounter + 1
		call LogMessage(exelog, TRACE_LOGGING_LEVEL, trim(logkey)//" t = ", mesh%mesh%t)
	endif
enddo

!--------------------------------
!	finalize : clean up
!--------------------------------

programEnd = MPI_WTIME()

write(logstring,'(A,F12.2,A)') "PROGRAM COMPLETE : elapsed time ", programEnd - programStart, " seconds."
call LogMessage(exelog, TRACE_LOGGING_LEVEL, trim(logkey)//" ", logString)

call Delete(pseSetup)
call Delete(timekeeper)
call Delete(mesh)

call MPI_FINALIZE(mpiErrCode)

contains

!> @brief Defines the initial divergence.
!>
!> Conforms to the numberkindsmodule::scalarFnOf2DSpace interface.
!>
!> @param[in] x
!> @param[in] y
!> @return initial divergence, @f$ \delta(x,y,0) @f$
function initDivergence( x, y )
	real(kreal) :: initDivergence
	real(kreal), intent(in) :: x, y
	initDivergence = 0.0_kreal
end function

!> @brief Defines the initial vorticity.
!>
!> Conforms to the numberkindsmodule::scalarFnOf2DSpace interface.
!>
!> @param[in] x
!> @param[in] y
!> @return initial vorticiy, @f$ \zeta(x,y,0) @f$
function initVorticity( x, y)
	real(kreal) :: initVorticity
	real(kreal), intent(in) :: x, y
	!
	real(kreal) :: r2
	real(kreal), parameter :: b = 0.5_kreal
	r2 = x*x + y*y
	initVorticity = (3.0_kreal * sqrt(r2) /( r2 + ZERO_TOL * ZERO_TOL) - 2.0_kreal * b * sqrt(r2)) * r2 * exp(-b * r2)
end function

!> @brief Defines the initial velocity.
!>
!> Conforms to the numberkindsmodule::vectorFnOf2DSpace interface.
!>
!> @param[in] x
!> @param[in] y
!> @return initial velocity, @f$ \vec{u}(x,y,0) @f$
function initVelocity(x, y)
	real(kreal) :: initVelocity(2)
	real(kreal), intent(in) :: x, y
	!
	real(kreal) :: utheta, r2, theta
	real(kreal), parameter :: b = 0.5_kreal

	r2 = x * x + y * y
	utheta = r2 * exp( - b * r2)
	theta = atan2(y,x)

	initVelocity(1) = - utheta * sin(theta)
	initVelocity(2) =   utheta * cos(theta)
end function

!> @brief Defines the initial fluid depth.
!>
!> Conforms to the numberkindsmodule::scalarFnOf2DSpace interface.
!>
!> @param[in] x
!> @param[in] y
!> @return initial depth, @f$ h(x,y,0) @f$
function initH(x, y)
	real(kreal) :: initH
	real(kreal), intent(in) :: x, y
	initH = 1.0_kreal - bottomTopo(x,y)
end function

!> @brief Defines the bottom topography.
!>
!> Conforms to the numberkindsmodule::scalarFnOf2DSpace interface.
!>
!> @param[in] x
!> @param[in] y
!> @return height of bottom, @f$ h_B(x,y) @f$
function bottomTopo(x,y)
	real(kreal) :: bottomTopo
	real(kreal), intent(in) :: x, y
	!bottomTopo = 0.0_kreal
	bottomTopo = 0.25_kreal * exp( -5.0_kreal * (x-0.75_kreal) * (x-0.75_kreal) - 5.0_kreal * y * y)
end function

!> @brief Initializes a @ref Logger for this executable program.
!>
!> Output is controlled by message priority level and MPI rank.
!>
!> @param[in] log @ref Logger to initialize
!> @param[in] rank MPI rank
subroutine InitLogger(log, rank)
	type(Logger), intent(inout) :: log
	integer(kint), intent(in) :: rank
	if ( rank == 0 ) then
		call New(log, logLevel)
	else
		call New(log, ERROR_LOGGING_LEVEL)
	endif
	write(logKey,'(A,I0.2,A)') trim(logKey)//"_", rank, ":"
end subroutine

!> @brief Reads a namelist file, which must be specified on the command line at run-time execution as the first argument,
!> to define the user-specified variables for this driver program.
!>
!> Only MPI rank 0 reads the file; it then broadcasts the relevant data to all other ranks.
!>
!> @param[in] rank MPI rank
subroutine ReadNamelistFile(rank)
	integer(kint), intent(in) :: rank
	!
	integer(kint), parameter :: initBCAST_intSize = 6
	integer(kint), parameter :: initBCAST_realSize = 4
	integer(kint) :: readStat
	integer(kint) :: bcastIntegers(initBCAST_intSize)
	real(kreal) :: bcastReals(initBCAST_realSize)
	integer(kint) :: mpiErrCode

	if ( COMMAND_ARGUMENT_COUNT() /= 1 ) then
		call LogMessage(exeLog,ERROR_LOGGING_LEVEL, trim(logKey), " expected namelist file name as 1st argument.")
		stop
	endif

	if ( rank == 0 ) then
		call GET_COMMAND_ARGUMENT(1, namelistFilename)

		open( unit=READ_UNIT, file=namelistFilename, status='OLD', action='READ', iostat=readStat)
			if (readStat /= 0 ) then
				call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey), " cannot read namelist file.")
				stop
			endif
			read(READ_UNIT, nml=meshDefine)
			rewind(READ_UNIT)
			read(READ_UNIT, nml=timestepping)
			rewind(READ_UNIT)
			read(READ_UNIT, nml=fileIO)
			! namelist /meshDefine/ faceKind, initNest, maxNest, amrLimit

			if ( faceKind == 3 ) then
				meshSeed = TRI_HEX_SEED
			elseif ( faceKind == 4 ) then
				meshSeed = QUAD_RECT_SEED
			else
				call LogMessage(exeLog, WARNING_LOGGING_LEVEL, trim(logKey)//" ReadNamelistFile WARNING :", &
					" invalid faceKind -- using triangles.")
				meshSeed = TRI_HEX_SEED
			endif

			if (amrLimit == 0) maxNest = initNest

			bcastIntegers(1) = meshSeed
			bcastIntegers(2) = initNest
			bcastIntegers(3) = maxNest
			bcastIntegers(4) = amrLimit
			bcastIntegers(5) = frameOut
			bcastIntegers(6) = remeshInterval

			bcastReals(1) = dt
			bcastReals(2) = tfinal
			bcastReals(3) = f0
			bcastReals(4) = beta
		close(READ_UNIT)
	endif

	call MPI_BCAST(bcastIntegers, initBCAST_intSize, MPI_INTEGER, 0, MPI_COMM_WORLD, mpiErrCode)

	call MPI_BCAST(bcastReals, initBCAST_realSize, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, mpiErrCode)

	meshSeed = bcastIntegers(1)
	initNest = bcastIntegers(2)
	maxNest = bcastIntegers(3)
	amrLimit = bcastIntegers(4)
	frameOut = bcastIntegers(5)
	remeshInterval = bcastIntegers(6)

	dt = bcastReals(1)
	tfinal = bcastReals(2)
	f0 = bcastReals(3)
	beta = bcastReals(4)
end subroutine

end program


program multiply
	! This is similar to Perl's 'use strict' or gcc's -Werror.
	! Use it always. It disallows implicit variable declaration.
	implicit none

	! Declare all your variables at the beggining of your code.
	! integer type is 32 bits by default on my machine.
	! Other types include 'real', which is a float type,
	! 'double' (a double precision float), and 'character'
	! which is used both for characters and strings.
	integer :: a, b, c

	! Read reads from stdin, converting what it gets to integers
	! because the compiler knows 'a' and 'b' are meant to be
	! integers.
	! The asterisks mean "default". What we're defaulting here
	! is where to read from (first asterisk) and what format
	! the input will be in (similar to a sprintf format string).
	Read (*,*) a,b

	! This should be self-exmplanatory
	c = a * b

	! Write. Again, we default to stdout but this time we do
	! specify a format string.
	!
	! '2x' means 'two spaces' and it doesn't 'eat up any of the
	! arguments passed to the write function.
	!
	! 'a2' means 'string of length two', it eats up our first string.
	!
	! 'i5' means 'integer with five digits'. This one also eats up
	! one of our arguments.
	!
	! '/' signals an EOL ('\n' in C-inspired languages).
	Write (*,'(2x,a2,5x,i5/2x,a2,5x,i5/a4,i10)') "a:", a, "b:", b, "a*b:", c

	! This is optional. Think of it like a 'return 0' of sorts.
	stop
end program multiply


*DECK CGBCO
      SUBROUTINE CGBCO (ABD, LDA, N, ML, MU, IPVT, RCOND, Z)
C***BEGIN PROLOGUE  CGBCO
C***PURPOSE  Factor a band matrix by Gaussian elimination and
C            estimate the condition number of the matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2C2
C***TYPE      COMPLEX (SGBCO-S, DGBCO-D, CGBCO-C)
C***KEYWORDS  BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK,
C             MATRIX FACTORIZATION
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     CGBCO factors a complex band matrix by Gaussian
C     elimination and estimates the condition of the matrix.
C
C     If  RCOND  is not needed, CGBFA is slightly faster.
C     To solve  A*X = B , follow CGBCO by CGBSL.
C     To compute  INVERSE(A)*C , follow CGBCO by CGBSL.
C     To compute  DETERMINANT(A) , follow CGBCO by CGBDI.
C
C     On Entry
C
C        ABD     COMPLEX(LDA, N)
C                contains the matrix in band storage.  The columns
C                of the matrix are stored in the columns of  ABD  and
C                the diagonals of the matrix are stored in rows
C                ML+1 through 2*ML+MU+1 of  ABD .
C                See the comments below for details.
C
C        LDA     INTEGER
C                the leading dimension of the array  ABD .
C                LDA must be .GE. 2*ML + MU + 1 .
C
C        N       INTEGER
C                the order of the original matrix.
C
C        ML      INTEGER
C                number of diagonals below the main diagonal.
C                0 .LE. ML .LT. N .
C
C        MU      INTEGER
C                number of diagonals above the main diagonal.
C                0 .LE. MU .LT. N .
C                More efficient if  ML .LE. MU .
C
C     On Return
C
C        ABD     an upper triangular matrix in band storage and
C                the multipliers which were used to obtain it.
C                The factorization can be written  A = L*U  where
C                L  is a product of permutation and unit lower
C                triangular matrices and  U  is upper triangular.
C
C        IPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        RCOND   REAL
C                an estimate of the reciprocal condition of  A .
C                For the system  A*X = B , relative perturbations
C                in  A  And  B  of size  EPSILON  may cause
C                relative perturbations in  X  of size  EPSILON/RCOND .
C                If  RCOND  is so small that the logical expression
C                           1.0 + RCOND .EQ. 1.0
C                is true, then  A  may be singular to working
C                precision.  In particular,  RCOND  is zero  if
C                exact singularity is detected or the estimate
C                underflows.
C
C        Z       COMPLEX(N)
C                a work vector whose contents are usually unimportant.
C                If  A  is close to a singular matrix, then  Z  is
C                an approximate null vector in the sense that
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     Band Storage
C
C           if  A  is a band matrix, the following program segment
C           will set up the input.
C
C                   ML = (band width below the diagonal)
C                   MU = (band width above the diagonal)
C                   M = ML + MU + 1
C                   DO 20 J = 1, N
C                      I1 = MAX(1, J-MU)
C                      I2 = MIN(N, J+Ml)
C                      DO 10 I = I1, I2
C                         K = I - J + M
C                         ABD(K,J) = A(I,J)
C                10    CONTINUE
C                20 CONTINUE
C
C           This uses rows  ML+1  through  2*ML+MU+1  of  ABD .
C           In addition, the first  ML  rows in  ABD  are used for
C           elements generated during the triangularization.
C           The total number of rows needed in  ABD  is  2*ML+MU+1 .
C           The  ML+MU by ML+MU  upper left triangle and the
C           ML by ML  lower right triangle are not referenced.
C
C     Example:  If the original matrix is
C
C           11 12 13  0  0  0
C           21 22 23 24  0  0
C            0 32 33 34 35  0
C            0  0 43 44 45 46
C            0  0  0 54 55 56
C            0  0  0  0 65 66
C
C      then  N = 6, ML = 1, MU = 2, LDA .GE. 5  and ABD should contain
C
C            *  *  *  +  +  +  , * = not used
C            *  * 13 24 35 46  , + = used for pivoting
C            * 12 23 34 45 56
C           11 22 33 44 55 66
C           21 32 43 54 65  *
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  CAXPY, CDOTC, CGBFA, CSSCAL, SCASUM
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CGBCO
      INTEGER LDA,N,ML,MU,IPVT(*)
      COMPLEX ABD(LDA,*),Z(*)
      REAL RCOND
C
      COMPLEX CDOTC,EK,T,WK,WKM
      REAL ANORM,S,SCASUM,SM,YNORM
      INTEGER IS,INFO,J,JU,K,KB,KP1,L,LA,LM,LZ,M,MM
      COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1
      REAL CABS1
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
      CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2))
C
C     COMPUTE 1-NORM OF A
C
C***FIRST EXECUTABLE STATEMENT  CGBCO
      ANORM = 0.0E0
      L = ML + 1
      IS = L + MU
      DO 10 J = 1, N
         ANORM = MAX(ANORM,SCASUM(L,ABD(IS,J),1))
         IF (IS .GT. ML + 1) IS = IS - 1
         IF (J .LE. MU) L = L + 1
         IF (J .GE. N - ML) L = L - 1
   10 CONTINUE
C
C     FACTOR
C
      CALL CGBFA(ABD,LDA,N,ML,MU,IPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  CTRANS(A)*Y = E .
C     CTRANS(A)  IS THE CONJUGATE TRANSPOSE OF A .
C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C     GROWTH IN THE ELEMENTS OF W  WHERE  CTRANS(U)*W = E .
C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C     SOLVE CTRANS(U)*W = E
C
      EK = (1.0E0,0.0E0)
      DO 20 J = 1, N
         Z(J) = (0.0E0,0.0E0)
   20 CONTINUE
      M = ML + MU + 1
      JU = 0
      DO 100 K = 1, N
         IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K))
         IF (CABS1(EK-Z(K)) .LE. CABS1(ABD(M,K))) GO TO 30
            S = CABS1(ABD(M,K))/CABS1(EK-Z(K))
            CALL CSSCAL(N,S,Z,1)
            EK = CMPLX(S,0.0E0)*EK
   30    CONTINUE
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = CABS1(WK)
         SM = CABS1(WKM)
         IF (CABS1(ABD(M,K)) .EQ. 0.0E0) GO TO 40
            WK = WK/CONJG(ABD(M,K))
            WKM = WKM/CONJG(ABD(M,K))
         GO TO 50
   40    CONTINUE
            WK = (1.0E0,0.0E0)
            WKM = (1.0E0,0.0E0)
   50    CONTINUE
         KP1 = K + 1
         JU = MIN(MAX(JU,MU+IPVT(K)),N)
         MM = M
         IF (KP1 .GT. JU) GO TO 90
            DO 60 J = KP1, JU
               MM = MM - 1
               SM = SM + CABS1(Z(J)+WKM*CONJG(ABD(MM,J)))
               Z(J) = Z(J) + WK*CONJG(ABD(MM,J))
               S = S + CABS1(Z(J))
   60       CONTINUE
            IF (S .GE. SM) GO TO 80
               T = WKM - WK
               WK = WKM
               MM = M
               DO 70 J = KP1, JU
                  MM = MM - 1
                  Z(J) = Z(J) + T*CONJG(ABD(MM,J))
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
         Z(K) = WK
  100 CONTINUE
      S = 1.0E0/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
C
C     SOLVE CTRANS(L)*Y = W
C
      DO 120 KB = 1, N
         K = N + 1 - KB
         LM = MIN(ML,N-K)
         IF (K .LT. N) Z(K) = Z(K) + CDOTC(LM,ABD(M+1,K),1,Z(K+1),1)
         IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 110
            S = 1.0E0/CABS1(Z(K))
            CALL CSSCAL(N,S,Z,1)
  110    CONTINUE
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
  120 CONTINUE
      S = 1.0E0/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
C
      YNORM = 1.0E0
C
C     SOLVE L*V = Y
C
      DO 140 K = 1, N
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
         LM = MIN(ML,N-K)
         IF (K .LT. N) CALL CAXPY(LM,T,ABD(M+1,K),1,Z(K+1),1)
         IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 130
            S = 1.0E0/CABS1(Z(K))
            CALL CSSCAL(N,S,Z,1)
            YNORM = S*YNORM
  130    CONTINUE
  140 CONTINUE
      S = 1.0E0/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE  U*Z = W
C
      DO 160 KB = 1, N
         K = N + 1 - KB
         IF (CABS1(Z(K)) .LE. CABS1(ABD(M,K))) GO TO 150
            S = CABS1(ABD(M,K))/CABS1(Z(K))
            CALL CSSCAL(N,S,Z,1)
            YNORM = S*YNORM
  150    CONTINUE
         IF (CABS1(ABD(M,K)) .NE. 0.0E0) Z(K) = Z(K)/ABD(M,K)
         IF (CABS1(ABD(M,K)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0)
         LM = MIN(K,M) - 1
         LA = M - LM
         LZ = K - LM
         T = -Z(K)
         CALL CAXPY(LM,T,ABD(LA,K),1,Z(LZ),1)
  160 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0E0/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
      RETURN
      END


module rmsd
implicit none
contains
  subroutine get_cov_matrix(coord_c, coord_r, coord_c_c, coord_r_c, cov_matrix, m, n)

    integer::m,n
    integer::i,j,k
    real(kind=4)::sum_value
    real(kind=4),dimension(n)::coord_c_c,coord_r_c
    real(kind=4),dimension(m,n)::coord_c,coord_r
    real(kind=4),dimension(m,n)::coord_c_d,coord_r_d
    real(kind=4),dimension(n,n)::cov_matrix

    !f2py intent(in)::m,n
    !f2py intent(in)::coord_c_c,coord_r_c
    !f2py intent(in)::coord_c,coord_r
    !f2py intent(out)::cov_matrix

    do i=1,m
      do j=1,n
        coord_c_d(i,j)=coord_c(i,j)-coord_c_c(j)
        coord_r_d(i,j)=coord_r(i,j)-coord_r_c(j)
      end do
    end do

    do i=1,n
      do j=1,n
        sum_value=0.0
        do k=1,m
          sum_value=sum_value+coord_c_d(k,i)*coord_r_d(k,j)
        end do
      cov_matrix(i,j)=sum_value
      end do
    end do

    return

  end subroutine get_cov_matrix

  subroutine quarternion_rotate(cov_matrix,quart_matrix,n)

    integer::n
    real(kind=4),dimension(n,n)::cov_matrix
    real(kind=4),dimension(4,4)::quart_matrix

    !f2py intent(in)::n
    !f2py intent(in)::cov_matrix
    !f2py intent(out)::quart_matrix

    quart_matrix(1,1)=cov_matrix(1,1)+cov_matrix(2,2)+cov_matrix(3,3)
    quart_matrix(1,2)=cov_matrix(2,3)-cov_matrix(3,2)
    quart_matrix(1,3)=cov_matrix(3,1)-cov_matrix(1,3)
    quart_matrix(1,4)=cov_matrix(1,2)-cov_matrix(2,1)
    quart_matrix(2,1)=cov_matrix(2,3)-cov_matrix(3,2)
    quart_matrix(2,2)=cov_matrix(1,1)-cov_matrix(2,2)-cov_matrix(3,3)
    quart_matrix(2,3)=cov_matrix(1,2)+cov_matrix(2,1)
    quart_matrix(2,4)=cov_matrix(1,3)+cov_matrix(3,1)
    quart_matrix(3,1)=cov_matrix(3,1)-cov_matrix(1,3)
    quart_matrix(3,2)=cov_matrix(1,2)+cov_matrix(2,1)
    quart_matrix(3,3)=-cov_matrix(1,1)+cov_matrix(2,2)-cov_matrix(3,3)
    quart_matrix(3,4)=cov_matrix(2,3)+cov_matrix(3,2)
    quart_matrix(4,1)=cov_matrix(1,2)-cov_matrix(2,1)
    quart_matrix(4,2)=cov_matrix(1,3)+cov_matrix(3,1)
    quart_matrix(4,3)=cov_matrix(2,3)+cov_matrix(3,2)
    quart_matrix(4,4)=-cov_matrix(1,1)-cov_matrix(2,2)+cov_matrix(3,3)

    return

  end subroutine quarternion_rotate

  subroutine quart_to_rot(quart_vec,rot_matrix,m)

    integer::m
    real(kind=4),dimension(m)::quart_vec
    real(kind=4),dimension(3,3)::rot_matrix

    !f2py intent(in)::m
    !f2py intent(in)::quart_vec
    !f2py intent(out)::rot_matrix

    rot_matrix(1,1)=quart_vec(1)**2+quart_vec(2)**2-quart_vec(3)**2-quart_vec(4)**2
    rot_matrix(1,2)=2.0*(quart_vec(2)*quart_vec(3)-quart_vec(1)*quart_vec(4))
    rot_matrix(1,3)=2.0*(quart_vec(2)*quart_vec(4)+quart_vec(1)*quart_vec(3))
    rot_matrix(2,1)=2.0*(quart_vec(2)*quart_vec(3)+quart_vec(1)*quart_vec(4))
    rot_matrix(2,2)=quart_vec(1)**2-quart_vec(2)**2+quart_vec(3)**2-quart_vec(4)**2
    rot_matrix(2,3)=2.0*(quart_vec(3)*quart_vec(4)-quart_vec(1)*quart_vec(2))
    rot_matrix(3,1)=2.0*(quart_vec(2)*quart_vec(4)-quart_vec(1)*quart_vec(3))
    rot_matrix(3,2)=2.0*(quart_vec(3)*quart_vec(4)+quart_vec(1)*quart_vec(2))
    rot_matrix(3,3)=quart_vec(1)**2-quart_vec(2)**2-quart_vec(3)**2+quart_vec(4)**2

    return

  end subroutine quart_to_rot

  subroutine get_rmsd(coord_c,coord_r,coord_c_c,coord_r_c,eig_max,rmsd_value,m,n)

    integer::m,n
    integer::i,j
    real(kind=4)::sum_value
    real(kind=4)::eig_max
    real(kind=4)::rmsd_value
    real(kind=4),dimension(n)::coord_c_c,coord_r_c
    real(kind=4),dimension(m,n)::coord_c,coord_r
    real(kind=4),dimension(m,n)::coord_c_d,coord_r_d

    !f2py intent(in)::m,n
    !f2py intent(in)::coord_c_c,coord_r_c
    !f2py intent(in)::coord_c,coord_r
    !f2py intent(out)::rmsd_value

    do i=1,m
      do j=1,n
        coord_c_d(i,j)=coord_c(i,j)-coord_c_c(j)
        coord_r_d(i,j)=coord_r(i,j)-coord_r_c(j)
      end do
    end do

    sum_value=0.0
    do i=1,m
      do j=1,n
        sum_value=sum_value+coord_c_d(i,j)**2+coord_r_d(i,j)**2
      end do
    end do

!    write(*,*)sum_value,eig_max
    rmsd_value=sqrt((sum_value-2*eig_max)/m)

    return

  end subroutine get_rmsd

end module rmsd


      SUBROUTINE fddvel (strzon, ntrzon, dt, dx, dtpool, rtpool, ntau,
     +  taustp, nx, lunvel, lenint, vpadss, vpadse, vpadgs, vpadge,
     +     line3d, ncrbln, nline, insamp, crbdum)
!
!-------------------------------------------------------------------------------
!$R   FDM___: Calculate RMS velocities over each Tau interval for the interval.
!     This returns a velocity function for EVERY trace (ntrzon traces).
!
!     VERITAS SOFTWARE LTD.                  CALGARY, ALBERTA, CANADA
! Author:      N.M.M.                        Date:      February, 1985
! Inputs:      RMS velocities for each trace at control points. (See array
!              DTPOOL.) Note that this RMS velocity is from time = 0 to length
!              of data, and this is NOT the same as the RMS velocity to be
!              calculated over the Tau intervals.
!
! Function:    1- Calculate the interval velocity V(n) at all samples of each
!                 CRB:
!                            -----------------------------------------
!                           / Vin(n)**2 * t(n+1) - Vin(n-1)**2 * t(n)
!                 V(n) =   /  ---------------------------------------
!                       /\/               t(n+1) - t(n)                ,
!                     n = 0 .. length of data (in steps of sample rate),
!                     Vin = input RMS velocity for the CRB.
!
!              2- For each Tau interval calculate 1/2 the RMS velocity over the
!                 interval times a factor for use in the migration calculation:
!                             --------------------------------
!                            /        sum (V(n)**2)
!                 C(n) =    /   -----------------------------
!                        /\/    4 * (t(i+1)/DT - t(i)/DT + 1) ,
!                     i = 1 .. the number of TAU intervals,
!                     n = t(i) .. t(i+1),
!                     DT = Sample rate (in seconds).
!
!                 Note that this is equivalent to:
!                            ------------------------------------------------
!                           /      1             ( V(n)**2                 )
!                          / ------------- * sum ( ------- * (t(n+1)-t(n)) )
!                       /\/  t(i+1) - t(i)       (    4                    )
!
!              3- Partially calculate g. G is used in the migration calculation
!                 and requires: (Refer to FDM programmers' notes.)
!                 a = delta-tau * C'
!                 b = DT/4 * C'
!                         C(n)**2 * DT
!                 C'(n) = ------------
!                           4 * DX**2 ,
!                     DX = Trace separation.
!
!              4- Determine the velocity at the zone of interest at the section
!                 ends. (This is for the trace pad calculation.)
!
!              *****************************************************************
!              * NOTE THE FOLLOWING:                                           *
!              *   A) The square root in point 1 above is NOT taken because of *
!              *      "V(n)**2" in point 2.                                    *
!              *   B) The square root in point 2 above is NOT taken because of *
!              *      "C(n)**2" in point 3.                                    *
!              *****************************************************************
!
! Outputs:     Array VRMS (2D calculation) or file 'FDMV' (3D).
!
! Calling Sequence:
!  STRZON = Start CRB of current zone (line).
!  NTRZON = # of CRB's in the zone.
!  DT     = Sample rate (seconds).
!  DX     = Trace separation (for 3D this is in the "in-line" direction).
!  DTPOOL = Array in which the velocity parameters will be contained. DTPOOL is
!           defined (230,200) to hold 198 control points (the first 2 rows have
!           a special use). The format of DTPOOL is now described:
!    (1,1)= 3 (Always. This is the row index of the first control point.
!    (2,1)= Index of the last control point. (The number of control points =
!           DTPOOL(2,1)-2.
!    (3..230,1) = Unused.
!    (1..230,2) = Interpolation buffer (used in FDMVEL).
!    (1,ix) = Type of input function. (1=TRMS, 2=TVI, 3=TNMO, 4=TDEP)
!    (2,ix) = Control point interpolation code (1="S",2="C" or 3="E")
!    (3,ix) = CRB number of control point.
!    (4,ix) = Distance at which NMO function picked (TNMO only).
!    (5,ix) = Number of time, velocity pairs read at this control point.
!    (6....117,ix) = Control times of function.
!    (118..230,ix) = Velocities at control times.
!  NTAU   = # of Tau steps.
!  TAUSTP = Time of each Tau step.
!  TAUSIZ = Delta-tau for each Tau step.
!  VRMS   = Output velocity (2D only).
!           (NOTE: This is referred to as " C' " in the notes.)
!  LENINT = Greatest time in zone of interest.
!  VPADSS = Interval velocity (V(n)) for 1st CRB at zone of interest.
!  VPADSE = Interval velocity (V(n)) for last CRB at zone of interest.
!           (For 3D VPADSS & VPADSE are the maximum V(n) in the zone of interest
!           at all CRB's that are the start or end of a section.)
!  VPADGS = Same as VPADSS but for 3D cross-lines.
!  VPADGE = Same as VPADSE but for 3D cross-lines.
!  LINE3D = Flag for 3D.
!  NCRBLN = # of CRB's in a line (3D).
!  NLINE  = # of lines (cross-lines) in the 3D survey.
!  INSAMP = # of samples input.
!  CRB    = Current CRB #.
!
! EXTERNALS:
!     AVBUFIN
!
! REVISIONS:
!  Author:   N.M.M.                           Date: August, 1985
! Description: Use interval velocity at the bottom of each Tau step (rather than
!             the middle) so that velocities may be tapered over the Tau step
!             samples to the previous Tau step samples to properly merge steps.
!
! Revised by:   N.M.M.                          Date:   May, 1987
! Reason:       Add 8192 sample limit with no sample rate or length restriction.
!
!  17 June 1988, by pch to make f77 for non-vms, non-ap,  and non-veritas!
!  August - pch.  the vrms array is a virual array, not in Cray!  So,
!                vrms is now stored on disc.  vrms contains a velocity
!                for every tau step of every trace.  It must be
!                transposed too, all of each time steps next to each
!                  other
!           Also think in seconds rather than milleseconds.
!  Sept - pch   CRB is an argument, but it is used as a do loop
!               counter, so I changed the argument to crbdum
!
! Non-standard Fortran-66 items:
!    1- IMPLICIT NONE statement.
!    2- Common block names and/or external routines with names > 6 characters.
!    3- Use of %REF or %VAL functions.
!-------------------------------------------------------------------------------
!
      INTEGER crbdum
!
      COMMON /sioap/ iasgnd, irelse, in, iout, nextad, lapsiz, ifree,
     *               iuseap, idecimf, mdsize
      COMMON /apmem/ apdata(0:65536)                                      ! it is really mdsize big
!      IMPLICIT NONE
!
      PARAMETER ( MAXSMP = 8192 )
      INTEGER  strzon,   ntrzon,   ntau,     lenint,   ncrbln,   nline,
     +         insamp,   crb,
     +         dtpool(230,200),    taustp(ntau)
      REAL     rtpool(230,200)
!     equivalence(dtpool,rtpool)

      REAL     dt,       dx,       vpadss,   vpadse,   vpadgs,   vpadge
      LOGICAL  line3d
!
      REAL     vin(112)
!      integer   VIN(112)
      INTEGER  crbst,    crben,    list(5),  time(112),
     +         nv,       i,        lsamp,    n,        esamp,
     +         sr,       tau,      sp,       sc,       s,        c
      REAL     gbase,    vn,       v,        vl,       tl,
     +         tc,       tp,       velint,   veltau,   veloc(MAXSMP)
!
      DATA     list      /118, 6, 5, 4, 0/
      DATA nsofar/1/, icol/1/
!
!
!.... Calculate some loop indeces and partially calculate G. (see notes above)
!      print *,' strzon=',strzon,' ntrzon=',ntrzon,' dt=',dt,' dx=',
!     * dx,' lunvel=',lunvel,' lenint=',lenint
!      print *,vpadss,vpadse,vpadge,vpadge
!      print *,' line3d=',line3d,' ncrbln=',ncrnln,' nline=',nline,
!     *   ' insamp=',insamp,' crbdum=',crbdum
!
      IF( insamp .LE. 0 ) STOP
      maxcol = mdsize / insamp
      maxco  = maxcol
      sr     = nint(dt * 1000.0)
      crbst  = strzon
      crben  = strzon + ntrzon - 1
      vpadss = 0.0
      vpadse = 0.0
      vpadgs = 0.0
      vpadge = 0.0
      gbase  = dt / (4.0 * dx**2)
!
!.... Get the velocity for each CRB in the zone.
      DO 100 crb = crbst, crben
!
!....     Interpolate the input (possibly bulked) RMS velocity functions to get
!....     the velocity for this CRB.
!****     crb can be sent in dtpool(2,2) or as an argument - I chose argument
          CALL avbufin (dtpool, rtpool, 230, 2, -3, list, crb)
!
!....     Convert RMS to interval velocity and fill a velocity array with the
!....     interval velocity at every sample. (Refer to note 1 above.)
          nv = dtpool(5,2)
!
          DO 10 i = 1, nv
             time(i) = dtpool(5+i,2)
             vin(i) = rtpool(117+i,2)
   10     CONTINUE
!
          v     = vin(1)
          tim   = time(1)
          lsamp = 1
          DO 110 n = 2, nv
!
!....          Calculate the interval velocity.
               vl  = v
               tl  = tim
               v   = vin(n)
               tim = time(n)
               vn  = (v**2 * tim - vl**2 * tl) / (tim-tl)
!              call fdmChck1(crb, n-1, tl, tim, vn)
!
!....          Now fill the velocity array with the interval velocity at all
!....          samples in the interval.
               esamp = nint(tim / sr) + 1
               if (esamp .gt. insamp) esamp = insamp
               if (esamp .ge. lsamp) then
                   DO 80 i = 1, esamp-lsamp+1
                      veloc(lsamp+i-1) = vn
   80              CONTINUE
                   lsamp = esamp + 1
               END IF
  110     CONTINUE
!
!          IF (LSAMP .LE. INSAMP)
!     +         CALL SET (VELOC(LSAMP), INSAMP-LSAMP+1, VN)
!
          IF ( lsamp .le. insamp) THEN                                  ! Pad to end of trace with vint
              DO 120 i = 1, insamp-lsamp+1
                 veloc(lsamp+i-1) = vn
  120         CONTINUE
          ENDIF
!
!....     Get V(n) at the zone of interest.
          velint = sqrt(veloc(lenint/sr))
!
!....     Start the Tau step loop to calculate C' (1/2 the RMS velocity over the
!....     Tau interval). Refer to the note above and note that the square root
!....     is never actually taken. (Refer to notes 2 and 3 above.)
!**** GMK had to change velocity taustep loop to include tau step at t = 0
!**** GMK thus, no taustp exists at the bottm of the section ( t = insamp)
!**** GMK because of this, averaging loop was modified below
          sp = 1
          DO 200 tau = 1, ntau
!
               tc = taustp(tau+1)                                       ! Update End of tau interval
               sc = tc / float(sr) + 1.0                                ! Sample number
               sc = min (sc, insamp)

!**** GMK Since there is not a (tau+1) taustp need to set sc = to last samp
!**** GMK thereby averaging over entire taustep
               if (tau.eq.ntau) then
                 sc = insamp
               endif
!
               veltau = 0.0                                             ! Average velocity over tau step
               DO 300 s = sp, sc
                  veltau = veltau + veloc(s)
  300          CONTINUE
               veltau     = veltau / (4.0 * (sc-sp+1))
               veloc(tau) = veltau * gbase                              ! Store average back in veloc
!              call fdmChck2(crb,tau,sp,sc,veltau,dt,dx)
               sp = MIN (sc+1, insamp)
  200     CONTINUE

!....     If the line is a 2D line then move C' into the array VRMS for use by
!....     routine FDMLIN. Don't forget to find the velocity of the zone of
!....     interest at the end CRB's.
          IF (.not.line3d) THEN
!****                  Multiplex the velocity function and save it on disk
               jndex = crb - crbst + 1
               index = jndex-((jndex-1)/maxcol)*maxcol
               DO 400 tau = 1, ntau
!                    VRMS(CRB-CRBST+1,TAU) = VELOC(TAU)
                  apdata(index) = veloc(tau)
                  index         = index + maxco
  400          CONTINUE
               icol = icol + 1
               IF( jndex .EQ. ntrzon )
     $            maxcol = icol - 1                                     ! Force O/P: Last CDP done.
               IF( icol .GT. maxcol ) THEN
                   index = 1
                   n = icol - 1
                   DO 420 i = 1, ntau
                      ipos = (i-1)*nx+nsofar
                      CALL podisc( lunvel, 1, ipos)
                      CALL wrdisc( lunvel, apdata(index), n )
                      index = index + maxco
  420              CONTINUE
                   nsofar = nsofar + maxcol
                   icol   = 1
               ENDIF

               IF (crb .eq. crbst) vpadss = velint
               IF (crb .eq. crben) vpadse = velint
!
!....     But if this is a 3D line then write C' to file 'FDMV' and check for
!....     the maximum velocity in the zone of interest at the boundaries of the
!....     grid.
          ELSE
!               CALL FILEWRIT ('FDMV', CRB, VELOC)
!
!....          Check for the maximum velocity in the zone of interest in the
!....          first and last lines of the survey.
               IF (CRB .LE. NCRBLN)       VPADGS = MAX (VPADGS, VELINT)
               IF (CRB .GT. CRBEN-NCRBLN) VPADGE = MAX (VPADGE, VELINT)
!
!....          Now check the start and end sections (first and last
!....          "cross-lines").
               DO 501 c = crbst, crben, ncrbln
                  IF (crb .eq. c) vpadss = max (vpadss, velint)
  501          CONTINUE
               DO 502 c = crbst+ncrbln-1, crben, ncrbln
                  IF (crb .eq. c) vpadse = max (vpadse, velint)
  502          CONTINUE
          END IF
  100 CONTINUE
      RETURN
      END


	FUNCTION convlv(data,respns,isign)
	USE nrtype; USE nrutil, ONLY : assert,nrerror
	USE nr, ONLY : realft
	IMPLICIT NONE
	REAL(SP), DIMENSION(:), INTENT(INOUT) :: data
	REAL(SP), DIMENSION(:), INTENT(IN) :: respns
	INTEGER(I4B), INTENT(IN) :: isign
	REAL(SP), DIMENSION(size(data)) :: convlv
	INTEGER(I4B) :: no2,n,m
	COMPLEX(SPC), DIMENSION(size(data)/2) :: tmpd,tmpr
	n=size(data)
	m=size(respns)
	call assert(iand(n,n-1)==0, 'n must be a power of 2 in convlv')
	call assert(mod(m,2)==1, 'm must be odd in convlv')
	convlv(1:m)=respns(:)
	convlv(n-(m-3)/2:n)=convlv((m+3)/2:m)
	convlv((m+3)/2:n-(m-1)/2)=0.0
	no2=n/2
	call realft(data,1,tmpd)
	call realft(convlv,1,tmpr)
	if (isign == 1) then
		tmpr(1)=cmplx(real(tmpd(1))*real(tmpr(1))/no2, &
			aimag(tmpd(1))*aimag(tmpr(1))/no2, kind=spc)
		tmpr(2:)=tmpd(2:)*tmpr(2:)/no2
	else if (isign == -1) then
		if (any(abs(tmpr(2:)) == 0.0) .or. real(tmpr(1)) == 0.0 &
			.or. aimag(tmpr(1)) == 0.0) call nrerror &
			('deconvolving at response zero in convlv')
		tmpr(1)=cmplx(real(tmpd(1))/real(tmpr(1))/no2, &
			aimag(tmpd(1))/aimag(tmpr(1))/no2, kind=spc)
		tmpr(2:)=tmpd(2:)/tmpr(2:)/no2
	else
		call nrerror('no meaning for isign in convlv')
	end if
	call realft(convlv,-1,tmpr)
	END FUNCTION convlv


c
c
c ==============================================================
       subroutine qinit(maxmx,meqn,mbc,mx,xlower,dx,q,maux,aux)
c ==============================================================

      implicit none
      double precision q(1-mbc:maxmx+mbc, meqn)
      double precision aux(1-mbc:maxmx+mbc, *)

      integer maxmx,meqn,mbc,mx,maux
      double precision xlower,dx,flumegeo,hinit

      !local
      integer i
      double precision h,theta,xcell

      include "digparamsdec.i"
      include "digparamscommon.i"

      do i=1-mbc,mx+mbc
         xcell = xlower + (i-0.5d0)*dx
         if (init_htype.eq.0) then
            h = max(0.d0,flumegeo(xcell))
         elseif (init_htype.eq.1) then
            !you must supply a function hinit(xcell)
            h = max(0.d0,hinit(xcell))
         endif
         q(i,1) = h
         theta = aux(i,i_theta)
         q(i,2)= 0.d0
         q(i,3)= q(i,1)*m0
         q(i,4)= rho_f*grav*q(i,1)*cos(theta)
      enddo

      call calcaux(maxmx,meqn,mbc,mx,xlower,dx,q,maux,aux)

      p_initialized = 1
      if (init_ptype.gt.0) then
         p_initialized = 0
         pimin = 1.d0
         call calcpmin(maxmx,meqn,mbc,mx,xlower,dx,q,maux,aux)
         write(*,*) 'pimin', pimin
         do i = 1-mbc,mx+mbc
            theta = aux(i,i_theta)
            if (init_ptype.eq.1) then
                q(i,4) = pimin*rho_f*grav*cos(theta)*q(i,1)
            elseif (init_ptype.eq.2) then
                q(i,4) = 0.d0
            endif
         enddo
         if (init_ptype.eq.1) p_initialized = 1
      endif

      return
      end

c=======================================================================
      function flumegeo(x)
c
c     function to return the depth, given x, for the flume hopper
c     uses parameters set in digparams
c=======================================================================

      implicit none

      double precision x,h,flumegeo
      double precision pi,x0,x1,x2,x3,y0,y1,y2,y3,m

      include "digparamsdec.i"
      include "digparamscommon.i"

      pi = 3.14159
      x0 = -hopperlen
      x3 = 0.d0
      x2 = -hmax*cos(0.5d0*pi - theta1)
      x1 = x2 - hoppertop*cos(theta1 - hopperangle)

      y0 = 0.d0
      y2 = hmax*sin(0.5d0*pi - theta1)
      y1 = y2 - hoppertop*sin(theta1 - hopperangle)
      y3 = 0.d0

      if (x.ge.x0 .and. x.lt.x1) then
         m = (y1-y0)/(x1-x0)
         h = y0 + m*(x-x0)
      elseif (x.ge.x1 .and. x.lt.x2) then
         m = (y2-y1)/(x2-x1)
         h = y1 + m*(x-x1)
      elseif (x.ge.x2 .and. x.lt.x3) then
         m = (y3-y2)/(x3-x2)
         h = y2 + m*(x-x2)
      else
         h = 0.d0
      endif

      flumegeo = h
      return
      end

c ================================================================
       subroutine calcpmin(maxmx,meqn,mbc,mx,xlower,dx,q,maux,aux)
c ================================================================

      implicit none
      double precision q(1-mbc:maxmx+mbc, meqn)
      double precision aux(1-mbc:maxmx+mbc, *)

      integer maxmx,meqn,mbc,mx,maux
      double precision xlower,dx

      !local
      integer i
      double precision h,hr,hl,rhol,rhor,rho
      double precision thetal,thetar,theta,phil,phir,phi
      double precision forcemag,pcrit,drytol

      include "digparamsdec.i"
      include "digparamscommon.i"

      drytol = 2.d0*dry_tol

      do i=2-mbc,mx+mbc
         hr = q(i,1)
         hl = q(i-1,1)
         if (hl.le.dry_tol.and.hr.le.dry_tol) then
            cycle
         endif

         thetar = aux(i,i_theta)
         thetal = aux(i-1,i_theta)
         phir = aux(i,i_phi)
         phil = aux(i-1,i_phi)
         rhor = aux(i,i_rho)
         rhol = aux(i-1,i_rho)

         if (hl.gt.drytol.and.hr.gt.drytol) then
            h = 0.5d0*(hr + hl)
            phi = 0.5d0*(phir + phil)
            theta = 0.5d0*(thetar + thetal)
            rho = 0.5d0*(rhol + rhor)
         elseif (hr.gt.drytol) then
            h = hr
            phi = phir
            theta = thetar
            rho = rhor
         else
            h = hl
            phi = phil
            theta = thetal
            rho = rhol
         endif

*        !determine pressure min ratio
         forcemag = abs(grav*h*sin(theta)*dx
     &         -0.5d0*grav*(cos(thetar)*hr**2 - cos(thetal)*hl**2))

         pcrit = rho*h*grav*cos(theta) - rho*forcemag/(dx*tan(phi))
         pcrit = max(pcrit,0.0)
         pimin = min(pimin,pcrit/(rho_f*grav*cos(theta)*h))
         pimin = max(pimin,0.d0)

      enddo

      return
      end