!
! BDF (backward differentiation formula) time-stepping routines.
!
! See
!
!   1. VODE: A variable-coefficient ODE solver; Brown, Byrne, and
!      Hindmarsh; SIAM J. Sci. Stat. Comput., vol. 10, no. 5, pp.
!      1035-1051, 1989.
!
!   2. An alternative implementation of variable step-size multistep
!      formulas for stiff ODES; Jackson and Sacks-Davis; ACM
!      Trans. Math. Soft., vol. 6, no. 3, pp. 295-318, 1980.
!
!   3. A polyalgorithm for the numerical solution of ODEs; Byrne and
!      Hindmarsh; ACM Trans. Math. Soft., vol. 1, no. 1, pp. 71-96,
!      1975.
!

module bdf

  use bl_types
  use bl_error_module
  use parallel

  implicit none

  real(dp_t), private, parameter :: one  = 1.0_dp_t
  real(dp_t), private, parameter :: two  = 2.0_dp_t
  real(dp_t), private, parameter :: half = 0.5_dp_t

  integer, parameter :: bdf_max_iters = 666666666

  integer, parameter :: BDF_ERR_SUCCESS  = 0
  integer, parameter :: BDF_ERR_SOLVER   = 1
  integer, parameter :: BDF_ERR_MAXSTEPS = 2
  integer, parameter :: BDF_ERR_DTMIN    = 3

  character(len=64), parameter :: errors(0:3) = [ &
       'Success.                                                ', &
       'Newton solver failed to converge several times in a row.', &
       'Too many steps were taken.                              ', &
       'Minimum time-step reached several times in a row.       ' ]

  !
  ! bdf time-stepper
  !
  type :: bdf_ts

     integer  :: neq                      ! number of equations (degrees of freedom) per point
     integer  :: npt                      ! number of points
     integer  :: max_order                ! maximum order (1 to 6)
     integer  :: max_steps                ! maximum allowable number of steps
     integer  :: max_iters                ! maximum allowable number of newton iterations
     integer  :: verbose                  ! verbosity level
     real(dp_t) :: dt_min                   ! minimum allowable step-size
     real(dp_t) :: eta_min                  ! minimum allowable step-size shrink factor
     real(dp_t) :: eta_max                  ! maximum allowable step-size growth factor
     real(dp_t) :: eta_thresh               ! step-size growth threshold
     integer  :: max_j_age                ! maximum age of jacobian
     integer  :: max_p_age                ! maximum age of newton iteration matrix

     logical  :: debug
     integer  :: dump_unit

     real(dp_t), pointer :: rtol(:)         ! realtive tolerances
     real(dp_t), pointer :: atol(:)         ! absolute tolerances

     ! state
     real(dp_t), pointer :: t(:)          ! current time
     real(dp_t) :: t1                     ! final time
     real(dp_t), pointer :: dt(:)         ! current time step
     real(dp_t), pointer :: dt_nwt(:)     ! dt used when building newton iteration matrix
     integer, pointer :: k(:)             ! current order
     integer  :: n                        ! current step
     !TODO: As of now, j_age and p_age are de-facto scalars.
     !   Should decide if vectorized age boosts performance
     integer, pointer :: j_age(:)         ! age of jacobian
     integer, pointer :: p_age(:)         ! age of newton iteration matrix
     integer,   pointer  :: k_age(:)      ! number of steps taken at current order
     real(dp_t), pointer :: tq(:,:)    ! error coefficients (test quality)
     real(dp_t), pointer :: tq2save(:)
     logical  :: refactor

     real(dp_t), pointer :: J(:,:,:)        ! jacobian matrix
     real(dp_t), pointer :: P(:,:,:)        ! newton iteration matrix
     real(dp_t), pointer :: z(:,:,:)        ! nordsieck histroy array, indexed as (dof, p, n)
     real(dp_t), pointer :: z0(:,:,:)       ! nordsieck predictor array
     real(dp_t), pointer :: h(:,:)          ! time steps, h = [ h_n, h_{n-1}, ..., h_{n-k} ]
     real(dp_t), pointer :: l(:,:)          ! predictor/corrector update coefficients (0:max_order,npt)
     real(dp_t), pointer :: upar(:,:)       ! array of user parameters (passed to
                                            ! user's Jacobian and f)
     real(dp_t), pointer :: y(:,:)          ! current y
     real(dp_t), pointer :: yd(:,:)         ! current \dot{y}
     real(dp_t), pointer :: rhs(:,:)        ! solver rhs (NOT the f in xdot = f)
     real(dp_t), pointer :: e(:,:)          ! accumulated correction
     real(dp_t), pointer :: e1(:,:)         ! accumulated correction, previous step
     real(dp_t), pointer :: ewt(:,:)        ! cached error weights
     real(dp_t), pointer :: b(:,:)          ! solver work space
     integer,  pointer :: ipvt(:,:)         ! pivots (neq,npts)
     integer,  pointer :: A(:,:)            ! pascal matrix

     ! counters
     integer :: nfe                       ! number of function evaluations
     integer :: nje                       ! number of jacobian evaluations
     integer :: nlu                       ! number of factorizations
     integer :: nit                       ! number of non-linear solver iterations
     integer :: nse                       ! number of non-linear solver errors
     integer :: ncse                      ! number of consecutive non-linear solver errors
     integer :: ncit                      ! number of current non-linear solver iterations
     integer :: ncdtmin                   ! number of consecutive times we tried to shrink beyound the minimum time step

  end type bdf_ts

  private :: &
       rescale_timestep, decrease_order, increase_order, &
       alpha0, alphahat0, xi_j, xi_star_inv, ewts, norm, eye_r, eye_i, factorial
  !public subroutines: bdf_advance, bdf_update, bdf_predict, bdf_solve, bdf_check
  !                    bdf_correct, bdf_dump, bdf_adjust, bdf_reset, print_y
  !                    bdf_ts_build, bdf_ts_destroy, bdf_wrap

  !TODO: delete these!  Just for temporary testing
  real(dp_t), public, save :: build_total = 0.0_dp_t
  real(dp_t), public, save :: advance_total = 0.0_dp_t
  real(dp_t), public, save :: update_total = 0.0_dp_t
  real(dp_t), public, save :: predict_total = 0.0_dp_t
  real(dp_t), public, save :: solve_total = 0.0_dp_t
  real(dp_t), public, save :: check_total = 0.0_dp_t
  real(dp_t), public, save :: correct_total = 0.0_dp_t
  real(dp_t), public, save :: adjust_total = 0.0_dp_t
  real(dp_t), public, save :: init_time = 0.0_dp_t
  real(dp_t), public, save :: kl_time = 0.0_dp_t
  real(dp_t), public, save :: refac_time = 0.0_dp_t
  real(dp_t), public, save :: feval_time = 0.0_dp_t
  real(dp_t), public, save :: slv_time = 0.0_dp_t
contains

  !
  ! Wrapper of the vectorized BDF (VBDF) integrator that mirrors the interface of DVODE.
  ! It translates DVODE input into the equivalent VBDF input and wraps
  ! DVODE-style interfaces with VBDF-style interfaces.
  !
  ! This will be the quickest way to replace DVODE with VBDF, but there will be
  ! no performance benefit.  This is intended for debugging and comparing VBDF
  ! with DVODE.
  !
  ! See the DVODE source code's extensive comments for an explanation of this
  ! interface.
  !
  ! TODO: Delete this old wrapper code once things are finalized and you're sure
  ! you don't need it.
  !

  !subroutine bdf_wrap(f, neq, y, t, tout, itol, rtol, atol, itask, &
  !    istate, iopt, rwork, lrw, iwork, liw, jac, mf,    &
  !    rpar, ipar)
  !  integer,         intent(in   ) :: neq, itol, itask, istate, iopt, &
  !                                    lrw, liw, mf
  !  integer,         intent(in   ) :: iwork(liw), ipar(:)
  !  real(kind=dp_t), intent(in   ) :: tout, rtol(:), atol(:), &
  !                                    rwork(lrw)
  !  real(kind=dp_t), intent(inout) :: y(neq), t, rpar(:)
  !  interface
  !     subroutine f(neq, t, y, yd, rpar, ipar)
  !       import dp_t
  !       integer,    intent(in   ) :: neq, ipar(:)
  !       real(dp_t), intent(in   ) :: y(neq), t
  !       real(dp_t), intent(  out) :: yd(neq)
  !       real(dp_t), intent(inout) :: rpar(:)
  !     end subroutine f
  !     subroutine Jac(neq, t, y, ml, mu, pd, nrowpd, rpar, ipar)
  !       import dp_t
  !       integer,    intent(in   ) :: neq, nrowpd, ml, mu, ipar(:)
  !       real(dp_t), intent(in   ) :: y(neq), t
  !       real(dp_t), intent(  out) :: pd(nrowpd, neq)
  !       real(dp_t), intent(inout) :: rpar(:)
  !     end subroutine Jac
  !  end interface

  !  integer, parameter :: NPT = 1         !For DVODE-style calls there's no concept of npt>1
  !  integer, parameter :: MAX_ORDER = 3   !This is arbitrary, should investigate other values
  !  logical, parameter :: RESET = .true.  !.true. means we want to initialize the bdf_ts object
  !  logical, parameter :: REUSE = .false. !.false. means don't reuse the Jacobian
  !  integer, parameter :: MF_ANALYTIC_JAC = 21
  !  real(kind=dp_t), parameter :: DT0 = 1.0d-9 !Initial dt to be used in getting from
  !                                             !t to tout.  Also arbitrary,
  !                                             !multiple values should be
  !                                             !explored.
  !  type(bdf_ts)    :: ts
  !  logical         :: first_call
  !  integer         :: ierr
  !  real(kind=dp_t) :: y0(neq,NPT), y1(neq,NPT), r1, r2
  !  real(kind=dp_t),allocatable :: upar(:,:)

  !  ! Check user input
  !  if(mf .ne. MF_ANALYTIC_JAC) then
  !    call bl_error("ERROR in BDF integrator: mf != MF_ANALYTIC_JAC not yet supported")
  !  endif

  !  ! Build the bdf_ts time-stepper object
  !  r1 = parallel_wtime()
  !  allocate(upar(size(rpar),NPT))
  !  upar(:,NPT) = rpar(:)
  !  call bdf_ts_build(ts, neq, NPT, rtol, atol, MAX_ORDER, upar)
  !  r2 = parallel_wtime() - r1
  !  build_total = build_total + r2

  !  ! Translate DVODE args into args for bdf_advance
  !  y0(:,NPT) = y
  !  r1 = parallel_wtime()
  !  call bdf_advance(ts, f_wrap, Jac_wrap, neq, NPT, y0, t, y1, tout, &
  !                   DT0, RESET, REUSE, ierr, initial_call=.true.)
  !  r2 = parallel_wtime() - r1
  !  advance_total = advance_total + r2
  !  t = tout !BDF is designed to always end at tout,
  !           !set t to tout to mimic the output behavior of DVODE
  !  y = y1(:,NPT)
  !  rpar(:) = upar(:,NPT)

  !  ! Cleanup
  !  r1 = parallel_wtime()

  !  call bdf_ts_destroy(ts)
  !  r2 = parallel_wtime() - r1
  !  build_total = build_total + r2

  !  contains
  !    ! Wraps the DVODE-style f in a BDF-style interface
  !    subroutine f_wrap(neq, npt, y, t, yd, upar)
  !       integer,  intent(in   ) :: neq, npt
  !       real(kind=dp_t), intent(in   ) :: y(neq,npt), t
  !       real(kind=dp_t), intent(  out) :: yd(neq,npt)
  !       real(kind=dp_t), intent(inout), optional :: upar(:,:)

  !       integer :: ipar(2) !Dummy array to match DVODE interface

  !       ipar = -1

  !       call f(neq, t, y(:,1), yd(:,1), upar(:,1), ipar)
  !    end subroutine f_wrap

  !    ! Wraps the DVODE-style Jacobian in a BDF-style interface
  !    subroutine Jac_wrap(neq, npt, y, t, J, upar)
  !       integer,  intent(in   ) :: neq, npt
  !       real(kind=dp_t), intent(in   ) :: y(neq,npt), t
  !       real(kind=dp_t), intent(  out) :: J(neq, neq, npt)
  !       real(kind=dp_t), intent(inout), optional :: upar(:,:)

  !       integer :: ipar(2), ml, mu

  !       ml = -1
  !       mu = -1
  !       ipar = -1

  !       call Jac(neq, t, y(:,1), ml, mu, J(:,:,1), neq, upar(:,1), ipar)
  !    end subroutine Jac_wrap
  !end subroutine bdf_wrap

  !
  ! Advance system from t0 to t1.
  !
  subroutine bdf_advance(ts, f, Jac, neq, npt, y0, t0, y1, t1, dt0, reset, reuse, ierr, initial_call)
    use rpar_indices
    use network
    type(bdf_ts), intent(inout) :: ts
    integer,      intent(in   ) :: neq, npt
    real(kind=dp_t),   intent(in   ) :: y0(neq,npt), t0, t1, dt0
    real(kind=dp_t),   intent(  out) :: y1(neq,npt)
    logical,      intent(in   ) :: reset, reuse
    integer,      intent(  out) :: ierr
    logical,      intent(in   ), optional :: initial_call
    interface
       subroutine f(neq, npt, y, t, yd, upar)
         import dp_t
         integer,    intent(in   ) :: neq, npt
         real(kind=dp_t), intent(in   ) :: y(neq,npt), t(npt)
         real(kind=dp_t), intent(  out) :: yd(neq,npt)
         real(kind=dp_t), intent(inout), optional :: upar(:,:)
       end subroutine f
       subroutine Jac(neq, npt, y, t, J, upar)
         import dp_t
         integer,    intent(in   ) :: neq, npt
         real(kind=dp_t), intent(in   ) :: y(neq,npt), t(npt)
         real(kind=dp_t), intent(  out) :: J(neq, neq, npt)
         real(kind=dp_t), intent(inout), optional :: upar(:,:)
       end subroutine Jac
    end interface

    external f_rhs
    type(bdf_ts) :: ts_local
    integer  :: k, p, m, index_map(npt), iierr, niter
    logical  :: retry, linitial
    real(kind=dp_t) :: r1, r2, yy(neq), ttemp(neq), h0

    linitial = .false.; if (present(initial_call)) linitial = initial_call

    if (reset) call bdf_reset(ts, f, y0, dt0, reuse)

    ierr = BDF_ERR_SUCCESS
    do p = 1, npt
       index_map(p) = p
    enddo

    ts%t1 = t1; ts%t = t0; ts%ncse = 0; ts%ncdtmin = 0;
    !Create local copy of ts that will be pruned down as points are solved.
    call bdf_ts_build(ts_local, ts%neq, ts%npt, ts%rtol, ts%atol, &
                      ts%max_order, ts%upar)
    call bdf_ts_globalcopy(ts, ts_local)
    call ewts(ts_local)
    do p = 1, npt
       call bdf_ts_ptcopy(ts, p, ts_local, p)
       call dvhin(ts_local%neq, t0, ts_local%y(:,p),ts_local%yd(:,p), &
                  f_rhs, ts_local%upar(:,p), -1, t1, epsilon(t1),     &
                  ts_local%ewt(:,p), 2, ts_local%atol, yy, ttemp, h0, &
                  niter, iierr)
       ts_local%dt(p) = h0
       !print *, 'dt0: ',  dt0
       !print *, 'h0: ',   h0
       !print *, 'ierr: ', iierr
    enddo
    do k = 1, bdf_max_iters + 1
       !print *, 'iterating with', ts_local%npt, 'points'
       !print *, 'bdf iter ', k
       !call flush()
       if (ts_local%n > ts_local%max_steps .or. k > bdf_max_iters) then
          ierr = BDF_ERR_MAXSTEPS; return
       end if

       if (k == 1) &
            call bdf_dump(ts_local)

       !r1 = parallel_wtime()
       !print *, 'call update... '
       !call flush()
       call bdf_update(ts_local)                ! update various coeffs (l, tq) based on time-step history
       !r2 = parallel_wtime() - r1
       !update_total = update_total + r2

       !r1 = parallel_wtime()
       !print *, 'call predict... '
       !call flush()
       call bdf_predict(ts_local)               ! predict nordsieck array using pascal matrix
       !r2 = parallel_wtime() - r1
       !predict_total = predict_total + r2
       if(linitial .and. k == 1) then
          !print *, 'initial call... '
          !call flush()
          !This is the initial solve, so use the user's initial value,
          !not the predicted value.
          do p = 1, ts_local%npt
             do m = 1, ts_local%neq
                !Overwrite the predicted z0 with the user's y0
                ts_local%z0(m,p,0) = ts_local%y(m,p)
             end do
          end do
       endif
       !r1 = parallel_wtime()
       !print *, 'call solve... '
       !call flush()
       call bdf_solve(ts_local, f, Jac)         ! solve for y_n based on predicted y and yd
       !r2 = parallel_wtime() - r1
       !solve_total = solve_total + r2
       !r1 = parallel_wtime()
       !print *, 'call check... '
       !call flush()
       call bdf_check(ts_local, retry, ierr)    ! check for solver errors and test error estimate
       !r2 = parallel_wtime() - r1
       !check_total = check_total + r2

       if (ierr /= BDF_ERR_SUCCESS) return
       if (retry) cycle

       !r1 = parallel_wtime()
       !print *, 'call correct... '
       !call flush()
       call bdf_correct(ts_local)               ! new solution looks good, correct history and advance
       !r2 = parallel_wtime() - r1
       !correct_total = correct_total + r2

       call bdf_dump(ts_local)
       !print *, 'call prune... '
       !call flush()
       if (maxval(ts_local%t) >= t1) then
          !p = 1
          !do while(p <= ts_local%npt)
          !   if (ts_local%t(p) >= t1) then
          !      !print *, 'prune    ', p, ' / ', ts_local%npt
          !      !print *, 'npts b4: ', ts_local%npt
          !      !print *, 'k b4:    ', ts_local%k(p)
          !print *, 'npts b4: ', ts_local%npt
          call bdf_ts_prune(ts_local, ts, index_map)
          !print *, 'npts af: ', ts_local%npt
          !      !print *, 'npts af: ', ts_local%npt
          !      !print *, 'k af:    ', ts_local%k(p)
          !      if (ts_local%npt == 0) exit
          !   else
          !      p = p + 1
          !   endif
          !enddo
          if (ts_local%npt == 0) exit
       endif

       !r1 = parallel_wtime()
       !print *, 'call adjust... '
       !call flush()
       call bdf_adjust(ts_local)                ! adjust step-size/order
       !r2 = parallel_wtime() - r1
       !adjust_total = adjust_total + r2
    end do

    !print *, "bdf_solve's init_time:  ", init_time
    !print *, "bdf_solve's kl_time:    ", kl_time
    !print *, "bdf_solve's refac_time: ", refac_time
    !print *, "bdf_solve's feval_time: ", feval_time
    !print *, "bdf_solve's slv_time:   ", slv_time
    !TODO: Handle how to display dt, k now that it's vector
    if (ts%verbose > 0) &
         print '("BDF: n:",i6,", fe:",i6,", je: ",i3,", lu: ",i3,", &
         &it: ",i3,", se: ",i3,", min(dt): ",e15.8,", min(k): ",i2)', &
         ts%n, ts%nfe, ts%nje, ts%nlu, ts%nit, ts%nse, minval(ts%dt), minval(ts%k)

    y1 = ts%z(:,:,0)

    contains
      subroutine f_vode(neq, t, y, yd, rpar, ipar)
        integer,         intent(in   ) :: neq, ipar(*)
        real(kind=dp_t), intent(in   ) :: y(neq), t
        real(kind=dp_t), intent(  out) :: yd(neq)
        real(kind=dp_t), intent(inout) :: rpar(*)

        real(kind=dp_t) :: y_bdf(neq,1), yd_bdf(neq,1), t_bdf(1)
        real(kind=dp_t), allocatable :: rpar_bdf(:,:)
        integer :: rp_n
        t_bdf(1) = t
        rp_n = size(ts%upar,1)
        allocate(rpar_bdf(rp_n, 1))
        rpar_bdf(:,1) = rpar(1:rp_n)

        call f(neq, 1, y_bdf, t_bdf, yd_bdf, rpar_bdf)
      end subroutine
  end subroutine bdf_advance

  !
  ! Compute Nordsieck update coefficients l and error coefficients tq.
  !
  ! Regarding the l coefficients, see section 5, and in particular
  ! eqn. 5.2, of Jackson and Sacks-Davis (1980).
  !
  ! Regarding the error coefficients tq, these have been adapted from
  ! cvode.  The tq array is indexed as:
  !
  !  tq(-1) coeff. for order k-1 error est.
  !  tq(0)  coeff. for order k error est.
  !  tq(1)  coeff. for order k+1 error est.
  !  tq(2)  coeff. for order k+1 error est. (used for e_{n-1})
  !
  ! Note:
  !
  !   1. The input vector t = [ t_n, t_{n-1}, ... t_{n-k} ] where we
  !      are advancing from step n-1 to step n.
  !
  !   2. The step size h_n = t_n - t_{n-1}.
  !
  subroutine bdf_update(ts)
    type(bdf_ts), intent(inout) :: ts

    integer  :: j, p
    real(dp_t) :: a0, a0hat, a1, a2, a3, a4, a5, a6, xistar_inv, xi_inv, c

    ts%l  = 0
    ts%tq = 0

    ! compute l vector
    do p = 1, ts%npt
       ts%l(0,p) = 1
       ts%l(1,p) = xi_j(ts%h(:,p), 1)
       if (ts%k(p) > 1) then
          do j = 2, ts%k(p)-1
             ts%l(:,p) = ts%l(:,p) + eoshift(ts%l(:,p), -1) / xi_j(ts%h(:,p), j)
          end do
          ts%l(:,p) = ts%l(:,p) + eoshift(ts%l(:,p), -1) * xi_star_inv(ts%k(p), ts%h(:,p))
       end if
    enddo

    ! compute error coefficients (adapted from cvode)
    do p = 1, ts%npt
       a0hat = alphahat0(ts%k(p), ts%h(:,p))
       a0    = alpha0(ts%k(p))

       xi_inv     = one
       xistar_inv = one
       if (ts%k(p) > 1) then
          xi_inv     = one / xi_j(ts%h(:,p), ts%k(p))
          xistar_inv = xi_star_inv(ts%k(p), ts%h(:,p))
       end if

       a1 = one - a0hat + a0
       a2 = one + ts%k(p) * a1
       ts%tq(0,p) = abs(a1 / (a0 * a2))
       ts%tq(2,p) = abs(a2 * xistar_inv / (ts%l(ts%k(p),p) * xi_inv))
       if (ts%k(p) > 1) then
          c  = xistar_inv / ts%l(ts%k(p),p)
          a3 = a0 + one / ts%k(p)
          a4 = a0hat + xi_inv
          ts%tq(-1,p) = abs(c * (one - a4 + a3) / a3)
       else
          ts%tq(-1,p) = one
       end if

       xi_inv = ts%h(0,p) / sum(ts%h(0:ts%k(p),p))
       a5 = a0 - one / (ts%k(p)+1)
       a6 = a0hat - xi_inv
       ts%tq(1,p) = abs((one - a6 + a5) / a2 / (xi_inv * (ts%k(p)+2) * a5))
    enddo

    call ewts(ts)
  end subroutine bdf_update

  !
  ! Predict (apply Pascal matrix).
  !
  subroutine bdf_predict(ts)
    type(bdf_ts), intent(inout) :: ts
    integer :: i, j, m, p, pp
    do p = 1, ts%npt
      do i = 0, ts%k(p)
          ts%z0(:,p,i) = 0
          do j = i, ts%k(p)
             do m = 1, ts%neq
                ts%z0(m,p,i) = ts%z0(m,p,i) + ts%A(i,j) * ts%z(m,p,j)
             end do
          end do
       end do
    end do
  end subroutine bdf_predict

  !
  ! Solve "y_n - dt f(y_n,t) = y - dt yd" for y_n where y and yd are
  ! predictors from the Nordsieck form.
  !
  ! Newton iteration is:
  !   solve:   P x = -c G(y(k)) for x
  !   update:  y(k+1) = y(k) + x
  ! where
  !   G(y) = y - dt * f(y,t) - rhs
  !
  subroutine bdf_solve(ts, f, Jac)
    type(bdf_ts), intent(inout) :: ts
    interface
       subroutine f(neq, npt, y, t, yd, upar)
         import dp_t
         integer,  intent(in   ) :: neq, npt
         real(dp_t), intent(in   ) :: y(neq,npt), t(npt)
         real(dp_t), intent(  out) :: yd(neq,npt)
         real(dp_t), intent(inout), optional :: upar(:,:)
       end subroutine f
       subroutine Jac(neq, npt, y, t, J, upar)
         import dp_t
         integer,  intent(in   ) :: neq, npt
         real(dp_t), intent(in   ) :: y(neq,npt), t(npt)
         real(dp_t), intent(  out) :: J(neq, neq,npt)
         real(dp_t), intent(inout), optional :: upar(:,:)
       end subroutine Jac
    end interface

    !include 'LinAlg.inc'

    integer  :: k, m, n, p, info
    real(dp_t) :: c(ts%npt), dt_adj(ts%npt), dt_rat(ts%npt), inv_l1, r1, r11, r2
    logical  :: rebuild, iterating(ts%npt)

    !r1 = parallel_wtime()
    do p = 1, ts%npt
       do m = 1, ts%neq
          inv_l1 = 1.0_dp_t / ts%l(1,p)
          ts%e(m,p)   = 0
          ts%rhs(m,p) = ts%z0(m,p,0) - ts%z0(m,p,1) * inv_l1
          ts%y(m,p)   = ts%z0(m,p,0)
       end do
    end do
    !r2 = parallel_wtime()
    !init_time = init_time + (r2 - r1)
    dt_adj    = ts%dt / ts%l(1,:)

    dt_rat = dt_adj / ts%dt_nwt
    if (maxval(ts%p_age) > ts%max_p_age) ts%refactor = .true.
    !TODO: using min, max may not be best solution
    if (minval(dt_rat) < 0.7d0 .or. maxval(dt_rat) > 1.429d0) ts%refactor = .true.

    iterating = .true.

    !r1 = parallel_wtime()
    do k = 1, ts%max_iters

       ! build iteration matrix and factor
       !r11 = parallel_wtime()
       if (ts%refactor) then
          rebuild = .true.
          if (ts%ncse == 0 .and. maxval(ts%j_age) < ts%max_j_age) rebuild = .false.
          if (ts%ncse > 0  .and. (minval(dt_rat) < 0.2d0 .or. maxval(dt_rat) > 5.d0)) rebuild = .false.

          if (rebuild) then
             call Jac(ts%neq, ts%npt, ts%y, ts%t, ts%J, ts%upar)
             ts%nje   = ts%nje + 1*ts%npt
             ts%j_age = 0
          end if

          call eye_r(ts%P)

          !This spawns redudantly executing threads on each gang

          !This distributes the iterations of the p-loop across gangs and the
          !workers within each gang.
          do p = 1, ts%npt
             !This collapses the two loops into one and distributes the new
             !single loop's iterations across the SIMD vectors of each worker
             do m = 1, ts%neq
                do n = 1, ts%neq
                   ts%P(n,m,p) = ts%P(n,m,p) - dt_adj(p) * ts%J(n,m,p)
                end do
             end do
             call dgefa(ts%P(:,:,p), ts%neq, ts%neq, ts%ipvt(:,p), info)
             ! lapack      call dgetrf(neq, neq, ts%P, neq, ts%ipvt, info)
          end do

          ts%nlu = ts%nlu + ts%npt !The number of times dgefa was called above

          !do p = 1, ts%npt
          !   do m = 1, ts%neq
          !      do n = 1, ts%neq
          !         print *, 'pt', p, ' m', m, ' n', n
          !         print *, 'P:    ', ts%P(n,m,p)
          !      enddo
          !      print *, 'ipvt: ', ts%ipvt(m,p)
          !   enddo
          !enddo

          ts%dt_nwt = dt_adj
          ts%p_age  = 0
          ts%refactor  = .false.
       end if
       !r2 = parallel_wtime()
       !refac_time = refac_time + (r2 - r11)

       c = 2 * ts%dt_nwt / (dt_adj + ts%dt_nwt)

       !r11 = parallel_wtime()
       call f(ts%neq, ts%npt, ts%y, ts%t, ts%yd, ts%upar)
       ts%nfe = ts%nfe + 1
       !r2 = parallel_wtime()
       !feval_time = feval_time + (r2 - r11)

       !r11 = parallel_wtime()
       do p = 1, ts%npt
          if (.not. iterating(p)) cycle
          !if (p == 11950) then
          !  print *, 'pt', p
          !  print *, '  dt_adj: ', dt_adj
          !  print *, '  c:      ', c
          !  print *, '  ipvt:   ', ts%ipvt(:,p)
          !endif

          ! solve using factorized iteration matrix
          do m = 1, ts%neq
             ts%b(m,p) = c(p) * (ts%rhs(m,p) - ts%y(m,p) + dt_adj(p) * ts%yd(m,p))
             !if (p == 11950) then
             !  print *, '  eq', m
             !  print *, '    b:   ', ts%b(m,p)
             !  print *, '    rhs: ', ts%rhs(m,p)
             !  print *, '    y:   ', ts%y(m,p)
             !  print *, '    yd:  ', ts%yd(m,p)
             !endif
          end do
          call dgesl(ts%P(:,:,p), ts%neq, ts%neq, ts%ipvt(:,p), ts%b(:,p), 0)
          ! lapack   call dgetrs ('N', neq, 1, ts%P, neq, ts%ipvt, ts%b, neq, info)
          ts%nit = ts%nit + 1

          do m = 1, ts%neq
             !if (p == 11950) then
             !   print *, '  eq', m
             !   print *, '    ei:      ', ts%e(m,p)
             !   print *, '    b:   ', ts%b(m,p)
             !endif
             ts%e(m,p) = ts%e(m,p) + ts%b(m,p)
             ts%y(m,p) = ts%z0(m,p,0) + ts%e(m,p)
             !if (p == 11950) then
             !   print *, '    y_final: ', ts%y(m,p)
             !   print *, '    ef:      ', ts%e(m,p)
             !endif
          end do
          if (norm(ts%b(:,p), ts%ewt(:,p)) < one) iterating(p) = .false.
       end do
       !r2 = parallel_wtime()
       !slv_time = slv_time + (r2 - r11)

       if (.not. any(iterating)) exit

    end do
    !r2 = parallel_wtime()
    !kl_time = kl_time + (r2 - r1)

    ts%ncit = k; ts%p_age = ts%p_age + 1; ts%j_age = ts%j_age + 1
    !print *, "k:   ", k
    !print *, "bdf_solve's init_time:  ", init_time
    !print *, "bdf_solve's kl_time:    ", kl_time
    !print *, "bdf_solve's refac_time: ", refac_time
    !print *, "bdf_solve's feval_time: ", feval_time
    !print *, "bdf_solve's slv_time:   ", slv_time
    !print *, 'neq: ', ts%neq
    !print *, 'npt: ', ts%npt
    !do p =1, ts%npt
    !print *, 'y_ultimate:  ', ts%y(:,11950)
    !   print *, 'up:  ', ts%upar(:,p)
    !enddo
    !stop 'debug'
  end subroutine bdf_solve

  !
  ! Check error estimates.
  !
  subroutine bdf_check(ts, retry, err)
    type(bdf_ts), intent(inout) :: ts
    logical,      intent(out)   :: retry
    integer,      intent(out)   :: err

    real(dp_t) :: error, eta
    integer    :: p
    logical    :: retry_mask(ts%npt)

    retry = .false.; err = BDF_ERR_SUCCESS
    retry_mask = .false.

    ! if solver failed many times, bail
    if (ts%ncit >= ts%max_iters .and. ts%ncse > 7) then
       err = BDF_ERR_SOLVER
       return
    end if

    ! if solver failed to converge, shrink all dt's and try again
    if (ts%ncit >= ts%max_iters) then
       ts%refactor = .true.; ts%nse = ts%nse + 1; ts%ncse = ts%ncse + 1
       do p = 1, ts%npt
         call rescale_timestep(ts, 0.25d0, p)
       enddo
       retry = .true.
       return
    end if
    ts%ncse = 0

    do p = 1, ts%npt
       ! if local error is too large, shrink dt and try again
       error = ts%tq(0,p) * norm(ts%e(:,p), ts%ewt(:,p))
       if (error > one) then
          eta = one / ( (6.d0 * error) ** (one / ts%k(p)) + 1.d-6 )
          call rescale_timestep(ts, eta, p)
          retry_mask(p) = .true.
          if (ts%dt(p) < ts%dt_min + epsilon(ts%dt_min)) ts%ncdtmin = ts%ncdtmin + 1
          !if (ts%ncdtmin > 7) err = BDF_ERR_DTMIN
       end if
    end do
    if (ts%ncdtmin > 7*ts%npt) err = BDF_ERR_DTMIN
    !print *, 'number pts rescaled: ', count(retry_mask)
    retry = any(retry_mask)
    if (retry) return
    ts%ncdtmin = 0

  end subroutine bdf_check

  !
  ! Correct (apply l coeffs) and advance step.
  !
  subroutine bdf_correct(ts)
    type(bdf_ts), intent(inout) :: ts
    integer :: i, m, p

    do p = 1, ts%npt
       do i = 0, ts%k(p)
          do m = 1, ts%neq
             ts%z(m,p,i) = ts%z0(m,p,i) + ts%e(m,p) * ts%l(i,p)
          end do
       end do
       ts%h(:,p)   = eoshift(ts%h(:,p), -1)
       ts%t(p)     = ts%t(p) + ts%dt(p)
       ts%h(0,p)   = ts%dt(p)
       ts%k_age(p) = ts%k_age(p) + 1
    end do

    ts%n     = ts%n + 1
  end subroutine bdf_correct

  !
  ! Dump (for debugging)...
  !
  subroutine bdf_dump(ts)
    type(bdf_ts), intent(inout) :: ts
    integer :: i, m, p

    if (.not. ts%debug) return
    write(ts%dump_unit,*) ts%t
    write(ts%dump_unit,*) ts%z(:,:,0)
  end subroutine bdf_dump

  !
  ! Adjust step-size/order to maximize step-size.
  !
  subroutine bdf_adjust(ts)
    type(bdf_ts), intent(inout) :: ts

    real(dp_t) :: c, error, eta(-1:1,ts%npt), rescale, etamax(ts%npt), etaminmax, delta(ts%npt)
    integer  :: p

    ! initialize
    rescale = 0
    eta = 0
    etamax = -1.0
    rescale = 0

    do p = 1, ts%npt
       ! compute eta(k-1), eta(k), eta(k+1)
       error  = ts%tq(0,p) * norm(ts%e(:,p), ts%ewt(:,p))
       eta(0,p) = one / ( (6.d0 * error) ** (one / ts%k(p)) + 1.d-6 )
       if (ts%k_age(p) > ts%k(p)) then
          if (ts%k(p) > 1) then
             error     = ts%tq(-1,p) * norm(ts%z(:,p,ts%k(p)), ts%ewt(:,p))
             eta(-1,p) = one / ( (6.d0 * error) ** (one / ts%k(p)) + 1.d-6 )
          end if
          if (ts%k(p) < ts%max_order) then
             c = (ts%tq(2,p) / ts%tq2save(p)) * (ts%h(0,p) / ts%h(2,p)) ** (ts%k(p)+1)
             error  = ts%tq(1,p) * norm(ts%e(:,p) - c * ts%e1(:,p), ts%ewt(:,p))
             eta(1,p) = one / ( (10.d0 * error) ** (one / (ts%k(p)+2)) + 1.d-6 )
          end if
          ts%k_age(p) = 0
       end if

       ! choose which eta will maximize the time step
       if (eta(-1,p) > etamax(p)) then
          etamax(p) = eta(-1,p)
          delta(p)  = -1
       end if
       if (eta(1,p) > etamax(p)) then
          etamax(p) = eta(1,p)
          delta(p)  = 1
       end if
       if (eta(0,p) > etamax(p)) then
          etamax(p) = eta(0,p)
          delta(p)  = 0
       end if

       ! optimize order
       rescale = 0
       if (etamax(p) > ts%eta_thresh) then
          if (delta(p) == -1) then
             call decrease_order(ts,p)
          else if (delta(p) == 1) then
             call increase_order(ts,p)
          end if
          rescale = etamax(p)
       end if

       ! optimize timestep
       if (ts%t(p) + ts%dt(p) > ts%t1) then
          rescale = (ts%t1 - ts%t(p)) / ts%dt(p)
          call rescale_timestep(ts, rescale, p, .true.)
       else if (rescale /= 0) then
          call rescale_timestep(ts, rescale, p)
       end if

    end do

    ! save for next step (needed to compute eta(1))
    ts%e1 = ts%e
    ts%tq2save = ts%tq(2,:)

    !NOTE: The below commented out section is what we did when we had shared dt's
    !
    !You only want minimum of array of max's for multiple pts sharing dt.
    !p = minloc(etamax, dim=1)
    !rescale = 0
    !etaminmax = etamax(p)

    !if (etaminmax > ts%eta_thresh) then
    !   if (delta(p) == -1) then
    !      call decrease_order(ts)
    !   else if (delta(p) == 1) then
    !      call increase_order(ts)
    !   end if
    !   rescale = etaminmax
    !end if

    !if (ts%t + ts%dt > ts%t1) then
    !   rescale = (ts%t1 - ts%t) / ts%dt
    !   call rescale_timestep(ts, rescale, .true.)
    !else if (rescale /= 0) then
    !   call rescale_timestep(ts, rescale)
    !end if

    !! save for next step (needed to compute eta(1))
    !ts%e1 = ts%e
    !ts%tq2save = ts%tq(2)

  end subroutine bdf_adjust

  !
  ! Reset counters, set order to one, init Nordsieck history array.
  !
  subroutine bdf_reset(ts, f, y0, dt, reuse)
    type(bdf_ts), intent(inout) :: ts
    real(dp_t),     intent(in   ) :: y0(ts%neq, ts%npt), dt
    logical,      intent(in   ) :: reuse
    interface
       subroutine f(neq, npt, y, t, yd, upar)
         import dp_t
         integer,  intent(in   ) :: neq, npt
         real(dp_t), intent(in   ) :: y(neq,npt), t(npt)
         real(dp_t), intent(  out) :: yd(neq,npt)
         real(dp_t), intent(inout), optional :: upar(:,:)
       end subroutine f
    end interface

    ts%nfe = 0
    ts%nje = 0
    ts%nlu = 0
    ts%nit = 0
    ts%nse = 0

    ts%y  = y0
    ts%dt = dt
    ts%n  = 1
    ts%k  = 1

    ts%h        = dt
    ts%dt_nwt   = ts%dt
    ts%refactor = .true.

    call f(ts%neq, ts%npt, ts%y, ts%t, ts%yd, ts%upar)
    ts%nfe = ts%nfe + 1

    ts%z(:,:,0) = ts%y
    ts%z(:,:,1) = dt * ts%yd

    ts%k_age = 0
    if (.not. reuse) then
       ts%j_age = ts%max_j_age + 1
       ts%p_age = ts%max_p_age + 1
    else
       ts%j_age = 0
       ts%p_age = 0
    end if

  end subroutine bdf_reset

  !
  ! Rescale time-step.
  !
  ! This consists of:
  !   1. bound eta to honor eta_min, eta_max, and dt_min
  !   2. scale dt and adjust time array t accordingly
  !   3. rescale Nordsieck history array
  !
  subroutine rescale_timestep(ts, eta_in, p_in, force_in)
    type(bdf_ts), intent(inout)           :: ts
    real(dp_t),   intent(in   )           :: eta_in
    integer,      intent(in   )           :: p_in
    logical,      intent(in   ), optional :: force_in

    real(dp_t) :: eta
    integer  :: i
    logical  :: force

    force = .false.; if (present(force_in)) force = force_in

    if (force) then
       eta = eta_in
    else
       eta = max(eta_in, ts%dt_min / ts%dt(p_in), ts%eta_min)
       eta = min(eta, ts%eta_max)

       if (ts%t(p_in) + eta*ts%dt(p_in) > ts%t1) then
          eta = (ts%t1 - ts%t(p_in)) / ts%dt(p_in)
       end if
    end if

    ts%dt(p_in)  = eta * ts%dt(p_in)
    ts%h(0,p_in) = ts%dt(p_in)

    do i = 1, ts%k(p_in)
       ts%z(:,p_in,i) = eta**i * ts%z(:,p_in,i)
    end do
  end subroutine rescale_timestep

  !
  ! Decrease order.
  !
  subroutine decrease_order(ts, p)
    type(bdf_ts), intent(inout) :: ts
    integer,      intent(in   ) :: p
    integer  :: j
    real(dp_t) :: c(0:6)

    if (ts%k(p) > 2) then
       c = 0
       c(2) = 1
       do j = 1, ts%k(p)-2
          c = eoshift(c, -1) + c * xi_j(ts%h(:,p), j)
       end do

       do j = 2, ts%k(p)-1
          ts%z(:,p,j) = ts%z(:,p,j) - c(j) * ts%z(:,p,ts%k(p))
       end do
    end if

    ts%z(:,p,ts%k(p)) = 0
    ts%k(p) = ts%k(p) - 1
  end subroutine decrease_order

  !
  ! Increase order.
  !
  subroutine increase_order(ts,p)
    type(bdf_ts), intent(inout) :: ts
    integer,      intent(in   ) :: p
    integer  :: j
    real(dp_t) :: c(0:6)

    c = 0
    c(2) = 1
    do j = 1, ts%k(p)-2
       c = eoshift(c, -1) + c * xi_j(ts%h(:,p), j)
    end do

    ts%z(:,p,ts%k(p)+1) = 0
    do j = 2, ts%k(p)+1
       ts%z(:,p,j) = ts%z(:,p,j) + c(j) * ts%e(:,p)
    end do

    ts%k(p) = ts%k(p) + 1
  end subroutine increase_order

  !
  ! Return $\alpha_0$.
  !
  function alpha0(k) result(a0)
    integer,  intent(in) :: k
    real(dp_t) :: a0
    integer  :: j
    a0 = -1
    do j = 2, k
       a0 = a0 - one / j
    end do
  end function alpha0

  !
  ! Return $\hat{\alpha}_{n,0}$.
  !
  function alphahat0(k, h) result(a0)
    integer,  intent(in) :: k
    real(dp_t), intent(in) :: h(0:k)
    real(dp_t) :: a0
    integer  :: j
    a0 = -1
    do j = 2, k
       a0 = a0 - h(0) / sum(h(0:j-1))
    end do
  end function alphahat0

  !
  ! Return 1 / $\xi^*_k$.
  !
  ! Note that a lot of simplifications can be made to the formula for
  ! $\xi^*_k$ that appears in Jackson and Sacks-Davis.
  !
  function xi_star_inv(k, h) result(xii)
    integer,  intent(in) :: k
    real(dp_t), intent(in) :: h(0:)
    real(dp_t) :: xii, hs
    integer  :: j
    hs = 0.0_dp_t
    xii = -alpha0(k)
    do j = 0, k-2
       hs  = hs + h(j)
       xii = xii - h(0) / hs
    end do
  end function xi_star_inv

  !
  ! Return $\xi_j$.
  !
  function xi_j(h, j) result(xi)
    integer,  intent(in) :: j
    real(dp_t), intent(in) :: h(0:)
    real(dp_t) :: xi
    xi = sum(h(0:j-1)) / h(0)
  end function xi_j

  !
  ! Pre-compute error weights.
  !
  subroutine ewts(ts)
    type(bdf_ts), intent(inout) :: ts
    integer :: m, p
    do p = 1, ts%npt
       do m = 1, ts%neq
          ts%ewt(m,p) = one / (ts%rtol(m) * abs(ts%y(m,p)) + ts%atol(m))
       end do
    end do
  end subroutine ewts

  subroutine print_y(ts)
    type(bdf_ts), intent(in) :: ts
    integer :: p
    do p = 1, ts%npt
       print *, ts%y(:,p)
    end do
  end subroutine print_y

  !
  ! Compute weighted norm of y.
  !
  function norm(y, ewt) result(r)
    real(dp_t), intent(in) :: y(1:), ewt(1:)
    real(dp_t) :: r
    integer :: m, n
    n = size(y)
    r = 0.0_dp_t
    do m = 1, n
       r = r + (y(m)*ewt(m))**2
    end do
    r = sqrt(r/n)
  end function norm

  !
  ! Prune out all solved points, copying their final data
  ! into ts_master based on index_map which maps ts_sub
  ! indices to those in ts_master.
  !
  subroutine bdf_ts_prune(ts_sub, ts_master, index_map)
     type(bdf_ts), intent(inout) :: ts_sub
     type(bdf_ts), intent(inout) :: ts_master
     integer,      intent(inout) :: index_map(:)

     type(bdf_ts) :: ts_old
     integer      :: p, new_p
     logical      :: remove_me(ts_sub%npt)
     remove_me = .false.

     !Copy final pt-based values into ts_master based on index_map.
     do p = 1, ts_sub%npt
        if (ts_sub%t(p) >= ts_sub%t1) then
           remove_me(p) = .true.
           call bdf_ts_ptcopy(ts_sub, p, ts_master, index_map(p))
        endif
     enddo

     !Check if any points remain
     if (all(remove_me)) then
        !No need to build ts_old -- we pruned all the points
        !Just copy over the globals
        ts_sub%npt = 0
        call bdf_ts_globalcopy(ts_sub, ts_master)
        print *, 'Last point!'
        return
     endif

     !Create a copy of ts_sub
     call bdf_ts_build(ts_old, ts_sub%neq, ts_sub%npt, &
                       ts_sub%rtol, ts_sub%atol, ts_sub%max_order, ts_sub%upar)
     call bdf_ts_globalcopy(ts_sub, ts_old)
     do p = 1, ts_sub%npt
        call bdf_ts_ptcopy(ts_sub, p, ts_old, p)
     enddo
     !Now, rebuild ts_sub with only points that need more iterations
     call bdf_ts_destroy(ts_sub)
     call bdf_ts_build(ts_sub, ts_old%neq, ts_old%npt-count(remove_me), &
                       ts_old%rtol, ts_old%atol, ts_old%max_order)
     allocate(ts_sub%upar(size(ts_old%upar,1),ts_sub%npt))

     !Copy global (not point-indexed) data from ts_old to ts_sub
     call bdf_ts_globalcopy(ts_old, ts_sub)
     ts_sub%npt = ts_old%npt-count(remove_me)

     !Copy all pts needing more work into ts_sub from ts_old,
     !update index_map
     new_p = 1
     do p = 1, ts_old%npt
        if (remove_me(p)) cycle
        call bdf_ts_ptcopy(ts_old, p, ts_sub, new_p)
        index_map(new_p) = index_map(p)
        new_p = new_p + 1
     enddo

     call bdf_ts_destroy(ts_old)
  end subroutine bdf_ts_prune

  !
  ! Copy over all point-based values
  !
  subroutine bdf_ts_ptcopy(ts_src, p_src, ts_dst, p_dst)
     type(bdf_ts), intent(inout) :: ts_src, ts_dst
     integer,      intent(in   ) :: p_src,  p_dst

     if(ts_dst%max_order /= ts_src%max_order) then
        call bl_error('unequal max_orders!')
     endif
     ts_dst%t(p_dst)       = ts_src%t(p_src)
     ts_dst%dt(p_dst)      = ts_src%dt(p_src)
     ts_dst%dt_nwt(p_dst)  = ts_src%dt_nwt(p_src)
     ts_dst%k(p_dst)       = ts_src%k(p_src)
     ts_dst%j_age(p_dst)   = ts_src%j_age(p_src)
     ts_dst%p_age(p_dst)   = ts_src%p_age(p_src)
     ts_dst%k_age(p_dst)   = ts_src%k_age(p_src)
     ts_dst%tq(:,p_dst)    = ts_src%tq(:,p_src)
     ts_dst%tq2save(p_dst) = ts_src%tq2save(p_src)
     ts_dst%J(:,:,p_dst)   = ts_src%J(:,:,p_src)
     ts_dst%P(:,:,p_dst)   = ts_src%P(:,:,p_src)
     ts_dst%z(:,p_dst,:)   = ts_src%z(:,p_src,:)
     ts_dst%z0(:,p_dst,:)  = ts_src%z0(:,p_src,:)
     ts_dst%h(:,p_dst)     = ts_src%h(:,p_src)
     ts_dst%l(:,p_dst)     = ts_src%l(:,p_src)
     ts_dst%upar(:,p_dst)  = ts_src%upar(:,p_src)
     ts_dst%y(:,p_dst)     = ts_src%y(:,p_src)
     ts_dst%yd(:,p_dst)    = ts_src%yd(:,p_src)
     ts_dst%rhs(:,p_dst)   = ts_src%rhs(:,p_src)
     ts_dst%e(:,p_dst)     = ts_src%e(:,p_src)
     ts_dst%e1(:,p_dst)    = ts_src%e1(:,p_src)
     ts_dst%ewt(:,p_dst)   = ts_src%ewt(:,p_src)
     ts_dst%b(:,p_dst)     = ts_src%b(:,p_src)
     ts_dst%ipvt(:,p_dst)  = ts_src%ipvt(:,p_src)
  end subroutine bdf_ts_ptcopy

  !
  ! Copy over global values.
  !
  subroutine bdf_ts_globalcopy(ts_src, ts_dst)
     type(bdf_ts), intent(inout) :: ts_src, ts_dst

     ts_dst%neq        = ts_src%neq
     ts_dst%npt        = ts_src%npt
     ts_dst%max_order  = ts_src%max_order
     ts_dst%max_steps  = ts_src%max_steps
     ts_dst%max_iters  = ts_src%max_iters
     ts_dst%verbose    = ts_src%verbose
     ts_dst%dt_min     = ts_src%dt_min
     ts_dst%eta_min    = ts_src%eta_min
     ts_dst%eta_max    = ts_src%eta_max
     ts_dst%eta_thresh = ts_src%eta_thresh
     ts_dst%max_j_age  = ts_src%max_j_age
     ts_dst%max_p_age  = ts_src%max_p_age
     ts_dst%debug      = ts_src%debug
     ts_dst%dump_unit  = ts_src%dump_unit
     ts_dst%rtol       = ts_src%rtol
     ts_dst%atol       = ts_src%atol
     ts_dst%t1         = ts_src%t1
     ts_dst%n          = ts_src%n
     ts_dst%refactor   = ts_src%refactor
     ts_dst%A          = ts_src%A
     ts_dst%nfe        = ts_src%nfe
     ts_dst%nje        = ts_src%nje
     ts_dst%nlu        = ts_src%nlu
     ts_dst%nit        = ts_src%nit
     ts_dst%nse        = ts_src%nse
     ts_dst%ncse       = ts_src%ncse
     ts_dst%ncit       = ts_src%ncit
     ts_dst%ncdtmin    = ts_src%ncdtmin
  end subroutine bdf_ts_globalcopy

  !
  ! Build/destroy BDF time-stepper.
  !
  subroutine bdf_ts_build(ts, neq, npt, rtol, atol, max_order, upar)
    type(bdf_ts), intent(inout) :: ts
    integer,      intent(in   ) :: max_order, neq, npt
    real(dp_t),     intent(in   ) :: rtol(neq), atol(neq)
    real(dp_t),     intent(in   ), optional :: upar(:,:)

    integer :: k, U(max_order+1, max_order+1), Uk(max_order+1, max_order+1)

    allocate(ts%rtol(neq))
    allocate(ts%atol(neq))
    allocate(ts%t(npt))
    allocate(ts%dt(npt))
    allocate(ts%dt_nwt(npt))
    allocate(ts%k(npt))
    allocate(ts%j_age(npt))
    allocate(ts%p_age(npt))
    allocate(ts%k_age(npt))
    allocate(ts%tq(-1:2, npt))
    allocate(ts%tq2save(npt))
    allocate(ts%z(neq, npt, 0:max_order))
    allocate(ts%z0(neq, npt, 0:max_order))
    allocate(ts%l(0:max_order, npt))
    allocate(ts%h(0:max_order, npt))
    allocate(ts%A(0:max_order, 0:max_order))
    allocate(ts%P(neq, neq, npt))
    allocate(ts%J(neq, neq, npt))
    allocate(ts%y(neq, npt))
    allocate(ts%yd(neq, npt))
    allocate(ts%rhs(neq, npt))
    allocate(ts%e(neq, npt))
    allocate(ts%e1(neq, npt))
    allocate(ts%ewt(neq, npt))
    allocate(ts%b(neq, npt))
    allocate(ts%ipvt(neq,npt))

    if(present(upar)) then
      allocate(ts%upar(size(upar,1),npt))
      ts%upar = upar
    else
      nullify(ts%upar)
    endif

    ts%neq        = neq
    ts%npt        = npt
    ts%max_order  = max_order
    ts%max_steps  = 1000000
    ts%max_iters  = 100
    ts%verbose    = 0
    ts%dt_min     = epsilon(ts%dt_min)
    !ts%dt_min     = 1.0e-13_dp_t
    ts%eta_min    = 0.2_dp_t
    ts%eta_max    = 10.0_dp_t
    ts%eta_thresh = 1.50_dp_t
    ts%max_j_age  = 50
    ts%max_p_age  = 20

    ts%k = -1

    ts%rtol = rtol
    ts%atol = atol

    ts%J  = 0
    ts%P  = 0
    ts%yd = 0

    ts%j_age = 666666666
    ts%p_age = 666666666
    ts%k_age = 666666666

    ts%debug = .false.

    ! build pascal matrix A using A = exp(U)
    U = 0
    do k = 1, max_order
       U(k,k+1) = k
    end do
    Uk = U
    call eye_i(ts%A)
    do k = 1, max_order+1
       ts%A  = ts%A + Uk / factorial(k)
       Uk = matmul(U, Uk)
    end do
  end subroutine bdf_ts_build

  subroutine bdf_ts_destroy(ts)
    type(bdf_ts), intent(inout) :: ts
    integer :: p
    deallocate(ts%h,ts%l,ts%ewt,ts%rtol,ts%atol)
    deallocate(ts%t,ts%dt,ts%dt_nwt,ts%k,ts%j_age)
    deallocate(ts%p_age,ts%k_age,ts%tq,ts%tq2save)
    deallocate(ts%y,ts%yd,ts%z,ts%z0,ts%A)
    deallocate(ts%P,ts%J,ts%rhs,ts%e,ts%e1,ts%b,ts%ipvt)
    if(associated(ts%upar)) then
      deallocate(ts%upar)
    endif
  end subroutine bdf_ts_destroy

  !
  ! Various misc. helper functions
  !
  subroutine eye_r(A)
    real(dp_t), intent(inout) :: A(:,:,:)
    integer :: i
    A = 0
    do i = 1, size(A, 1)
       A(i,i,:) = 1.0_dp_t
    end do
  end subroutine eye_r
  subroutine eye_i(A)
    integer, intent(inout) :: A(:,:)
    integer :: i
    A = 0
    do i = 1, size(A, 1)
       A(i,i) = 1
    end do
  end subroutine eye_i
  recursive function factorial(n) result(r)
    integer, intent(in) :: n
    integer :: r
    if (n == 1) then
       r = 1
    else
       r = n * factorial(n-1)
    end if
  end function factorial

end module bdf


      SUBROUTINE fixaray
      USE vmec_main, p5 => cp5
      USE vmec_params, ONLY: jmin2, mscale, nscale,
     &                       mnyq, nnyq, signgs
#ifdef _HBANGLE
      USE angle_constraints, ONLY: init_multipliers
#endif
      IMPLICIT NONE
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(dp), PARAMETER :: two=2, pexp=4
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  :: i, m, j, n, mn, mn1, nmin0, istat1, istat2
      INTEGER  :: mnyq0, nnyq0
      REAL(dp) :: argi, arg, argj, dnorm, tfixon, tfixoff
C-----------------------------------------------
!
!     INDEX OF LOCAL VARIABLES
!
!     mscale   array for norming theta-trig functions (internal use only)
!              so that the discrete SUM[cos(mu)*cos(m'u)] = .5 delta(m,m')
!     nscale   array for norming zeta -trig functions (internal use only)

!
!    COMPUTE TRIGONOMETRIC FUNCTION ARRAYS
!    NOTE: ARRAYS ALLOCATED HERE ARE GLOBAL AND ARE DEALLOCATED IN FILEOUT
!    NOTE: NEED 2 X NYQUIST FOR FAST HESSIAN CALCULATIONS
!
      mnyq0  = ntheta1/2
      nnyq0  = nzeta/2

      mnyq = MAX(0, 2*mnyq0, 2*mpol1)
      nnyq = MAX(0, 2*nnyq0, 2*ntor)

      mnmax_nyq = nnyq/2 + 1 + mnyq*(nnyq + 1)/2

      ALLOCATE(cosmu(ntheta3,0:mnyq),  sinmu(ntheta3,0:mnyq),
     1         cosmum(ntheta3,0:mnyq), sinmum(ntheta3,0:mnyq),
     2         cosmui(ntheta3,0:mnyq), cosmumi(ntheta3,0:mnyq),
     2         cosmui3(ntheta3,0:mnyq),cosmumi3(ntheta3,0:mnyq),
     3         sinmui(ntheta3,0:mnyq), sinmumi(ntheta3,0:mnyq),
     4         cosnv(nzeta,0:nnyq),    sinnv(nzeta,0:nnyq),
     5         cosnvn(nzeta,0:nnyq),   sinnvn(nzeta,0:nnyq),
     6         cos01(nznt), sin01(nznt), stat=istat1 )
      ALLOCATE(xm(mnmax), xn(mnmax), ixm(mnsize), jmin3(0:mnsize-1),
     1         xm_nyq(mnmax_nyq), xn_nyq(mnmax_nyq),
     2         mscale(0:mnyq), nscale(0:nnyq), stat=istat2)

      IF (istat1.ne.0) THEN
         STOP 'allocation error in fixaray: istat1'
      END IF
      IF (istat2.ne.0) THEN
         STOP 'allocation error in fixaray: istat2'
      END IF

      dnorm = one/(nzeta*(ntheta2 - 1))
      IF (lasym) THEN
         dnorm = one/(nzeta*ntheta3)     !Fix, SPH012314
      END IF

      mscale(0) = 1;  nscale(0) = 1
!     mscale(0) = osqrt2;  nscale(0) = osqrt2    !versions < 6.9, incorrectly used osqrt2

      mscale(1:mnyq) = mscale(0)/osqrt2
      nscale(1:nnyq) = nscale(0)/osqrt2
      r0scale = mscale(0)*nscale(0)

!
!     GENERALLY, ONLY NEED THIS FROM 1, ntheta2 EXCEPT IN GETBRHO ROUTINE
!
      DO i = 1, ntheta3
         argi = twopi*(i - 1)/ntheta1
         DO m = 0, mnyq
            arg = argi*m
            cosmu(i,m) = COS(arg)*mscale(m)
            sinmu(i,m) = SIN(arg)*mscale(m)
            cosmui(i,m) = dnorm*cosmu(i,m)
            cosmui3(i,m) = cosmui(i,m)          !Use this if integration over FULL 1,ntheta3 interval
            sinmui(i,m) = dnorm*sinmu(i,m)
            IF (i.EQ.1 .OR. i.EQ.ntheta2) THEN
               cosmui(i,m) = cosmui(i,m)/2
            END IF
            IF (ntheta2 .EQ. ntheta3) THEN
               cosmui3(i,m) = cosmui(i,m)
            END IF
            cosmum(i,m) = cosmu(i,m)*(m)
            sinmum(i,m) = -sinmu(i,m)*(m)
            cosmumi(i,m) = cosmui(i,m)*(m)
            cosmumi3(i,m) = cosmui3(i,m)*m
            sinmumi(i,m) = -sinmui(i,m)*(m)
         END DO
      END DO

      DO j = 1, nzeta
         argj = twopi*(j - 1)/nzeta
         DO n = 0, nnyq
            arg = argj*(n)
            cosnv(j,n) = COS(arg)*nscale(n)
            sinnv(j,n) = SIN(arg)*nscale(n)
            cosnvn(j,n) = cosnv(j,n)*(n*nfp)
            sinnvn(j,n) = -sinnv(j,n)*(n*nfp)
         END DO
      END DO

!
!     R,Z,L / s**(m/2) ARE LINEAR NEAR ORIGIN
!
      mn = 0
      mn1 = 0
      DO m = 0, mpol1
         xmpq(m,1) = m*(m - 1)
         xmpq(m,2) = m**pexp
         xmpq(m,3) = m**(pexp + 1)
         DO n = 0, ntor
            jmin3(mn) = jmin2(m)
            mn = mn + 1
            ixm(mn) = m
         END DO
         nmin0 = -ntor
         IF (m .eq. 0) nmin0 = 0
         DO n = nmin0, ntor
            mn1 = mn1 + 1
            xm(mn1) = m
            xn(mn1) = n*nfp
         END DO
      END DO

      IF (mn1 .ne. mnmax) THEN
         STOP 'mn1 != mnmax'
      END IF

!
!     COMPUTE NYQUIST-SIZED ARRAYS FOR OUTPUT.
!     RESTORE m,n Nyquist TO 1 X ... (USED IN WROUT, JXBFORCE)
!      mnyq = mnyq0;  nnyq = nnyq0
      mnyq = mnyq/2
      nnyq = nnyq/2

      mn1 = 0
      DO m = 0, mnyq
         nmin0 = -nnyq
         IF (m .eq. 0) nmin0 = 0
         DO n = nmin0, nnyq
            mn1 = mn1 + 1
            xm_nyq(mn1) = m
            xn_nyq(mn1) = n*nfp
         END DO
      END DO

      IF (mn1 .ne. mnmax_nyq) THEN
         STOP 'mn1 != mnmax_nyq'
      END IF

      mn = 0
      m = 1
      DO i = 1, ntheta3
         argi = twopi*(i - 1)/ntheta1
         DO j = 1, nzeta
            mn = mn + 1
            cos01(mn) =  m*COS(m*argi)*mscale(m)
            sin01(mn) = -m*SIN(m*argi)*mscale(m)
         END DO
      END DO

      faccon(0) = zero
      faccon(mpol1) = zero
      faccon(1:mpol1 - 1) = -0.25_dp*signgs/xmpq(2:mpol1,1)**2

#ifdef _HBANGLE
      CALL init_multipliers
#endif

      END SUBROUTINE fixaray


program sopfbr
  use tensor_nmode
  use chebval
  implicit none
  integer :: i, j, k, jkappa, tkappa, mode, newsize, chebslice
  integer :: ndim = 3
  integer, dimension(3) :: gdim = (/5, 5, 5/)
  integer :: tdim = 4
  real, dimension(3) :: point
  real, dimension(15) :: u_vects
  real, dimension(60) :: coef_u_vects
  real, dimension(125) :: core ! Flattened version of the core tensor
  real, dimension(:), allocatable :: tensor_holder
  real, dimension(:), allocatable :: tensor_prod
  real :: serieval

  ! A test geometry

  point = (/-0.33, 0.15, 0.88/)

  ! A test core tensor

  core = 1.

  ! A test with unit tensor and Chebyshev series

  coef_u_vects = 1.0
  u_vects = 0.0

  ! Initialize factor vectors

  jkappa = 0
  tkappa = 0
  do i = 1, ndim
     do j = 1, gdim(i)
        jkappa = jkappa + 1
        serieval = 0.0
        do k = 1, tdim
           tkappa = tkappa + 1
           serieval = serieval + coef_u_vects(tkappa) * chebpoly(point(i), k - 1)
        enddo
        u_vects(jkappa) = u_vects(jkappa) + serieval
     enddo
  enddo

  ! Compute tensor n-mode product (final result contained in `tensor_prod`)

  allocate(tensor_holder(125))
  tensor_holder = core
  chebslice = 1

  do mode = 1, ndim

     if (allocated(tensor_prod)) deallocate(tensor_prod)

     newsize = product(gdim(mode:)) / gdim(mode)
     allocate(tensor_prod(newsize))

     tensor_prod = n_mode(mode, gdim(mode:), newsize, &
                   tensor_holder, u_vects(chebslice:(chebslice + 4)))

     deallocate(tensor_holder)
     allocate(tensor_holder(newsize))
     tensor_holder = tensor_prod

     chebslice = chebslice + 5

  enddo

  deallocate(tensor_holder)

  print *, tensor_prod

end program sopfbr


      SUBROUTINE setgmn(meanv,covm,ldcovm,p,parm,ierr)
C      SUBROUTINE setgmn(meanv,covm,p,parm)
C     JJV changed this routine to take leading dimension of COVM
C     JJV argument and pass it to SPOFA, making it easier to use
C     JJV if the COVM which is used is contained in a larger matrix
C     JJV and to make the routine more consistent with LINPACK.
C     JJV Changes are in comments, declarations, and the call to SPOFA.
C**********************************************************************
C
C     SUBROUTINE SETGMN( MEANV, COVM, LDCOVM, P, PARM)
C            SET Generate Multivariate Normal random deviate
C
C
C                              Function
C
C
C      Places P, MEANV, and the Cholesky factoriztion of COVM
C      in PARM for GENMN.
C
C
C                              Arguments
C
C
C     MEANV --> Mean vector of multivariate normal distribution.
C                                        DOUBLE PRECISION MEANV(P)
C
C     COVM   <--> (Input) Covariance   matrix    of  the  multivariate
C                 normal distribution.  This routine uses only the
C                 (1:P,1:P) slice of COVM, but needs to know LDCOVM.
C
C                 (Output) Destroyed on output
C                                        DOUBLE PRECISION COVM(LDCOVM,P)
C
C     LDCOVM --> Leading actual dimension of COVM.
C                                        INTEGER LDCOVM
C
C     P     --> Dimension of the normal, or length of MEANV.
C                                        INTEGER P
C
C     PARM <-- Array of parameters needed to generate multivariate
C                normal deviates (P, MEANV and Cholesky decomposition
C                of COVM).
C                1 : 1                - P
C                2 : P + 1            - MEANV
C                P+2 : P*(P+3)/2 + 1  - Cholesky decomposition of COVM
C                                             DOUBLE PRECISION PARM(P*(P+3)/2 + 1)
C
C**********************************************************************
C     .. Scalar Arguments ..
C      INTEGER p
c      include '../stack.h'
      INTEGER p, ldcovm
C     ..
C     .. Array Arguments ..
C      DOUBLE PRECISION covm(p,p),meanv(p),parm(p* (p+3)/2+1)
      DOUBLE PRECISION covm(ldcovm,p),meanv(p),parm(p* (p+3)/2+1)
C     ..
C     .. Local Scalars ..
      INTEGER i,icount,info,j
C     ..
C     .. External Subroutines ..
      EXTERNAL spofa
C     ..
C     .. Executable Statements ..
C
C
C     TEST THE INPUT
C
   10 parm(1) = p
C
C     PUT P AND MEANV INTO PARM
C
      DO 20,i = 2,p + 1
          parm(i) = meanv(i-1)
   20 CONTINUE
C
C      Cholesky decomposition to find A s.t. trans(A)*(A) = COVM
C
C      CALL spofa(covm,p,p,info)
      CALL spofa(covm,ldcovm,p,info)
      ierr=0
      IF (.NOT. (info.NE.0)) GO TO 30
      call basout(io,wte,"Rand: COV not positive definite")
      ierr=1
      return
   30 icount = p + 1
C
C     PUT UPPER HALF OF A, WHICH IS NOW THE CHOLESKY FACTOR, INTO PARM
C          COVM(1,1) = PARM(P+2)
C          COVM(1,2) = PARM(P+3)
C                    :
C          COVM(1,P) = PARM(2P+1)
C          COVM(2,2) = PARM(2P+2)  ...
C
      DO 50,i = 1,p
          DO 40,j = i,p
              icount = icount + 1
              parm(icount) = covm(i,j)
   40     CONTINUE
   50 CONTINUE
      RETURN
C
      END


      REAL FUNCTION slRVLD (R2000, D2000)
*+
*     - - - - - - -
*      R V L D
*     - - - - - - -
*
*  Velocity component in a given direction due to the Sun's motion
*  with respect to the dynamical Local Standard of Rest.
*
*  (single precision)
*
*  Given:
*     R2000,D2000   r    J2000.0 mean RA,Dec (radians)
*
*  Result:
*     Component of "peculiar" solar motion in direction R2000,D2000 (km/s)
*
*  Sign convention:
*     The result is +ve when the Sun is receding from the given point on
*     the sky.
*
*  Note:  The Local Standard of Rest used here is the "dynamical" LSR,
*         a point in the vicinity of the Sun which is in a circular
*         orbit around the Galactic centre.  The Sun's motion with
*         respect to the dynamical LSR is called the "peculiar" solar
*         motion.
*
*         There is another type of LSR, called a "kinematical" LSR.  A
*         kinematical LSR is the mean standard of rest of specified star
*         catalogues or stellar populations, and several slightly
*         different kinematical LSRs are in use.  The Sun's motion with
*         respect to an agreed kinematical LSR is known as the "standard"
*         solar motion.  To obtain a radial velocity correction with
*         respect to an adopted kinematical LSR use the routine slRVLK.
*
*  Reference:  Delhaye (1965), in "Stars and Stellar Systems", vol 5,
*              p73.
*
*  Called:
*     slCS2C, slVDV
*
*  P.T.Wallace   Starlink   9 March 1994
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      REAL R2000,D2000

      REAL VA(3), VB(3)

      REAL slVDV

*
*  Peculiar solar motion from Delhaye 1965: in Galactic Cartesian
*  coordinates (+9,+12,+7) km/s.  This corresponds to about 16.6 km/s
*  towards Galactic coordinates L2 = 53 deg, B2 = +25 deg, or RA,Dec
*  17 49 58.7 +28 07 04 J2000.
*
*  The solar motion is expressed here in the form of a J2000.0
*  equatorial Cartesian vector:
*
*      VA(1) = X = -SPEED*COS(RA)*COS(DEC)
*      VA(2) = Y = -SPEED*SIN(RA)*COS(DEC)
*      VA(3) = Z = -SPEED*SIN(DEC)

      DATA VA / +0.63823, +14.58542, -7.80116 /

*  Convert given J2000 RA,Dec to x,y,z
      CALL slCS2C(R2000,D2000,VB)

*  Compute dot product with solar motion vector
      slRVLD=slVDV(VA,VB)

      END


      SUBROUTINE GSER(GAMSER,A,X,GLN)
      PARAMETER (ITMAX=100,EPS=3.E-7)
      GLN=GAMMLN(A)
      IF(X.LE.0.)THEN
        IF(X.LT.0.)PAUSE
        GAMSER=0.
        RETURN
      ENDIF
      AP=A
      SUM=1./A
      DEL=SUM
      DO 11 N=1,ITMAX
        AP=AP+1.
        DEL=DEL*X/AP
        SUM=SUM+DEL
        IF(ABS(DEL).LT.ABS(SUM)*EPS)GO TO 1
11    CONTINUE
      PAUSE 'A too large, ITMAX too small'
1     GAMSER=SUM*EXP(-X+A*LOG(X)-GLN)
      RETURN
      END


!============================================================================
      SUBROUTINE grid_construction_left_low()
!============================================================================
! Region Left Low (LL)
!
! The specific internal energy along from Triple point to Critical
! point. The liquid region is bounded by the saturation line and the maximum
! pressure line, the minimum internal energy and the critical internal
! energy.
!
!  ** left isobar boundary (e,P)-->(T,v) 2D New_Raph
!     right saturation boundary (e)-->(vl,vv,T)-->(P) 3D New_Raph
!     middle (v,e)-->(T)--(P) 1D New_Raph
!
! The bilinear mapping is used for the interpolation from physical (v,e)
! doamin to the transformed domaine (X,Y).(Bicubic can be
! considered later by using also the derivatives)
!========================================================================
!
     USE def_constants
     USE def_variables
     USE non_linear_solvers
     USE properties
     USE grid_functions
!
      IMPLICIT NONE
!
      INTEGER  ::  i, j, N, exitflag, i1, i2, Niter
!      INTEGER, DIMENSION (NNN_LL,MMM_LL) ::  flag_pT_LL, N_pT_LL
!
      REAL(pr)  ::  u_min, res, delta, p_guess, extern, utest_max,&
&                   T_guess_sat,v_guess_sat, vap_guess_sat
!      REAL(pr)  :: p0, v_inters, T_inters, u_inters
!
      REAL(pr), DIMENSION (NNN_LL)  ::  vap_guess, vap_LL
!
      REAL(pr), DIMENSION (NNN_LL,MMM_LL)  ::  res_pT_LL, res_LL,&
      &                                        T_guess, v_guess,vvv_LL_log
      REAL(pr), DIMENSION (NNN_sat_LL) :: res_sat_LL,vap_sat_LL, T_sat_sat,&
&                                         T_sat_pmax,res_pmax_LL,T_liq_meta
      REAL(pr)  ::  energy,press, temp, out_2, sound,in_2,guess3,out3
!
! data used for bicubic interpolation
!
!REAL(8) :: v1, v2, v3, v4, u1, u2, u3, u4
!REAL(8) :: F1, F2, F3, F4, G1, G2, G3, G4
!REAL(8) :: a1, a2, a3, a4, b1, b2, b3, b4
!REAL(8) :: dF1v, dF2v, dF3v, dF4v, dF1u, dF2u, dF3u, dF4u, dF1vu, dF2vu,
!dF3vu, dF4vu
!REAL(8) :: dF1vv, dF2vv, dF3vv, dF4vv, dF1uu, dF2uu, dF3uu, dF4uu
!REAL(8) :: dF1x, dF2x, dF3x, dF4x, dF1y, dF2y, dF3y, dF4y, dF1xy, dF2xy,
!dF3xy, dF4xy
!
!REAL(8), DIMENSION (4, 4) :: A_bicub, C_bicub
!
!
! Initial guess for point (1,1) and (1,MMM_LL)
!
        T_guess(1,1) = T_tri
        v_guess(1,1) = 1_pr / rho_tri_L
!
        TTT_LL(1,MMM_LL) = T_tri
        T_guess(1,MMM_LL) = T_tri
!
        vvv_LL(1,MMM_LL) = 1_pr / rho_tri_L
        v_guess(1,MMM_LL) = 1_pr / rho_tri_L
        ppp_LL(1,MMM_LL) = P_tri
        vap_guess(1) = 1_pr / rho_tri_R
        vap_LL(1) = 1_pr / rho_tri_R
        ccc_LL(1,MMM_LL) = c_tri_L
!--------------------------------------------------------------------------
!
! Construct vector y_mesh_LL(physical domain), x_mesh_LL(tansformed
! domain)
!
!-------------------------------------------------------------------------
        utest_max = 1.0_pr*e_cr ! interal energy smaller than cirtical internal energy
        u_min = e_tri_L
!
        delta = (utest_max - u_min) / (NNN_LL - 1)
        y_mesh_LL = u_min + (/(i*delta,i=0,NNN_LL-1)/)
!        y_mesh_LL(NNN_LL) = utest_max
!
        delta = (x_mesh_max - x_mesh_min) / (MMM_LL -1)
        x_mesh_LL = x_mesh_min + (/(i*delta, i=0,MMM_LL-1)/)
!        x_mesh_LL(NNN_LL) = x_mesh_max
!
! array y_mesh_sat_LL
!
        delta             = (utest_max - u_min)/(NNN_sat_LL-1)
        y_mesh_sat_LL     = u_min + (/(i*delta, i=0,NNN_sat_LL-1)/)
!
!
!--------------------------------------------------------------------------
!
! Left boundary of LL domain. isobar Pmax,  and u_min-->u_max
!
!--------------------------------------------------------------------------
!
!P (iso) at each point of  left boundary
!
        ppp_LL(:,1) = p_max
!
        DO i=1,NNN_LL
!
              CALL New_Rap2D(2, TTT_LL(i,1), vvv_LL(i,1), &
              & res_LL(i,1), Niter, exitflag, ppp_LL(i,1), y_mesh_LL(i),&
              & T_guess(i,1), v_guess(i,1))
!
             CALL sound_speed(TTT_LL(i,1),vvv_LL(i,1), sound)
             ccc_LL(i,1) = sound
!
!             CALL inter_energy(TTT_LL(i,1),vvv_LL(i,1),energy)
!        print*, i, abs(y_mesh_LL(i) - energy ) / y_mesh_LL(i)
              IF (res_LL(i,1) > res_ref) THEN
                print*, "left_res IN LL", res_LL(i,1), "iter", Niter,"flag",exitflag
                STOP
              ENDIF
              T_guess(i+1,1) = TTT_LL(i,1)
              v_guess(i+1,1) = vvv_LL(i,1)
!
         END DO

!---------------------------------------------------------------------------
!
! Right boundary of LL domain. Saturation line u_min-->u_max
!
!--------------------------------------------------------------------------
        DO i=2, NNN_LL-1
              T_guess(i,MMM_LL) = TTT_LL(i-1,MMM_LL)
              v_guess(i,MMM_LL) = vvv_LL(i-1,MMM_LL)
              vap_guess(i) = vap_LL(i-1)
!
              CALL New_Rap3D(1,vvv_LL(i,MMM_LL),vap_LL(i),TTT_LL(i,MMM_LL),&
              & res_LL(i,MMM_LL), Niter, exitflag, y_mesh_LL(i),in_2,&
              & v_guess(i,MMM_LL), vap_guess(i),T_guess(i,MMM_LL))
!
              CALL pressure(TTT_LL(i,MMM_LL),vvv_LL(i,MMM_LL),press)
              ppp_LL(i,MMM_LL) = press
!
              CALL sound_speed(TTT_LL(i,MMM_LL),vvv_LL(i,MMM_LL), sound)
              ccc_LL(i,MMM_LL) = sound
!
!        print*, "vap_v", vap_LL(i)
              IF (res_LL(i,MMM_LL) > res_ref) THEN
                print*, "right_res IN LL", res_LL(i,MMM_LL), "iter", Niter
                print*, 'i',i,'v',vvv_LL(i,MMM_LL),'vap',vap_LL(i),'e',y_mesh_LL(i)
                STOP
              ENDIF
!
!        print*, "v_right", vvv_LL(i,MMM_LL), 't_right',TTT_LL(i,MMM_LL)
!        print*, 'e', y_mesh_LL()
        END DO
! Last point is fixed to critical point values
        vvv_LL(NNN_LL,MMM_LL) = 1_pr/rho_cr
        TTT_LL(NNN_LL,MMM_LL) = T_cr
        ppp_LL(NNN_LL,MMM_LL) = P_cr
        ccc_LL(NNN_LL,MMM_LL) = c_cr
!        print*, 'LL','n-1','e', y_mesh_LL(NNN_LL-1), vvv_LL(NNN_LL-1,MMM_LL),&
!&                               TTT_LL(NNN_LL-1,MMM_LL),ppp_LL(NNN_LL-1,MMM_LL),ccc_LL(NNN_LL-1,MMM_LL)
!        print*, 'LL','n',  'e', y_mesh_LL(NNN_LL), vvv_LL(NNN_LL,MMM_LL),&
!&                               TTT_LL(NNN_LL,MMM_LL),ppp_LL(NNN_LL,MMM_LL),ccc_LL(NNN_LL,MMM_LL)

!
!              T_guess(NNN_LL-2,MMM_LL) = TTT_LL(NNN_LL-3,MMM_LL)
!              v_guess(NNN_LL-2,MMM_LL) = 1_pr/rho_cr
!              vap_guess(NNN_LL-2) = vap_LL(NNN_LL-3)
!        DO i=NNN_LL-2, NNN_LL
!
!              CALL New_Rap3D(1,vvv_LL(i,MMM_LL),vap_LL(i),TTT_LL(i,MMM_LL),&
!              & res_LL(i,MMM_LL), Niter, exitflag, y_mesh_LL(i),&
!              & v_guess(i,MMM_LL), vap_guess(i),T_guess(i,MMM_LL))
!
!              CALL pressure(TTT_LL(i,MMM_LL),vvv_LL(i,MMM_LL),press)
!              ppp_LL(i,MMM_LL) = press
!
!             CALL sound_speed(TTT_LL(i,MMM_LL),vvv_LL(i,MMM_LL), sound)
!             ccc_LL(i,MMM_LL) = sound
!              T_guess(i+1,MMM_LL) = TTT_LL(i,MMM_LL)
!              v_guess(i+1,MMM_LL) = vvv_LL(i,MMM_LL)
!              vap_guess(i+1) = vap_LL(i)
!
!       print*, Niter, res_LL(i,MMM_LL)
!              IF (res_LL(i,MMM_LL) > res_ref) THEN
!                print*, "right_res", res_LL(i,MMM_LL), "iter", Niter
!                STOP
!              ENDIF
!
!        print*, "v_right", vvv_LL(i,MMM_LL), 't_right',TTT_LL(i,MMM_LL)
!        print*, 'e', y_mesh_LL(i)
!        END DO

!---------------------------------------------------------------------------
!
! Middle domain of the two boundaries. v_min-->v_max, u_min-->u_max
! vvv_LL in the physical space is built by the X in the transformed
! space with a LINEAR SCALING TRANSFORMATION
!
!--------------------------------------------------------------------------
        DO j=2,MMM_LL-1
           DO i=1, NNN_LL
!
                vvv_LL(i,j) = ((x_mesh_LL(j) - x_mesh_min) /&
                & (x_mesh_max - x_mesh_min)) *(vvv_LL(i,MMM_LL)-vvv_LL(i,1))+&
                & vvv_LL(i,1)
!                vvv_LL_log(i,j) = ((x_mesh_LL(j) - x_mesh_min) /&
!                & (x_mesh_max - x_mesh_min)) *(log10(vvv_LL(i,MMM_LL))-log10(vvv_LL(i,1)))+&
!                & log10(vvv_LL(i,1))
!               vvv_LL(i,j) = 10_pr**vvv_LL_log(i,j)
!
                CALL New_Rap1D(1, temp, out_2, res_LL(i,j), Niter,&
               & exitflag, y_mesh_LL(i), TTT_LL(i,j-1),&
               & vvv_LL(i,j), out3)
!
                CALL New_Rap1D(1, temp, out_2, res_LL(i,j), Niter,&
               & exitflag, y_mesh_LL(i), temp,&
               & vvv_LL(i,j), out3)

!
                TTT_LL(i,j) = temp
!
!
              CALL pressure(TTT_LL(i,j),vvv_LL(i,j),press)
              ppp_LL(i,j) = press
!
             CALL sound_speed(TTT_LL(i,j),vvv_LL(i,j), sound)
             ccc_LL(i,j) = sound
!
                IF (res_LL(i,j) > res_ref) THEN
                  print*, "middle_res_LL", res_LL(i,j), "iter", Niter,i,j
                  STOP
                ENDIF
!
!                CALL inter_energy(temp, vvv_LL(i,j),energy)
!                print*, "error e", (y_mesh_LL(i) - energy)/y_mesh_LL(i)
!                print*, "residu", res_LL(i,j)
           END DO
        END DO
!        print*, 'LL ','n-1 ','e ', y_mesh_LL(NNN_LL), vvv_LL(NNN_LL,MMM_LL-1),&
!&                                  TTT_LL(NNN_LL,MMM_LL-1),ppp_LL(NNN_LL,MMM_LL-1),ccc_LL(NNN_LL,MMM_LL-1)
!
!
!print*, 'grid Cp'
! grid for Cp
!
!        DO j = 1,MMM_LL
!           DO  i = 1, NNN_LL
!               CALL heat_cap_p(TTT_LL(i,j),vvv_LL(i,j),cpcp_LL(i,j))
!               IF ( (cpcp_LL(i,j) /= cpcp_LL(i,j)) .OR. (cpcp_LL(i,j) <= 0.0) .OR.&
!&                   (cpcp_LL(i,j) >  cp_cr  ) ) THEN
!!                  print*,'cp in LL kJ/(kgK)', cpcp_LL(i,j)/1000.0,i,j
!                  cpcp_LL(i,j) = cp_cr
!                ENDIF
!             ENDDO
!        ENDDO
!
!------------------------------------------------------------
!
!          MESH CONSTRUCTION for spline coefficients
!
!------------------------------------------------------------
!print*, 'start spline'
!
! SATURATION
!
        T_sat_sat(1) = T_tri
        v_Lsat_LL(1) = 1_pr/rho_tri_L
        vap_sat_LL(1)= 1_pr/rho_tri_R
! 21/08/2017 fix last point to critical point
        T_sat_sat(NNN_sat_LL) = T_cr
        v_Lsat_LL(NNN_sat_LL) = 1_pr/rho_cr
        vap_sat_LL(NNN_sat_LL)= 1_pr/rho_cr
!
        T_sat_sat(NNN_sat_LL-1) = 304.1281
        v_Lsat_LL(NNN_sat_LL-1) = 1_pr/rho_cr - 2d-5
        vap_sat_LL(NNN_sat_LL-1)= 1_pr/rho_cr + 2d-5
! 20/05/2018 fix (NNN_sat_LL-1) point value
        DO i=2, NNN_sat_LL-2
              T_guess_sat = T_sat_sat(i-1)+4d-6
              v_guess_sat = v_Lsat_LL(i-1)!+1d-6
              vap_guess_sat = vap_sat_LL(i-1)!-1d-6
!print*, i, T_guess_sat, v_guess_sat,vap_guess_sat
!
              CALL New_Rap3D(1,v_Lsat_LL(i),vap_sat_LL(i),T_sat_sat(i),&
              & res_sat_LL(i), Niter, exitflag, y_mesh_sat_LL(i),in_2,&
              & v_guess_sat, vap_guess_sat,T_guess_sat)

!              CALL New_Rap3D(1,v_Lsat_LL(i),vap_sat_LL(i),T_sat_sat(i),&
!              & res_sat_LL(i), Niter, exitflag, y_mesh_sat_LL(i),in_2,&
!              & v_Lsat_LL(i), vap_sat_LL(i), T_sat_sat(i))
!
!print*, i, T_sat_sat(i), v_Lsat_LL(i), vap_sat_LL(i)
!
              IF (res_sat_LL(i) > res_ref) THEN
                print*, "right_sat_res", res_sat_LL(i), "iter", Niter,&
              &         'T=',T_sat_sat(i),i
                print*, 'Tguess',T_guess_sat,'vlquess',v_guess_sat,vap_guess_sat
                print*,'IN LL CONSTRUCTION'
                STOP
              ENDIF
!
        END DO
!
!
! META: compute spinodal liquid between  -290;004 - -190.3 (kj/kg)
!
!e = -427.18 - -290.004  (kj/kg) p = 0
!      T_guess_sat = 263.0
!      v_guess_sat = 1.1e-3_pr
! DO i = 1, 172
!    CALL New_Rap2D(4, T_liq_meta(i), v_liq_meta(i), &
!              & res, N, exitflag, y_mesh_sat_LL(i),in_2,&
!              & T_guess_sat,v_guess_sat)
!!
!   IF (res > 1e-5) THEN
!       print*,'LL_sat_spin-Convergence failed calculating T_sat_sat at spinodal(',i,')'
!       print*,'resnorm     = ',res ,'N_iter = ',N
!       STOP
!   ENDIF
!      T_guess_sat = T_liq_meta(i)
!      v_guess_sat = v_liq_meta(i)+0.1e-4_pr
!      CALL pressure(T_liq_meta(i),v_liq_meta(i), press)
!   print*, 'meta T_liqmeta', T_liq_meta(i), 'vliqmeta', v_liq_meta(i), y_mesh_sat_LL(i),i
!   print*,' press', press
!    T_liq_meta(i) = T_sat_sat(i)
!    v_liq_meta(i) = v_Lsat_LL(i)
! ENDDO
!STOP
!
!
!
!
!e = -290.004 - -201.476 (kj/kg) dp/dv_T = 0
!      T_guess_sat = 275.0
!      v_guess_sat = v_tri_L +1e-4_pr
! DO i = 173, 284
!!
!        CALL New_Rap2D(3, T_liq_meta(i), v_liq_meta(i), &
!              & res, N, exitflag, y_mesh_sat_LL(i),in_2,&
!              & T_guess_sat,v_guess_sat)
!!
!   IF (res > 1e-5) THEN
!       print*,'LL_sat_spin-Convergence failed calculating T_sat_sat at spinodal(',i,')'
!       print*,'resnorm     = ',res ,'N_iter = ',N
!       STOP
!   ENDIF
!   IF (i<200) THEN
!      T_guess_sat = T_liq_meta(i)
!      v_guess_sat = v_liq_meta(i)+1e-4_pr
!!   ELSEIF (i>=284) THEN
!!      T_guess_sat = T_liq_meta(i)+0.1_pr
!!      v_guess_sat = v_liq_meta(i)
!   ELSE
!      T_guess_sat = T_liq_meta(i)
!      v_guess_sat = v_liq_meta(i)-1e-4_pr

!   ENDIF
!      CALL pressure(T_liq_meta(i),v_liq_meta(i), press)
!   print*, 'meta T_liqmeta', T_liq_meta(i), 'vliqmeta', v_liq_meta(i), y_mesh_sat_LL(i),i
!   print*,' press', press
!   print*, 'sat', v_Lsat_LL(i), T_sat_sat(i)
! ENDDO
!!e = -201.476 - -190.3 (kj/kg) saturation line
!   DO i = 285, NNN_sat_LL
!      T_liq_meta(i) = T_sat_sat(i)
!      v_liq_meta(i) = v_Lsat_LL(i)
! ENDDO
!!   v_liq_meta(NNN_sat_LL)  = 1_pr/rho_cr
!
!
!print*, 'start p_max spline'
! P_max
!
!
        T_guess(1,1) = T_tri
        v_guess(1,1) = 1_pr/rho_tri_L
!
        DO i=1,NNN_sat_LL
!
              CALL New_Rap2D(2, T_sat_pmax(i), v_Lpmax_LL(i), &
              & res_pmax_LL(i), Niter, exitflag, p_max, y_mesh_sat_LL(i),&
              & T_guess(i,1), v_guess(i,1))
!
              IF (res_pmax_LL(i) > res_ref) THEN
                print*, "left_pmax_res IN LL ", res_pmax_LL(i), "iter", Niter
                STOP
              ENDIF
              T_guess(i+1,1) = T_sat_pmax(i)
              v_guess(i+1,1) = v_Lpmax_LL(i)
!
         END DO

!
!
! construction of spline coefficients associated to saturation
! curve nodes(What I need), meta curve nodes and pmax curve nodes(What I  need)
!
DO i = 1, NNN_LL-1
   j = ord_spline * (i-1) + 1
   CALL polyfit(spline_Lsat_LL(:,i), y_mesh_sat_LL(j:j+ord_spline),v_Lsat_LL(j:j+ord_spline), ord_spline)
!   CALL polyfit(spline_Lsat_LL(:,i), y_mesh_sat_LL(j:j+3),LOG10(v_Lsat_LL(j:j+3)), ord_spline)
!   CALL polyfit(spline_meta_LL(:,i), y_mesh_sat_LL(j:j+ord_spline),v_liq_meta(j:j+ord_spline), ord_spline)
   CALL polyfit(spline_pmax_LL(:,i), y_mesh_sat_LL(j:j+ord_spline),v_Lpmax_LL(j:j+ord_spline), ord_spline)
ENDDO
!print*,'------------------------------------------------------'
print*,           'LL GRID FINISH'
!print*,'------------------------------------------------------'
!
!
!
      END SUBROUTINE grid_construction_left_low


module grid_mod
  use optical_properties_mod, only:nwl,nlayer
  implicit none
  save
  !contains
  integer, parameter :: nxg=50,nyg=50,nzg=400
  !integer, parameter :: nxg=100,nyg=100,nzg=100
  real*8 :: xface(-3:nxg+4),yface(-3:nyg+4),zface(-3:nzg+4)
  real*8 :: MASK(nxg,nyg,nzg,nlayer)
  real*8 :: rhokap(nxg,nyg,nzg)

  REAL*8 :: PL_SUM(nwl,NXG,NYG,NZG)

  real*8,parameter :: xmax=0.025,ymax=0.025,zmax=0.02
  !real*8,parameter :: xmax=0.05,ymax=0.05,zmax=0.05
  real*8 :: grid_max(3)
  real*8 :: delta

end module grid_mod


      SUBROUTINE SVBKSB(U,W,V,M,N,MP,NP,B,X)
      PARAMETER (NMAX=100)
      DIMENSION U(MP,NP),W(NP),V(NP,NP),B(MP),X(NP),TMP(NMAX)
      DO 12 J=1,N
        S=0.
        IF(W(J).NE.0.)THEN
          DO 11 I=1,M
            S=S+U(I,J)*B(I)
11        CONTINUE
          S=S/W(J)
        ENDIF
        TMP(J)=S
12    CONTINUE
      DO 14 J=1,N
        S=0.
        DO 13 JJ=1,N
          S=S+V(J,JJ)*TMP(JJ)
13      CONTINUE
        X(J)=S
14    CONTINUE
      RETURN
      END


!***********************************/
!	Name:FDS法による1次元風上流束を求めるプログラム
!	Alias:UpwindFlux_Dim1
!	Description:FDS法を用いて1次元系における風上流束を求める
!	Type:CE
!	Input:Geometory,CellEdge,CellCenter
!	Output:CellEdge
!	Note:次元ごとにサブルーチンを分けているのは1つだけでも割と長いプログラムになってしまったため
!	Author:Akitaka Toyota
!	Date:2017.10.26
!	Update:2017.11.09
!	Other:1次元と2次元に対応
!***********************************/
    subroutine UpwindFlux_Dim1(Geom,CE,CC) !MUSCL経由の場合CEのみ，1次精度の場合CCを渡す
    use StructVar_Mod
    use LoopVar_Mod
    use ConstantVar_Mod, Gamma => SpecificOfHeatRatio, Epsilon => EntropyCorrection
    implicit none
    type(Geometry), intent(in) :: Geom
    type(CellEdge), intent(inout) :: CE
    type(CellCenter), intent(in), optional :: CC

    type(FDSMatrix) :: FM
    type(RoeAverage) :: RA
    double precision, allocatable :: DeltaQuantity(:)
    double precision, allocatable :: RoeFlux(:)
    integer iTestMode
    iTestMode = 0
    allocate(RA%GeneralFlux(3,1,2), DeltaQuantity(3),RoeFlux(3))
    allocate(FM%RightEigenMatrix(3,3),FM%LeftEigenMatrix(3,3),FM%AbsEigenValues(3,3))
    allocate(RA%RoeAverage(3),RA%SideQuantity(3,2))

    !Roeスキームの流束を求める
    do iFaceX=0,Geom%CellNumber(1) !すべての界面についての総和
        if( present(CC)) then !保存変数からの流束計算
            RA%SideQuantity(:,1) = CC%ConservedQuantity(:,iCX,1,1) !負側の保存量
            RA%SideQuantity(:,2) = CC%ConservedQuantity(:,iCX+1,1,1) !正側の保存量
            RA%TypeOfQuantity = 1
        else  !基礎変数からの流束計算
            RA%SideQuantity(1,1) = CE%RebuildQunatity(1,iCX,1,1,2)
            RA%SideQuantity(2,1) = CE%RebuildQunatity(2,iCX,1,1,2)*CE%RebuildQunatity(1,iCX,1,1,2)
            RA%SideQuantity(3,1) = InverseGmin1*CE%RebuildQunatity(3,iCX,1,1,2) &
                &   + 0.5d0*CE%RebuildQunatity(1,iCX,1,1,2)*CE%RebuildQunatity(2,iCX,1,1,2)**2

            RA%SideQuantity(1,2) = CE%RebuildQunatity(1,iCX+1,1,1,1)
            RA%SideQuantity(2,2) = CE%RebuildQunatity(2,iCX+1,1,1,1)*CE%RebuildQunatity(1,iCX+1,1,1,1)
            RA%SideQuantity(3,2) = InverseGmin1*CE%RebuildQunatity(3,iCX+1,1,1,1)  &
                &   + 0.5d0*CE%RebuildQunatity(1,iCX+1,1,1,1)*CE%RebuildQunatity(2,iCX+1,1,1,1)**2
            RA%TypeOfQuantity = 1
        end if

        DeltaQuantity(:) = RA%SideQuantity(:,2) - RA%SideQuantity(:,1)
        call GetGeneralFlux(Geom,RA)

        !call GetRoeAverage(Geom,RA)

!左右の固有ベクトルから風上化流束を求める
        !call GetEigenMatrix(Geom,RA,FM)

!エントロピー補正
        do iLoop =1,3
        if(FM%AbsEigenValues(iLoop,iLoop) < Epsilon) then
            FM%AbsEigenValues(iLoop,iLoop) = 0.5d0*(FM%AbsEigenValues(iLoop,iLoop)**2 + Epsilon**2)/Epsilon
        end if
        end do
        !TestCode
        iTestMode = 0
        if(iTestMode == 0) then
        RoeFlux = matmul(matmul(matmul(FM%RightEigenMatrix,FM%AbsEigenValues),FM%LeftEigenMatrix),DeltaQuantity)
        else
            call RoeMultiply
        end if
        CE%NormalFluxDiff(:,iCX,1,1,1) = &
            &   0.5d0 * ((RA%GeneralFlux(:,1,1)+RA%GeneralFlux(:,1,2)) - RoeFlux(:))

    end do
    return
contains
    subroutine RoeMultiply
    implicit none
    double precision :: CalcAssistB2,CalcAssistB1
        CalcAssistB2 = Gmin1/RA%RoeAverage(1)**2
        CalcAssistB1 = 0.5d0*RA%RoeAverage(2)**2 * CalcAssistB2

        RoeFlux(1) = &
        & (0.5d0*(CalcAssistB1 + RA%RoeAverage(2)/RA%RoeAverage(1)) &
        &+(1.0d0 - CalcAssistB1) &
        &+0.5d0*(CalcAssistB1 - RA%RoeAverage(2)/RA%RoeAverage(1)))*DeltaQuantity(1) &
        &*dabs(RA%RoeAverage(2) - RA%RoeAverage(1))

        RoeFlux(2) = &
        & ((RA%RoeAverage(2) - RA%RoeAverage(1))&
        &*(-0.5d0*(1.0d0/RA%RoeAverage(1) + CalcAssistB2*RA%RoeAverage(2))) &
        &+RA%RoeAverage(2)*CalcAssistB2 * RA%RoeAverage(2) &
        &+(RA%RoeAverage(2) + RA%RoeAverage(1))&
        &*0.5d0*(1.0d0/RA%RoeAverage(1) - CalcAssistB2*RA%RoeAverage(2))) &
        &*DeltaQuantity(2)*dabs(RA%RoeAverage(2))

        RoeFlux(3) = &
        & ((RA%RoeAverage(3) - RA%RoeAverage(2)*RA%RoeAverage(1))*0.5d0*CalcAssistB2 &
        &+0.5d0 * RA%RoeAverage(2)**2 *(-CalcAssistB2) &
        &+(RA%RoeAverage(3) + RA%RoeAverage(2)*RA%RoeAverage(1))*0.5d0*CalcAssistB2) &
        &*DeltaQuantity(3)*dabs(RA%RoeAverage(2) + RA%RoeAverage(1))
    return
    end subroutine RoeMultiply

    end subroutine UpwindFlux_Dim1


	SUBROUTINE GDTXGD ( gridin, nx, nv, ivcord, iyaxis, rlvls,
     +                      ybot, ytop, lvlflg, grdout, qlvls, nvout,
     +			    iret)
C************************************************************************
C* GDTXGD								*
C*									*
C* This subroutine vertically interpolates values in a cross section	*
C* plane to regularly spaced levels in a specified vertical coordinate	*
C* type.								*
C*									*
C* GDTXGD ( GRIDIN, NX, NV, IVCORD, IYAXIS, RLVLS, YBOT, YTOP, LVLFLG,	*
C*          GRDOUT, QLVLS, NVOUT, IRET )				*
C*									*
C* Input parameters:							*
C*	GRIDIN (NX, NV)       REAL	Input cross section array	*
C*      NX		      INTEGER	Number of points in horz	*
C*      NV		      INTEGER	Number of points in vert	*
C*	IVCORD		      INTEGER   Vertical coordinate		*
C*	 			          1 = PRES			*
C*					  2 = THET			*
C*					  3 = HGHT			*
C*      IYAXIS		      INTEGER   Vertical coordinate type:	*
C*					  1 = linear			*
C*                                        2 = logarthmic		*
C*                                        3 = ** RKAPPA			*
C*      RLVLS (NV)	      REAL      Values of vert lvls in GRIDIN	*
C*	YBOT		      REAL	Lower bound for vert coord	*
C*      YTOP		      REAL	Upper bound for vert coord	*
C*	LVLFLG		      LOGICAL	Flag for levels:		*
C*					 .false. = compute QLVLS,	*
C*						   NVOUT		*
C*					 .true.  = QLVLS, NVOUT input	*
C*									*
C* Output parameters:							*
C*      GRDOUT (NX, NVOUT)    REAL      Output cross section grid	*
C*	QLVLS (NVOUT)	      REAL	Values of vert lvls in GRDOUT	*
C*      NVOUT		      INTEGER   Number of vert lvls post	*
C*					interp				*
C*	IRET		      INTEGER	Return code			*
C*					  0 = normal return		*
C*					 -4 = invalid vert coord	*
C*									*
C* Log:									*
C* K. F. Brill/GSC       7/89  						*
C* K. Brill/GSC          8/89           Interpolate to exact levels	*
C* K. Brill/GSC          1/90           Set lower/upper lvls for int	*
C* K. Brill/NMC		 1/91		Check for equality between 	*
C*        				input and output levels		*
C* K. Brill/NMC		11/92		Fix calls to ER_WMSG		*
C* S. Gilbert/NCEP	08/07		Removed reference to LLMXGD	*
C************************************************************************
	INCLUDE 	'GEMPRM.PRM'
C*
        REAL 		gridin (nx, nv), grdout (*), rlvls (nv)
	REAL		qlvls (*)
	LOGICAL		lvlflg
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C*
	IF ( .not. lvlflg ) THEN
C*
	    rkinv = 1./RKAPPA
C
C*	  Compute the vertical increment for the output grid using the
C*        minimum vertical differential distance in the transformed
C*        coordinate.
C
	    difmin = 1.e32
	    DO k = 1, nv
		IF ( iyaxis .eq. 1 ) THEN
		    qk = rlvls ( k )
		ELSE IF ( iyaxis .eq. 2 ) THEN
		    IF ( rlvls ( k ) .gt. 0.0 ) THEN
			qk = ALOG ( rlvls ( k ) )
		    ELSE
			iret = -7
			CALL ER_WMSG ( 'GDTHGT', -4, ' ', ier )
			RETURN
		    END IF
		ELSE IF ( iyaxis .eq. 3 ) THEN
		    IF ( rlvls ( k ) .gt. 0.0 ) THEN
			qk = rlvls ( k ) ** RKAPPA
		    ELSE
			iret = -7
			CALL ER_WMSG ( 'GDTHGT', -4, ' ', ier )
			RETURN
		    END IF
		ELSE
		    iret = -7
		    CALL ER_WMSG ( 'GDTHGT', -4, ' ', ier )
		    RETURN
		END IF
		IF ( k .gt. 1 ) THEN
		    dif = ABS ( qk - qkm1 )
		    IF ( dif .lt. difmin ) difmin = dif
		END IF
		IF ( k .eq. 1 ) q1 = qk
		IF ( k .eq. nv ) qnv = qk
		qkm1 = qk
	    END DO
C
C*	    Compute the bounds in output coordinate system.
C
            IF ( iyaxis .eq. 1 ) THEN
		q1 = ybot
		q2 = ytop
            ELSE IF ( iyaxis .eq. 2 ) THEN
		IF ( ybot .gt. 0.0 .and. ytop .gt. 0.0 ) THEN
		    q1 = ALOG ( ybot )
		    q2 = ALOG ( ytop )
		ELSE
		    iret = -7
		    CALL ER_WMSG ( 'GDTHGT', -4, ' ', ier )
		    RETURN
		END IF
	    ELSE IF ( iyaxis .eq. 3 ) THEN
		IF ( ybot .gt. 0.0 .and. ytop .gt. 0.0 ) THEN
		    q1 = ybot ** RKAPPA
		    q2 = ytop ** RKAPPA
		ELSE
		    iret = -7
		    CALL ER_WMSG ( 'GDTHGT', -4, ' ', ier )
		    RETURN
		END IF
	    ELSE
		iret = -7
		CALL ER_WMSG ( 'GDTHGT', -4, ' ', ier )
		RETURN
	    END IF
C
C*	    Determine the number of levels to which to interpolate.
C
	    rnolv = ABS ( q1 - q2 ) / difmin
	    nvout = INT ( rnolv + .5 ) + 1
	    nvchk = nvout * nx
	    maxsize = LLMXLV * LLMXGT
	    IF ( nvchk .gt. maxsize ) nvout = maxsize / nx
	    IF ( nvout .gt. LLMXLV ) nvout = LLMXLV
C*
	    nvm1 = nvout - 1
	    dz = ( q2 - q1 ) / FLOAT ( nvm1 )
C
C*	    Create array of output levels.
C
	    z = q1
	    DO k = 2, nvm1
		z = z + dz
		IF ( iyaxis .eq. 1 ) qlvls ( k ) = z
		IF ( iyaxis .eq. 2 ) qlvls ( k ) = EXP ( z )
		IF ( iyaxis .eq. 3 ) qlvls ( k ) = z ** rkinv
	    END DO
C
C*	    Set lower and upper most levels for the interpolation.
C
	    qlvls ( 1 ) = rlvls ( 1 )
	    qlvls ( nvout ) = rlvls ( nv )
C
	END IF
C
C* 	Load output grid with missing values.
C
        istp = nvout * nx
	DO i = 1, istp
	    grdout ( i ) = RMISSD
	END DO
C
C*	Do the interpolation to the regularly spaced grid.
C
	DO ko = 2, nv
	    DO kn = 1, nvout
		indx = nx * ( kn - 1 )
		q = qlvls ( kn )
C
C*		Compute interpolation weights.
C
		IF ( q .eq. rlvls ( ko - 1 ) ) THEN
		    wt = 0.
		ELSE IF ( q .eq. rlvls ( ko ) ) THEN
		    wt = 1.0
		ELSE IF ( ( q .gt. rlvls ( ko - 1 ) .and.
     +			    q .lt. rlvls ( ko ) ) .or.
     +			  ( q .lt. rlvls ( ko - 1 ) .and.
     +			    q .gt. rlvls ( ko ) ) ) THEN
		    IF ( ivcord .eq. 1 ) THEN
			wt = ALOG ( q / rlvls ( ko - 1 ) ) /
     +			     ALOG ( rlvls ( ko ) / rlvls ( ko - 1 ) )
		    ELSE
			wt = ( q - rlvls ( ko - 1 ) ) /
     +                       ( rlvls ( ko ) - rlvls ( ko - 1 ) )
		    END IF
		ELSE
		    wt = -9999.
		END IF
C
C*		If the weight is positive, apply it.
C
		IF ( wt .ge. 0.0 ) THEN
		    wb = 1.000 - wt
		    DO i = 1, nx
			indx = indx + 1
			IF ( ERMISS (gridin ( i, ko ) ) .OR.
     +			     ERMISS (gridin ( i, ko-1 ) ) ) THEN
			    grdout ( indx ) = RMISSD
			ELSE
			    grdout ( indx ) = gridin ( i, ko ) * wt +
     +					      gridin ( i, ko-1 ) * wb
			END IF
		    END DO
		END IF
	    END DO
	END DO
C*
	RETURN
	END