#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_urffact_singlestep
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes one iteration of Francis' singleshift algorithm on a
! unitary upper hessenberg matrix that is stored as a product of givens
! rotations.
!
! | nu  0 | | u1       -v1 |
! |  0  1 | | v1  conj(u1) | | u2       -v2 |
!                            | v2  conj(u2) | | u3       -v3 | | 1   0 |
!                                             | v3  conj(u3) | | 0  u4 |
!
! The square root free algorithm only requires the storage of the vi^2,
! so the arrays U and VV contain the following:
!
!  U(i) = ui
! VV(i) = vi^2
!
! The input must satisfy the following:
!
!  |U(i)|^2 + VV(i) = 1
!             VV(N) = 0
!              |NU| = 1
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    dimension of matrix, must be >= 2
!
!  U               COMPLEX(8) array of dimension N
!                    array of complex generators for Givens rotations
!
!  VV              REAL(8) array of dimension N
!                    array of real generators for Givens rotations
!
!  NU              COMPLEX(8)
!                    unimodular phase
!
!  ITCNT           INTEGER
!                    Contains the number of iterations since last deflation
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_urffact_singlestep(N,U,VV,NU,ITCNT)

  implicit none

  ! input variables
  integer, intent(in) :: N
  integer, intent(inout) :: ITCNT
  complex(8), intent(inout) :: U(N)
  real(8), intent(inout) :: VV(N)
  complex(8), intent(in) :: NU

  ! compute variables
  integer :: ii
  real(8) :: vvt, cc, ss, xx
  complex(8) :: ut, w, rho
  complex(8) :: block(2,2), t1(2,2), t2(2,2)

  ! get 2x2 block
  block(1,1) =  U(N-1)
  block(2,2) =  conjg(U(N-1))
  block(1,2) = -sqrt(VV(N-1))
  block(2,1) =  sqrt(VV(N-1))
  block(:,2) =  block(:,2)*U(N)
  if (N > 2) then
    xx = abs(U(N-2))
    if (xx.GT.0) then
      block(1,:) = conjg(U(N-2))*block(1,:)/xx
    end if
  end if

  ! compute eigenvalues and eigenvectors
  t1 = block
  call z_2x2array_eig(.FALSE.,t1,t1,t2,t2)

  ! choose wikinson shift
  ! complex abs does not matter here
  if(abs(block(2,2)-t1(1,1)) < abs(block(2,2)-t1(2,2)))then
    rho = t1(1,1)
  else
    rho = t1(2,2)
  end if

  ! compute a nonzero shift
  ! random shift
  xx = abs(rho)
  if (xx == 0) then
    call random_number(xx)
    rho = cmplx(cos(xx),sin(xx),kind=8)
  ! wilkinson shift
  else
    rho = rho/xx
  end if

  ! initialize
  w = -rho
  cc = 1d0
  ss = 0d0

  ! main chasing loop
  do ii=0,(N-1)

    ! set ut and vvt
    ut = NU*U(ii+1)
    vvt = VV(ii+1)

    ! turnover
    call z_rfr3_turnover(w,cc,ss,ut,vvt,rho)

    ! store ut and vvt
    if ( ii > 0 ) then
      U(ii) = conjg(NU)*ut
      VV(ii) = vvt
    end if

  end do

end subroutine z_urffact_singlestep


! This module is used to calculate reaction rates.
! Storage is used to handle common temperature factors used
! in the various reaction rates.
!
! This module is created via the make_rate_module.py routine.
module rates_module

  use bl_types
  use bl_constants_module

  implicit none

  type temp_t
     real (kind=dp_t) :: t9
     real (kind=dp_t) :: t9i
     real (kind=dp_t) :: t9i13
     real (kind=dp_t) :: t913
     real (kind=dp_t) :: t953
     real (kind=dp_t) :: lnt9
  end type temp_t

  real (kind=dp_t), parameter :: f17_to_o17 = exp(-4.53302d0)
  real (kind=dp_t), parameter :: ne18_to_f18 = exp(-0.880534d0)
  real (kind=dp_t), parameter :: ne19_to_f19 = exp(-3.21258d0)
  real (kind=dp_t), parameter :: o14_to_n14 = exp(-4.62412d0)
  real (kind=dp_t), parameter :: o15_to_n15 = exp(-5.1725d0)
  !$acc declare copyin(f17_to_o17, ne18_to_f18, ne19_to_f19, o14_to_n14, o15_to_n15)

contains

  subroutine calc_tfactors(t9, tfactors)
    !$acc routine seq
    real (kind=dp_t), intent(in   ) :: t9
    type (temp_t), intent(out) :: tfactors

    tfactors%t9 = t9
    tfactors%t9i = 1.d0 / tfactors%t9
    tfactors%t9i13 = tfactors%t9i**THIRD
    tfactors%t913 = tfactors%t9**THIRD
    tfactors%t953 = tfactors%t9 * tfactors%t913 * tfactors%t913
    tfactors%lnt9 = log(tfactors%t9)

  end subroutine calc_tfactors

  subroutine rate_p_c12_to_n13(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    real (kind=dp_t) :: ct9i, ct9i13, ct913, ct9, ct953, clnt9

    real (kind=dp_t) :: r0, r1

    rate = ZERO

    ct9i = tfactors%t9i*(-3.77849d0)
    ct9i13 = tfactors%t9i13*(-5.10735d0)
    ct913 = tfactors%t913*(-2.24111d0)
    ct9 = tfactors%t9*(0.148883d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r0 = exp(17.5428d0 &
         +ct9i &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +clnt9)

    ct9i13 = tfactors%t9i13*(-13.692d0)
    ct913 = tfactors%t913*(-0.230881d0)
    ct9 = tfactors%t9*(4.44362d0)
    ct953 = tfactors%t953*(-3.15898d0)
    clnt9 = tfactors%lnt9*(-0.666667d0)

    r1 = exp(17.1482d0 &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    rate = r0 + r1

  end subroutine rate_p_c12_to_n13

  subroutine rate_f17_to_p_o16(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    real (kind=dp_t) :: ct9i, ct9i13, ct913, ct9, ct953, clnt9

    real (kind=dp_t) :: r0

    rate = ZERO

    ct9i = tfactors%t9i*(-6.96583d0)
    ct9i13 = tfactors%t9i13*(-16.696d0)
    ct913 = tfactors%t913*(-1.16252d0)
    ct9 = tfactors%t9*(0.267703d0)
    ct953 = tfactors%t953*(-0.0338411d0)
    clnt9 = tfactors%lnt9*(0.833333d0)

    r0 = exp(40.9135d0 &
         +ct9i &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    rate = r0

  end subroutine rate_f17_to_p_o16

  subroutine rate_f17_to_o17(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    rate = f17_to_o17

  end subroutine

  subroutine rate_p_f17_to_ne18(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    real (kind=dp_t) :: ct9i, ct9i13, ct913, ct9, ct953, clnt9

    real (kind=dp_t) :: r0, r1

    rate = ZERO

    ct9i = tfactors%t9i*(-0.0323504d0)
    ct9i13 = tfactors%t9i13*(-14.2191d0)
    ct913 = tfactors%t913*(34.0647d0)
    ct9 = tfactors%t9*(-16.5698d0)
    ct953 = tfactors%t953*(2.48116d0)
    clnt9 = tfactors%lnt9*(-2.13376d0)

    r0 = exp(-7.84708d0 &
         +ct9i &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    ct9i = tfactors%t9i*(-4.95969d0)
    ct9i13 = tfactors%t9i13*(-21.3249d0)
    ct913 = tfactors%t913*(-0.230774d0)
    ct9 = tfactors%t9*(0.917931d0)
    ct953 = tfactors%t953*(-0.0440377d0)
    clnt9 = tfactors%lnt9*(-7.36014d0)

    r1 = exp(27.5778d0 &
         +ct9i &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    rate = r0 + r1

  end subroutine rate_p_f17_to_ne18

  subroutine rate_he4_he4_he4_to_c12(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    real (kind=dp_t) :: ct9i, ct9i13, ct913, ct9, ct953, clnt9

    real (kind=dp_t) :: r0, r1, r2

    rate = ZERO

    ct9i = tfactors%t9i*(-1.02446d0)
    ct9i13 = tfactors%t9i13*(-23.57d0)
    ct913 = tfactors%t913*(20.4886d0)
    ct9 = tfactors%t9*(-12.9882d0)
    ct953 = tfactors%t953*(-20.0d0)
    clnt9 = tfactors%lnt9*(-2.16667d0)

    r0 = exp(-11.7884d0 &
         +ct9i &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    ct9i13 = tfactors%t9i13*(-37.06d0)
    ct913 = tfactors%t913*(29.3493d0)
    ct9 = tfactors%t9*(-115.507d0)
    ct953 = tfactors%t953*(-10.0d0)
    clnt9 = tfactors%lnt9*(-1.33333d0)

    r1 = exp(-0.971052d0 &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    ct9i = tfactors%t9i*(-4.12656d0)
    ct9i13 = tfactors%t9i13*(-13.49d0)
    ct913 = tfactors%t913*(21.4259d0)
    ct9 = tfactors%t9*(-1.34769d0)
    ct953 = tfactors%t953*(0.0879816d0)
    clnt9 = tfactors%lnt9*(-13.1653d0)

    r2 = exp(-24.3505d0 &
         +ct9i &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    rate = r0 + r1 + r2

  end subroutine rate_he4_he4_he4_to_c12

  subroutine rate_p_n14_to_o15(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    real (kind=dp_t) :: ct9i, ct9i13, ct913, ct9, ct953, clnt9

    real (kind=dp_t) :: r0, r1, r2, r3

    rate = ZERO

    ct9i13 = tfactors%t9i13*(-15.193d0)
    ct913 = tfactors%t913*(-4.63975d0)
    ct9 = tfactors%t9*(9.73458d0)
    ct953 = tfactors%t953*(-9.55051d0)
    clnt9 = tfactors%lnt9*(0.333333d0)

    r0 = exp(20.1169d0 &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    ct9i13 = tfactors%t9i13*(-15.193d0)
    ct913 = tfactors%t913*(-0.161954d0)
    ct9 = tfactors%t9*(-7.52123d0)
    ct953 = tfactors%t953*(-0.987565d0)
    clnt9 = tfactors%lnt9*(-0.666667d0)

    r1 = exp(17.01d0 &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    ct9i = tfactors%t9i*(-4.891d0)
    clnt9 = tfactors%lnt9*(0.0682d0)

    r2 = exp(6.73578d0 &
         +ct9i &
         +clnt9)

    ct9i = tfactors%t9i*(-2.998d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r3 = exp(7.65444d0 &
         +ct9i &
         +clnt9)

    rate = r0 + r1 + r2 + r3

  end subroutine rate_p_n14_to_o15

  subroutine rate_he4_ne18_to_p_na21(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    real (kind=dp_t) :: ct9i, ct9i13, ct913, ct9, ct953, clnt9

    real (kind=dp_t) :: r0, r1, r2, r3, r4, r5, r6

    rate = ZERO

    ct9i = tfactors%t9i*(-24.7176d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r0 = exp(19.4058d0 &
         +ct9i &
         +clnt9)

    ct9i = tfactors%t9i*(-0.452576d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r1 = exp(-137.358d0 &
         +ct9i &
         +clnt9)

    ct9i = tfactors%t9i*(-10.885d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r2 = exp(6.39797d0 &
         +ct9i &
         +clnt9)

    ct9i = tfactors%t9i*(-7.45009d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r3 = exp(-1.15641d0 &
         +ct9i &
         +clnt9)

    ct9i = tfactors%t9i*(-5.97632d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r4 = exp(-6.65137d0 &
         +ct9i &
         +clnt9)

    ct9i = tfactors%t9i*(-3.14078d0)
    ct9i13 = tfactors%t9i13*(-17.7759d0)
    ct913 = tfactors%t913*(36.0724d0)
    ct9 = tfactors%t9*(-5.34039d0)
    ct953 = tfactors%t953*(0.382679d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r5 = exp(-13.3392d0 &
         +ct9i &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    ct9i = tfactors%t9i*(-2.81989d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r6 = exp(-28.6929d0 &
         +ct9i &
         +clnt9)

    rate = r0 + r1 + r2 + r3 + r4 + r5 + r6

  end subroutine rate_he4_ne18_to_p_na21

  subroutine rate_ne18_to_f18(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    rate = ne18_to_f18

  end subroutine

  subroutine rate_ne19_to_f19(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    rate = ne19_to_f19

  end subroutine

  subroutine rate_p_ne19_to_na20(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    real (kind=dp_t) :: ct9i, ct9i13, ct913, ct9, ct953, clnt9

    real (kind=dp_t) :: r0, r1

    rate = ZERO

    ct9i = tfactors%t9i*(-5.07623d0)
    ct913 = tfactors%t913*(1.23704d0)
    ct9 = tfactors%t9*(0.337618d0)
    ct953 = tfactors%t953*(-0.0562825d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r0 = exp(5.63289d0 &
         +ct9i &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    ct9i13 = tfactors%t9i13*(-19.5908d0)
    ct913 = tfactors%t913*(-2.37696d0)
    ct9 = tfactors%t9*(3.26815d0)
    ct953 = tfactors%t953*(-1.06524d0)
    clnt9 = tfactors%lnt9*(-0.666667d0)

    r1 = exp(17.822d0 &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    rate = r0 + r1

  end subroutine rate_p_ne19_to_na20

  subroutine rate_he4_o14_to_p_f17(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    real (kind=dp_t) :: ct9i, ct9i13, ct913, ct9, ct953, clnt9

    real (kind=dp_t) :: r0, r1, r2, r3, r4, r5

    rate = ZERO

    ct9i = tfactors%t9i*(-12.0223d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r0 = exp(12.1289d0 &
         +ct9i &
         +clnt9)

    ct9i = tfactors%t9i*(-26.0d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r1 = exp(18.6518d0 &
         +ct9i &
         +clnt9)

    ct9i13 = tfactors%t9i13*(-39.388d0)
    ct913 = tfactors%t913*(-17.4673d0)
    ct9 = tfactors%t9*(35.3029d0)
    ct953 = tfactors%t953*(-24.8162d0)
    clnt9 = tfactors%lnt9*(-0.666667d0)

    r2 = exp(40.8358d0 &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    ct9i = tfactors%t9i*(-22.51d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r3 = exp(16.3087d0 &
         +ct9i &
         +clnt9)

    ct9i = tfactors%t9i*(-13.6d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r4 = exp(11.1184d0 &
         +ct9i &
         +clnt9)

    ct9i = tfactors%t9i*(-0.453036d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r5 = exp(-106.091d0 &
         +ct9i &
         +clnt9)

    rate = r0 + r1 + r2 + r3 + r4 + r5

  end subroutine rate_he4_o14_to_p_f17

  subroutine rate_o14_to_n14(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    rate = o14_to_n14

  end subroutine

  subroutine rate_he4_o15_to_ne19(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    real (kind=dp_t) :: ct9i, ct9i13, ct913, ct9, ct953, clnt9

    real (kind=dp_t) :: r0, r1, r2

    rate = ZERO

    ct9i = tfactors%t9i*(-5.88439d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r0 = exp(-0.0452465d0 &
         +ct9i &
         +clnt9)

    ct9i13 = tfactors%t9i13*(-39.578d0)
    ct953 = tfactors%t953*(-3.0d0)
    clnt9 = tfactors%lnt9*(-0.666667d0)

    r1 = exp(26.2914d0 &
         +ct9i13 &
         +ct953 &
         +clnt9)

    ct9i = tfactors%t9i*(-4.20439d0)
    ct9i13 = tfactors%t9i13*(-3.24609d0)
    ct913 = tfactors%t913*(44.4647d0)
    ct9 = tfactors%t9*(-9.79962d0)
    ct953 = tfactors%t953*(0.841782d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r2 = exp(-32.2496d0 &
         +ct9i &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    rate = r0 + r1 + r2

  end subroutine rate_he4_o15_to_ne19

  subroutine rate_o15_to_n15(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    rate = o15_to_n15

  end subroutine

  subroutine rate_he4_o16_to_ne20(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    real (kind=dp_t) :: ct9i, ct9i13, ct913, ct9, ct953, clnt9

    real (kind=dp_t) :: r0, r1, r2

    rate = ZERO

    ct9i = tfactors%t9i*(-10.3585d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r0 = exp(3.88571d0 &
         +ct9i &
         +clnt9)

    ct9i13 = tfactors%t9i13*(-39.7262d0)
    ct913 = tfactors%t913*(-0.210799d0)
    ct9 = tfactors%t9*(0.442879d0)
    ct953 = tfactors%t953*(-0.0797753d0)
    clnt9 = tfactors%lnt9*(-0.666667d0)

    r1 = exp(23.903d0 &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    ct9i = tfactors%t9i*(-12.7643d0)
    ct913 = tfactors%t913*(-3.65925d0)
    ct9 = tfactors%t9*(0.714224d0)
    ct953 = tfactors%t953*(-0.00107508d0)
    clnt9 = tfactors%lnt9*(-1.5d0)

    r2 = exp(9.50848d0 &
         +ct9i &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    rate = r0 + r1 + r2

  end subroutine rate_he4_o16_to_ne20

  subroutine rate_p_o16_to_f17(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    real (kind=dp_t) :: ct9i, ct9i13, ct913, ct9, ct953, clnt9

    real (kind=dp_t) :: r0

    rate = ZERO

    ct9i13 = tfactors%t9i13*(-16.696d0)
    ct913 = tfactors%t913*(-1.16252d0)
    ct9 = tfactors%t9*(0.267703d0)
    ct953 = tfactors%t953*(-0.0338411d0)
    clnt9 = tfactors%lnt9*(-0.666667d0)

    r0 = exp(19.0904d0 &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    rate = r0

  end subroutine rate_p_o16_to_f17

  subroutine rate_he4_si26_to_p_p29(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    real (kind=dp_t) :: ct9i, ct9i13, ct913, ct9, ct953, clnt9

    real (kind=dp_t) :: r0

    rate = ZERO

    ct9i13 = tfactors%t9i13*(-59.3013d0)
    ct913 = tfactors%t913*(0.480742d0)
    ct9 = tfactors%t9*(-0.834505d0)
    ct953 = tfactors%t953*(0.0621841d0)
    clnt9 = tfactors%lnt9*(-0.666667d0)

    r0 = exp(48.8732d0 &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    rate = r0

  end subroutine rate_he4_si26_to_p_p29

  subroutine rate_he4_ti44_to_p_v47(tfactors,rate)
    !$acc routine seq
    type (temp_t),    intent(in   ) :: tfactors
    real (kind=dp_t), intent(  out) :: rate

    real (kind=dp_t) :: ct9i, ct9i13, ct913, ct9, ct953, clnt9

    real (kind=dp_t) :: r0

    rate = ZERO

    ct9i = tfactors%t9i*(-9.07869d0)
    ct9i13 = tfactors%t9i13*(5.56533d0)
    ct913 = tfactors%t913*(18.4415d0)
    ct9 = tfactors%t9*(-4.10095d0)
    ct953 = tfactors%t953*(0.24244d0)
    clnt9 = tfactors%lnt9*(16.0516d0)

    r0 = exp(-34.2468d0 &
         +ct9i &
         +ct9i13 &
         +ct913 &
         +ct9 &
         +ct953 &
         +clnt9)

    rate = r0

  end subroutine rate_he4_ti44_to_p_v47

end module rates_module


module local_routines
    !!
    !! Steady uniform flow down a planar slope
    !!
    use global_mod, only: dp, ip, wall_elevation
    use domain_mod, only: domain_type, STG, UH, VH, ELV
    implicit none

    real(dp), parameter:: bed_slope = 0.01_dp

    contains

    subroutine set_initial_conditions_uniform_slope(domain)
        class(domain_type), target, intent(inout):: domain
        integer(ip):: i,j
        real(dp):: x, y, cx, cy, slope

        ! Set elevation
        slope = bed_slope

        cx = (domain%lw(1))*0.5
        cy = (domain%lw(2))*0.5
        do i = 1,domain%nx(1)
            do j = 1, domain%nx(2)
                x = (i-0.5_dp)*domain%dx(1) - cx
                y = (j-0.5_dp)*domain%dx(2) - cy
                domain%U(i,j,ELV) = y*slope
            end do
        end do

        domain%U(:,:,STG) = domain%U(:,:,ELV)
        if(domain%timestepping_method == 'leapfrog_linear_plus_nonlinear_friction') then
            ! linear_with_nonlinear_friction is fragile for this problem (however we want
            ! to test the friction correctness). So we "help" it by giving initial conditions
            ! close to the steady-state solution. Otherwise shocks develop and the solver
            ! performs very badly. We do not set it exactly
            domain%U(:,:,STG) = domain%U(:,:,STG) + 0.485_dp
            domain%U(:,:,VH) = -0.9999_dp
        end if

        ! Wall boundaries along the sides and top
        domain%U(1,:,ELV) = wall_elevation
        domain%U(domain%nx(1),:,ELV) = wall_elevation
        domain%U(:,domain%nx(2),ELV) = wall_elevation
        domain%U(:,1,ELV) = wall_elevation

        ! Ensure stage >= elevation
        domain%U(:,:,STG) = max(domain%U(:,:,STG), domain%U(:,:,ELV))

        if(domain%timestepping_method == 'leapfrog_linear_plus_nonlinear_friction') then
            ! More nursing of the leapfrog solver.
            ! Ensure the initial condition respects that wall boundaries have no discharge
            do j = 1, domain%nx(2)
                do i = 1, domain%nx(1)
                    if( (domain%U(i,j  ,STG) < domain%U(i,j  ,ELV) + 1.0e-03_dp) .or. &
                        (domain%U(i,j+1,STG) < domain%U(i,j+1,ELV) + 1.0e-03_dp) ) then
                        domain%U(i,j,VH) = 0.0_dp
                    end if
                end do
            end do
        end if

        domain%manning_squared = 0.03_dp**2

    end subroutine

end module

!@!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program uniform_slope
    !!
    !! Steady uniform flow down a planar slope
    !!
    use global_mod, only: ip, dp, charlen
    use domain_mod, only: domain_type, STG, UH, VH, ELV
    use file_io_mod, only: read_csv_into_array
    use local_routines
    implicit none

    integer(ip):: i, j
    real(dp):: last_write_time
    type(domain_type):: domain

    ! Approx timestep between outputs
    real(dp), parameter :: approximate_writeout_frequency = 60.0_dp
    real(dp) :: final_time

    ! length/width
    real(dp), parameter, dimension(2):: global_lw = [50._dp, 1000._dp]
    ! lower-left corner coordinate
    real(dp), parameter, dimension(2):: global_ll = [0._dp, 0._dp]
    ! grid size (number of x/y cells)
    integer(ip), parameter, dimension(2):: global_nx = [50, 1000] ! [400, 400]

    ! Discharge of 1 cubic meter / second per metre width
    real(dp), parameter :: discharge_per_unit_width = 1.0_dp
    real(dp) :: Qin, model_vd, model_d, model_v, theoretical_d, &
        theoretical_v, theoretical_vol, model_vol, initial_vol, ts, error_thresh_vd
    integer(ip) :: nspread

    ! This gives the inflow discharge per cell, where it is applied
    Qin = discharge_per_unit_width * (global_lw(1)/global_nx(1))

    call get_command_argument(1, domain%timestepping_method)

    !domain%timestepping_method = 'rk2'
    !domain%timestepping_method = 'leapfrog_linear_plus_nonlinear_friction'

    if(domain%timestepping_method == 'leapfrog_linear_plus_nonlinear_friction') then
        ! This is not a good numerical method for this problem. But to facilitate testing,
        ! we "nurse it" when setting the initial conditions.
        domain%linear_solver_is_truely_linear = .false. ! Would not make sense to use purely-linear on this problem
        final_time = 600.0_dp
        error_thresh_vd = 1.0e-04_dp
    else
        ! The finite volume methods are good for this problem, no issues with dry states, etc.
        final_time = 600.0_dp
        error_thresh_vd = 1.0e-05_dp
    end if

    ! Prevent dry domain from causing enormous initial step
    domain%maximum_timestep = 5.0_dp

    ! Allocate domain
    call domain%allocate_quantities(global_lw, global_nx, global_ll)

    ! call local routine to set initial conditions
    call set_initial_conditions_uniform_slope(domain)

    initial_vol = sum(domain%U(:,:,STG) - domain%U(:,:,ELV))*product(domain%dx)

    ! Trick to get the code to write out just after the first timestep
    last_write_time = -approximate_writeout_frequency

    if(.not. domain%adaptive_timestepping) then
        ! The leapfrog solve needs a specified timestep
        ! Because this problem is "hard" for that solver, it turns out we need a fairly
        ! small timestep
        ts = 0.02_dp
    end if

    ! Evolve the code
    do while (.true.)

        if(domain%time - last_write_time >= approximate_writeout_frequency) then

            last_write_time = last_write_time + approximate_writeout_frequency

            call domain%print()
            call domain%write_to_output_files()

            if (domain%time > final_time) then
                exit
            end if

        end if

        ! Evolve
        if(.not. domain%adaptive_timestepping) then
            call domain%evolve_one_step(timestep=ts)
            ! Add discharge inflow
            domain%U(2:(domain%nx(1)-1), domain%nx(2)-1, STG) = &
                domain%U(2:(domain%nx(1)-1), domain%nx(2)-1, STG) + Qin*ts / product(domain%dx)
        else
            call domain%evolve_one_step()
            ! Add discharge inflow
            domain%U(2:(domain%nx(1)-1), domain%nx(2)-1, STG) = &
                domain%U(2:(domain%nx(1)-1), domain%nx(2)-1, STG) + Qin*domain%evolve_step_dt / product(domain%dx)
        end if

    end do

    call domain%write_max_quantities()

    call domain%timer%print()

    theoretical_vol = Qin * domain%time * domain%lw(1) * (global_nx(1) - 2) * 1.0_dp / global_nx(1) + initial_vol
    model_vol = sum(domain%U(:,:,STG) - domain%U(:,:,ELV)) * product(domain%dx)

    ! Analytical solution
    ! vd = discharge_per_unit_width
    ! bed_slope = manning_squared * v * abs(v) / d^(4/3)
    ! bed_slope = manning_squared * discharge_per_unit_width**2 / (d^(10/3))
    ! d = (manning_squared * discharge_per_unit_width**2 / bed_slope )**(3/10)

    i = domain%nx(1)/2
    j = domain%nx(2)/2
    model_vd = -1.0_dp * domain%U(i,j,VH)
    model_d = domain%U(i,j,STG) - domain%U(i,j,ELV)
    model_v = model_vd/model_d

    theoretical_d = (domain%manning_squared(i,j) * discharge_per_unit_width**2 / bed_slope)**(3.0_dp/10.0_dp)

    print*, 'Initial vol: ', initial_vol
    print*, ''
    print*, ''

    print*, '## Testing ##'
    print*, ' '
    print*, '    Theoretical volume: ', theoretical_vol
    print*, '    Model volume: ', model_vol
    print*, '      error: ', theoretical_vol - model_vol
    if( abs(theoretical_vol - model_vol) < 1.0e-06_dp * theoretical_vol) then
        print*, 'PASS'
    else
        print*, 'FAIL: Mass conservation error', theoretical_vol, model_vol
    end if
    print*, ' '
    print*, '   Theoretical vd: ', discharge_per_unit_width
    print*, '   Model vd (near centre): ', model_vd
    if( abs(discharge_per_unit_width - model_vd) < error_thresh_vd*discharge_per_unit_width) then
        print*, 'PASS'
    else
        print*, 'FAIL: Flux error ', discharge_per_unit_width, model_vd
    end if

    print*, ' '
    print*, '   Theoretical d: ', theoretical_d
    print*, '   Model d: ', model_d
    if( abs(theoretical_d - model_d) < 1.0e-04_dp*theoretical_d) then
        print*, 'PASS'
    else
        print*, 'FAIL: Friction or steady flow error', theoretical_d, model_d
    end if

    call domain%finalise()

end program


MODULE Grid

  IMPLICIT NONE

  INTEGER(KIND=4), PARAMETER :: CARTESIAN   = 0
  INTEGER(KIND=4), PARAMETER :: UNIRECT     = 1
  INTEGER(KIND=4), PARAMETER :: RECTILINEAR = 2
  INTEGER(KIND=4), PARAMETER :: CURVILINEAR = 3

CONTAINS

  SUBROUTINE ComputeGridMetrics( &
       numDim,gridSizes,numPoints,          &
       opInterval, numStencils,             &
       numStencilValues, stencilSizes,      &
       stencilStarts, stencilOffsets,       &
       stencilWeights,stencilID,            &
       gridCoordinates, gridMetricTensor,   &
       gridJacobianDeterminants)

    USE OPERATORS

    IMPLICIT NONE

    INTEGER(KIND=4), INTENT(IN)            :: numDim
    INTEGER(KIND=8), INTENT(IN)            :: gridSizes(numDim),  numPoints
    INTEGER(KIND=8), INTENT(IN)            :: opInterval(2*numDim)
    INTEGER(KIND=4), INTENT(IN)            :: numStencils,numStencilValues
    INTEGER(KIND=4), INTENT(IN)            :: stencilSizes(numStencils)
    INTEGER(KIND=4), INTENT(IN)            :: stencilStarts(numStencils)
    INTEGER(KIND=4), INTENT(IN)            :: stencilOffsets(numStencilValues)
    INTEGER(KIND=4), INTENT(IN),    TARGET :: stencilID(numDim*numPoints)
    REAL(KIND=8),    INTENT(IN)            :: stencilWeights(numStencilValues)
    REAL(KIND=8),    INTENT(IN),    TARGET :: gridCoordinates(numDim*numPoints)
    REAL(KIND=8),    INTENT(INOUT), TARGET :: gridMetricTensor(numDim*numDim*numPoints)
    REAL(KIND=8),    INTENT(INOUT), TARGET :: gridJacobianDeterminants(2*numPoints)

    REAL(KIND=8),    DIMENSION(:), ALLOCATABLE :: dCoords
    REAL(KIND=8),    DIMENSION(:), POINTER     :: jacPtr, jacM1Ptr
    REAL(KIND=8),    DIMENSION(:), POINTER     :: gridMetricTensorPtr
    REAL(KIND=8),    DIMENSION(:), POINTER     :: coordPtr
    INTEGER(KIND=4), DIMENSION(:), POINTER     :: stencilConnPtr

    INTEGER(KIND=4) :: numComponents, iDim

  END SUBROUTINE ComputeGridMetrics

  ! NOT THREADED
  SUBROUTINE ComputeCurvilinearGridMetrics( &
       numDim,gridSizes,numPoints,          &
       opInterval, numStencils,             &
       numStencilValues, stencilSizes,      &
       stencilStarts, stencilOffsets,       &
       stencilWeights,stencilID,            &
       gridCoordinates, gridMetricTensor,   &
       gridJacobianDeterminants)

    USE OPERATORS
    USE SIMPLE
    USE SPECIAL

    IMPLICIT NONE

    INTEGER(KIND=4), INTENT(IN)            :: numDim
    INTEGER(KIND=8), INTENT(IN)            :: gridSizes(numDim),  numPoints
    INTEGER(KIND=8), INTENT(IN)            :: opInterval(2*numDim)
    INTEGER(KIND=4), INTENT(IN)            :: numStencils,numStencilValues
    INTEGER(KIND=4), INTENT(IN)            :: stencilSizes(numStencils)
    INTEGER(KIND=4), INTENT(IN)            :: stencilStarts(numStencils)
    INTEGER(KIND=4), INTENT(IN)            :: stencilOffsets(numStencilValues)
    INTEGER(KIND=4), INTENT(IN),    TARGET :: stencilID(numDim*numPoints)
    REAL(KIND=8),    INTENT(IN)            :: stencilWeights(numStencilValues)
    REAL(KIND=8),    INTENT(IN),    TARGET :: gridCoordinates(numDim*numPoints)
    REAL(KIND=8),    INTENT(INOUT), TARGET :: gridMetricTensor(numDim*numDim*numPoints)
    REAL(KIND=8),    INTENT(INOUT), TARGET :: gridJacobianDeterminants(2*numPoints)

    REAL(KIND=8),    DIMENSION(:), ALLOCATABLE :: dCoords
    REAL(KIND=8),    DIMENSION(:), POINTER     :: jacPtr, jacM1Ptr
    REAL(KIND=8),    DIMENSION(:), POINTER     :: m1Ptr
    REAL(KIND=8),    DIMENSION(:), POINTER     :: coordPtr
    INTEGER(KIND=4), DIMENSION(:), POINTER     :: stencilConnPtr

    INTEGER(KIND=4) :: numComponents, iDim
    INTEGER(KIND=8) :: offSet

    ALLOCATE(dCoords(numDim*numPoints))

    numComponents = 1
    iDim = 1
    jacM1Ptr => gridJacobianDeterminants(numPoints+1:2*numPoints)
    jacPtr => gridJacobianDeterminants(1:numPoints)

    IF(numDim == 1) THEN
       CALL APPLYOPERATOR(numDim, gridSizes, numComponents, numPoints, iDim, opInterval, &
            numStencils, stencilSizes, stencilStarts, numStencilValues,                  &
            stencilWeights, stencilOffsets, stencilID, gridCoordinates, jacPtr)

       ! Y = a/X
       CALL YAXM1(numDim,numPoints,gridSizes,opInterval,1.0_8,jacM1Ptr,jacPtr)

       ! X = a
       CALL ASSIGNMENTXA(numDim,numPoints,gridSizes,opInterval,1.0_8,gridMetricTensor)

   ELSE IF(numDim == 2) THEN

      iDim = 2 ! d(xi)/dx = dy/d(eta)
      coordPtr       => gridCoordinates(numPoints+1:numPoints+numPoints)
      m1Ptr          => gridMetricTensor(1:numPoints)
      jacPtr         => gridJacobianDeterminants(1:numPoints)
      jacM1Ptr       => gridJacobianDeterminants(1:numPoints)
      stencilConnPtr => stencilID(numPoints+1:numPoints+numPoints)

      ! calculate
      CALL APPLYOPERATOR(numDim,gridSizes,numComponents,numPoints,iDim,opInterval, &
           numStencils,stencilSizes,stencilStarts,numStencilValues,                &
           stencilWeights, stencilOffsets,stencilConnPtr,coordPtr,jacM1Ptr)

      ! 1/J = 1/dy
      CALL ASSIGNMENTYX(numDim,numPoints,gridSizes,opInterval,jacM1Ptr,m1Ptr)

      iDim = 1 ! d(eta)/dy = dx/d(xi)
      offSet         = 3*numPoints
      coordPtr       => gridCoordinates(1:numPoints)
      m1Ptr          => gridMetricTensor(offSet+1:offSet+numPoints)
      jacPtr         => gridJacobianDeterminants(1:numPoints)
      jacM1Ptr       => gridJacobianDeterminants(1:numPoints)
      stencilConnPtr => stencilID(1:numPoints)

      ! calculate 1/dx
      CALL APPLYOPERATOR(numDim,gridSizes,numComponents,numPoints,iDim,opInterval, &
           numStencils,stencilSizes,stencilStarts,numStencilValues,                &
           stencilWeights, stencilOffsets,stencilConnPtr,coordPtr,m1Ptr)

      ! 1/J = 1/dy * 1/dx
!      CALL YXY(numDim,numPoints,gridSizes,opInterval,jacM1Ptr,m1Ptr)

      iDim = 2 ! d(xi)/dy = -dx/d(eta)
      offSet        =  numPoints
      coordPtr      => gridCoordinates(numPoints+1:numPoints+numPoints)
      m1Ptr         => gridMetricTensor(offSet+1:offSet+numPoints)
      jacM1Ptr      => gridJacobianDeterminants(1:numPoints)

      ! calculate 1/dx
      CALL APPLYOPERATOR(numDim,gridSizes,numComponents,numPoints,iDim,opInterval, &
           numStencils,stencilSizes,stencilStarts,numStencilValues,                &
           stencilWeights, stencilOffsets,stencilConnPtr,coordPtr,m1Ptr)

      iDim = 1 ! d(eta)/dx = -dy/d(xi)

      offSet        =  numPoints
      coordPtr      => gridCoordinates(numPoints+1:numPoints+numPoints)
      m1Ptr         => gridMetricTensor(offSet+1:offSet+numPoints)
      jacM1Ptr      => gridJacobianDeterminants(1:numPoints)

      ! calculate 1/dx
      CALL APPLYOPERATOR(numDim,gridSizes,numComponents,numPoints,iDim,opInterval, &
           numStencils,stencilSizes,stencilStarts,numStencilValues,                &
           stencilWeights, stencilOffsets,stencilConnPtr,coordPtr,m1Ptr)

   ELSE IF(numDim == 3) THEN
   END IF

   DEALLOCATE(dCoords)

  END SUBROUTINE ComputeCurvilinearGridMetrics

  SUBROUTINE ApplyUniformGridMetric( &
       numDim, gridSizes, numPoints, &
       opInterval, gridMetric, vBuffer,vHat)

    IMPLICIT NONE

    INTEGER(KIND=4), INTENT(IN)  :: numDim
    INTEGER(KIND=8), INTENT(IN)  :: gridSizes(numDim),  numPoints
    INTEGER(KIND=8), INTENT(IN)  :: opInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)  :: gridMetric(numDim)
    REAL(KIND=8),    INTENT(IN)  :: vBuffer(numDim*numPoints)
    REAL(KIND=8),    INTENT(OUT) :: vHat(numDim*numPoints)

    INTEGER         :: iDim
    INTEGER(KIND=8) :: iPoint,iX,iY,iZ,iStart,iEnd,jStart,jEnd,kStart,kEnd
    INTEGER(KIND=8) :: xIndex,zIndex,yIndex,yzIndex,xSize,ySize,zSize
    INTEGER(KIND=8) :: iPoint2, iPoint3, nPlane, numPoints2, numPoints3
    REAL(KIND=8)    :: xMetric,yMetric,zMetric

    xSize   = gridSizes(1)
    iStart  = opInterval(1)
    iEnd    = opInterval(2)
    xMetric = gridMetric(1)

    IF( numDim == 1 ) THEN

       DO iX = iStart, iEnd
          vHat(iX) = xMetric*vBuffer(iX)
       END DO

    ELSE IF( numDim == 2 ) THEN

       yMetric = gridMetric(2)
       ySize = gridSizes(2)
       jStart = opInterval(3)
       jEnd   = opInterval(4)

       DO iY = jStart,jEnd
          yIndex = (iY-1)*xSize
          DO iX = iStart,iEnd
             iPoint = yIndex + iX
             iPoint2 = iPoint+numPoints
             vHat(iPoint)  = xMetric  * vBuffer(iPoint)
             vHat(iPoint2) = yMetric  * vBuffer(iPoint2)
          END DO
       END DO

    ELSE IF( numDim == 3 ) THEN

       yMetric = gridMetric(2)
       ySize   = gridSizes(2)
       jStart  = opInterval(3)
       jEnd    = opInterval(4)

       zMetric = gridMetric(3)
       zSize   = gridSizes(3)
       kStart  = opInterval(5)
       kEnd    = opInterval(6)

       nPlane     = xSize  * ySize
       numPoints2 = 2*numPoints

       DO iZ = kStart, kEnd
          zIndex = (iZ-1)*nPlane
          DO iY = jStart,jEnd
             yzIndex = zIndex + (iY-1)*xSize
             DO iX = iStart, iEnd
                iPoint  = yzIndex + iX
                iPoint2 = iPoint + numPoints
                iPoint3 = iPoint + numPoints2
                vHat(iPoint)  = xMetric * vBuffer(iPoint)
                vHat(iPoint2) = yMetric * vBuffer(iPoint2)
                vHat(iPoint3) = zMetric * vBuffer(iPoint3)
             END DO
          END DO
       END DO
    END IF

  END SUBROUTINE ApplyUniformGridMetric

  SUBROUTINE ApplyCartesianGridMetric( &
       numDim, gridSizes, numPoints,   &
       opInterval, gridMetric, vBuffer, vHat)

    IMPLICIT NONE

    INTEGER(KIND=4), INTENT(IN)  :: numDim
    INTEGER(KIND=8), INTENT(IN)  :: gridSizes(numDim),  numPoints
    INTEGER(KIND=8), INTENT(IN)  :: opInterval(2*numDim)
    REAL(KIND=8),    INTENT(IN)  :: gridMetric(numDim*numPoints)
    REAL(KIND=8),    INTENT(IN)  :: vBuffer(numDim*numPoints)
    REAL(KIND=8),    INTENT(OUT) :: vHat(numDim*numPoints)

    INTEGER         :: iDim
    INTEGER(KIND=8) :: iPoint,iX,iY,iZ,iStart,iEnd,jStart,jEnd,kStart,kEnd
    INTEGER(KIND=8) :: xIndex,zIndex,yIndex,yzIndex,xSize,ySize,zSize
    INTEGER(KIND=8) :: iPoint2, iPoint3, nPlane, numPoints2, numPoints3
    REAL(KIND=8)    :: xMetric,yMetric,zMetric

    xSize  = gridSizes(1)
    iStart = opInterval(1)
    iEnd   = opInterval(2)

    IF( numDim == 1 ) THEN

       DO iX = iStart, iEnd
          vHat(iX) = gridMetric(iX)*vBuffer(iPoint)
       END DO

    ELSE IF( numDim == 2 ) THEN

       ySize = gridSizes(2)
       jStart = opInterval(3)
       jEnd   = opInterval(4)

       DO iY = jStart,jEnd
          yIndex = (iY-1)*xSize
          DO iX = iStart,iEnd
             iPoint = yIndex + iX
             iPoint2 = iPoint+numPoints
             vHat(iPoint)  = gridMetric(iPoint)  * vBuffer(iPoint)
             vHat(iPoint2) = gridMetric(iPoint2) * vBuffer(iPoint2)
          END DO
       END DO

    ELSE IF( numDim == 3 ) THEN

       ySize  = gridSizes(2)
       jStart = opInterval(3)
       jEnd   = opInterval(4)

       zSize  = gridSizes(3)
       kStart = opInterval(5)
       kEnd   = opInterval(6)

       nPlane     = xSize  * ySize
       numPoints2 = 2*numPoints

       DO iZ = kStart, kEnd
          zIndex = (iZ-1)*nPlane
          DO iY = jStart,jEnd
             yzIndex = zIndex + (iY-1)*xSize
             DO iX = iStart, iEnd
                iPoint = yzIndex + iX
                iPoint2 = iPoint + numPoints
                iPoint3 = iPoint + numPoints2
                vHat(iPoint)  = gridMetric(iPoint)  * vBuffer(iPoint)
                vHat(iPoint2) = gridMetric(iPoint2) * vBuffer(iPoint2)
                vHat(iPoint3) = gridMetric(iPoint3) * vBuffer(iPoint3)
             END DO
          END DO
       END DO
    END IF

  END SUBROUTINE ApplyCartesianGridMetric

END MODULE Grid


submodule(euler_interface_m) euler_prob_0002_m
    implicit none

contains

    module character(len=20) function euler0002()
        write (euler0002, "(i20)") answer(4000000)
    end function euler0002

    function answer(n) result(ret)
        integer, intent(in) :: n
        integer :: ret, i

        i = 0; ret = 0
        do while (fibonacci(i) <= n)
            ret = ret + fibonacci(i)
            i = i + 3
        end do
    end function answer

end submodule euler_prob_0002_m


program vin
  integer :: val2(2,5), i, j, val3(2,5,10)

  do i = 1,5
    do j = 1,2
      val2(j,i) = mod(i * j, i + j)
    end do
  end do

!  print *, minloc(val2,dim=1)
  print *, minloc(val2,dim=1)
  print *, minloc(val2,dim=2)
  print *, minloc(val2(1,:),dim=1)
  print *, minloc(val2(:,1),dim=1)

  val3 = 30
  val3(2,1,1) = 50

  print *,minloc(val3,dim=3)
  print *,minloc(val3,dim=2)
  print *,minloc(val3,dim=1)
  print *,minloc(val3(:,1,1),dim=1)
  print *,minloc(val3(1,:,1),dim=1)
  print *,minloc(val3(1,1,:),dim=1)

  ! TODO: Yet to support
  !print *,minloc(val3(:,1,:),dim=2)

end program vin


SUBROUTINE mnbrak_sp(ax,bx,cx,fa,fb,fc,func)
  use mo_kind
  use mo_nrutil, ONLY : swap
  IMPLICIT NONE
  REAL(SP), INTENT(INOUT)   :: ax,bx
  REAL(SP), INTENT(OUT)     :: cx,fa,fb,fc
  INTERFACE
     FUNCTION func(x)
       use mo_kind
       IMPLICIT NONE
       REAL(SP), INTENT(IN) :: x
       REAL(SP)             :: func
     END FUNCTION func
  END INTERFACE
  REAL(SP), PARAMETER       :: GOLD=1.618034_sp,GLIMIT=100.0_sp,TINY=1.0e-20_sp
  REAL(SP)                  :: fu,q,r,u,ulim
  fa=func(ax)
  fb=func(bx)
  if (fb > fa) then
     call swap(ax,bx)
     call swap(fa,fb)
  end if
  cx=bx+GOLD*(bx-ax)
  fc=func(cx)
  do
     if (fb < fc) RETURN
     r=(bx-ax)*(fb-fc)
     q=(bx-cx)*(fb-fa)
     u=bx-((bx-cx)*q-(bx-ax)*r)/(2.0_sp*sign(max(abs(q-r),TINY),q-r))
     ulim=bx+GLIMIT*(cx-bx)
     if ((bx-u)*(u-cx) > 0.0) then
        fu=func(u)
        if (fu < fc) then
           ax=bx
           fa=fb
           bx=u
           fb=fu
           RETURN
        else if (fu > fb) then
           cx=u
           fc=fu
           RETURN
        end if
        u=cx+GOLD*(cx-bx)
        fu=func(u)
     else if ((cx-u)*(u-ulim) > 0.0) then
        fu=func(u)
        if (fu < fc) then
           bx=cx
           cx=u
           u=cx+GOLD*(cx-bx)
           call shft(fb,fc,fu,func(u))
        end if
     else if ((u-ulim)*(ulim-cx) >= 0.0) then
        u=ulim
        fu=func(u)
     else
        u=cx+GOLD*(cx-bx)
        fu=func(u)
     end if
     call shft(ax,bx,cx,u)
     call shft(fa,fb,fc,fu)
  end do
CONTAINS
  !BL
  SUBROUTINE shft(a,b,c,d)
    REAL(SP), INTENT(OUT)   :: a
    REAL(SP), INTENT(INOUT) :: b,c
    REAL(SP), INTENT(IN)    :: d
    a=b
    b=c
    c=d
  END SUBROUTINE shft
END SUBROUTINE mnbrak_sp

SUBROUTINE mnbrak_dp(ax,bx,cx,fa,fb,fc,func)
  use mo_kind
  use mo_nrutil, ONLY : swap
  IMPLICIT NONE
  REAL(DP), INTENT(INOUT)   :: ax,bx
  REAL(DP), INTENT(OUT)     :: cx,fa,fb,fc
  INTERFACE
     FUNCTION func(x)
       use mo_kind
       IMPLICIT NONE
       REAL(DP), INTENT(IN) :: x
       REAL(DP)             :: func
     END FUNCTION func
  END INTERFACE
  REAL(DP), PARAMETER       :: GOLD=1.618034_dp,GLIMIT=100.0_dp,TINY=1.0e-20_dp
  REAL(DP)                  :: fu,q,r,u,ulim
  fa=func(ax)
  fb=func(bx)
  if (fb > fa) then
     call swap(ax,bx)
     call swap(fa,fb)
  end if
  cx=bx+GOLD*(bx-ax)
  fc=func(cx)
  do
     if (fb < fc) RETURN
     r=(bx-ax)*(fb-fc)
     q=(bx-cx)*(fb-fa)
     u=bx-((bx-cx)*q-(bx-ax)*r)/(2.0_dp*sign(max(abs(q-r),TINY),q-r))
     ulim=bx+GLIMIT*(cx-bx)
     if ((bx-u)*(u-cx) > 0.0) then
        fu=func(u)
        if (fu < fc) then
           ax=bx
           fa=fb
           bx=u
           fb=fu
           RETURN
        else if (fu > fb) then
           cx=u
           fc=fu
           RETURN
        end if
        u=cx+GOLD*(cx-bx)
        fu=func(u)
     else if ((cx-u)*(u-ulim) > 0.0) then
        fu=func(u)
        if (fu < fc) then
           bx=cx
           cx=u
           u=cx+GOLD*(cx-bx)
           call shft(fb,fc,fu,func(u))
        end if
     else if ((u-ulim)*(ulim-cx) >= 0.0) then
        u=ulim
        fu=func(u)
     else
        u=cx+GOLD*(cx-bx)
        fu=func(u)
     end if
     call shft(ax,bx,cx,u)
     call shft(fa,fb,fc,fu)
  end do
CONTAINS
  !BL
  SUBROUTINE shft(a,b,c,d)
    REAL(DP), INTENT(OUT)   :: a
    REAL(DP), INTENT(INOUT) :: b,c
    REAL(DP), INTENT(IN)    :: d
    a=b
    b=c
    c=d
  END SUBROUTINE shft
END SUBROUTINE mnbrak_dp


      subroutine ndveccur(i1,i2,n,p,vcm)
      implicit none
C-----Author R.K. Ellis
C-----October 2005
C     Calculate the basic vector current current
C         <i1-|Gamma(mu)|i2->*n(mu)
C     and <i2-|Gamma(mu)|i1->*n(mu)
C
      include 'constants.f'
      integer i1,i2
      double precision p(mxpart,4),n(4),rtbp,rtpp
      double complex fac,c23b,c23p,fb,fp,vc(4),vcm(mxpart,mxpart)
         if (p(i1,4) .gt. 0d0) then
C-----positive energy case
            rtbp=dsqrt(p(i1,4)+p(i1,1))
            c23b=dcmplx(p(i1,3),-p(i1,2))
            fb=cone
         else
C-----negative energy case
            rtbp=dsqrt(-p(i1,4)-p(i1,1))
            c23b=dcmplx(-p(i1,3),p(i1,2))
            fb=im
         endif

         if (p(i2,4) .gt. 0d0) then
C-----positive energy case
            rtpp=dsqrt(p(i2,4)+p(i2,1))
            c23p=dcmplx(p(i2,3),-p(i2,2))
            fp=cone
         else
C-----negative energy case
            rtpp=dsqrt(-p(i2,4)-p(i2,1))
            c23p=dcmplx(-p(i2,3),p(i2,2))
            fp=im
         endif

      fac=fb*fp
      vc(3)=+fac
     . *(dcmplx(rtbp/rtpp)*dconjg(c23p)+dcmplx(rtpp/rtbp)*c23b)
      vc(2)=fac
     . *(-im*dcmplx(rtbp/rtpp)*dconjg(c23p)+im*dcmplx(rtpp/rtbp)*c23b)
      vc(1)=fac
     . *(dcmplx(rtbp*rtpp)-c23b*dconjg(c23p)/dcmplx(rtbp*rtpp))
      vc(4)=fac
     . *(dcmplx(rtbp*rtpp)+c23b*dconjg(c23p)/dcmplx(rtbp*rtpp))

      vcm(i1,i2)=n(4)*vc(4)-n(1)*vc(1)-n(2)*vc(2)-n(3)*vc(3)

      vc(3)=fac
     . *(dcmplx(rtbp/rtpp)*c23p+dcmplx(rtpp/rtbp)*dconjg(c23b))
      vc(2)=fac
     . *(im*(dcmplx(rtbp/rtpp))*c23p-im*dcmplx(rtpp/rtbp)*dconjg(c23b))
      vc(1)=fac
     . *(dcmplx(rtbp*rtpp)-dconjg(c23b)*c23p/dcmplx(rtbp*rtpp))
      vc(4)=fac
     . *(dcmplx(rtbp*rtpp)+dconjg(c23b)*c23p/dcmplx(rtbp*rtpp))

      vcm(i2,i1)=n(4)*vc(4)-n(1)*vc(1)-n(2)*vc(2)-n(3)*vc(3)
c      write(6,*) 'vcm(i1,i2)',vcm(i1,i2)
c      write(6,*) 'vcm(i2,i1)',vcm(i2,i1)
      return
      end


      SUBROUTINE MB04IY( SIDE, TRANS, N, M, K, P, A, LDA, TAU, C, LDC,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To overwrite the real n-by-m matrix  C  with  Q' * C,  Q * C,
C     C * Q',  or  C * Q,  according to the following table
C
C                     SIDE = 'L'     SIDE = 'R'
C     TRANS = 'N':      Q * C          C * Q
C     TRANS = 'T':      Q'* C          C * Q'
C
C     where  Q  is a real orthogonal matrix defined as the product of
C     k elementary reflectors
C
C        Q = H(1) H(2) . . . H(k)
C
C     as returned by SLICOT Library routine MB04ID.  Q  is of order n
C     if  SIDE = 'L'  and of order m if  SIDE = 'R'.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SIDE    CHARACTER*1
C             Specify if  Q  or  Q'  is applied from the left or right,
C             as follows:
C             = 'L':  apply  Q  or  Q'  from the left;
C             = 'R':  apply  Q  or  Q'  from the right.
C
C     TRANS   CHARACTER*1
C             Specify if  Q  or  Q'  is to be applied, as follows:
C             = 'N':  apply  Q   (No transpose);
C             = 'T':  apply  Q'  (Transpose).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of rows of the matrix C.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrix C.  M >= 0.
C
C     K       (input) INTEGER
C             The number of elementary reflectors whose product defines
C             the matrix Q.
C             N >= K >= 0,  if  SIDE = 'L';
C             M >= K >= 0,  if  SIDE = 'R'.
C
C     P       (input) INTEGER
C             The order of the zero triagle (or the number of rows of
C             the zero trapezoid) in the matrix triangularized by SLICOT
C             Library routine MB04ID.  P >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,K)
C             On input, the elements in the rows  i+1:min(n,n-p-1+i)  of
C             the  i-th  column, and  TAU(i),  represent the orthogonal
C             reflector  H(i),  so that matrix  Q  is the product of
C             elementary reflectors:  Q = H(1) H(2) . . . H(k).
C             A is modified by the routine but restored on exit.
C
C     LDA     INTEGER
C             The leading dimension of the array  A.
C             LDA >= max(1,N),  if  SIDE = 'L';
C             LDA >= max(1,M),  if  SIDE = 'R'.
C
C     TAU     (input) DOUBLE PRECISION array, dimension (K)
C             The scalar factors of the elementary reflectors.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,M)
C             On entry, the leading N-by-M part of this array must
C             contain the matrix  C.
C             On exit, the leading N-by-M part of this array contains
C             the updated matrix C.
C
C     LDC     INTEGER
C             The leading dimension of the array  C.  LDC >= max(1,N).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,M),  if  SIDE = 'L';
C             LDWORK >= MAX(1,N),  if  SIDE = 'R'.
C             For optimum performance LDWORK >= M*NB if SIDE = 'L',
C             or LDWORK >= N*NB if SIDE = 'R', where NB is the optimal
C             block size.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     If  SIDE = 'L',  each elementary reflector  H(i)  modifies
C     n-p  elements of each column of  C,  for  i = 1:p+1,  and
C     n-i+1  elements, for  i = p+2:k.
C     If  SIDE = 'R',  each elementary reflector  H(i)  modifies
C     m-p  elements of each row of  C,  for  i = 1:p+1,  and
C     m-i+1  elements, for  i = p+2:k.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically stable.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Matrix operations, QR decomposition.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
C     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, LDC, LDWORK, M, N, P
      CHARACTER          SIDE, TRANS
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), DWORK( * ), TAU( * )
C     .. Local Scalars ..
      LOGICAL            LEFT, TRAN
      INTEGER            I
      DOUBLE PRECISION   AII, WRKOPT
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           DLARF, DORMQR, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, MIN
C     .. Executable Statements ..
C
C     Check the scalar input arguments.
C
      INFO = 0
      LEFT = LSAME( SIDE,  'L' )
      TRAN = LSAME( TRANS, 'T' )
C
      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( K.LT.0 .OR. ( LEFT .AND. K.GT.N ) .OR.
     $                ( .NOT.LEFT .AND. K.GT.M ) ) THEN
         INFO = -5
      ELSE IF( P.LT.0 ) THEN
         INFO = -6
      ELSE IF( ( LEFT .AND. LDA.LT.MAX( 1, N ) ) .OR.
     $    ( .NOT.LEFT .AND. LDA.LT.MAX( 1, M ) ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( ( LEFT .AND. LDWORK.LT.MAX( 1, M ) ) .OR.
     $    ( .NOT.LEFT .AND. LDWORK.LT.MAX( 1, N ) ) ) THEN
         INFO = -13
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04IY', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 .OR. ( LEFT .AND. N.LT.P )
     $           .OR. ( .NOT.LEFT .AND. M.LT.P ) ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      IF( LEFT ) THEN
         WRKOPT = DBLE( M )
         IF( TRAN ) THEN
C
            DO 10 I = 1, MIN( K, P )
C
C              Apply H(i) to C(i:i+n-p-1,1:m), from the left.
C              Workspace: need M.
C
               AII = A( I, I )
               A( I, I ) = ONE
               CALL DLARF( SIDE, N-P, M, A( I, I ), 1, TAU( I ),
     $                     C( I, 1 ), LDC, DWORK )
               A( I, I ) = AII
   10       CONTINUE
C
            IF ( P.LE.MIN( N, K ) ) THEN
C
C              Apply H(i) to C, i = p+1:k, from the left.
C              Workspace: need M;  prefer M*NB.
C
               CALL DORMQR( SIDE, TRANS, N-P, M, K-P, A( P+1, P+1 ),
     $                      LDA, TAU( P+1 ), C( P+1, 1 ), LDC, DWORK,
     $                      LDWORK, I )
               WRKOPT = MAX( WRKOPT, DWORK( 1 ) )
            END IF
C
         ELSE
C
            IF ( P.LE.MIN( N, K ) ) THEN
C
C              Apply H(i) to C, i = k:p+1:-1, from the left.
C              Workspace: need M;  prefer M*NB.
C
               CALL DORMQR( SIDE, TRANS, N-P, M, K-P, A( P+1, P+1 ),
     $                      LDA, TAU( P+1 ), C( P+1, 1 ), LDC, DWORK,
     $                      LDWORK, I )
               WRKOPT = MAX( WRKOPT, DWORK( 1 ) )
            END IF
C
            DO 20 I = MIN( K, P ), 1, -1
C
C              Apply H(i) to C(i:i+n-p-1,1:m), from the left.
C              Workspace: need M.
C
               AII = A( I, I )
               A( I, I ) = ONE
               CALL DLARF( SIDE, N-P, M, A( I, I ), 1, TAU( I ),
     $                     C( I, 1 ), LDC, DWORK )
               A( I, I ) = AII
   20       CONTINUE
         END IF
C
      ELSE
C
         WRKOPT = DBLE( N )
         IF( TRAN ) THEN
C
            IF ( P.LE.MIN( M, K ) ) THEN
C
C              Apply H(i) to C, i = k:p+1:-1, from the right.
C              Workspace: need N;  prefer N*NB.
C
               CALL DORMQR( SIDE, TRANS, N, M-P, K-P, A( P+1, P+1 ),
     $                      LDA, TAU( P+1 ), C( 1, P+1 ), LDC, DWORK,
     $                      LDWORK, I )
               WRKOPT = MAX( WRKOPT, DWORK( 1 ) )
            END IF
C
            DO 30 I = MIN( K, P ), 1, -1
C
C              Apply H(i) to C(1:n,i:i+m-p-1), from the right.
C              Workspace: need N.
C
               AII = A( I, I )
               A( I, I ) = ONE
               CALL DLARF( SIDE, N, M-P, A( I, I ), 1, TAU( I ),
     $                     C( 1, I ), LDC, DWORK )
               A( I, I ) = AII
   30       CONTINUE
C
         ELSE
C
            DO 40 I = 1, MIN( K, P )
C
C              Apply H(i) to C(1:n,i:i+m-p-1), from the right.
C              Workspace: need N.
C
               AII = A( I, I )
               A( I, I ) = ONE
               CALL DLARF( SIDE, N, M-P, A( I, I ), 1, TAU( I ),
     $                     C( 1, I ), LDC, DWORK )
               A( I, I ) = AII
   40       CONTINUE
C
            IF ( P.LE.MIN( M, K ) ) THEN
C
C              Apply H(i) to C, i = p+1:k, from the right.
C              Workspace: need N;  prefer N*NB.
C
               CALL DORMQR( SIDE, TRANS, N, M-P, K-P, A( P+1, P+1 ),
     $                      LDA, TAU( P+1 ), C( 1, P+1 ), LDC, DWORK,
     $                      LDWORK, I )
               WRKOPT = MAX( WRKOPT, DWORK( 1 ) )
            END IF
C
         END IF
      END IF
C
      DWORK( 1 ) = WRKOPT
      RETURN
C
C *** Last line of MB04IY ***
      END


      subroutine runCY_0000(k,l,Xtwiddle,Gtwiddle,Shat4zz,N0)
      implicit none
C---  Expression for C0000 obtained from 5.50, following the comment after
C     5.50 on how to add adcing adcitional "00" pairs
C---  Calculates C0000
C---  Small terms of order Xtwiddle(0,k)*C00i,Xtwiddle(0,0)*C00ii
C---  Denominator Gtwiddle(k,l)
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat4zz(np,z1max,-2:0)

      do ep=-2,0
         Cv(cc0000+N0,ep) =
     .    -(-(Gtwiddle(k,1)*Shat4zz(1,l,ep)
     .    +Gtwiddle(k,2)*Shat4zz(2,l,ep)
     .    +Xtwiddle(k,0)*Cv(czzi(l)+N0,ep)
     .    -Xtwiddle(0,0)*Cv(czzii(z2(k,l))+N0,ep)
     .        ))/(2d0*Gtwiddle(k,l))

      enddo

      return
      end


module vf1

        implicit none

contains

        subroutine step(f1, f2, model_padded2_dt2, nxi, dx, dt,        &
                        sources, sources_x, sources_y, sources_z,      &
                        num_steps)

                real, intent (in out), dimension (:, :, :) :: f1
                real, intent (in out), dimension (:, :, :) :: f2
                real, intent (in), dimension (:, :, :) ::              &
                        model_padded2_dt2
                integer, intent (in) :: nxi
                real, intent (in) :: dx
                real, intent (in) :: dt
                real, intent (in), dimension (:, :) :: sources
                integer, intent (in), dimension (:) :: sources_x
                integer, intent (in), dimension (:) :: sources_y
                integer, intent (in), dimension (:) :: sources_z
                integer, intent (in) :: num_steps

                integer :: step_idx
                logical :: even
                real, dimension(9) :: fd_coeff

                fd_coeff = (/                                          &
                        -924708642.0 / 302702400 / (dx * dx),          &
                        538137600.0 / 302702400 / (dx * dx),           &
                        -94174080.0 / 302702400 / (dx * dx),           &
                        22830080.0 / 302702400 / (dx * dx),            &
                        -5350800.0 / 302702400 / (dx * dx),            &
                        1053696.0 / 302702400 / (dx * dx),             &
                        -156800.0 / 302702400 / (dx * dx),             &
                        15360.0 / 302702400 / (dx * dx),               &
                        -735.0 / 302702400 / (dx * dx)                 &
                        /)

                do step_idx = 1, num_steps
                even = (mod (step_idx, 2) == 0)
                if (even) then
                        call step_inner(f2, f1, model_padded2_dt2, nxi,&
                                dt, sources, sources_x, sources_y,     &
                                sources_z, step_idx, fd_coeff)
                else
                        call step_inner(f1, f2, model_padded2_dt2, nxi,&
                                dt, sources, sources_x, sources_y,     &
                                sources_z, step_idx, fd_coeff)
                end if
                end do

        end subroutine step

        subroutine step_inner(f, fp, model_padded2_dt2, nxi, dt,       &
                        sources, sources_x, sources_y, sources_z,      &
                        step_idx, fd_coeff)

                real, intent (in), dimension (:, :, :) :: f
                real, intent (in out), dimension (:, :, :) :: fp
                real, intent (in), dimension (:, :, :) ::              &
                        model_padded2_dt2
                integer, intent (in) :: nxi
                real, intent (in) :: dt
                real, intent (in), dimension (:, :) :: sources
                integer, intent (in), dimension (:) :: sources_x
                integer, intent (in), dimension (:) :: sources_y
                integer, intent (in), dimension (:) :: sources_z
                integer, intent (in) :: step_idx
                real, intent (in), dimension (9) :: fd_coeff

                integer :: x
                integer :: y
                integer :: z
                integer :: i
                integer :: sx
                integer :: sy
                integer :: sz
                integer :: ny
                integer :: nz
                integer :: num_sources
                real :: f_xx

                ny = size(f, dim=2)
                nz = size(f, dim=3)
                num_sources = size(sources, dim=2)

                do z = 9, nz - 8
                do y = 9, ny - 8
                do x = 9, nxi + 8
                f_xx = 3 * fd_coeff(1) * f(x, y, z)
                do i = 1, 8
                f_xx = f_xx + fd_coeff(i + 1) *                        &
                        (f(x + i, y, z) + f(x - i, y, z) +             &
                        f(x, y + i, z) + f(x, y - i, z) +              &
                        f(x, y, z + i) + f(x, y, z - i))
                end do
                fp(x, y, z) = (model_padded2_dt2(x, y, z) * f_xx +     &
                        2 * f(x, y, z) - fp(x, y, z))
                end do
                end do
                end do

                do i = 1, num_sources
                sx = sources_x(i) + 9
                sy = sources_y(i) + 9
                sz = sources_z(i) + 9
                fp(sx, sy, sz) = fp(sx, sy, sz) +                      &
                        model_padded2_dt2(sx, sy, sz) *                &
                        sources(step_idx, i) * dt
                end do

        end subroutine step_inner

end module vf1


program inverse
use cholesky
use cudafor
use cublas
use nvtx
integer, parameter :: n=1024
complex(8):: A_h(n,n),B_h(n,n)
complex(8),device :: B(n,n)

real*8:: x,y,threshold=1.d-14
integer:: info
type(dim3):: threads
type(cudaEvent):: startEvent,stopEvent
type(cusolverDnHandle):: h
real:: time
logical:: print=.false.

istat=cudaEventCreate(startEvent)
istat=cudaEventCreate(stopEvent)

! Generate hermitian positive definite matrix

do j=1,n
 do i=j,n
  call random_number(x)
  call random_number(y)
  A_h(i,j)=cmplx(x,y)
  A_h(j,i)=conjg(A_h(i,j))
  if (i==j) A_h(i,j)=real(A_h(i,j))
 end do
end do

call zgemm('N', 'C', N, N, N, cmplx(1.0, 0.0, 8), A_h, N, A_h, N, cmplx(0.0, 0.0, 8), B_h, N)
A_h=B_h

!A_h is an hermitian positive definite matrix

! Copy the matrix to the device
B=A_h

print *,"calling CPU zpotrf and ztrtri"
! Call Cholesky
call nvtxStartRange("zportf CPU",1)
call zpotrf('L', n, A_h, n, INFO )
call nvtxEndRange
! Compute the inverse
call nvtxStartRange("ztrtri CPU",2)
CALL ztrtri( 'L', 'N', n, A_h, n, INFO )
call nvtxEndRange

if (info .lt.  0) print *,"Error in CPU path !!!!!!!!!!!!!",info

print *,"calling GPU zpotrf and ztrtri"
! Call Cholesky
call nvtxStartRange("zportf GPU",1)
call zpotrf('L', n, B, n, INFO )
call nvtxEndRange
! Compute the inverse
call nvtxStartRange("ztrtri GPU",2)
CALL ZTRTRI( 'L', 'N', n, B, n, INFO )
B_h=B
call nvtxEndRange
if (info .lt.  0) print *,"Error in GPU path !!!!!!!!!!!!!",info

! Copy result back to host to compare it to CPU solution

print *,"Difference "
   print *,(B_h(1,1)-A_h(1,1))
   print *,(B_h(n/2,n/2)-A_h(n/2,n/2))
   print *,(B_h(n,n)-A_h(n,n))
end program inverse


program main
  use cublas
  implicit none
  integer, parameter :: N = 2**20
  real, dimension(N) :: X, Y
  real:: nrm2
  type(cublasHandle) :: h
  integer :: istat

  istat = cublasCreate(h)
  if (istat .ne. CUBLAS_STATUS_SUCCESS) print *,istat

  !$acc data create(x,y)
  !$acc kernels
  X(:) = 1.0
  Y(:) = 0.0
  !$acc end kernels

  !$acc host_data use_device(x,y)
  call cublassaxpy(N, 2.0, x, 1, y, 1)
  istat = cublasSnrm2_v2(h, N, x, 1, nrm2)
  if (istat .ne. CUBLAS_STATUS_SUCCESS) print *,istat
  !$acc end host_data

  !$acc update self(y)
  !$acc end data

  istat = cublasDestroy(h)
  print *, y(1)
  print*,nrm2
end program


*> \brief  CGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CGEGS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE CGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA,
*                         VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK,
*                         INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          JOBVSL, JOBVSR
*       INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N
*       ..
*       .. Array Arguments ..
*       REAL               RWORK( * )
*       COMPLEX            A( LDA, * ), ALPHA( * ), B( LDB, * ),
*      $                   BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ),
*      $                   WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> This routine is deprecated and has been replaced by routine CGGES.
*>
*> CGEGS computes the eigenvalues, Schur form, and, optionally, the
*> left and or/right Schur vectors of a complex matrix pair (A,B).
*> Given two square matrices A and B, the generalized Schur
*> factorization has the form
*>
*>    A = Q*S*Z**H,  B = Q*T*Z**H
*>
*> where Q and Z are unitary matrices and S and T are upper triangular.
*> The columns of Q are the left Schur vectors
*> and the columns of Z are the right Schur vectors.
*>
*> If only the eigenvalues of (A,B) are needed, the driver routine
*> CGEGV should be used instead.  See CGEGV for a description of the
*> eigenvalues of the generalized nonsymmetric eigenvalue problem
*> (GNEP).
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] JOBVSL
*> \verbatim
*>          JOBVSL is CHARACTER*1
*>          = 'N':  do not compute the left Schur vectors;
*>          = 'V':  compute the left Schur vectors (returned in VSL).
*> \endverbatim
*>
*> \param[in] JOBVSR
*> \verbatim
*>          JOBVSR is CHARACTER*1
*>          = 'N':  do not compute the right Schur vectors;
*>          = 'V':  compute the right Schur vectors (returned in VSR).
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrices A, B, VSL, and VSR.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX array, dimension (LDA, N)
*>          On entry, the matrix A.
*>          On exit, the upper triangular matrix S from the generalized
*>          Schur factorization.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is COMPLEX array, dimension (LDB, N)
*>          On entry, the matrix B.
*>          On exit, the upper triangular matrix T from the generalized
*>          Schur factorization.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] ALPHA
*> \verbatim
*>          ALPHA is COMPLEX array, dimension (N)
*>          The complex scalars alpha that define the eigenvalues of
*>          GNEP.  ALPHA(j) = S(j,j), the diagonal element of the Schur
*>          form of A.
*> \endverbatim
*>
*> \param[out] BETA
*> \verbatim
*>          BETA is COMPLEX array, dimension (N)
*>          The non-negative real scalars beta that define the
*>          eigenvalues of GNEP.  BETA(j) = T(j,j), the diagonal element
*>          of the triangular factor T.
*>
*>          Together, the quantities alpha = ALPHA(j) and beta = BETA(j)
*>          represent the j-th eigenvalue of the matrix pair (A,B), in
*>          one of the forms lambda = alpha/beta or mu = beta/alpha.
*>          Since either lambda or mu may overflow, they should not,
*>          in general, be computed.
*> \endverbatim
*>
*> \param[out] VSL
*> \verbatim
*>          VSL is COMPLEX array, dimension (LDVSL,N)
*>          If JOBVSL = 'V', the matrix of left Schur vectors Q.
*>          Not referenced if JOBVSL = 'N'.
*> \endverbatim
*>
*> \param[in] LDVSL
*> \verbatim
*>          LDVSL is INTEGER
*>          The leading dimension of the matrix VSL. LDVSL >= 1, and
*>          if JOBVSL = 'V', LDVSL >= N.
*> \endverbatim
*>
*> \param[out] VSR
*> \verbatim
*>          VSR is COMPLEX array, dimension (LDVSR,N)
*>          If JOBVSR = 'V', the matrix of right Schur vectors Z.
*>          Not referenced if JOBVSR = 'N'.
*> \endverbatim
*>
*> \param[in] LDVSR
*> \verbatim
*>          LDVSR is INTEGER
*>          The leading dimension of the matrix VSR. LDVSR >= 1, and
*>          if JOBVSR = 'V', LDVSR >= N.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK.  LWORK >= max(1,2*N).
*>          For good performance, LWORK must generally be larger.
*>          To compute the optimal value of LWORK, call ILAENV to get
*>          blocksizes (for CGEQRF, CUNMQR, and CUNGQR.)  Then compute:
*>          NB  -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR;
*>          the optimal LWORK is N*(NB+1).
*>
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the WORK array, and no error
*>          message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension (3*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
*>          =1,...,N:
*>                The QZ iteration failed.  (A,B) are not in Schur
*>                form, but ALPHA(j) and BETA(j) should be correct for
*>                j=INFO+1,...,N.
*>          > N:  errors that usually indicate LAPACK problems:
*>                =N+1: error return from CGGBAL
*>                =N+2: error return from CGEQRF
*>                =N+3: error return from CUNMQR
*>                =N+4: error return from CUNGQR
*>                =N+5: error return from CGGHRD
*>                =N+6: error return from CHGEQZ (other than failed
*>                                               iteration)
*>                =N+7: error return from CGGBAK (computing VSL)
*>                =N+8: error return from CGGBAK (computing VSR)
*>                =N+9: error return from CLASCL (various places)
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complexGEeigen
*
*  =====================================================================
      SUBROUTINE CGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA,
     $                  VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK,
     $                  INFO )
*
*  -- LAPACK driver routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          JOBVSL, JOBVSR
      INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N
*     ..
*     .. Array Arguments ..
      REAL               RWORK( * )
      COMPLEX            A( LDA, * ), ALPHA( * ), B( LDB, * ),
     $                   BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ),
     $                   WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
      COMPLEX            CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0E0, 0.0E0 ),
     $                   CONE = ( 1.0E0, 0.0E0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY
      INTEGER            ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT,
     $                   ILO, IRIGHT, IROWS, IRWORK, ITAU, IWORK,
     $                   LOPT, LWKMIN, LWKOPT, NB, NB1, NB2, NB3
      REAL               ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
     $                   SAFMIN, SMLNUM
*     ..
*     .. External Subroutines ..
      EXTERNAL           CGEQRF, CGGBAK, CGGBAL, CGGHRD, CHGEQZ, CLACPY,
     $                   CLASCL, CLASET, CUNGQR, CUNMQR, XERBLA
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      REAL               CLANGE, SLAMCH
      EXTERNAL           ILAENV, LSAME, CLANGE, SLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX
*     ..
*     .. Executable Statements ..
*
*     Decode the input arguments
*
      IF( LSAME( JOBVSL, 'N' ) ) THEN
         IJOBVL = 1
         ILVSL = .FALSE.
      ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
         IJOBVL = 2
         ILVSL = .TRUE.
      ELSE
         IJOBVL = -1
         ILVSL = .FALSE.
      END IF
*
      IF( LSAME( JOBVSR, 'N' ) ) THEN
         IJOBVR = 1
         ILVSR = .FALSE.
      ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
         IJOBVR = 2
         ILVSR = .TRUE.
      ELSE
         IJOBVR = -1
         ILVSR = .FALSE.
      END IF
*
*     Test the input arguments
*
      LWKMIN = MAX( 2*N, 1 )
      LWKOPT = LWKMIN
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      INFO = 0
      IF( IJOBVL.LE.0 ) THEN
         INFO = -1
      ELSE IF( IJOBVR.LE.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
         INFO = -11
      ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
         INFO = -13
      ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
         INFO = -15
      END IF
*
      IF( INFO.EQ.0 ) THEN
         NB1 = ILAENV( 1, 'CGEQRF', ' ', N, N, -1, -1 )
         NB2 = ILAENV( 1, 'CUNMQR', ' ', N, N, N, -1 )
         NB3 = ILAENV( 1, 'CUNGQR', ' ', N, N, N, -1 )
         NB = MAX( NB1, NB2, NB3 )
         LOPT = N*(NB+1)
         WORK( 1 ) = LOPT
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGEGS ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Get machine constants
*
      EPS = SLAMCH( 'E' )*SLAMCH( 'B' )
      SAFMIN = SLAMCH( 'S' )
      SMLNUM = N*SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
*
*     Scale A if max element outside range [SMLNUM,BIGNUM]
*
      ANRM = CLANGE( 'M', N, N, A, LDA, RWORK )
      ILASCL = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         ANRMTO = SMLNUM
         ILASCL = .TRUE.
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         ANRMTO = BIGNUM
         ILASCL = .TRUE.
      END IF
*
      IF( ILASCL ) THEN
         CALL CLASCL( 'G', -1, -1, ANRM, ANRMTO, N, N, A, LDA, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 9
            RETURN
         END IF
      END IF
*
*     Scale B if max element outside range [SMLNUM,BIGNUM]
*
      BNRM = CLANGE( 'M', N, N, B, LDB, RWORK )
      ILBSCL = .FALSE.
      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
         BNRMTO = SMLNUM
         ILBSCL = .TRUE.
      ELSE IF( BNRM.GT.BIGNUM ) THEN
         BNRMTO = BIGNUM
         ILBSCL = .TRUE.
      END IF
*
      IF( ILBSCL ) THEN
         CALL CLASCL( 'G', -1, -1, BNRM, BNRMTO, N, N, B, LDB, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 9
            RETURN
         END IF
      END IF
*
*     Permute the matrix to make it more nearly triangular
*
      ILEFT = 1
      IRIGHT = N + 1
      IRWORK = IRIGHT + N
      IWORK = 1
      CALL CGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ),
     $             RWORK( IRIGHT ), RWORK( IRWORK ), IINFO )
      IF( IINFO.NE.0 ) THEN
         INFO = N + 1
         GO TO 10
      END IF
*
*     Reduce B to triangular form, and initialize VSL and/or VSR
*
      IROWS = IHI + 1 - ILO
      ICOLS = N + 1 - ILO
      ITAU = IWORK
      IWORK = ITAU + IROWS
      CALL CGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
     $             WORK( IWORK ), LWORK+1-IWORK, IINFO )
      IF( IINFO.GE.0 )
     $   LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
      IF( IINFO.NE.0 ) THEN
         INFO = N + 2
         GO TO 10
      END IF
*
      CALL CUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
     $             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ),
     $             LWORK+1-IWORK, IINFO )
      IF( IINFO.GE.0 )
     $   LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
      IF( IINFO.NE.0 ) THEN
         INFO = N + 3
         GO TO 10
      END IF
*
      IF( ILVSL ) THEN
         CALL CLASET( 'Full', N, N, CZERO, CONE, VSL, LDVSL )
         CALL CLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
     $                VSL( ILO+1, ILO ), LDVSL )
         CALL CUNGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
     $                WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK,
     $                IINFO )
         IF( IINFO.GE.0 )
     $      LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 4
            GO TO 10
         END IF
      END IF
*
      IF( ILVSR )
     $   CALL CLASET( 'Full', N, N, CZERO, CONE, VSR, LDVSR )
*
*     Reduce to generalized Hessenberg form
*
      CALL CGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
     $             LDVSL, VSR, LDVSR, IINFO )
      IF( IINFO.NE.0 ) THEN
         INFO = N + 5
         GO TO 10
      END IF
*
*     Perform QZ algorithm, computing Schur vectors if desired
*
      IWORK = ITAU
      CALL CHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
     $             ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK( IWORK ),
     $             LWORK+1-IWORK, RWORK( IRWORK ), IINFO )
      IF( IINFO.GE.0 )
     $   LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
      IF( IINFO.NE.0 ) THEN
         IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN
            INFO = IINFO
         ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN
            INFO = IINFO - N
         ELSE
            INFO = N + 6
         END IF
         GO TO 10
      END IF
*
*     Apply permutation to VSL and VSR
*
      IF( ILVSL ) THEN
         CALL CGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ),
     $                RWORK( IRIGHT ), N, VSL, LDVSL, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 7
            GO TO 10
         END IF
      END IF
      IF( ILVSR ) THEN
         CALL CGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ),
     $                RWORK( IRIGHT ), N, VSR, LDVSR, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 8
            GO TO 10
         END IF
      END IF
*
*     Undo scaling
*
      IF( ILASCL ) THEN
         CALL CLASCL( 'U', -1, -1, ANRMTO, ANRM, N, N, A, LDA, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 9
            RETURN
         END IF
         CALL CLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHA, N, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 9
            RETURN
         END IF
      END IF
*
      IF( ILBSCL ) THEN
         CALL CLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 9
            RETURN
         END IF
         CALL CLASCL( 'G', -1, -1, BNRMTO, BNRM, N, 1, BETA, N, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = N + 9
            RETURN
         END IF
      END IF
*
   10 CONTINUE
      WORK( 1 ) = LWKOPT
*
      RETURN
*
*     End of CGEGS
*
      END


Subroutine hboost
  Implicit Double Precision (D)
  Common /lujets/n, k(9000, 5), p(9000, 5), v(9000, 5)
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Save
  Do i = 1, n
    dbeta = dble(p(i,3)/p(i,4))
    If (abs(dbeta)>=1.D0) Then
      db = dble(hint1(2))
      If (db>0.99999999D0) Then
        Write (6, *) '(HIBOOT:) boost vector too large'
        db = 0.99999999D0
      End If
      dga = 1D0/sqrt(1D0-db**2)
      dp3 = dble(p(i,3))
      dp4 = dble(p(i,4))
      p(i, 3) = sngl((dp3+db*dp4)*dga)
      p(i, 4) = sngl((dp4+db*dp3)*dga)
      Goto 100
    End If
    y = 0.5*sngl(dlog((1.D0+dbeta)/(1.D0-dbeta)))
    amt = sqrt(p(i,1)**2+p(i,2)**2+p(i,5)**2)
    p(i, 3) = amt*sinh(y+hint1(3))
    p(i, 4) = amt*cosh(y+hint1(3))
  100 End Do
  Return
End Subroutine hboost


Subroutine cropro(vx1, vy1, vz1, vx2, vy2, vz2)
  Implicit Double Precision (A-H, O-Z)
  Common /cprod/vx3, vy3, vz3
  Save
  vx3 = vy1*vz2 - vz1*vy2
  vy3 = vz1*vx2 - vx1*vz2
  vz3 = vx1*vy2 - vy1*vx2
  Return
End Subroutine cropro


        PROGRAM TDEX06
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
        PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C This example shows how a user can directly generate the list of
C triangles defining a surface and then render the surface using
C TDPACK routines.
C
C Consider the surface defined by the following equations (for values
C of u and v between 0 and 2 pi).
C
C     R (A,U,V) = A * [ COS(U) + COS(U-V) ] + B
C   PHI (A,U,V) = V
C     Z (A,U,V) = A * [ SIN(U) + SIN(U-V) ]
C
C where R, PHI, and Z are the usual cylindrical coordinates (radius,
C angle, and height).
C
C 0 < A < 1 is the range of interest and B is any convenient value
C greater than A.
C
C Define A, B, and the sum of the two for scaling.
C
        PARAMETER (A=1.,B=3.,BMIN=-A-B,BMAX=+A+B)
C
C Define a parameter specifying the maximum size of the array required
C for the list of triangles.
C
        PARAMETER (MTRI=100000)
C
C Define values of pi, two times pi, and pi over 180.
C
        PARAMETER (PI=3.14159265358979323846,TWOPI=2.*PI,DTOR=PI/180.)
C
C Declare a local array to hold the triangle list and a couple of
C temporary variables to be used in sorting the list.
C
        DIMENSION RTRI(10,MTRI),RTWK(MTRI,2),ITWK(MTRI)
C
C Declare variables to hold labels.
C
        CHARACTER*64 XNLB,YNLB,ZNLB,XILB,YILB,ZILB
C
C Set the desired minimum and maximum values of U and V (for the grid
C over which the surface is generated).
C
        DATA UMIN,UMAX /  0. , TWOPI /
        DATA VMIN,VMAX /  0. , TWOPI /
C
C Set the desired minimum and maximum values of X, Y, and Z.
C
        DATA XMIN,XMAX / BMIN , BMAX /
        DATA YMIN,YMAX / BMIN , BMAX /
        DATA ZMIN,ZMAX / BMIN , BMAX /
C
C Set the values determining the resolution of the grid over which the
C surface is generated.  Note that, if each of IDIM and JDIM is one more
C than a multiple of 12, the assignment of rendering styles works out
C best.
C
        DATA IDIM,JDIM / 109 , 109 /
C
C Set the desired values of parameters determining the eye position.
C ANG1 is a bearing angle, ANG2 is an elevation angle, and RMUL is a
C multiplier of the length of the diagonal of the data box, specifying
C the distance from the center of the box to the eye.
C
        DATA ANG1,ANG2,RMUL / 215. , 35. , 2.9 /
C
C ISTE is a flag that says whether to do a simple image (ISTE=0),
C a one-frame stereo image (ISTE=-1), or a two-frame stereo image
C (ISTE=+1).
C
        DATA ISTE / -1 /
C
C ASTE is the desired angle (in degrees) between the lines of sight for
C a pair of stereo views.
C
        DATA ASTE / 4. /
C
C WOSW is the width of the stereo windows to be used in one-frame stereo
C images; the width is stated as a fraction of the width of the plotter
C frame.  (The windows are centered vertically; horizontally, they are
C placed as far apart as possible in the plotter frame.)  The value used
C must be positive and non-zero; it may be slightly greater than .5, if
C it is desired that the stereo windows should overlap slightly.
C
        DATA WOSW / .5 /
C
C Set the desired value of the flag that says whether the basic color
C scheme will be white on black (IBOW=0) or black on white (IBOW=1).
C
        DATA IBOW / 1 /
C
C Set the desired value of the flag that says whether shading of the
C surfaces will be done using gray scales (ICLR=0) or colors (ICLR=1).
C
        DATA ICLR / 1 /
C
C Set the desired values of the shading parameters.  Values of SHDE
C near 0 give brighter colors and values near 1 give pastel shades.
C Values of SHDR near 0 give a narrow range of shades and values near
C 1 give a wide range of shades.
C
        DATA SHDE,SHDR / .1 , .8 /
C
C Define labels for the edges of the box.
C
        DATA XNLB / ' -4 -3 -2 -1 0 1 2 3 4 ' /
        DATA YNLB / ' -4 -3 -2 -1 0 1 2 3 4 ' /
        DATA ZNLB / ' -4 -3 -2 -1 0 1 2 3 4 ' /
C
        DATA XILB / 'X Coordinate Values' /
        DATA YILB / 'Y Coordinate Values' /
        DATA ZILB / 'Z Coordinate Values' /
C
C Define arithmetic statement functions for r, phi, and h as functions
C of U and V.
C
        RVAL(U,V)=A*(COS(U)+COS(U-V))+B
        PVAL(U,V)=V
        HVAL(U,V)=A*(SIN(U)+SIN(U-V))
C
C Define arithmetic statement functions to transform cylindrical
C coordinates into Cartesian coordinates.
C
        XVAL(R,P,H)=R*COS(P)
        YVAL(R,P,H)=R*SIN(P)
        ZVAL(R,P,H)=H
C
C Open GKS.
C
        CALL GOPKS (IERRF, ISZDM)
        CALL GOPWK (IWKID, LUNIT, IWTYPE)
        CALL GACWK (IWKID)
C
C Turn clipping off.
C
        CALL GSCLIP (0)
C
C Double the line width.
C
        CALL GSLWSC (2.)
C
C Define colors to use.
C
        CALL TDCLRS (1,IBOW,SHDE,SHDR,11,26,8)
C
C Select font number 25, turn on the outlining of filled fonts, set the
C line width to 1, and turn off the setting of the outline color.
C
        CALL PCSETI ('FN - FONT NUMBER',25)
        CALL PCSETI ('OF - OUTLINE FLAG',1)
        CALL PCSETR ('OL - OUTLINE LINE WIDTH',1.)
        CALL PCSETR ('OC - OUTLINE LINE COLOR',-1.)
C
C Make TDPACK characters a bit bigger.
C
        CALL TDSETR ('CS1',1.25)
C
C Define TDPACK rendering styles 1 through 7, using black-and-white
C shading or colored shading, whichever is selected.  The indices
C 1-7 can then be used as final arguments in calls to TDITRI, TDSTRI,
C and TDMTRI.
C
        IF (ICLR.EQ.0) THEN
C
C Rendering styles 1-7 are all gray on both sides:
C
          CALL TDSTRS (1,27,42, 27, 42,-1,-1,1,0.,0.,0.)
          CALL TDSTRS (2,27,42, 27, 42,-1,-1,1,0.,0.,0.)
          CALL TDSTRS (3,27,42, 27, 42,-1,-1,1,0.,0.,0.)
          CALL TDSTRS (4,27,42, 27, 42,-1,-1,1,0.,0.,0.)
          CALL TDSTRS (5,27,42, 27, 42,-1,-1,1,0.,0.,0.)
          CALL TDSTRS (6,27,42, 27, 42,-1,-1,1,0.,0.,0.)
          CALL TDSTRS (7,27,42, 27, 42,-1,-1,1,0.,0.,0.)
C
        ELSE
C
C Rendering styles 1-7 are all gray on one side.  The other side is
C 1) gray, 2) red, 3) green, 4) blue, 5) cyan, 6) magenta, 7) yellow.
C
          CALL TDSTRS (1,27,42, 27, 42,-1,-1,1,0.,0.,0.)
          CALL TDSTRS (2,27,42, 43, 58,-1,-1,1,0.,0.,0.)
          CALL TDSTRS (3,27,42, 59, 74,-1,-1,1,0.,0.,0.)
          CALL TDSTRS (4,27,42, 75, 90,-1,-1,1,0.,0.,0.)
          CALL TDSTRS (5,27,42, 91,106,-1,-1,1,0.,0.,0.)
          CALL TDSTRS (6,27,42,107,122,-1,-1,1,0.,0.,0.)
          CALL TDSTRS (7,27,42,123,138,-1,-1,1,0.,0.,0.)
C
        END IF
C
C Initialize the count of triangles in the triangle list.
C
        NTRI=0
C
C For each box on a rectangular grid in the UV plane, generate two
C triangles and add them to the triangle list.  Each triangle is
C transformed from cylindrical coordinates to Cartesian coordinates.
C The rendering style is made a function of the U coordinate; try
C uncommenting the second expression for ISRS to see what happens
C when the rendering style is made a function of the V coordinate.
C
        DO 102 I=1,IDIM-1
          UVMI=UMIN+(REAL(I-1)/REAL(IDIM-1))*(UMAX-UMIN)
          UVMA=UMIN+(REAL(I  )/REAL(IDIM-1))*(UMAX-UMIN)
          IURS=MAX(1,MIN(12,1+INT(12.*((UVMI+UVMA)/2.-UMIN)/
     +                                                    (UMAX-UMIN))))
          DO 101 J=1,JDIM-1
            VVMI=VMIN+(REAL(J-1)/REAL(JDIM-1))*(VMAX-VMIN)
            VVMA=VMIN+(REAL(J  )/REAL(JDIM-1))*(VMAX-VMIN)
            IVRS=MAX(1,MIN(12,1+INT(12.*((VVMI+VVMA)/2.-VMIN)/
     +                                                    (VMAX-VMIN))))
            ISRS=MOD(IURS-1       ,3)+2
C           ISRS=MOD(       IVRS-1,3)+2
C           ISRS=MOD(IURS-1+IVRS-1,3)+2
            RV00=RVAL(UVMI,VVMI)
            PV00=PVAL(UVMI,VVMI)
            HV00=HVAL(UVMI,VVMI)
            RV01=RVAL(UVMI,VVMA)
            PV01=PVAL(UVMI,VVMA)
            HV01=HVAL(UVMI,VVMA)
            RV10=RVAL(UVMA,VVMI)
            PV10=PVAL(UVMA,VVMI)
            HV10=HVAL(UVMA,VVMI)
            RV11=RVAL(UVMA,VVMA)
            PV11=PVAL(UVMA,VVMA)
            HV11=HVAL(UVMA,VVMA)
            IF (NTRI.LT.MTRI) THEN
              NTRI=NTRI+1
              RTRI(1,NTRI)=XVAL(RV10,PV10,HV10)
              RTRI(2,NTRI)=YVAL(RV10,PV10,HV10)
              RTRI(3,NTRI)=ZVAL(RV10,PV10,HV10)
              RTRI(4,NTRI)=XVAL(RV00,PV00,HV00)
              RTRI(5,NTRI)=YVAL(RV00,PV00,HV00)
              RTRI(6,NTRI)=ZVAL(RV00,PV00,HV00)
              RTRI(7,NTRI)=XVAL(RV01,PV01,HV01)
              RTRI(8,NTRI)=YVAL(RV01,PV01,HV01)
              RTRI(9,NTRI)=ZVAL(RV01,PV01,HV01)
              RTRI(10,NTRI)=REAL(ISRS)
            END IF
            IF (NTRI.LT.MTRI) THEN
              NTRI=NTRI+1
              RTRI(1,NTRI)=XVAL(RV01,PV01,HV01)
              RTRI(2,NTRI)=YVAL(RV01,PV01,HV01)
              RTRI(3,NTRI)=ZVAL(RV01,PV01,HV01)
              RTRI(4,NTRI)=XVAL(RV11,PV11,HV11)
              RTRI(5,NTRI)=YVAL(RV11,PV11,HV11)
              RTRI(6,NTRI)=ZVAL(RV11,PV11,HV11)
              RTRI(7,NTRI)=XVAL(RV10,PV10,HV10)
              RTRI(8,NTRI)=YVAL(RV10,PV10,HV10)
              RTRI(9,NTRI)=ZVAL(RV10,PV10,HV10)
              RTRI(10,NTRI)=REAL(ISRS)
            END IF
  101     CONTINUE
  102   CONTINUE
C
C Find the midpoint of the data box (to be used as the point looked at).
C
        XMID=.5*(XMIN+XMAX)
        YMID=.5*(YMIN+YMAX)
        ZMID=.5*(ZMIN+ZMAX)
C
C Determine the distance (R) from which the data box will be viewed and,
C given that, the eye position.
C
        R=RMUL*SQRT((XMAX-XMIN)**2+(YMAX-YMIN)**2+(ZMAX-ZMIN)**2)
C
        XEYE=XMID+R*COS(DTOR*ANG1)*COS(DTOR*ANG2)
        YEYE=YMID+R*SIN(DTOR*ANG1)*COS(DTOR*ANG2)
        ZEYE=ZMID+R*SIN(DTOR*ANG2)
C
C Initialize the stereo offset argument to do either a single view or
C a left-eye view (whichever is selected by the value of ISTE).
C
        IF (ISTE.EQ.0) THEN
          OTEP=0.
        ELSE
          OTEP=-R*TAN(DTOR*ASTE/2.)
        END IF
C
C Initialize TDPACK.
C
  109   CALL TDINIT (XEYE,YEYE,ZEYE,XMID,YMID,ZMID,
     +                              XMID,YMID,ZMID+R,OTEP)
C
C If stereo views are being done, do the requested thing, either by
C redoing the SET call to put them side by side on the same frame,
C or by calling FRAME to put them on separate frames.
C
        IF (OTEP.NE.0.) THEN
          IF (ISTE.LT.0) THEN
            CALL GETSET (XVPL,XVPR,YVPB,YVPT,XWDL,XWDR,YWDB,YWDT,LNLG)
            IF (OTEP.LT.0.) THEN
              CALL SET  (1.-WOSW,1.,.5-.5*WOSW,.5+.5*WOSW,
     +                           XWDL,XWDR,YWDB,YWDT,LNLG)
            ELSE
              CALL SET  (  0., WOSW,.5-.5*WOSW,.5+.5*WOSW,
     +                           XWDL,XWDR,YWDB,YWDT,LNLG)
            END IF
          ELSE
            IF (OTEP.GT.0.) CALL FRAME
          END IF
        END IF
C
C Order the triangles in the triangle list.
C
        CALL TDOTRI (RTRI,MTRI,NTRI,RTWK,ITWK,1)
C
        IF (NTRI.EQ.MTRI) THEN
          PRINT * , 'TRIANGLE LIST OVERFLOW IN TDOTRI'
          STOP
        END IF
C
C Draw labels for the axes.
C
        CALL TDLBLS (XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX,
     +               XNLB,YNLB,ZNLB,XILB,YILB,ZILB,1)
C
C Draw the sides of the box that could be hidden.
C
        CALL TDGRDS (XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX,
     +               .1*(XMAX-XMIN),.1*(YMAX-YMIN),.1*(ZMAX-ZMIN),
     +                                                       12,1)
C
C Draw the triangles in the triangle list.
C
        CALL TDDTRI (RTRI,MTRI,NTRI,ITWK)
C
C Draw the sides of the box that could not be hidden.
C
        CALL TDGRDS (XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX,
     +               .1*(XMAX-XMIN),.1*(YMAX-YMIN),.1*(ZMAX-ZMIN),
     +                                                       12,0)
C
C If a left-eye view has just been done, loop back for a right-eye view.
C
        IF (OTEP.LT.0.) THEN
          OTEP=-OTEP
          GO TO 109
        END IF
C
C Advance the frame.
C
        CALL FRAME
C
C Close GKS.
C
        CALL GDAWK (IWKID)
        CALL GCLWK (IWKID)
        CALL GCLKS
C
C Done.
C
        STOP
C
      END


REAL*8 function kern_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
kern_num = sin(x_a - x_b)
end function
REAL*8 function dkdx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdx_num = cos(x_a - x_b)
end function
INTEGER*4 function dkdy_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdy_num = 0
end function
REAL*8 function dkdx0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdx0_num = -cos(x_a - x_b)
end function
INTEGER*4 function dkdy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdy0_num = 0
end function
REAL*8 function d2kdxdx0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdxdx0_num = sin(x_a - x_b)
end function
INTEGER*4 function d2kdydy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdydy0_num = 0
end function
INTEGER*4 function d2kdxdy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdxdy0_num = 0
end function
INTEGER*4 function d3kdxdx0dy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdx0dy0_num = 0
end function
INTEGER*4 function d3kdydy0dy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdydy0dy0_num = 0
end function
INTEGER*4 function d3kdxdy0dy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdy0dy0_num = 0
end function
INTEGER*4 function dkdlx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdlx_num = 0
end function
INTEGER*4 function dkdly_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdly_num = 0
end function
INTEGER*4 function d3kdxdx0dlx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdx0dlx_num = 0
end function
INTEGER*4 function d3kdydy0dlx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdydy0dlx_num = 0
end function
INTEGER*4 function d3kdxdy0dlx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdy0dlx_num = 0
end function
INTEGER*4 function d3kdxdx0dly_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdx0dly_num = 0
end function
INTEGER*4 function d3kdydy0dly_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdydy0dly_num = 0
end function
INTEGER*4 function d3kdxdy0dly_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d3kdxdy0dly_num = 0
end function


      SUBROUTINE CBALEV1
C
C CHANGE RECORD
C **  SUBROUTINES CBALEV CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C **  AND ENERGY BALANCES
C
      USE GLOBAL
      IF(NBALE.GT.1) RETURN
C
C **  INITIALIZE VOLUME, SALT MASS, DYE MASS, MOMENTUM, KINETIC ENERGY
C **  AND POTENTIAL ENERGY, AND ASSOCIATED FLUXES
C
      VOLBEGE=0.
      SALBEGE=0.
      DYEBEGE=0.
      UMOBEGE=0.
      VMOBEGE=0.
      UUEBEGE=0.
      VVEBEGE=0.
      PPEBEGE=0.
      BBEBEGE=0.
      VOLOUTE=0.
      SALOUTE=0.
      DYEOUTE=0.
      UMOOUTE=0.
      VMOOUTE=0.
      UUEOUTE=0.
      VVEOUTE=0.
      PPEOUTE=0.
      BBEOUTE=0.
      DO L=2,LA
        LN=LNC(L)
        VOLBEGE=VOLBEGE+SPB(L)*DXYP(L)*H1P(L)
        UMOBEGE=UMOBEGE+SPB(L)*0.5*DXYP(L)*H1P(L)
     &      *(DYIU(L)*UHDY1E(L)/H1U(L)+DYIU(LEAST(L))*UHDY1E(LEAST(L))/H1U(LEAST(L)))
        VMOBEGE=VMOBEGE+SPB(L)*0.5*DXYP(L)*H1P(L)
     &      *(DXIV(L)*VHDX1E(L)/H1V(L)+DXIV(LN)*VHDX1E(LN)/H1V(LN))
        PPEBEGE=PPEBEGE+SPB(L)*0.5*DXYP(L)
     &      *(GI*P1(L)*P1(L)-G*BELV(L)*BELV(L))
      ENDDO
      AMOBEGE=SQRT(UMOBEGE*UMOBEGE+VMOBEGE*VMOBEGE)
      DO K=1,KC
        DO L=2,LA
          LN=LNC(L)
          SALBEGE=SALBEGE+SCB(L)*DXYP(L)*H1P(L)*SAL1(L,K)*DZC(K)
          DYEBEGE=DYEBEGE+SCB(L)*DXYP(L)*H1P(L)*DYE1(L,K)*DZC(K)
          UUEBEGE=UUEBEGE+SPB(L)*0.125*DXYP(L)*H1P(L)*DZC(K)
     &        *( (U1(L,K)+U1(LEAST(L),K))*(U1(L,K)+U1(LEAST(L),K)) )
          VVEBEGE=VVEBEGE+SPB(L)*0.125*DXYP(L)*H1P(L)*DZC(K)
     &        *( (V1(L,K)+V1(LN,K))*(V1(L,K)+V1(LN,K)) )
          BBEBEGE=BBEBEGE+SPB(L)*GP*DXYP(L)*H1P(L)*DZC(K)*( BELV(L)
     &        +0.5*H1P(L)*(Z(K)+Z(K-1)) )*B1(L,K)
        ENDDO
      ENDDO
      RETURN
      END