module gc_nscbc_mod

  private
  public impose_NSCBC

contains

!------------------------------
! Imposing Ghost-Cells Navier-Stokes Characteristic BCs.
! For the theory, see Motheau et al. AIAA J. Vol. 55, No. 10 : pp. 3399-3408, 2017.
!
! Note that for the corner treatment, we depart from the AIAA paper, because
! we found out that the corner coupling method was superfluous and that providing
! transverse terms computed from one-sided derivative do the job.
!
!------------------------------

 subroutine impose_NSCBC(lo, hi, domlo, domhi, &
                         uin, uin_l1, uin_l2, uin_l3, uin_h1, uin_h2, uin_h3, &
                         q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                         qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3, &
                         x_bcMask, x_bcMask_l1, x_bcMask_l2, x_bcMask_l3, x_bcMask_h1, x_bcMask_h2, x_bcMask_h3, &
                         y_bcMask, y_bcMask_l1, y_bcMask_l2, y_bcMask_l3, y_bcMask_h1, y_bcMask_h2, y_bcMask_h3, &
                         z_bcMask, z_bcMask_l1, z_bcMask_l2, z_bcMask_l3, z_bcMask_h1, z_bcMask_h2, z_bcMask_h3, &
                         flag_nscbc_isAnyPerio, flag_nscbc_perio, &
                         time,delta,dt,verbose) bind(C, name="impose_NSCBC")

  use amrex_fort_module
  use eos_module
  use fundamental_constants_module, only: k_B, n_A

  use amrex_constants_module
  use prob_params_module, only : physbc_lo, physbc_hi, problo, probhi, UserBC

  use meth_params_module, only : NVAR, NQAUX,QVAR
  use bc_fill_module, only: bcnormal

  implicit none

  integer, intent(in) :: lo(3), hi(3), verbose
  integer, intent(in) :: domlo(3), domhi(3)
  integer, intent(in) :: q_l1, q_l2, q_l3, q_h1, q_h2, q_h3
  integer, intent(in) :: qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3
  integer, intent(in) :: uin_l1, uin_l2, uin_l3, uin_h1, uin_h2, uin_h3
  integer, intent(in) :: x_bcMask_l1, x_bcMask_l2, x_bcMask_l3, x_bcMask_h1, x_bcMask_h2, x_bcMask_h3
  integer, intent(in) :: y_bcMask_l1, y_bcMask_l2, y_bcMask_l3, y_bcMask_h1, y_bcMask_h2, y_bcMask_h3
  integer, intent(in) :: z_bcMask_l1, z_bcMask_l2, z_bcMask_l3, z_bcMask_h1, z_bcMask_h2, z_bcMask_h3
  integer, intent(in) :: flag_nscbc_isAnyPerio
  integer, intent(in) :: flag_nscbc_perio(3)

  double precision, intent(inout) :: q(q_l1:q_h1,q_l2:q_h2,q_l3:q_h3,QVAR)
  double precision, intent(inout) :: qaux(qa_l1:qa_h1,qa_l2:qa_h2,qa_l3:qa_h3,NQAUX)
  double precision, intent(inout) :: uin(uin_l1:uin_h1,uin_l2:uin_h2,uin_l3:uin_h3,NVAR)
  integer, intent(inout) :: x_bcMask(x_bcMask_l1:x_bcMask_h1,x_bcMask_l2:x_bcMask_h2,x_bcMask_l3:x_bcMask_h3)
  integer, intent(inout) :: y_bcMask(y_bcMask_l1:y_bcMask_h1,y_bcMask_l2:y_bcMask_h2,y_bcMask_l3:y_bcMask_h3)
  integer, intent(inout) :: z_bcMask(z_bcMask_l1:z_bcMask_h1,z_bcMask_l2:z_bcMask_h2,z_bcMask_l3:z_bcMask_h3)
  double precision, intent(in) :: delta(3), dt, time

  ! Local
  double precision dx, dy, dz
  double precision x, y, z

  double precision :: drhodx, dudx, dvdx, dwdx, dpdx
  double precision :: dpdy, dudy, dvdy, dwdy, drhody
  double precision :: dpdz, dudz, dvdz, dwdz, drhodz
  double precision :: L1, L2, L3, L4, L5
  double precision :: M1, M2, M3, M4, M5
  double precision :: N1, N2, N3, N4, N5

  double precision :: T1_X, T2_X, T3_X, T4_X, T5_X
  double precision :: T1_Y, T2_Y, T3_Y, T4_Y, T5_Y
  double precision :: T1_Z, T2_Z, T3_Z, T4_Z, T5_Z

  double precision :: U_dummy(NVAR)
  double precision :: U_ext(NVAR)
  double precision, parameter :: small = 1.d-8

  integer          :: q_lo(3), q_hi(3)
  integer          :: uin_lo(3),  uin_hi(3)
  integer          :: i, j, k
  integer          :: bc_type, x_bc_type, y_bc_type, z_bc_type
  integer          :: x_isign, y_isign, z_isign, x_idx_Mask, y_idx_Mask, z_idx_Mask
  integer          :: test_keyword_x, test_keyword_y, test_keyword_z
  double precision :: bc_params(6), x_bc_params(6), y_bc_params(6), z_bc_params(6)
  double precision :: bc_target(5), x_bc_target(5), y_bc_target(5), z_bc_target(5)

  type (eos_t) :: eos_state
  call build(eos_state)

  q_lo = [q_l1, q_l2, q_l3]
  q_hi = [q_h1, q_h2, q_h3]

  uin_lo  = [uin_l1, uin_l2, uin_l3]
  uin_hi  = [uin_h1, uin_h2, uin_h3]

  dx = delta(1)
  dy = delta(2)
  dz = delta(3)

  x_bcMask(:,:,:) = 0
  y_bcMask(:,:,:) = 0
  z_bcMask(:,:,:) = 0

  bc_params(:) = 0
  bc_target(:) = 0
  x_bc_params(:) = 0
  x_bc_target(:) = 0
  y_bc_params(:) = 0
  y_bc_target(:) = 0
  z_bc_params(:) = 0
  z_bc_target(:) = 0

  if ( flag_nscbc_isAnyPerio == 0) then

 !--------------------------------------------------------------------------
 ! corners
 !--------------------------------------------------------------------------

   if       (((q_hi(1) > domhi(1)) .or. (q_lo(1) < domlo(1))) &
       .and. ((q_hi(2) > domhi(2)) .or. (q_lo(2) < domlo(2))) &
       .and. ((q_hi(3) > domhi(3)) .or. (q_lo(3) < domlo(3)))) then

    if (q_hi(1) > domhi(1)) then
      test_keyword_x = physbc_hi(1)
      i = domhi(1)
      x_isign = -1
      x_idx_Mask = i+1
    elseif (q_lo(1) < domlo(1)) then
      test_keyword_x = physbc_lo(1)
      i = domlo(1)
      x_isign = 1
      x_idx_Mask = i
    endif

    if (q_hi(2) > domhi(2)) then
      test_keyword_y = physbc_hi(2)
      j = domhi(2)
      y_isign = -1
      y_idx_Mask = j+1
    elseif (q_lo(2) < domlo(2)) then
      test_keyword_y = physbc_lo(2)
      j = domlo(2)
      y_isign = 1
      y_idx_Mask = j
    endif

    if (q_hi(3) > domhi(3)) then
      test_keyword_z = physbc_hi(3)
      k = domhi(3)
      z_isign = -1
      z_idx_Mask = k+1
    elseif (q_lo(3) < domlo(3)) then
      test_keyword_z = physbc_lo(3)
      k = domlo(3)
      z_isign = 1
      z_idx_Mask = k
    endif

    x   = (dble(i)+HALF)*dx
    y   = (dble(j)+HALF)*dy
    z   = (dble(k)+HALF)*dz

    ! Normal derivative along x
    call normal_derivative(i, j, k, 1, x_isign, dx, &
                           dpdx, dudx, dvdx, dwdx, drhodx, &
                           q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

    ! Normal derivative along y
    call normal_derivative(i, j, k, 2, y_isign, dy, &
                           dpdy, dudy, dvdy, dwdy, drhody, &
                           q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

    ! Normal derivative along z
    call normal_derivative(i, j, k, 3, z_isign, dz, &
                           dpdz, dudz, dvdz, dwdz, drhodz, &
                           q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

    ! Compute transverse terms for X
    call compute_transverse_terms(i, j, k, 1,  &
                                  T1_X, T2_X, T3_X, T4_X, T5_X, &
                                  dpdx, dudx, dvdx, dwdx, drhodx, &
                                  dpdy, dudy, dvdy, dwdy, drhody, &
                                  dpdz, dudz, dvdz, dwdz, drhodz, &
                                  q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                                  qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

    ! Compute transverse terms for X
    call compute_transverse_terms(i, j, k, 2,  &
                                  T1_Y, T2_Y, T3_Y, T4_Y, T5_Y, &
                                  dpdx, dudx, dvdx, dwdx, drhodx, &
                                  dpdy, dudy, dvdy, dwdy, drhody, &
                                  dpdz, dudz, dvdz, dwdz, drhodz, &
                                  q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                                  qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

    ! Compute transverse terms for X
    call compute_transverse_terms(i, j, k, 3,  &
                                  T1_Z, T2_Z, T3_Z, T4_Z, T5_Z, &
                                  dpdx, dudx, dvdx, dwdx, drhodx, &
                                  dpdy, dudy, dvdy, dwdy, drhody, &
                                  dpdz, dudz, dvdz, dwdz, drhodz, &
                                  q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                                  qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

    ! Calling user target BC values
    ! x face
    if (test_keyword_x == UserBC) then
      call bcnormal([x,y,z],U_dummy,U_ext,1,x_isign,time,x_bc_type,x_bc_params,x_bc_target)
    else
      x_bc_type = test_keyword_x
    endif
    x_bcMask(x_idx_Mask,j,k) = x_bc_type

    ! y face
    if (test_keyword_y == UserBC) then
      call bcnormal([x,y,z],U_dummy,U_ext,2,y_isign,time,y_bc_type,y_bc_params,y_bc_target)
    else
      y_bc_type = test_keyword_y
    endif
    y_bcMask(i,y_idx_Mask,k) = y_bc_type

    ! z face
    if (test_keyword_z == UserBC) then
      call bcnormal([x,y,z],U_dummy,U_ext,3,z_isign,time,z_bc_type,z_bc_params,z_bc_target)
    else
      z_bc_type = test_keyword_z
    endif
    z_bcMask(i,j,z_idx_Mask) = z_bc_type

    ! Computing the LODI system waves along X
    call compute_waves(i, j, k, 1, x_isign, &
                       x_bc_type, x_bc_params, x_bc_target, &
                       T1_X, T2_X, T3_X, T4_X, T5_X, &
                       L1, L2, L3, L4, L5, &
                       dpdx, dudx, dvdx, dwdx, drhodx, &
                       q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                       qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

    ! Computing the LODI system waves along Y
    call compute_waves(i, j, k, 2, y_isign, &
                       y_bc_type, y_bc_params, y_bc_target, &
                       T1_Y, T2_Y, T3_Y, T4_Y, T5_Y, &
                       M1, M2, M3, M4, M5, &
                       dpdy, dudy, dvdy, dwdy, drhody, &
                       q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                       qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

    ! Computing the LODI system waves along Z
    call compute_waves(i, j, k, 3, z_isign, &
                       z_bc_type, z_bc_params, z_bc_target, &
                       T1_Z, T2_Z, T3_Z, T4_Z, T5_Z, &
                       N1, N2, N3, N4, N5, &
                       dpdz, dudz, dvdz, dwdz, drhodz, &
                       q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                       qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

    ! Recomputing ghost-cells values with the LODI waves along X
    call update_ghost_cells(i, j, k, x_bc_type, 1, x_isign, dx, &
                            domlo, domhi, &
                            L1, L2, L3, L4, L5, &
                            uin, uin_l1, uin_l2, uin_l3, uin_h1, uin_h2, uin_h3, &
                            q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                            qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

    ! Recomputing ghost-cells values with the LODI waves along Y
    call update_ghost_cells(i, j, k, y_bc_type, 2, y_isign, dy, &
                            domlo, domhi, &
                            M1, M2, M3, M4, M5, &
                            uin, uin_l1, uin_l2, uin_l3, uin_h1, uin_h2, uin_h3, &
                            q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                            qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

    ! Recomputing ghost-cells values with the LODI waves along Y
    call update_ghost_cells(i, j, k, z_bc_type, 3, z_isign, dz, &
                            domlo, domhi, &
                            N1, N2, N3, N4, N5, &
                            uin, uin_l1, uin_l2, uin_l3, uin_h1, uin_h2, uin_h3, &
                            q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                            qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

 endif
endif ! flag_nscbc_isAnyPerio )

 !--------------------------------------------------------------------------
 ! lower X
 !--------------------------------------------------------------------------

 if ((q_lo(1) < domlo(1)) .and. (physbc_lo(1) == UserBC)) then

   i = domlo(1)
   x   = (dble(i)+HALF)*dx

   do j = q_lo(2)+1,q_hi(2)-1

     y   = (dble(j)+HALF)*dy

     if ( flag_nscbc_isAnyPerio == 0) then
       if ((j == domlo(2)) .or. (j == domhi(2))) cycle !Doing that to avoid ghost cells already filled by corners
     endif

     do k = q_lo(3)+1,q_hi(3)-1

       z   = (dble(k)+HALF)*dz

       if ( flag_nscbc_isAnyPerio == 0) then
         if ((k== domlo(3)) .or. (k == domhi(3))) cycle !Doing that to avoid ghost cells already filled by corners
       endif

       ! Normal derivative along x
       call normal_derivative(i, j, k, 1, 1, dx, &
                              dpdx, dudx, dvdx, dwdx, drhodx, &
                              q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Tangential derivative along y
       call tangential_derivative(i, j, k, 2, dy, &
                                  dpdy, dudy, dvdy, dwdy, drhody, &
                                  q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Tangential derivative along z
       call tangential_derivative(i, j, k, 3, dz, &
                                  dpdz, dudz, dvdz, dwdz, drhodz, &
                                  q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Compute transverse terms
       call compute_transverse_terms(i, j, k, 1,  &
                               T1_X, T2_X, T3_X, T4_X, T5_X, &
                               dpdx, dudx, dvdx, dwdx, drhodx, &
                               dpdy, dudy, dvdy, dwdy, drhody, &
                               dpdz, dudz, dvdz, dwdz, drhodz, &
                               q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                               qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

       ! Calling user target BC values
       call bcnormal([x,y,z],U_dummy,U_ext,1,1,time,bc_type,bc_params,bc_target)

       ! Filling bcMask with specific user defined BC type
       if ((j < q_lo(2)+3) .or. (j > q_hi(2)-3) .or. (k < q_lo(3)+3) .or. (k > q_hi(3)-3)) then
         continue ! There is just 1 ghost-cell with bcMask because of the Riemann solver
       else
         x_bcMask(i,j,k) = bc_type
       endif

       ! Computing the LODI system waves
       call compute_waves(i, j, k, 1, 1, &
                          bc_type, bc_params, bc_target, &
                          T1_X, T2_X, T3_X, T4_X, T5_X, &
                          L1, L2, L3, L4, L5, &
                          dpdx, dudx, dvdx, dwdx, drhodx, &
                          q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                          qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

       ! Recomputing ghost-cells values with the LODI waves
       call update_ghost_cells(i, j, k, bc_type, 1, 1, dx, &
                               domlo, domhi, &
                               L1, L2, L3, L4, L5, &
                               uin, uin_l1, uin_l2, uin_l3, uin_h1, uin_h2, uin_h3, &
                               q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                               qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

     enddo
   enddo
 end if

 !--------------------------------------------------------------------------
 ! upper X
 !--------------------------------------------------------------------------

 if ((q_hi(1) > domhi(1)) .and. (physbc_hi(1) == UserBC)) then

   i = domhi(1)
   x   = (dble(i)+HALF)*dx

   do j = q_lo(2)+1,q_hi(2)-1

     y   = (dble(j)+HALF)*dy

     if ( flag_nscbc_isAnyPerio == 0) then
       if ((j == domlo(2)) .or. (j == domhi(2))) cycle !Doing that to avoid ghost cells already filled by corners
     endif

     do k = q_lo(3)+1,q_hi(3)-1

       z   = (dble(k)+HALF)*dz

       if ( flag_nscbc_isAnyPerio == 0) then
         if ((k== domlo(3)) .or. (k == domhi(3))) cycle !Doing that to avoid ghost cells already filled by corners
       endif

       ! Normal derivative along x
       call normal_derivative(i, j, k, 1, -1, dx, &
                              dpdx, dudx, dvdx, dwdx, drhodx, &
                              q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Tangential derivative along y
       call tangential_derivative(i, j, k, 2, dy, &
                                  dpdy, dudy, dvdy, dwdy, drhody, &
                                  q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Tangential derivative along z
       call tangential_derivative(i, j, k, 3, dz, &
                                  dpdz, dudz, dvdz, dwdz, drhodz, &
                                  q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Compute transverse terms
       call compute_transverse_terms(i, j, k, 1,  &
                               T1_X, T2_X, T3_X, T4_X, T5_X, &
                               dpdx, dudx, dvdx, dwdx, drhodx, &
                               dpdy, dudy, dvdy, dwdy, drhody, &
                               dpdz, dudz, dvdz, dwdz, drhodz, &
                               q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                               qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

       ! Filling bcMask with specific user defined BC type
       call bcnormal([x,y,z],U_dummy,U_ext,1,-1,time,bc_type,bc_params,bc_target)
       if ((j < q_lo(2)+3) .or. (j > q_hi(2)-3) .or. (k < q_lo(3)+3) .or. (k > q_hi(3)-3)) then
         continue ! There is just 1 ghost-cell with bcMask because of the Riemann solver
       else
         x_bcMask(i+1,j,k) = bc_type
       endif

       ! Computing the LODI system waves
       call compute_waves(i, j, k, 1, -1, &
                          bc_type, bc_params, bc_target, &
                          T1_X, T2_X, T3_X, T4_X, T5_X, &
                          L1, L2, L3, L4, L5, &
                          dpdx, dudx, dvdx, dwdx, drhodx, &
                          q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                          qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

       ! Recomputing ghost-cells values with the LODI waves
       call update_ghost_cells(i, j, k, bc_type, 1, -1, dx, &
                               domlo, domhi, &
                               L1, L2, L3, L4, L5, &
                               uin, uin_l1, uin_l2, uin_l3, uin_h1, uin_h2, uin_h3, &
                               q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                               qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

     enddo
   enddo
 endif

 !--------------------------------------------------------------------------
 ! lower Y
 !--------------------------------------------------------------------------

 if ((q_lo(2) < domlo(2)) .and. (physbc_lo(2) == UserBC)) then

   j = domlo(2)
   y   = (dble(j)+HALF)*dy

   do i = q_lo(1)+1,q_hi(1)-1

     x   = (dble(i)+HALF)*dx

     if ( flag_nscbc_isAnyPerio == 0) then
       if ((i == domlo(1)) .or. (i == domhi(1))) cycle !Doing that to avoid ghost cells already filled by corners
     endif

     do k = q_lo(3)+1,q_hi(3)-1

       z   = (dble(k)+HALF)*dz

       if ( flag_nscbc_isAnyPerio == 0) then
         if ((k== domlo(3)) .or. (k == domhi(3))) cycle !Doing that to avoid ghost cells already filled by corners
       endif

       ! Normal derivative along y
       call normal_derivative(i, j, k, 2, 1, dy, &
                              dpdy, dudy, dvdy, dwdy, drhody, &
                              q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Tangential derivative along x
       call tangential_derivative(i, j, k, 1, dx, &
                                  dpdx, dudx, dvdx, dwdx, drhodx, &
                                  q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Tangential derivative along z
       call tangential_derivative(i, j, k, 3, dz, &
                                  dpdz, dudz, dvdz, dwdz, drhodz, &
                                  q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Compute transverse terms
       call compute_transverse_terms(i, j, k, 2,  &
                               T1_Y, T2_Y, T3_Y, T4_Y, T5_Y, &
                               dpdx, dudx, dvdx, dwdx, drhodx, &
                               dpdy, dudy, dvdy, dwdy, drhody, &
                               dpdz, dudz, dvdz, dwdz, drhodz, &
                               q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                               qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

       ! Filling bcMask with specific user defined BC type
       call bcnormal([x,y,z],U_dummy,U_ext,2,1,time,bc_type,bc_params,bc_target)
       if ((i < q_lo(1)+3) .or. (i > q_hi(1)-3) .or. (k < q_lo(3)+3) .or. (k > q_hi(3)-3)) then
         continue ! There is just 1 ghost-cell with bcMask because of the Riemann solver
       else
         y_bcMask(i,j,k) = bc_type
       endif

       ! Computing the LODI system waves
       call compute_waves(i, j, k, 2, 1, &
                          bc_type, bc_params, bc_target, &
                          T1_Y, T2_Y, T3_Y, T4_Y, T5_Y, &
                          L1, L2, L3, L4, L5, &
                          dpdy, dudy, dvdy, dwdy, drhody, &
                          q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                          qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

       ! Recomputing ghost-cells values with the LODI waves
       call update_ghost_cells(i, j, k, bc_type, 2, 1, dy, &
                               domlo, domhi, &
                               L1, L2, L3, L4, L5, &
                               uin, uin_l1, uin_l2, uin_l3, uin_h1, uin_h2, uin_h3, &
                               q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                               qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

     enddo
   enddo
 end if

!--------------------------------------------------------------------------
! upper Y
!--------------------------------------------------------------------------

 if ((q_hi(2) > domhi(2)) .and. (physbc_hi(2) == UserBC)) then

   j = domhi(2)
   y   = (dble(j)+HALF)*dy

   do i = q_lo(1)+1,q_hi(1)-1

     x   = (dble(i)+HALF)*dx

     if ( flag_nscbc_isAnyPerio == 0) then
       if ((i == domlo(1)) .or. (i == domhi(1))) cycle !Doing that to avoid ghost cells already filled by corners
     endif

     do k = q_lo(3)+1,q_hi(3)-1

       z   = (dble(k)+HALF)*dz

       if ( flag_nscbc_isAnyPerio == 0) then
         if ((k== domlo(3)) .or. (k == domhi(3))) cycle !Doing that to avoid ghost cells already filled by corners
       endif

       ! Normal derivative along y
       call normal_derivative(i, j, k, 2, -1, dy, &
                              dpdy, dudy, dvdy, dwdy, drhody, &
                              q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Tangential derivative along x
       call tangential_derivative(i, j, k, 1, dx, &
                                  dpdx, dudx, dvdx, dwdx, drhodx, &
                                  q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Tangential derivative along z
       call tangential_derivative(i, j, k, 3, dz, &
                                  dpdz, dudz, dvdz, dwdz, drhodz, &
                                  q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Compute transverse terms
       call compute_transverse_terms(i, j, k, 2,  &
                               T1_Y, T2_Y, T3_Y, T4_Y, T5_Y, &
                               dpdx, dudx, dvdx, dwdx, drhodx, &
                               dpdy, dudy, dvdy, dwdy, drhody, &
                               dpdz, dudz, dvdz, dwdz, drhodz, &
                               q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                               qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

     ! Filling bcMask with specific user defined BC type
     call bcnormal([x,y,z],U_dummy,U_ext,2,-1,time,bc_type,bc_params,bc_target)
     if ((i < q_lo(1)+3) .or. (i > q_hi(1)-3) .or. (k < q_lo(3)+3) .or. (k > q_hi(3)-3)) then
       continue ! There is just 1 ghost-cell with bcMask because of the Riemann solver
     else
       y_bcMask(i,j+1,k) = bc_type
     endif

     ! Computing the LODI system waves
     call compute_waves(i, j, k, 2, -1, &
                          bc_type, bc_params, bc_target, &
                          T1_Y, T2_Y, T3_Y, T4_Y, T5_Y, &
                          L1, L2, L3, L4, L5, &
                          dpdy, dudy, dvdy, dwdy, drhody, &
                          q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                          qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

     ! Recomputing ghost-cells values with the LODI waves
     call update_ghost_cells(i, j, k, bc_type, 2, -1, dy, &
                             domlo, domhi, &
                             L1, L2, L3, L4, L5, &
                             uin, uin_l1, uin_l2, uin_l3, uin_h1, uin_h2, uin_h3, &
                             q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                             qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

     enddo
   enddo
end if

 !--------------------------------------------------------------------------
 ! lower Z
 !--------------------------------------------------------------------------

 if ((q_lo(3) < domlo(3)) .and. (physbc_lo(3) == UserBC)) then

   k = domlo(3)
   z   = (dble(k)+HALF)*dz

   do i = q_lo(1)+1,q_hi(1)-1

     x   = (dble(i)+HALF)*dx

     if ( flag_nscbc_isAnyPerio == 0) then
       if ((i == domlo(1)) .or. (i == domhi(1))) cycle !Doing that to avoid ghost cells already filled by corners
     endif

     do j = q_lo(2)+1,q_hi(2)-1

       y   = (dble(j)+HALF)*dy

       if ( flag_nscbc_isAnyPerio == 0) then
         if ((j == domlo(2)) .or. (j == domhi(2))) cycle !Doing that to avoid ghost cells already filled by corners
       endif

       ! Normal derivative along y
       call normal_derivative(i, j, k, 3, 1, dz, &
                              dpdz, dudz, dvdz, dwdz, drhodz, &
                              q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Tangential derivative along x
       call tangential_derivative(i, j, k, 1, dx, &
                                  dpdx, dudx, dvdx, dwdx, drhodx, &
                                  q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Tangential derivative along z
       call tangential_derivative(i, j, k, 2, dy, &
                                  dpdy, dudy, dvdy, dwdy, drhody, &
                                  q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Compute transverse terms
       call compute_transverse_terms(i, j, k, 3,  &
                               T1_Z, T2_Z, T3_Z, T4_Z, T5_Z, &
                               dpdx, dudx, dvdx, dwdx, drhodx, &
                               dpdy, dudy, dvdy, dwdy, drhody, &
                               dpdz, dudz, dvdz, dwdz, drhodz, &
                               q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                               qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

       ! Filling bcMask with specific user defined BC type
       call bcnormal([x,y,z],U_dummy,U_ext,3,1,time,bc_type,bc_params,bc_target)
       if ((i < q_lo(1)+3) .or. (i > q_hi(1)-3) .or. (j < q_lo(2)+3) .or. (j > q_hi(2)-3)) then
         continue ! There is just 1 ghost-cell with bcMask because of the Riemann solver
       else
         z_bcMask(i,j,k) = bc_type
       endif

       ! Computing the LODI system waves
       call compute_waves(i, j, k, 3, 1, &
                          bc_type, bc_params, bc_target, &
                          T1_Z, T2_Z, T3_Z, T4_Z, T5_Z, &
                          L1, L2, L3, L4, L5, &
                          dpdz, dudz, dvdz, dwdz, drhodz, &
                          q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                          qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

       ! Recomputing ghost-cells values with the LODI waves
       call update_ghost_cells(i, j, k, bc_type, 3, 1, dz, &
                               domlo, domhi, &
                               L1, L2, L3, L4, L5, &
                               uin, uin_l1, uin_l2, uin_l3, uin_h1, uin_h2, uin_h3, &
                               q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                               qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

     enddo
   enddo
 end if

!--------------------------------------------------------------------------
! upper Z
!--------------------------------------------------------------------------

 if ((q_hi(3) > domhi(3)) .and. (physbc_hi(3) == UserBC)) then

   k = domhi(3)
   z   = (dble(k)+HALF)*dz

   do i = q_lo(1)+1,q_hi(1)-1

     x   = (dble(i)+HALF)*dx

     if ( flag_nscbc_isAnyPerio == 0) then
       if ((i == domlo(1)) .or. (i == domhi(1))) cycle !Doing that to avoid ghost cells already filled by corners
     endif

     do j = q_lo(2)+1,q_hi(2)-1

       y   = (dble(j)+HALF)*dy

       if ( flag_nscbc_isAnyPerio == 0) then
         if ((j == domlo(2)) .or. (j == domhi(2))) cycle !Doing that to avoid ghost cells already filled by corners
       endif

       ! Normal derivative along y
       call normal_derivative(i, j, k, 3, -1, dz, &
                              dpdz, dudz, dvdz, dwdz, drhodz, &
                              q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Tangential derivative along x
       call tangential_derivative(i, j, k, 1, dx, &
                                  dpdx, dudx, dvdx, dwdx, drhodx, &
                                  q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Tangential derivative along z
       call tangential_derivative(i, j, k, 2, dy, &
                                  dpdy, dudy, dvdy, dwdy, drhody, &
                                  q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

       ! Compute transverse terms
       call compute_transverse_terms(i, j, k, 3,  &
                               T1_Z, T2_Z, T3_Z, T4_Z, T5_Z, &
                               dpdx, dudx, dvdx, dwdx, drhodx, &
                               dpdy, dudy, dvdy, dwdy, drhody, &
                               dpdz, dudz, dvdz, dwdz, drhodz, &
                               q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                               qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

       ! Filling bcMask with specific user defined BC type
       call bcnormal([x,y,z],U_dummy,U_ext,3,-1,time,bc_type,bc_params,bc_target)
       if ((i < q_lo(1)+3) .or. (i > q_hi(1)-3) .or. (j < q_lo(2)+3) .or. (j > q_hi(2)-3)) then
         continue ! There is just 1 ghost-cell with bcMask because of the Riemann solver
       else
         z_bcMask(i,j,k) = bc_type
       endif

       ! Computing the LODI system waves
       call compute_waves(i, j, k, 3, -1, &
                          bc_type, bc_params, bc_target, &
                          T1_Z, T2_Z, T3_Z, T4_Z, T5_Z, &
                          L1, L2, L3, L4, L5, &
                          dpdz, dudz, dvdz, dwdz, drhodz, &
                          q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                          qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

       ! Recomputing ghost-cells values with the LODI waves
       call update_ghost_cells(i, j, k, bc_type, 3, -1, dz, &
                               domlo, domhi, &
                               L1, L2, L3, L4, L5, &
                               uin, uin_l1, uin_l2, uin_l3, uin_h1, uin_h2, uin_h3, &
                               q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                               qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

     enddo
   enddo
 end if

call destroy(eos_state)

end subroutine impose_NSCBC

!-------------------------------------------------
! Generic routines below
!-------------------------------------------------

  subroutine normal_derivative(i, j, k, idir, isign, delta, &
                               dp, du, dv, dw, drho, &
                               q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

  use meth_params_module, only : QVAR, QPRES, QU, QV, QW, QRHO

  implicit none

  integer, intent(in) :: i,j,k,idir,isign
  integer, intent(in) :: q_l1, q_l2, q_l3, q_h1, q_h2, q_h3
  double precision, intent(in) :: delta
  double precision, intent(in) :: q(q_l1:q_h1,q_l2:q_h2,q_l3:q_h3,QVAR)

  double precision, intent(out) :: dp, du, dv, dw, drho

  if (idir == 1) then
    if (isign == 1) then

      ! 2nd order
      dp = ((-3.0d0/2.0d0)*q(i,j,k,QPRES)+2.0d0*q(i+1,j,k,QPRES)-0.5d0*q(i+2,j,k,QPRES))/delta
      du = ((-3.0d0/2.0d0)*q(i,j,k,QU)+2.0d0*q(i+1,j,k,QU)-0.5d0*q(i+2,j,k,QU))/delta
      dv = ((-3.0d0/2.0d0)*q(i,j,k,QV)+2.0d0*q(i+1,j,k,QV)-0.5d0*q(i+2,j,k,QV))/delta
      dw = ((-3.0d0/2.0d0)*q(i,j,k,QW)+2.0d0*q(i+1,j,k,QW)-0.5d0*q(i+2,j,k,QW))/delta
      drho = ((-3.0d0/2.0d0)*q(i,j,k,QRHO)+2.0d0*q(i+1,j,k,QRHO)-0.5d0*q(i+2,j,k,QRHO))/delta

    elseif (isign == -1) then

       !2nd order
       dp = ((3.0d0/2.0d0)*q(i,j,k,QPRES)-2.0d0*q(i-1,j,k,QPRES)+0.5d0*q(i-2,j,k,QPRES))/delta
       du = ((3.0d0/2.0d0)*q(i,j,k,QU)-2.0d0*q(i-1,j,k,QU)+0.5d0*q(i-2,j,k,QU))/delta
       dv = ((3.0d0/2.0d0)*q(i,j,k,QV)-2.0d0*q(i-1,j,k,QV)+0.5d0*q(i-2,j,k,QV))/delta
       dw = ((3.0d0/2.0d0)*q(i,j,k,QW)-2.0d0*q(i-1,j,k,QW)+0.5d0*q(i-2,j,k,QW))/delta
       drho = ((3.0d0/2.0d0)*q(i,j,k,QRHO)-2.0d0*q(i-1,j,k,QRHO)+0.5d0*q(i-2,j,k,QRHO))/delta

    else
      call bl_abort("Problem of isign in impose_NSCBC_3d:normal_derivative")
    end if

  elseif (idir == 2) then

    if (isign == 1) then

      !2nd order
      dp = ((-3.0d0/2.0d0)*q(i,j,k,QPRES)+2.0d0*q(i,j+1,k,QPRES)-0.5d0*q(i,j+2,k,QPRES))/delta
      du = ((-3.0d0/2.0d0)*q(i,j,k,QU)+2.0d0*q(i,j+1,k,QU)-0.5d0*q(i,j+2,k,QU))/delta
      dv = ((-3.0d0/2.0d0)*q(i,j,k,QV)+2.0d0*q(i,j+1,k,QV)-0.5d0*q(i,j+2,k,QV))/delta
      dw = ((-3.0d0/2.0d0)*q(i,j,k,QW)+2.0d0*q(i,j+1,k,QW)-0.5d0*q(i,j+2,k,QW))/delta
      drho = ((-3.0d0/2.0d0)*q(i,j,k,QRHO)+2.0d0*q(i,j+1,k,QRHO)-0.5d0*q(i,j+2,k,QRHO))/delta

    elseif (isign == -1) then

      !2nd order
      dp = ((3.0d0/2.0d0)*q(i,j,k,QPRES)-2.0d0*q(i,j-1,k,QPRES)+0.5d0*q(i,j-2,k,QPRES))/delta
      du = ((3.0d0/2.0d0)*q(i,j,k,QU)-2.0d0*q(i,j-1,k,QU)+0.5d0*q(i,j-2,k,QU))/delta
      dv = ((3.0d0/2.0d0)*q(i,j,k,QV)-2.0d0*q(i,j-1,k,QV)+0.5d0*q(i,j-2,k,QV))/delta
      dw = ((3.0d0/2.0d0)*q(i,j,k,QW)-2.0d0*q(i,j-1,k,QW)+0.5d0*q(i,j-2,k,QW))/delta
      drho = ((3.0d0/2.0d0)*q(i,j,k,QRHO)-2.0d0*q(i,j-1,k,QRHO)+0.5d0*q(i,j-2,k,QRHO))/delta

    else
      call bl_abort("Problem of isign in impose_NSCBC_3d:normal_derivative")
    end if

  elseif (idir == 3) then

    if (isign == 1) then

      !2nd order
      dp = ((-3.0d0/2.0d0)*q(i,j,k,QPRES)+2.0d0*q(i,j,k+1,QPRES)-0.5d0*q(i,j,k+2,QPRES))/delta
      du = ((-3.0d0/2.0d0)*q(i,j,k,QU)+2.0d0*q(i,j,k+1,QU)-0.5d0*q(i,j,k+2,QU))/delta
      dv = ((-3.0d0/2.0d0)*q(i,j,k,QV)+2.0d0*q(i,j,k+1,QV)-0.5d0*q(i,j,k+2,QV))/delta
      dw = ((-3.0d0/2.0d0)*q(i,j,k,QW)+2.0d0*q(i,j,k+1,QW)-0.5d0*q(i,j,k+2,QW))/delta
      drho = ((-3.0d0/2.0d0)*q(i,j,k,QRHO)+2.0d0*q(i,j,k+1,QRHO)-0.5d0*q(i,j,k+2,QRHO))/delta

    elseif (isign == -1) then

      !2nd order
      dp = ((3.0d0/2.0d0)*q(i,j,k,QPRES)-2.0d0*q(i,j,k-1,QPRES)+0.5d0*q(i,j,k-2,QPRES))/delta
      du = ((3.0d0/2.0d0)*q(i,j,k,QU)-2.0d0*q(i,j,k-1,QU)+0.5d0*q(i,j,k-2,QU))/delta
      dv = ((3.0d0/2.0d0)*q(i,j,k,QV)-2.0d0*q(i,j,k-1,QV)+0.5d0*q(i,j,k-2,QV))/delta
      dw = ((3.0d0/2.0d0)*q(i,j,k,QW)-2.0d0*q(i,j,k-1,QW)+0.5d0*q(i,j,k-2,QW))/delta
      drho = ((3.0d0/2.0d0)*q(i,j,k,QRHO)-2.0d0*q(i,j,k-1,QRHO)+0.5d0*q(i,j,k-2,QRHO))/delta

    else
      call bl_abort("Problem of isign in impose_NSCBC_3d:normal_derivative")
    end if

  else
      call bl_abort("Problem of idir in impose_NSCBC_3d:normal_derivative")
  end if

  end subroutine normal_derivative

  !----------------

  subroutine tangential_derivative(i, j, k, idir, delta, &
                               dp, du, dv, dw, drho, &
                               q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3)

  use meth_params_module, only : QVAR, QPRES, QU, QV, QW, QRHO

  implicit none

  integer, intent(in) :: i,j,k,idir
  integer, intent(in) :: q_l1, q_l2, q_l3, q_h1, q_h2, q_h3
  double precision, intent(in) :: delta
  double precision, intent(in) :: q(q_l1:q_h1,q_l2:q_h2,q_l3:q_h3,QVAR)

  double precision, intent(out) :: dp, du, dv, dw, drho

  ! Warning, idir means the tangential direction, this is different from 2D (sorry)
  if (idir == 1) then

    ! 2nd order Central
    dp = (q(i+1,j,k,QPRES)-q(i-1,j,k,QPRES))/(2.0d0*delta)
    du = (q(i+1,j,k,QU)-q(i-1,j,k,QU))/(2.0d0*delta)
    dv = (q(i+1,j,k,QV)-q(i-1,j,k,QV))/(2.0d0*delta)
    dw = (q(i+1,j,k,QW)-q(i-1,j,k,QW))/(2.0d0*delta)
    drho = (q(i+1,j,k,QRHO)-q(i-1,j,k,QRHO))/(2.0d0*delta)

  elseif (idir == 2) then

    ! 2nd order Central
    dp = (q(i,j+1,k,QPRES)-q(i,j-1,k,QPRES))/(2.0d0*delta)
    du = (q(i,j+1,k,QU)-q(i,j-1,k,QU))/(2.0d0*delta)
    dv = (q(i,j+1,k,QV)-q(i,j-1,k,QV))/(2.0d0*delta)
    dw = (q(i,j+1,k,QW)-q(i,j-1,k,QW))/(2.0d0*delta)
    drho = (q(i,j+1,k,QRHO)-q(i,j-1,k,QRHO))/(2.0d0*delta)

  elseif (idir == 3) then

    ! 2nd order Central
    dp = (q(i,j,k+1,QPRES)-q(i,j,k-1,QPRES))/(2.0d0*delta)
    du = (q(i,j,k+1,QU)-q(i,j,k-1,QU))/(2.0d0*delta)
    dv = (q(i,j,k+1,QV)-q(i,j,k-1,QV))/(2.0d0*delta)
    dw = (q(i,j,k+1,QW)-q(i,j,k-1,QW))/(2.0d0*delta)
    drho = (q(i,j,k+1,QRHO)-q(i,j,k-1,QRHO))/(2.0d0*delta)

  else
      call bl_abort("Problem of idir in impose_NSCBC_3d:tangential_derivative")
  end if

  end subroutine tangential_derivative

  !-----------------

  subroutine compute_transverse_terms(i, j, k, idir,  &
                               T1, T2, T3, T4, T5, &
                               dpdx, dudx, dvdx, dwdx, drhodx, &
                               dpdy, dudy, dvdy, dwdy, drhody, &
                               dpdz, dudz, dvdz, dwdz, drhodz, &
                               q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                               qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

  use meth_params_module, only : QVAR, QPRES, QU, QV, QW, QRHO, NQAUX, QC, QGAMC

  implicit none

  integer, intent(in) :: i,j,k,idir
  integer, intent(in) :: q_l1, q_l2, q_l3, q_h1, q_h2, q_h3
  integer, intent(in) :: qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3
  double precision, intent(in) :: q(q_l1:q_h1,q_l2:q_h2,q_l3:q_h3,QVAR)
  double precision, intent(in) :: qaux(qa_l1:qa_h1,qa_l2:qa_h2,qa_l3:qa_h3,NQAUX)
  double precision, intent(in) :: dpdx, dudx, dvdx, dwdx, drhodx
  double precision, intent(in) :: dpdy, dudy, dvdy, dwdy, drhody
  double precision, intent(in) :: dpdz, dudz, dvdz, dwdz, drhodz

  double precision, intent(out) :: T1, T2, T3, T4, T5

  double precision :: inv_rho

  inv_rho = 1.0d0/q(i,j,k,QRHO)

  if (idir == 1) then

     T1 =  (q(i,j,k,QV)*(dpdy - q(i,j,k,QRHO)*qaux(i,j,k,QC)*dudy)) &
         + (q(i,j,k,QW)*(dpdz - q(i,j,k,QRHO)*qaux(i,j,k,QC)*dudz)) &
         + (qaux(i,j,k,QGAMC) * q(i,j,k,QPRES)*(dvdy + dwdz))

     T2 =  (q(i,j,k,QV)*((qaux(i,j,k,QC)*qaux(i,j,k,QC)*drhody)-dpdy))  &
         + (q(i,j,k,QW)*((qaux(i,j,k,QC)*qaux(i,j,k,QC)*drhodz)-dpdz))

     T3 = q(i,j,k,QV)*dvdy + q(i,j,k,QW)*dvdz + dpdy*inv_rho

     T4 = q(i,j,k,QV)*dwdy + q(i,j,k,QW)*dwdz + dpdz*inv_rho

     T5 =  (q(i,j,k,QV)*(dpdy + q(i,j,k,QRHO)*qaux(i,j,k,QC)*dudy)) &
         + (q(i,j,k,QW)*(dpdz + q(i,j,k,QRHO)*qaux(i,j,k,QC)*dudz)) &
         + (qaux(i,j,k,QGAMC) * q(i,j,k,QPRES)*(dvdy + dwdz))

  elseif (idir == 2) then

     T1 =  (q(i,j,k,QU)*(dpdx - q(i,j,k,QRHO)*qaux(i,j,k,QC)*dvdx)) &
         + (q(i,j,k,QW)*(dpdz - q(i,j,k,QRHO)*qaux(i,j,k,QC)*dvdz)) &
         + (qaux(i,j,k,QGAMC) * q(i,j,k,QPRES)*(dudx + dwdz))

     T2 = q(i,j,k,QU)*dudx + q(i,j,k,QW)*dudz + dpdx*inv_rho

     T3 =  (q(i,j,k,QU)*((qaux(i,j,k,QC)*qaux(i,j,k,QC)*drhodx)-dpdx))  &
         + (q(i,j,k,QW)*((qaux(i,j,k,QC)*qaux(i,j,k,QC)*drhodz)-dpdz))

     T4 = q(i,j,k,QU)*dwdx + q(i,j,k,QW)*dwdz + dpdz*inv_rho

     T5 =  (q(i,j,k,QU)*(dpdx + q(i,j,k,QRHO)*qaux(i,j,k,QC)*dvdx)) &
         + (q(i,j,k,QW)*(dpdz + q(i,j,k,QRHO)*qaux(i,j,k,QC)*dvdz)) &
         + (qaux(i,j,k,QGAMC) * q(i,j,k,QPRES)*(dudx + dwdz))

  elseif (idir == 3) then

     T1 =  (q(i,j,k,QU)*(dpdx - q(i,j,k,QRHO)*qaux(i,j,k,QC)*dwdx)) &
         + (q(i,j,k,QV)*(dpdy - q(i,j,k,QRHO)*qaux(i,j,k,QC)*dwdz)) &
         + (qaux(i,j,k,QGAMC) * q(i,j,k,QPRES)*(dudx + dvdy))

     T2 =  q(i,j,k,QU)*dudx + q(i,j,k,QV)*dudy + dpdx*inv_rho

     T3 =  q(i,j,k,QU)*dvdx + q(i,j,k,QV)*dvdy + dpdy*inv_rho

     T4 =  (q(i,j,k,QU)*((qaux(i,j,k,QC)*qaux(i,j,k,QC)*drhodx)-dpdx))  &
         + (q(i,j,k,QV)*((qaux(i,j,k,QC)*qaux(i,j,k,QC)*drhody)-dpdy))

     T5 =  (q(i,j,k,QU)*(dpdx + q(i,j,k,QRHO)*qaux(i,j,k,QC)*dwdx)) &
         + (q(i,j,k,QV)*(dpdy + q(i,j,k,QRHO)*qaux(i,j,k,QC)*dwdz)) &
         + (qaux(i,j,k,QGAMC) * q(i,j,k,QPRES)*(dudx + dvdy))

  else
      call bl_abort("Problem of idir in impose_NSCBC_2d:compute_transverse_terms")
  end if

  end subroutine compute_transverse_terms

  !-------------------------

  subroutine update_ghost_cells(i, j, k, bc_type, idir, isign, delta, &
                                domlo, domhi, &
                                L1, L2, L3, L4, L5, &
                                uin, uin_l1, uin_l2, uin_l3, uin_h1, uin_h2, uin_h3, &
                                q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                                qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

  use eos_module
  use amrex_constants_module, only : ONE
  use network, only : nspecies
  use meth_params_module, only : NVAR, URHO, UMX, UMY, UMZ, UEDEN, UEINT, UTEMP,&
                                 UFS, NQAUX, QC, QGAMC, QRSPEC, &
                                 QC, QDPDE, QDPDR, QCSML, QGAMC, &
                                 QVAR, QRHO, QU, QV, QW, QREINT, QPRES, QTEMP, &
                                 QFS, QFX, QGAME, NHYP
  use prob_params_module, only : SlipWall, NoSlipWall

  implicit none

  integer, intent(in) :: i,j,k,idir,isign,bc_type
  integer, intent(in) :: domlo(3), domhi(3)
  integer, intent(in) :: q_l1, q_l2, q_l3, q_h1, q_h2, q_h3
  integer, intent(in) :: qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3
  integer, intent(in) :: uin_l1, uin_l2, uin_l3, uin_h1, uin_h2, uin_h3
  double precision, intent(in) :: L1, L2, L3, L4, L5
  double precision, intent(in) :: delta
  double precision, intent(inout) :: q(q_l1:q_h1,q_l2:q_h2,q_l3:q_h3,QVAR)
  double precision, intent(inout) :: qaux(qa_l1:qa_h1,qa_l2:qa_h2,qa_l3:qa_h3,NQAUX)
  double precision, intent(inout) :: uin(uin_l1:uin_h1,uin_l2:uin_h2,uin_l3:uin_h3,NVAR)

  integer :: idx_gc1, idx_gc2, idx_gc3, idx_gc4, idx_int1, idx_int2, idx_int3
  integer :: idx_start, idx_end, hop, n, local_index
  double precision :: drho, du, dv, dw, dp, wall_sign
  double precision, parameter :: small = 1.d-8

  type (eos_t) :: eos_state

  call build(eos_state)

  if ((idir == 1) .or. (idir == 2) .or. (idir == 3)) then
    continue
  else
    call bl_abort("Problem of idir in impose_NSCBC_3d:update_ghost_cells")
  end if

  if ((isign == 1) .or. (isign == -1)) then
    continue
  else
    call bl_abort("Problem of isign in impose_NSCBC_3d:update_ghost_cells")
  end if

  ! Compute new spatial derivative

  if (idir == 1) then
    local_index = i
    drho = (L2 + 0.5d0*(L1 + L5))/(qaux(i,j,k,QC)**2.0d0)
    du   = (L5-L1)/(2.0d0*qaux(i,j,k,QC)*q(i,j,k,QRHO))
    dv   = L3
    dw   = L4
    dp   = 0.5d0*(L1+L5)
  elseif (idir == 2) then
    local_index = j
    drho = (L3 + 0.5d0*(L1 + L5))/(qaux(i,j,k,QC)**2.0d0)
    du   = L2
    dv   = (L5-L1)/(2.0d0*qaux(i,j,k,QC)*q(i,j,k,QRHO))
    dw   = L4
    dp   = 0.5d0*(L1+L5)
  elseif (idir == 3) then
    local_index = k
    drho = (L4 + 0.5d0*(L1 + L5))/(qaux(i,j,k,QC)**2.0d0)
    du   = L2
    dv   = L3
    dw   = (L5-L1)/(2.0d0*qaux(i,j,k,QC)*q(i,j,k,QRHO))
    dp   = 0.5d0*(L1+L5)
  endif

  if (isign == 1) then
    idx_gc1 = local_index-1
    idx_gc2 = local_index-2
    idx_gc3 = local_index-3
    idx_gc4 = local_index-4
    idx_int1 = local_index+1
    idx_int2 = local_index+2
    idx_int3 = local_index+3
    idx_start = domlo(idir)-1
    idx_end   = domlo(idir)-4
  elseif (isign == -1) then
    idx_gc1 = local_index+1
    idx_gc2 = local_index+2
    idx_gc3 = local_index+3
    idx_gc4 = local_index+4
    idx_int1 = local_index-1
    idx_int2 = local_index-2
    idx_int3 = local_index-3
    idx_start = domhi(idir)+1
    idx_end   = domhi(idir)+4
  endif

  if (idir == 1) then

    ! Update ghost cells
    ! 2nd order
    q(idx_gc1,j,k,QU)    = q(idx_int1,j,k,QU) - 2.0d0*delta*du*isign
    q(idx_gc1,j,k,QV)    = q(idx_int1,j,k,QV) - 2.0d0*delta*dv*isign
    q(idx_gc1,j,k,QW)    = q(idx_int1,j,k,QW) - 2.0d0*delta*dw*isign
    q(idx_gc1,j,k,QRHO)  = q(idx_int1,j,k,QRHO)  - 2.0d0*delta*drho*isign
    q(idx_gc1,j,k,QPRES) = q(idx_int1,j,k,QPRES) - 2.0d0*delta*dp*isign

    !----------------
    q(idx_gc2,j,k,QU)    = -2.0d0*q(idx_int1,j,k,QU) - 3.0d0*q(i,j,k,QU) + 6.0d0*q(idx_gc1,j,k,QU) + 6.0d0*delta*du*isign
    q(idx_gc2,j,k,QV)    = -2.0d0*q(idx_int1,j,k,QV) - 3.0d0*q(i,j,k,QV) + 6.0d0*q(idx_gc1,j,k,QV) + 6.0d0*delta*dv*isign
    q(idx_gc2,j,k,QW)    = -2.0d0*q(idx_int1,j,k,QW) - 3.0d0*q(i,j,k,QW) + 6.0d0*q(idx_gc1,j,k,QW) + 6.0d0*delta*dw*isign
    q(idx_gc2,j,k,QRHO)  = -2.0d0*q(idx_int1,j,k,QRHO) - 3.0d0*q(i,j,k,QRHO) + 6.0d0*q(idx_gc1,j,k,QRHO) + 6.0d0*delta*drho*isign
    q(idx_gc2,j,k,QPRES) = -2.0d0*q(idx_int1,j,k,QPRES) - 3.0d0*q(i,j,k,QPRES) + 6.0d0*q(idx_gc1,j,k,QPRES) + 6.0d0*delta*dp*isign

    q(idx_gc3,j,k,QU)    = 3.0d0*q(idx_int1,j,k,QU) +10.0d0*q(i,j,k,QU) - 18.0d0*q(idx_gc1,j,k,QU) &
                         + 6.0d0*q(idx_gc2,j,k,QU) - 12.0d0*delta*du*isign
    q(idx_gc3,j,k,QV)    = 3.0d0*q(idx_int1,j,k,QV) +10.0d0*q(i,j,k,QV) - 18.0d0*q(idx_gc1,j,k,QV) &
                         + 6.0d0*q(idx_gc2,j,k,QV) - 12.0d0*delta*dv*isign
    q(idx_gc3,j,k,QW)    = 3.0d0*q(idx_int1,j,k,QW) +10.0d0*q(i,j,k,QW) - 18.0d0*q(idx_gc1,j,k,QW) &
                         + 6.0d0*q(idx_gc2,j,k,QW) - 12.0d0*delta*dw*isign
    q(idx_gc3,j,k,QRHO)    = 3.0d0*q(idx_int1,j,k,QRHO) +10.0d0*q(i,j,k,QRHO) - 18.0d0*q(idx_gc1,j,k,QRHO) &
                         + 6.0d0*q(idx_gc2,j,k,QRHO) - 12.0d0*delta*drho*isign
    q(idx_gc3,j,k,QPRES)    = 3.0d0*q(idx_int1,j,k,QPRES) +10.0d0*q(i,j,k,QPRES) - 18.0d0*q(idx_gc1,j,k,QPRES) &
                         + 6.0d0*q(idx_gc2,j,k,QPRES) - 12.0d0*delta*dp*isign

    q(idx_gc4,j,k,QU)    = -2.0d0*q(idx_int1,j,k,QU) - 13.0d0*q(i,j,k,QU) + 24.0d0*q(idx_gc1,j,k,QU) - 12.0d0*q(idx_gc2,j,k,QU)  &
                    + 4.0d0*q(idx_gc3,j,k,QU) + 12.0d0*delta*du*isign
    q(idx_gc4,j,k,QV)    = -2.0d0*q(idx_int1,j,k,QV) - 13.0d0*q(i,j,k,QV) + 24.0d0*q(idx_gc1,j,k,QV) - 12.0d0*q(idx_gc2,j,k,QV) &
                    + 4.0d0*q(idx_gc3,j,k,QV) + 12.0d0*delta*dv*isign
    q(idx_gc4,j,k,QW)    = -2.0d0*q(idx_int1,j,k,QW) - 13.0d0*q(i,j,k,QW) + 24.0d0*q(idx_gc1,j,k,QW) - 12.0d0*q(idx_gc2,j,k,QW) &
                    + 4.0d0*q(idx_gc3,j,k,QW) + 12.0d0*delta*dw*isign
    q(idx_gc4,j,k,QRHO)  = -2.0d0*q(idx_int1,j,k,QRHO) - 13.0d0*q(i,j,k,QRHO) + 24.0d0*q(idx_gc1,j,k,QRHO) - 12.0d0*q(idx_gc2,j,k,QRHO) &
                    + 4.0d0*q(idx_gc3,j,k,QRHO) + 12.0d0*delta*drho*isign
    q(idx_gc4,j,k,QPRES) = -2.0d0*q(idx_int1,j,k,QPRES) - 13.0d0*q(i,j,k,QPRES) + 24.0d0*q(idx_gc1,j,k,QPRES) - 12.0d0*q(idx_gc2,j,k,QPRES) &
                    + 4.0d0*q(idx_gc3,j,k,QPRES) + 12.0d0*delta*dp*isign

    if ((bc_type .eq. NoSlipWall).or.(bc_type .eq. SlipWall)) then

      if (bc_type .eq. NoSlipWall) then
        wall_sign = -1.0d0
      else if (bc_type .eq. SlipWall)  then
        wall_sign = 1.0d0
      end if

      q(idx_gc1,j,k,QU)    = -q(i,j,k,QU)
      q(idx_gc2,j,k,QU)    = -q(idx_int1,j,k,QU)
      q(idx_gc3,j,k,QU)    = -q(idx_int2,j,k,QU)
      q(idx_gc4,j,k,QU)    = -q(idx_int3,j,k,QU)

      q(idx_gc1,j,k,QV)    = wall_sign*q(i,j,k,QV)
      q(idx_gc2,j,k,QV)    = wall_sign*q(idx_int1,j,k,QV)
      q(idx_gc3,j,k,QV)    = wall_sign*q(idx_int2,j,k,QV)
      q(idx_gc4,j,k,QV)    = wall_sign*q(idx_int3,j,k,QV)

      q(idx_gc1,j,k,QW)    = wall_sign*q(i,j,k,QW)
      q(idx_gc2,j,k,QW)    = wall_sign*q(idx_int1,j,k,QW)
      q(idx_gc3,j,k,QW)    = wall_sign*q(idx_int2,j,k,QW)
      q(idx_gc4,j,k,QW)    = wall_sign*q(idx_int3,j,k,QW)

      q(idx_gc1,j,k,QRHO)  = q(i,j,k,QRHO)
      q(idx_gc2,j,k,QRHO)  = q(idx_int1,j,k,QRHO)
      q(idx_gc3,j,k,QRHO)  = q(idx_int2,j,k,QRHO)
      q(idx_gc4,j,k,QRHO)  = q(idx_int3,j,k,QRHO)

      q(idx_gc1,j,k,QPRES)  = q(i,j,k,QPRES)
      q(idx_gc2,j,k,QPRES)  = q(idx_int1,j,k,QPRES)
      q(idx_gc3,j,k,QPRES)  = q(idx_int2,j,k,QPRES)
      q(idx_gc4,j,k,QPRES)  = q(idx_int3,j,k,QPRES)

    end if

    ! Recompute missing values thanks to EOS
    do hop=idx_start,idx_end,-isign

      eos_state % p        = q(hop,j,k,QPRES )
      eos_state % rho      = q(hop,j,k,QRHO  )
      eos_state % massfrac = q(hop,j,k,QFS:QFS+nspecies-1)
      eos_state % aux      = q(hop,j,k,QFX:QFX+naux-1)

      call eos_rp(eos_state)
      q(hop,j,k,QTEMP)  = eos_state % T
      q(hop,j,k,QREINT) = eos_state % e * q(hop,j,k,QRHO)
      q(hop,j,k,QGAME)  = q(hop,j,k,QPRES) / q(hop,j,k,QREINT) + ONE

      qaux(hop,j,k,QDPDR)  = eos_state % dpdr_e
      qaux(hop,j,k,QDPDE)  = eos_state % dpde
      qaux(hop,j,k,QGAMC)  = eos_state % gam1
      qaux(hop,j,k,QC   )  = eos_state % cs
      qaux(hop,j,k,QCSML)  = max(small, small * qaux(hop,j,k,QC))

      ! Here the update of the conservative variables uin seems to have only an impact
      ! on the application of artificial viscosity difmag.
      uin(hop,j,k,URHO )  = eos_state % rho
      uin(hop,j,k,UMX  )  = q(hop,j,k,QU ) * eos_state % rho
      uin(hop,j,k,UMY  )  = q(hop,j,k,QV ) * eos_state % rho
      uin(hop,j,k,UMZ  ) =  q(hop,j,k,QW ) * eos_state % rho
      uin(hop,j,k,UEINT) = eos_state % rho   *  eos_state % e
      uin(hop,j,k,UEDEN) = eos_state % rho  &
         * (eos_state % e + 0.5d0 * (q(hop,j,k,QU)**2 + q(hop,j,k,QV)**2 + q(hop,j,k,QW)**2))
      uin(hop,j,k,UTEMP) = eos_state % T
      do n=1, nspecies
         uin(hop,j,k,UFS+n-1) = eos_state % rho  *  eos_state % massfrac(n)
      end do

    enddo

  elseif (idir == 2) then

    ! Update ghost cells
    ! 2nd order
    q(i,idx_gc1,k,QU)    = q(i,idx_int1,k,QU) - 2.0d0*delta*du*isign
    q(i,idx_gc1,k,QV)    = q(i,idx_int1,k,QV) - 2.0d0*delta*dv*isign
    q(i,idx_gc1,k,QW)    = q(i,idx_int1,k,QW) - 2.0d0*delta*dw*isign
    q(i,idx_gc1,k,QRHO)  = q(i,idx_int1,k,QRHO)  - 2.0d0*delta*drho*isign
    q(i,idx_gc1,k,QPRES) = q(i,idx_int1,k,QPRES) - 2.0d0*delta*dp*isign

    !----------------
    q(i,idx_gc2,k,QU)    = -2.0d0*q(i,idx_int1,k,QU) - 3.0d0*q(i,j,k,QU) + 6.0d0*q(i,idx_gc1,k,QU) + 6.0d0*delta*du*isign
    q(i,idx_gc2,k,QV)    = -2.0d0*q(i,idx_int1,k,QV) - 3.0d0*q(i,j,k,QV) + 6.0d0*q(i,idx_gc1,k,QV) + 6.0d0*delta*dv*isign
    q(i,idx_gc2,k,QW)    = -2.0d0*q(i,idx_int1,k,QW) - 3.0d0*q(i,j,k,QW) + 6.0d0*q(i,idx_gc1,k,QW) + 6.0d0*delta*dw*isign
    q(i,idx_gc2,k,QRHO)  = -2.0d0*q(i,idx_int1,k,QRHO) - 3.0d0*q(i,j,k,QRHO) + 6.0d0*q(i,idx_gc1,k,QRHO) + 6.0d0*delta*drho*isign
    q(i,idx_gc2,k,QPRES) = -2.0d0*q(i,idx_int1,k,QPRES) - 3.0d0*q(i,j,k,QPRES) + 6.0d0*q(i,idx_gc1,k,QPRES) + 6.0d0*delta*dp*isign

    q(i,idx_gc3,k,QU)    = 3.0d0*q(i,idx_int1,k,QU) +10.0d0*q(i,j,k,QU) - 18.0d0*q(i,idx_gc1,k,QU) &
                       + 6.0d0*q(i,idx_gc2,k,QU) - 12.0d0*delta*du*isign
    q(i,idx_gc3,k,QV)    = 3.0d0*q(i,idx_int1,k,QV) +10.0d0*q(i,j,k,QV) - 18.0d0*q(i,idx_gc1,k,QV) &
                       + 6.0d0*q(i,idx_gc2,k,QV) - 12.0d0*delta*dv*isign
    q(i,idx_gc3,k,QW)    = 3.0d0*q(i,idx_int1,k,QW) +10.0d0*q(i,j,k,QW) - 18.0d0*q(i,idx_gc1,k,QW) &
                       + 6.0d0*q(i,idx_gc2,k,QW) - 12.0d0*delta*dw*isign
    q(i,idx_gc3,k,QRHO)  = 3.0d0*q(i,idx_int1,k,QRHO) +10.0d0*q(i,j,k,QRHO) - 18.0d0*q(i,idx_gc1,k,QRHO) &
                       + 6.0d0*q(i,idx_gc2,k,QRHO) - 12.0d0*delta*drho*isign
    q(i,idx_gc3,k,QPRES) = 3.0d0*q(i,idx_int1,k,QPRES) +10.0d0*q(i,j,k,QPRES) - 18.0d0*q(i,idx_gc1,k,QPRES) &
                       + 6.0d0*q(i,idx_gc2,k,QPRES) - 12.0d0*delta*dp*isign

    q(i,idx_gc4,k,QU)    = -2.0d0*q(i,idx_int1,k,QU) - 13.0d0*q(i,j,k,QU) + 24.0d0*q(i,idx_gc1,k,QU) - 12.0d0*q(i,idx_gc2,k,QU)  &
                    + 4.0d0*q(i,idx_gc3,k,QU) + 12.0d0*delta*du*isign
    q(i,idx_gc4,k,QV)    = -2.0d0*q(i,idx_int1,k,QV) - 13.0d0*q(i,j,k,QV) + 24.0d0*q(i,idx_gc1,k,QV) - 12.0d0*q(i,idx_gc2,k,QV) &
                    + 4.0d0*q(i,idx_gc3,k,QV) + 12.0d0*delta*dv*isign
    q(i,idx_gc4,k,QW)    = -2.0d0*q(i,idx_int1,k,QW) - 13.0d0*q(i,j,k,QW) + 24.0d0*q(i,idx_gc1,k,QW) - 12.0d0*q(i,idx_gc2,k,QW) &
                    + 4.0d0*q(i,idx_gc3,k,QW) + 12.0d0*delta*dw*isign
    q(i,idx_gc4,k,QRHO)  = -2.0d0*q(i,idx_int1,k,QRHO) - 13.0d0*q(i,j,k,QRHO) + 24.0d0*q(i,idx_gc1,k,QRHO) - 12.0d0*q(i,idx_gc2,k,QRHO) &
                    + 4.0d0*q(i,idx_gc3,k,QRHO) + 12.0d0*delta*drho*isign
    q(i,idx_gc4,k,QPRES) = -2.0d0*q(i,idx_int1,k,QPRES) - 13.0d0*q(i,j,k,QPRES) + 24.0d0*q(i,idx_gc1,k,QPRES) - 12.0d0*q(i,idx_gc2,k,QPRES) &
                    + 4.0d0*q(i,idx_gc3,k,QPRES) + 12.0d0*delta*dp*isign

    if ((bc_type .eq. NoSlipWall).or.(bc_type .eq. SlipWall)) then

      if (bc_type .eq. NoSlipWall) then
        wall_sign = -1.0d0
      else if (bc_type .eq. SlipWall)  then
        wall_sign = 1.0d0
      end if

      q(i,idx_gc1,k,QU)    = wall_sign*q(i,j,k,QU)
      q(i,idx_gc2,k,QU)    = wall_sign*q(i,idx_int1,k,QU)
      q(i,idx_gc3,k,QU)    = wall_sign*q(i,idx_int2,k,QU)
      q(i,idx_gc4,k,QU)    = wall_sign*q(i,idx_int3,k,QU)

      q(i,idx_gc1,k,QV)    = -q(i,j,k,QV)
      q(i,idx_gc2,k,QV)    = -q(i,idx_int1,k,QV)
      q(i,idx_gc3,k,QV)    = -q(i,idx_int2,k,QV)
      q(i,idx_gc4,k,QV)    = -q(i,idx_int3,k,QV)

      q(i,idx_gc1,k,QW)    = wall_sign*q(i,j,k,QW)
      q(i,idx_gc2,k,QW)    = wall_sign*q(i,idx_int1,k,QW)
      q(i,idx_gc3,k,QW)    = wall_sign*q(i,idx_int2,k,QW)
      q(i,idx_gc4,k,QW)    = wall_sign*q(i,idx_int3,k,QW)

      q(i,idx_gc1,k,QRHO)  = q(i,j,k,QRHO)
      q(i,idx_gc2,k,QRHO)  = q(i,idx_int1,k,QRHO)
      q(i,idx_gc3,k,QRHO)  = q(i,idx_int2,k,QRHO)
      q(i,idx_gc4,k,QRHO)  = q(i,idx_int3,k,QRHO)

      q(i,idx_gc1,k,QPRES)  = q(i,j,k,QPRES)
      q(i,idx_gc2,k,QPRES)  = q(i,idx_int1,k,QPRES)
      q(i,idx_gc3,k,QPRES)  = q(i,idx_int2,k,QPRES)
      q(i,idx_gc4,k,QPRES)  = q(i,idx_int3,k,QPRES)

    end if

    ! Recompute missing values thanks to EOS
    do hop=idx_start,idx_end,-isign

      eos_state % p        = q(i,hop,k,QPRES )
      eos_state % rho      = q(i,hop,k,QRHO  )
      eos_state % massfrac = q(i,hop,k,QFS:QFS+nspecies-1)
      eos_state % aux      = q(i,hop,k,QFX:QFX+naux-1)

      call eos_rp(eos_state)
      q(i,hop,k,QTEMP)  = eos_state % T
      q(i,hop,k,QREINT) = eos_state % e * q(i,hop,k,QRHO)
      q(i,hop,k,QGAME)  = q(i,hop,k,QPRES) / q(i,hop,k,QREINT) + ONE

      qaux(i,hop,k,QDPDR)  = eos_state % dpdr_e
      qaux(i,hop,k,QDPDE)  = eos_state % dpde
      qaux(i,hop,k,QGAMC)  = eos_state % gam1
      qaux(i,hop,k,QC   )  = eos_state % cs
      qaux(i,hop,k,QCSML)  = max(small, small * qaux(i,hop,k,QC))

      ! Here the update of the conservative variables uin seems to have only an impact
      ! on the application of artificial viscosity difmag.
      uin(i,hop,k,URHO )  = eos_state % rho
      uin(i,hop,k,UMX  )  = q(i,hop,k,QU ) * eos_state % rho
      uin(i,hop,k,UMY  )  = q(i,hop,k,QV ) * eos_state % rho
      uin(i,hop,k,UMZ  )  = q(i,hop,k,QW ) * eos_state % rho
      uin(i,hop,k,UEINT) = eos_state % rho   *  eos_state % e
      uin(i,hop,k,UEDEN) = eos_state % rho  &
          * (eos_state % e + 0.5d0 * (q(i,hop,k,QU)**2 + q(i,hop,k,QV)**2 + q(i,hop,k,QW)**2))
      uin(i,hop,k,UTEMP) = eos_state % T
      do n=1, nspecies
         uin(i,hop,k,UFS+n-1) = eos_state % rho  *  eos_state % massfrac(n)
      end do

    enddo

  elseif (idir == 3) then

    ! Update ghost cells
    ! 2nd order
    q(i,j,idx_gc1,QU)    = q(i,j,idx_int1,QU) - 2.0d0*delta*du*isign
    q(i,j,idx_gc1,QV)    = q(i,j,idx_int1,QV) - 2.0d0*delta*dv*isign
    q(i,j,idx_gc1,QW)    = q(i,j,idx_int1,QW) - 2.0d0*delta*dw*isign
    q(i,j,idx_gc1,QRHO)  = q(i,j,idx_int1,QRHO)  - 2.0d0*delta*drho*isign
    q(i,j,idx_gc1,QPRES) = q(i,j,idx_int1,QPRES) - 2.0d0*delta*dp*isign

    !----------------
    q(i,j,idx_gc2,QU)    = -2.0d0*q(i,j,idx_int1,QU) - 3.0d0*q(i,j,k,QU) + 6.0d0*q(i,j,idx_gc1,QU) + 6.0d0*delta*du*isign
    q(i,j,idx_gc2,QV)    = -2.0d0*q(i,j,idx_int1,QV) - 3.0d0*q(i,j,k,QV) + 6.0d0*q(i,j,idx_gc1,QV) + 6.0d0*delta*dv*isign
    q(i,j,idx_gc2,QW)    = -2.0d0*q(i,j,idx_int1,QW) - 3.0d0*q(i,j,k,QW) + 6.0d0*q(i,j,idx_gc1,QW) + 6.0d0*delta*dw*isign
    q(i,j,idx_gc2,QRHO)  = -2.0d0*q(i,j,idx_int1,QRHO) - 3.0d0*q(i,j,k,QRHO) + 6.0d0*q(i,j,idx_gc1,QRHO) + 6.0d0*delta*drho*isign
    q(i,j,idx_gc2,QPRES) = -2.0d0*q(i,j,idx_int1,QPRES) - 3.0d0*q(i,j,k,QPRES) + 6.0d0*q(i,j,idx_gc1,QPRES) + 6.0d0*delta*dp*isign

    q(i,j,idx_gc3,QU)    = 3.0d0*q(i,j,idx_int1,QU) +10.0d0*q(i,j,k,QU) - 18.0d0*q(i,j,idx_gc1,QU) &
                       + 6.0d0*q(i,j,idx_gc2,QU) - 12.0d0*delta*du*isign
    q(i,j,idx_gc3,QV)    = 3.0d0*q(i,j,idx_int1,QV) +10.0d0*q(i,j,k,QV) - 18.0d0*q(i,j,idx_gc1,QV) &
                       + 6.0d0*q(i,j,idx_gc2,QV) - 12.0d0*delta*dv*isign
    q(i,j,idx_gc3,QW)    = 3.0d0*q(i,j,idx_int1,QW) +10.0d0*q(i,j,k,QW) - 18.0d0*q(i,j,idx_gc1,QW) &
                       + 6.0d0*q(i,j,idx_gc2,QW) - 12.0d0*delta*dw*isign
    q(i,j,idx_gc3,QRHO)  = 3.0d0*q(i,j,idx_int1,QRHO) +10.0d0*q(i,j,k,QRHO) - 18.0d0*q(i,j,idx_gc1,QRHO) &
                       + 6.0d0*q(i,j,idx_gc2,QRHO) - 12.0d0*delta*drho*isign
    q(i,j,idx_gc3,QPRES) = 3.0d0*q(i,j,idx_int1,QPRES) +10.0d0*q(i,j,k,QPRES) - 18.0d0*q(i,j,idx_gc1,QPRES) &
                       + 6.0d0*q(i,j,idx_gc2,QPRES) - 12.0d0*delta*dp*isign

    q(i,j,idx_gc4,QU)    = -2.0d0*q(i,j,idx_int1,QU) - 13.0d0*q(i,j,k,QU) + 24.0d0*q(i,j,idx_gc1,QU) - 12.0d0*q(i,j,idx_gc2,QU)  &
                    + 4.0d0*q(i,j,idx_gc3,QU) + 12.0d0*delta*du*isign
    q(i,j,idx_gc4,QV)    = -2.0d0*q(i,j,idx_int1,QV) - 13.0d0*q(i,j,k,QV) + 24.0d0*q(i,j,idx_gc1,QV) - 12.0d0*q(i,j,idx_gc2,QV) &
                    + 4.0d0*q(i,j,idx_gc3,QV) + 12.0d0*delta*dv*isign
    q(i,j,idx_gc4,QW)    = -2.0d0*q(i,j,idx_int1,QW) - 13.0d0*q(i,j,k,QW) + 24.0d0*q(i,j,idx_gc1,QW) - 12.0d0*q(i,j,idx_gc2,QW) &
                    + 4.0d0*q(i,j,idx_gc3,QW) + 12.0d0*delta*dw*isign
    q(i,j,idx_gc4,QRHO)  = -2.0d0*q(i,j,idx_int1,QRHO) - 13.0d0*q(i,j,k,QRHO) + 24.0d0*q(i,j,idx_gc1,QRHO) - 12.0d0*q(i,j,idx_gc2,QRHO) &
                    + 4.0d0*q(i,j,idx_gc3,QRHO) + 12.0d0*delta*drho*isign
    q(i,j,idx_gc4,QPRES) = -2.0d0*q(i,j,idx_int1,QPRES) - 13.0d0*q(i,j,k,QPRES) + 24.0d0*q(i,j,idx_gc1,QPRES) - 12.0d0*q(i,j,idx_gc2,QPRES) &
                    + 4.0d0*q(i,j,idx_gc3,QPRES) + 12.0d0*delta*dp*isign

    if ((bc_type .eq. NoSlipWall).or.(bc_type .eq. SlipWall)) then

      if (bc_type .eq. NoSlipWall) then
        wall_sign = -1.0d0
      else if (bc_type .eq. SlipWall)  then
        wall_sign = 1.0d0
      end if

      q(i,j,idx_gc1,QU)    = wall_sign*q(i,j,k,QU)
      q(i,j,idx_gc2,QU)    = wall_sign*q(i,j,idx_int1,QU)
      q(i,j,idx_gc3,QU)    = wall_sign*q(i,j,idx_int2,QU)
      q(i,j,idx_gc4,QU)    = wall_sign*q(i,j,idx_int3,QU)

      q(i,j,idx_gc1,QV)    = wall_sign*q(i,j,k,QV)
      q(i,j,idx_gc2,QV)    = wall_sign*q(i,j,idx_int1,QV)
      q(i,j,idx_gc3,QV)    = wall_sign*q(i,j,idx_int2,QV)
      q(i,j,idx_gc4,QV)    = wall_sign*q(i,j,idx_int3,QV)

      q(i,j,idx_gc1,QW)    = -q(i,j,k,QW)
      q(i,j,idx_gc2,QW)    = -q(i,j,idx_int1,QW)
      q(i,j,idx_gc3,QW)    = -q(i,j,idx_int2,QW)
      q(i,j,idx_gc4,QW)    = -q(i,j,idx_int3,QW)

      q(i,j,idx_gc1,QRHO)  = q(i,j,k,QRHO)
      q(i,j,idx_gc2,QRHO)  = q(i,j,idx_int1,QRHO)
      q(i,j,idx_gc3,QRHO)  = q(i,j,idx_int2,QRHO)
      q(i,j,idx_gc4,QRHO)  = q(i,j,idx_int3,QRHO)

      q(i,j,idx_gc1,QPRES)  = q(i,j,k,QPRES)
      q(i,j,idx_gc2,QPRES)  = q(i,j,idx_int1,QPRES)
      q(i,j,idx_gc3,QPRES)  = q(i,j,idx_int2,QPRES)
      q(i,j,idx_gc4,QPRES)  = q(i,j,idx_int3,QPRES)

    end if

    ! Recompute missing values thanks to EOS
    do hop=idx_start,idx_end,-isign

      eos_state % p        = q(i,j,hop,QPRES )
      eos_state % rho      = q(i,j,hop,QRHO  )
      eos_state % massfrac = q(i,j,hop,QFS:QFS+nspecies-1)
      eos_state % aux      = q(i,j,hop,QFX:QFX+naux-1)

      call eos_rp(eos_state)
      q(i,j,hop,QTEMP)  = eos_state % T
      q(i,j,hop,QREINT) = eos_state % e * q(i,j,hop,QRHO)
      q(i,j,hop,QGAME)  = q(i,j,hop,QPRES) / q(i,j,hop,QREINT) + ONE

      qaux(i,j,hop,QDPDR)  = eos_state % dpdr_e
      qaux(i,j,hop,QDPDE)  = eos_state % dpde
      qaux(i,j,hop,QGAMC)  = eos_state % gam1
      qaux(i,j,hop,QC   )  = eos_state % cs
      qaux(i,j,hop,QCSML)  = max(small, small * qaux(i,j,hop,QC))

      ! Here the update of the conservative variables uin seems to have only an impact
      ! on the application of artificial viscosity difmag.
      uin(i,j,hop,URHO )  = eos_state % rho
      uin(i,j,hop,UMX  )  = q(i,j,hop,QU ) * eos_state % rho
      uin(i,j,hop,UMY  )  = q(i,j,hop,QV ) * eos_state % rho
      uin(i,j,hop,UMZ  )  = q(i,j,hop,QW ) * eos_state % rho
      uin(i,j,hop,UEINT) = eos_state % rho   *  eos_state % e
      uin(i,j,hop,UEDEN) = eos_state % rho  &
          * (eos_state % e + 0.5d0 * (q(i,j,hop,QU)**2 + q(i,j,hop,QV)**2 + q(i,j,hop,QW)**2))
      uin(i,j,hop,UTEMP) = eos_state % T
      do n=1, nspecies
         uin(i,j,hop,UFS+n-1) = eos_state % rho  *  eos_state % massfrac(n)
      end do

    enddo

  endif

  call destroy(eos_state)

  end subroutine update_ghost_cells

  !--------------------

  subroutine compute_waves(i, j, k, idir, isign, &
                           bc_type, bc_params, bc_target, &
                           T1, T2, T3, T4, T5, &
                           L1, L2, L3, L4, L5, &
                           dp, du, dv, dw, drho, &
                           q, q_l1, q_l2, q_l3, q_h1, q_h2, q_h3, &
                           qaux, qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3)

  use meth_params_module, only : QVAR, QPRES, QU, QV, QW, QRHO, NQAUX, QC, QGAMC, QTEMP, QRSPEC
  use prob_params_module, only : probhi, Inflow, Outflow, SlipWall, NoSlipWall

  implicit none

  integer, intent(in) :: i, j, k, idir, isign
  integer, intent(in) :: q_l1, q_l2, q_l3, q_h1, q_h2, q_h3
  integer, intent(in) :: qa_l1, qa_l2, qa_l3, qa_h1, qa_h2, qa_h3
  double precision, intent(in) :: q(q_l1:q_h1,q_l2:q_h2,q_l3:q_h3,QVAR)
  double precision, intent(in) :: qaux(qa_l1:qa_h1,qa_l2:qa_h2,qa_l3:qa_h3,NQAUX)
  double precision, intent(in) :: dp, du, dv, dw, drho

  integer, intent(in)          :: bc_type
  double precision, intent(in) :: bc_params(6)
  double precision, intent(in) :: bc_target(5)

  double precision, intent(in) :: T1, T2, T3, T4, T5

  ! Note: for convenience, all waves are called L because we have just 1 direction here
  ! Waves M and N will be employed for corners
  double precision, intent(out) :: L1, L2, L3, L4, L5

  ! Local
  double precision :: mach_local, TARGET_VX, TARGET_VY, TARGET_VZ, TARGET_TEMPERATURE, TARGET_PRESSURE
  double precision :: beta, relax_T, relax_U, relax_V, relax_W, sigma_out, Kout

  if ((idir == 1) .or. (idir == 2) .or. (idir == 3)) then
    continue
  else
    call bl_abort("Problem of idir in impose_NSCBC_3d:compute_waves")
  end if

  if ((isign == 1) .or. (isign == -1)) then
    continue
  else
    call bl_abort("Problem of isign in impose_NSCBC_3d:compute_waves")
  end if

  mach_local = dsqrt(q(i,j,k,QU)**2.0d0 + q(i,j,k,QV)**2.0d0 + q(i,j,k,QW)**2.0d0)/qaux(i,j,k,QC)

  !--------
  ! Recasting targets values and numerical parameters
  TARGET_VX = bc_target(1)
  TARGET_VY = bc_target(2)
  TARGET_VZ = bc_target(3)
  TARGET_TEMPERATURE = bc_target(4)
  TARGET_PRESSURE = bc_target(5)

  relax_T = bc_params(1)
  relax_U = bc_params(2)
  relax_V = bc_params(3)
  relax_W = bc_params(4)
  ! Here we have the abilities to set beta=local Mach number
  ! it may works better for outflow BCs
  if (bc_params(5) < 0.0d0) then
    beta = mach_local
  else
    beta =  bc_params(5)
  endif
  sigma_out = bc_params(6)

  !--------
  ! Computing known numerical LODI waves
  if (idir == 1) then
    ! Numerical LODI waves along X
    L1 = (q(i,j,k,QU)-qaux(i,j,k,QC))* (dp - (q(i,j,k,QRHO)*qaux(i,j,k,QC))*du)
    L2 =  q(i,j,k,QU) * ( ((qaux(i,j,k,QC)**2.0d0)*drho) - dp)
    L3 =  q(i,j,k,QU) * dv
    L4 =  q(i,j,k,QU) * dw
    L5 = (q(i,j,k,QU)+qaux(i,j,k,QC))* (dp + (q(i,j,k,QRHO)*qaux(i,j,k,QC))*du)
  elseif (idir == 2) then
    ! Numerical LODI waves along Y
    L1 = (q(i,j,k,QV)-qaux(i,j,k,QC))* (dp - (q(i,j,k,QRHO)*qaux(i,j,k,QC))*dv)
    L2 =  q(i,j,k,QV) * du
    L3 =  q(i,j,k,QV) * ( ((qaux(i,j,k,QC)**2.0d0)*drho) - dp)
    L4 =  q(i,j,k,QV) * dw
    L5 = (q(i,j,k,QV)+qaux(i,j,k,QC))* (dp + (q(i,j,k,QRHO)*qaux(i,j,k,QC))*dv)
  elseif (idir == 3) then
    ! Numerical LODI waves along Z
    L1 = (q(i,j,k,QW)-qaux(i,j,k,QC))* (dp - (q(i,j,k,QRHO)*qaux(i,j,k,QC))*dw)
    L2 =  q(i,j,k,QW) * du
    L3 =  q(i,j,k,QW) * dv
    L4 =  q(i,j,k,QW) * ( ((qaux(i,j,k,QC)**2.0d0)*drho) - dp)
    L5 = (q(i,j,k,QW)+qaux(i,j,k,QC))* (dp + (q(i,j,k,QRHO)*qaux(i,j,k,QC))*dw)
  endif

  !--------
  ! Computing missing LODI waves from BC model
  if (bc_type == Inflow) then

    if (idir == 1) then
      if (isign == 1) then
        L5 = relax_U * ((q(i,j,k,QRHO)*qaux(i,j,k,QC)**2.0d0)*(1.0d0-mach_local*mach_local)/probhi(idir)) * &
                     (q(i,j,k,QU) - TARGET_VX)  - ((1.0d0 - beta)*T5)
      elseif (isign == -1) then
        L1 = relax_U * ((q(i,j,k,QRHO)*qaux(i,j,k,QC)**2.0d0)*(1.0d0-mach_local*mach_local)/probhi(idir)) * &
                        (q(i,j,k,QU) - TARGET_VX) - ((1.0d0 - beta)*T1)
      endif

      L2 = relax_T * (q(i,j,k,QRHO)*qaux(i,j,k,QC)*qaux(i,j,k,QRSPEC)/probhi(idir)) &
                 * (q(i,j,k,QTEMP) - TARGET_TEMPERATURE) - ((1.0d0 - beta)*T2)
      L3 = relax_V * (qaux(i,j,k,QC)/probhi(idir)) * (q(i,j,k,QV) - TARGET_VY) &
                     - ((1.0d0 - beta)*T3)
      L4 = relax_W * (qaux(i,j,k,QC)/probhi(idir)) * (q(i,j,k,QW) - TARGET_VZ) &
                     - ((1.0d0 - beta)*T4)

    elseif (idir == 2) then

      if (isign == 1) then
         L5 = relax_V * ((q(i,j,k,QRHO)*qaux(i,j,k,QC)**2.0d0)*(1.0d0-mach_local*mach_local)/probhi(idir)) * &
                       (q(i,j,k,QV) - TARGET_VY) - ((1.0d0 - beta)*T5)
      elseif (isign == -1) then
         L1 = relax_V * ((q(i,j,k,QRHO)*qaux(i,j,k,QC)**2.0d0)*(1.0d0-mach_local*mach_local)/probhi(idir)) * &
                         (q(i,j,k,QV) - TARGET_VY)  -  ((1.0d0 - beta)*T1)
      endif

      L2 = relax_U * (qaux(i,j,k,QC)/probhi(idir)) * (q(i,j,k,QU) - TARGET_VX)  &
                     - ((1.0d0 - beta)*T2)
      L3 = relax_T * (q(i,j,k,QRHO)*qaux(i,j,k,QC)*qaux(i,j,k,QRSPEC)/probhi(idir)) &
                   * (q(i,j,k,QTEMP) - TARGET_TEMPERATURE) - ((1.0d0 - beta)*T3)
      L4 = relax_W * (qaux(i,j,k,QC)/probhi(idir)) * (q(i,j,k,QW) - TARGET_VZ) &
                     - ((1.0d0 - beta)*T4)

    elseif (idir == 3) then

      if (isign == 1) then
         L5 = relax_W * ((q(i,j,k,QRHO)*qaux(i,j,k,QC)**2.0d0)*(1.0d0-mach_local*mach_local)/probhi(idir)) * &
                       (q(i,j,k,QW) - TARGET_VZ) - ((1.0d0 - beta)*T5)
      elseif (isign == -1) then
         L1 = relax_W * ((q(i,j,k,QRHO)*qaux(i,j,k,QC)**2.0d0)*(1.0d0-mach_local*mach_local)/probhi(idir)) * &
                         (q(i,j,k,QW) - TARGET_VZ)  -  ((1.0d0 - beta)*T1)
      endif

      L2 = relax_W * (qaux(i,j,k,QC)/probhi(idir)) * (q(i,j,k,QU) - TARGET_VX) &
                     - ((1.0d0 - beta)*T2)
      L3 = relax_W * (qaux(i,j,k,QC)/probhi(idir)) * (q(i,j,k,QV) - TARGET_VY) &
                     - ((1.0d0 - beta)*T3)
      L4 = relax_T * (q(i,j,k,QRHO)*qaux(i,j,k,QC)*qaux(i,j,k,QRSPEC)/probhi(idir)) &
                   * (q(i,j,k,QTEMP) - TARGET_TEMPERATURE) - ((1.0d0 - beta)*T4)

    else
      call bl_error("Error:: Wait, is this the fourth dimension?")
    endif

  elseif ((bc_type == SlipWall).or.(bc_type == NoSlipWall)) then

    ! Values long Y will be computed by mirror functions below
    ! but we set waves values to 0 to avoid undefined variables
    L1 = 0.0d0
    L2 = 0.0d0
    L3 = 0.0d0
    L4 = 0.0d0
    L5 = 0.0d0

  elseif (bc_type == Outflow) then

    Kout = sigma_out*(1.0d0 - (mach_local**2.0d0))*(qaux(i,j,k,QC)/probhi(idir))

    if (isign == 1) then
      L5 = (Kout*(q(i,j,k,QPRES) - TARGET_PRESSURE)) - ((1.0d0 - beta)*T5)
    elseif (isign == -1) then
      L1 = (Kout*(q(i,j,k,QPRES) - TARGET_PRESSURE)) - ((1.0d0 - beta)*T1)
    endif

  else
    call bl_error("Error:: This BC is not yet implemented for x dir in characteristic form")
  endif

  !--------
  ! Shaping the waves to be at the good dimension
  if (idir == 1) then
    L1 = L1 / (q(i,j,k,QU)-qaux(i,j,k,QC))
    L5 = L5 / (q(i,j,k,QU)+qaux(i,j,k,QC))
    if (q(i,j,k,QU) == 0.0d0) then
      L2 = 0.0d0
      L3 = 0.0d0
      L4 = 0.0d0
    else
      L2 = L2 / q(i,j,k,QU)
      L3 = L3 / q(i,j,k,QU)
      L4 = L4 / q(i,j,k,QU)
    endif
  elseif (idir == 2) then
    L1 = L1 / (q(i,j,k,QV)-qaux(i,j,k,QC))
    L5 = L5 / (q(i,j,k,QV)+qaux(i,j,k,QC))
    if (q(i,j,k,QV) == 0.0d0) then
      L2 = 0.0d0
      L3 = 0.0d0
      L4 = 0.0d0
     else
      L2 = L2 / q(i,j,k,QV)
      L3 = L3 / q(i,j,k,QV)
      L4 = L4 / q(i,j,k,QV)
    endif
  elseif (idir == 3) then
    L1 = L1 / (q(i,j,k,QW)-qaux(i,j,k,QC))
    L5 = L5 / (q(i,j,k,QW)+qaux(i,j,k,QC))
    if (q(i,j,k,QW) == 0.0d0) then
      L2 = 0.0d0
      L3 = 0.0d0
      L4 = 0.0d0
     else
      L2 = L2 / q(i,j,k,QW)
      L3 = L3 / q(i,j,k,QW)
      L4 = L4 / q(i,j,k,QW)
    endif
  end if

  end subroutine compute_waves

end module gc_nscbc_mod


*DECK BANDV
      SUBROUTINE BANDV (NM, N, MBW, A, E21, M, W, Z, IERR, NV, RV, RV6)
C***BEGIN PROLOGUE  BANDV
C***PURPOSE  Form the eigenvectors of a real symmetric band matrix
C            associated with a set of ordered approximate eigenvalues
C            by inverse iteration.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C3
C***TYPE      SINGLE PRECISION (BANDV-S)
C***KEYWORDS  EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine finds those eigenvectors of a REAL SYMMETRIC
C     BAND matrix corresponding to specified eigenvalues, using inverse
C     iteration.  The subroutine may also be used to solve systems
C     of linear equations with a symmetric or non-symmetric band
C     coefficient matrix.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        MBW is the number of columns of the array A used to store the
C          band matrix.  If the matrix is symmetric, MBW is its (half)
C          band width, denoted MB and defined as the number of adjacent
C          diagonals, including the principal diagonal, required to
C          specify the non-zero portion of the lower triangle of the
C          matrix.  If the subroutine is being used to solve systems
C          of linear equations and the coefficient matrix is not
C          symmetric, it must however have the same number of adjacent
C          diagonals above the main diagonal as below, and in this
C          case, MBW=2*MB-1.  MBW is an INTEGER variable.  MB must not
C          be greater than N.
C
C        A contains the lower triangle of the symmetric band input
C          matrix stored as an N by MB array.  Its lowest subdiagonal
C          is stored in the last N+1-MB positions of the first column,
C          its next subdiagonal in the last N+2-MB positions of the
C          second column, further subdiagonals similarly, and finally
C          its principal diagonal in the N positions of column MB.
C          If the subroutine is being used to solve systems of linear
C          equations and the coefficient matrix is not symmetric, A is
C          N by 2*MB-1 instead with lower triangle as above and with
C          its first superdiagonal stored in the first N-1 positions of
C          column MB+1, its second superdiagonal in the first N-2
C          positions of column MB+2, further superdiagonals similarly,
C          and finally its highest superdiagonal in the first N+1-MB
C          positions of the last column.  Contents of storage locations
C          not part of the matrix are arbitrary.  A is a two-dimensional
C          REAL array, dimensioned A(NM,MBW).
C
C        E21 specifies the ordering of the eigenvalues and contains
C            0.0E0 if the eigenvalues are in ascending order, or
C            2.0E0 if the eigenvalues are in descending order.
C          If the subroutine is being used to solve systems of linear
C          equations, E21 should be set to 1.0E0 if the coefficient
C          matrix is symmetric and to -1.0E0 if not.  E21 is a REAL
C          variable.
C
C        M is the number of specified eigenvalues or the number of
C          systems of linear equations.  M is an INTEGER variable.
C
C        W contains the M eigenvalues in ascending or descending order.
C          If the subroutine is being used to solve systems of linear
C          equations (A-W(J)*I)*X(J)=B(J), where I is the identity
C          matrix, W(J) should be set accordingly, for J=1,2,...,M.
C          W is a one-dimensional REAL array, dimensioned W(M).
C
C        Z contains the constant matrix columns (B(J),J=1,2,...,M), if
C          the subroutine is used to solve systems of linear equations.
C          Z is a two-dimensional REAL array, dimensioned Z(NM,M).
C
C        NV must be set to the dimension of the array parameter RV
C          as declared in the calling program dimension statement.
C          NV is an INTEGER variable.
C
C     On OUTPUT
C
C        A and W are unaltered.
C
C        Z contains the associated set of orthogonal eigenvectors.
C          Any vector which fails to converge is set to zero.  If the
C          subroutine is used to solve systems of linear equations,
C          Z contains the solution matrix columns (X(J),J=1,2,...,M).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          -J         if the eigenvector corresponding to the J-th
C                     eigenvalue fails to converge, or if the J-th
C                     system of linear equations is nearly singular.
C
C        RV and RV6 are temporary storage arrays.  If the subroutine
C          is being used to solve systems of linear equations, the
C          determinant (up to sign) of A-W(M)*I is available, upon
C          return, as the product of the first N elements of RV.
C          RV and RV6 are one-dimensional REAL arrays.  Note that RV
C          is dimensioned RV(NV), where NV must be at least N*(2*MB-1).
C          RV6 is dimensioned RV6(N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BANDV
C
      INTEGER I,J,K,M,N,R,II,IJ,JJ,KJ,MB,M1,NM,NV,IJ1,ITS,KJ1,MBW,M21
      INTEGER IERR,MAXJ,MAXK,GROUP
      REAL A(NM,*),W(*),Z(NM,*),RV(*),RV6(*)
      REAL U,V,UK,XU,X0,X1,E21,EPS2,EPS3,EPS4,NORM,ORDER,S
C
C***FIRST EXECUTABLE STATEMENT  BANDV
      IERR = 0
      IF (M .EQ. 0) GO TO 1001
      MB = MBW
      IF (E21 .LT. 0.0E0) MB = (MBW + 1) / 2
      M1 = MB - 1
      M21 = M1 + MB
      ORDER = 1.0E0 - ABS(E21)
C     .......... FIND VECTORS BY INVERSE ITERATION ..........
      DO 920 R = 1, M
         ITS = 1
         X1 = W(R)
         IF (R .NE. 1) GO TO 100
C     .......... COMPUTE NORM OF MATRIX ..........
         NORM = 0.0E0
C
         DO 60 J = 1, MB
            JJ = MB + 1 - J
            KJ = JJ + M1
            IJ = 1
            S = 0.0E0
C
            DO 40 I = JJ, N
               S = S + ABS(A(I,J))
               IF (E21 .GE. 0.0E0) GO TO 40
               S = S + ABS(A(IJ,KJ))
               IJ = IJ + 1
   40       CONTINUE
C
            NORM = MAX(NORM,S)
   60    CONTINUE
C
         IF (E21 .LT. 0.0E0) NORM = 0.5E0 * NORM
C     .......... EPS2 IS THE CRITERION FOR GROUPING,
C                EPS3 REPLACES ZERO PIVOTS AND EQUAL
C                ROOTS ARE MODIFIED BY EPS3,
C                EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ..........
         IF (NORM .EQ. 0.0E0) NORM = 1.0E0
         EPS2 = 1.0E-3 * NORM * ABS(ORDER)
         EPS3 = NORM
   70    EPS3 = 0.5E0*EPS3
         IF (NORM + EPS3 .GT. NORM) GO TO 70
         UK = SQRT(REAL(N))
         EPS3 = UK * EPS3
         EPS4 = UK * EPS3
   80    GROUP = 0
         GO TO 120
C     .......... LOOK FOR CLOSE OR COINCIDENT ROOTS ..........
  100    IF (ABS(X1-X0) .GE. EPS2) GO TO 80
         GROUP = GROUP + 1
         IF (ORDER * (X1 - X0) .LE. 0.0E0) X1 = X0 + ORDER * EPS3
C     .......... EXPAND MATRIX, SUBTRACT EIGENVALUE,
C                AND INITIALIZE VECTOR ..........
  120    DO 200 I = 1, N
            IJ = I + MIN(0,I-M1) * N
            KJ = IJ + MB * N
            IJ1 = KJ + M1 * N
            IF (M1 .EQ. 0) GO TO 180
C
            DO 150 J = 1, M1
               IF (IJ .GT. M1) GO TO 125
               IF (IJ .GT. 0) GO TO 130
               RV(IJ1) = 0.0E0
               IJ1 = IJ1 + N
               GO TO 130
  125          RV(IJ) = A(I,J)
  130          IJ = IJ + N
               II = I + J
               IF (II .GT. N) GO TO 150
               JJ = MB - J
               IF (E21 .GE. 0.0E0) GO TO 140
               II = I
               JJ = MB + J
  140          RV(KJ) = A(II,JJ)
               KJ = KJ + N
  150       CONTINUE
C
  180       RV(IJ) = A(I,MB) - X1
            RV6(I) = EPS4
            IF (ORDER .EQ. 0.0E0) RV6(I) = Z(I,R)
  200    CONTINUE
C
         IF (M1 .EQ. 0) GO TO 600
C     .......... ELIMINATION WITH INTERCHANGES ..........
         DO 580 I = 1, N
            II = I + 1
            MAXK = MIN(I+M1-1,N)
            MAXJ = MIN(N-I,M21-2) * N
C
            DO 360 K = I, MAXK
               KJ1 = K
               J = KJ1 + N
               JJ = J + MAXJ
C
               DO 340 KJ = J, JJ, N
                  RV(KJ1) = RV(KJ)
                  KJ1 = KJ
  340          CONTINUE
C
               RV(KJ1) = 0.0E0
  360       CONTINUE
C
            IF (I .EQ. N) GO TO 580
            U = 0.0E0
            MAXK = MIN(I+M1,N)
            MAXJ = MIN(N-II,M21-2) * N
C
            DO 450 J = I, MAXK
               IF (ABS(RV(J)) .LT. ABS(U)) GO TO 450
               U = RV(J)
               K = J
  450       CONTINUE
C
            J = I + N
            JJ = J + MAXJ
            IF (K .EQ. I) GO TO 520
            KJ = K
C
            DO 500 IJ = I, JJ, N
               V = RV(IJ)
               RV(IJ) = RV(KJ)
               RV(KJ) = V
               KJ = KJ + N
  500       CONTINUE
C
            IF (ORDER .NE. 0.0E0) GO TO 520
            V = RV6(I)
            RV6(I) = RV6(K)
            RV6(K) = V
  520       IF (U .EQ. 0.0E0) GO TO 580
C
            DO 560 K = II, MAXK
               V = RV(K) / U
               KJ = K
C
               DO 540 IJ = J, JJ, N
                  KJ = KJ + N
                  RV(KJ) = RV(KJ) - V * RV(IJ)
  540          CONTINUE
C
               IF (ORDER .EQ. 0.0E0) RV6(K) = RV6(K) - V * RV6(I)
  560       CONTINUE
C
  580    CONTINUE
C     .......... BACK SUBSTITUTION
C                FOR I=N STEP -1 UNTIL 1 DO -- ..........
  600    DO 630 II = 1, N
            I = N + 1 - II
            MAXJ = MIN(II,M21)
            IF (MAXJ .EQ. 1) GO TO 620
            IJ1 = I
            J = IJ1 + N
            JJ = J + (MAXJ - 2) * N
C
            DO 610 IJ = J, JJ, N
               IJ1 = IJ1 + 1
               RV6(I) = RV6(I) - RV(IJ) * RV6(IJ1)
  610       CONTINUE
C
  620       V = RV(I)
            IF (ABS(V) .GE. EPS3) GO TO 625
C     .......... SET ERROR -- NEARLY SINGULAR LINEAR SYSTEM ..........
            IF (ORDER .EQ. 0.0E0) IERR = -R
            V = SIGN(EPS3,V)
  625       RV6(I) = RV6(I) / V
  630    CONTINUE
C
         XU = 1.0E0
         IF (ORDER .EQ. 0.0E0) GO TO 870
C     .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS
C                MEMBERS OF GROUP ..........
         IF (GROUP .EQ. 0) GO TO 700
C
         DO 680 JJ = 1, GROUP
            J = R - GROUP - 1 + JJ
            XU = 0.0E0
C
            DO 640 I = 1, N
  640       XU = XU + RV6(I) * Z(I,J)
C
            DO 660 I = 1, N
  660       RV6(I) = RV6(I) - XU * Z(I,J)
C
  680    CONTINUE
C
  700    NORM = 0.0E0
C
         DO 720 I = 1, N
  720    NORM = NORM + ABS(RV6(I))
C
         IF (NORM .GE. 0.1E0) GO TO 840
C     .......... IN-LINE PROCEDURE FOR CHOOSING
C                A NEW STARTING VECTOR ..........
         IF (ITS .GE. N) GO TO 830
         ITS = ITS + 1
         XU = EPS4 / (UK + 1.0E0)
         RV6(1) = EPS4
C
         DO 760 I = 2, N
  760    RV6(I) = XU
C
         RV6(ITS) = RV6(ITS) - EPS4 * UK
         GO TO 600
C     .......... SET ERROR -- NON-CONVERGED EIGENVECTOR ..........
  830    IERR = -R
         XU = 0.0E0
         GO TO 870
C     .......... NORMALIZE SO THAT SUM OF SQUARES IS
C                1 AND EXPAND TO FULL ORDER ..........
  840    U = 0.0E0
C
         DO 860 I = 1, N
  860    U = U + RV6(I)**2
C
         XU = 1.0E0 / SQRT(U)
C
  870    DO 900 I = 1, N
  900    Z(I,R) = RV6(I) * XU
C
         X0 = X1
  920 CONTINUE
C
 1001 RETURN
      END


! !ROUTINE: Interpolate from observation space to model grid
!
! !INTERFACE:
subroutine gridinterpol(N,cols,obs_z,obs_prof,nlev_,model_z,model_prof)
!
! !DESCRIPTION:
!
!  This is a utility subroutine in which observational data, which might
!  be given on an arbitrary, but structured grid, are linearly interpolated and
!  extrapolated to the actual (moving) model grid.
!
! !USES:
   IMPLICIT NONE
!
! !INPUT PARAMETERS:
   !N    : number of vertical layers in observation data
   !cols : number of profiles in obs. data
   integer,  intent(in)                :: N,cols
   REAL,     intent(in)                :: obs_z(N),obs_prof(N,cols)
   !nlev_: number of vertical layers in model
   integer,  intent(in)                :: nlev_
   REAL,     intent(in)                :: model_z(nlev_)
!
! !OUTPUT PARAMETERS:
   REAL,     intent(out)               :: model_prof(nlev_,cols)
!
! !REVISION HISTORY:
!  Original author(s): Karsten Bolding & Hans Burchard
!
!EOP
!
! !LOCAL VARIABLES:
   integer                   :: i,j,ii
   REAL                      :: rat
!-----------------------------------------------------------------------
!BOC
   model_prof(:,:) = 0d0
!  Set surface values to uppermost input value
   do i=nlev_,1,-1
      if(model_z(i) .ge. obs_z(N)) then
         do j=1,cols
            model_prof(i,j) = obs_prof(N,j)
         end do
      end if
   end do

!  Set bottom values to lowest input value
   do i=1,nlev_
      if(model_z(i) .le. obs_z(1)) then
         do j=1,cols
            model_prof(i,j) = obs_prof(1,j)
         end do
      end if
   end do

!  Interpolate inner values linearly
   do i=1, nlev_, 1
!   do i= nlev_, 1, -1
      if ((model_z(i) .lt. obs_z(N)) .and. (model_z(i) .gt. obs_z(1))) then
         ii=0
224      ii=ii+1
         !write(6,*) 'model_z(',i,') = ',model_z(i)
         !write(6,*) 'obs_z(',ii,') = ',obs_z(ii)
         if (obs_z(ii) .le. model_z(i)) goto 224

         rat=(model_z(i)-obs_z(ii-1))/(obs_z(ii)-obs_z(ii-1))

         do j=1,cols
            model_prof(i,j)=(1d0-rat)*obs_prof(ii-1,j)+rat*obs_prof(ii,j)
         enddo
      endif
   enddo
end subroutine


use RandomClass
use FEMDomainClass
implicit none

type(Random_) :: random
type(FEMDomain_) :: domain,element
integer(int32) :: i

domain%mesh%nodcoord =zeros(300,3)

do i=1,300
domain%mesh%nodcoord(i,1) = random%random()
domain%mesh%nodcoord(i,2) = random%random()
domain%mesh%nodcoord(i,3) = random%random()
enddo
call domain%delaunay3D()

do i=1,domain%ne()
    element = domain%getElement(i)
    call element%vtk("Element"//str(i) )
enddo

call domain%msh("test")
call domain%vtk("test")

end


      subroutine checke(k,dt,den)
*
*
*       determine if escaping stars can realy escape from the system.
*       -----------------------------------------------------------------
*       Method proposed by D.C. Heggie - 1996.
*       -----------------------------------------------------------------
*
*
      include 'common.h'
*
*
      real*8 vr1,vr2,vtx1,vtx2,vty1,vty2,beta,wx,wy,
     &       wz,w,wx1,wy1,wz1,wx2,wy2,wz2,sinpsi,cospsi,
     &       sbeta,cbeta,wnx,wny,wnz,vnx1,vnx2,vny1,vny2,
     &       sm12,sm112,sm212,dt,den,lambda,cden,yran,pp,po,pppo,
     &       e1,e2,vrn1n,vrn2n,vtn1n,vtn2n,sin2b2
*
      real*4 ran2
*
      integer k
*
      common /chesc/ sm12,sm112,sm212,w,wx,wy,wz,wx1,wy1,wz1,wx2,
     &               wy2,wz2,vtx1,vtx2,vty1,vty2,vr1,vr2,
     &               sinpsi,cospsi
*
*
*     check if stars escape after relaxation
*
      e1 = u(k) + 0.5d0*(vrn1**2 + vtn1**2)
      e2 = u(k+1) + 0.5d0*(vrn2**2 + vtn2**2)
*
      if((e1.gt.0.0d0).or.(e2.gt.0.0d0)) then
*
*     determine deflection angle beta
*
      cden = 0.5d0/pi
      lambda = cden*pi*den*w*dt*nt/log(gamma*nt)
      yran = ran2(irun) - 1.d0
      yran = abs(yran)
      pp = sqrt(-log(yran)/lambda)
      po = sm12/w/w
      pppo = (pp/po)**2
      sin2b2 = 1.0d0/(1.0d0 + pppo)
      beta = 2.0d0*atan(sqrt(sin2b2/(1.0d0 - sin2b2)))
*
      sbeta = sin(beta)
      cbeta = cos(beta)
*
      wnx = wx*cbeta + wx1*sbeta*cospsi + wx2*sbeta*sinpsi
      wny = wy*cbeta + wy1*sbeta*cospsi + wy2*sbeta*sinpsi
      wnz = wz*cbeta + wz1*sbeta*cospsi + wz2*sbeta*sinpsi
*
      vnx1 = vtx1 - sm212*(wnx - wx)
      vnx2 = vtx2 + sm112*(wnx - wx)
      vny1 = vty1 - sm212*(wny - wy)
      vny2 = vty2 + sm112*(wny - wy)
      vrn1n = vr1 - sm212*(wnz - wz)
      vrn2n = vr2 + sm112*(wnz - wz)
      vtn1n = sqrt(vnx1*vnx1 + vny1*vny1)
      vtn2n = sqrt(vnx2*vnx2 + vny2*vny2)
*
*     check if any star has positive energy - escapers
*
c      if((e1.gt.0.0d0).or.(e2.gt.0.0d0)) then
        vrn1 = vrn1n
        vtn1 = vtn1n
        vrn2 = vrn2n
        vtn2 = vtn2n
      endif
*
c      e1 = u(k) + 0.5d0*(vrn1n**2 + vtn1n**2)
c      e2 = u(k+1) + 0.5d0*(vrn2n**2 + vtn2n**2)
*
c      if((e1.gt.0.0d0).or.(e2.gt.0.0d0)) then
c        vrn1 = vrn1n
c        vtn1 = vtn1n
c        vrn2 = vrn2n
c        vtn2 = vtn2n
c      endif
*
      return
*
      end
*
*
*
*


! This routine should be a simplified version of src2
! which applies source terms for a 1-d slice of data along the
! edge of a grid.  This is called only from qad where the conservative
! fix-up is applied and is used to apply source terms over partial
! time steps to the coarse grid cell values used in solving Riemann
! problems at the interface between coarse and fine grids.
subroutine src1d(meqn,mbc,mx1d,q1d,maux,aux1d,t,dt)

    use geoclaw_module, only: g => grav, coriolis_forcing, coriolis
    use geoclaw_module, only: friction_forcing, friction_depth, friction_index
    use geoclaw_module, only: num_layers, rho, omega, coordinate_system

    implicit none

    ! Input
    integer, intent(in) :: meqn, mbc, mx1d, maux
    real(kind=8), intent(in) :: t, dt
    real(kind=8), intent(inout) :: q1d(meqn, mx1d), aux1d(maux, mx1d)

    ! Local storage
    integer :: i, m, bottom_index, bottom_layer, layer_index
    logical :: found
    real(kind=8) :: h(num_layers), hu, hv, gamma, dgamma, y, fdt, a(2,2)

    ! Algorithm parameters
    ! Parameter controls when to zero out the momentum at a depth in the
    ! friction source term
    real(kind=8), parameter :: depth_tolerance = 1.0d-30

    ! Pressure forcing
    ! Handled in Riemann solver

    ! Friction forcing
    if (friction_forcing) then

        do i=1,mx1d

            ! Extract depths
            forall (m=1:num_layers)
                h(m) = q1d(3 * (m-1) + 1,i) / rho(m)
            end forall

            ! Extract appropriate momentum, also zero momentum in dry layers
            m = num_layers
            found = .false.
            do while(.not.found .and. m > 0)
                if (h(m) > depth_tolerance) then
                    ! Extract momentum components and exit loop
                    bottom_layer = m
                    bottom_index = 3 * (m - 1)
                    hu = q1d(bottom_index + 2, i) / rho(m)
                    hv = q1d(bottom_index + 3, i) / rho(m)
                    found = .true.
                else
                    ! Set almost dry layers momentum to zero
                    q1d(3 * (m - 1) + 2, i) = 0.d0
                    q1d(3 * (m - 1) + 3, i) = 0.d0
                endif
                m = m - 1
            end do

            if (.not.found) then
                cycle
            endif

            ! Apply friction source term only if in shallower water
            if (sum(h) <= friction_depth) then
                ! Calculate source term
                gamma = sqrt(hu**2 + hv**2) * (g * aux1d(friction_index,i)**2) &
                                            / (h(bottom_layer)**(7/3))
                dgamma = 1.d0 + dt * gamma
                q1d(bottom_index + 2, i) = q1d(bottom_index + 2, i) / dgamma
                q1d(bottom_index + 3, i) = q1d(bottom_index + 3, i) / dgamma
            endif
        enddo
    endif

    ! Only lat-long coordinate system supported here right now
    if (coriolis_forcing .and. coordinate_system == 2) then

        do i=1,mx1d
            ! aux(3,:,:) stores the y coordinates multiplied by deg2rad
            fdt = 2.d0 * omega * sin(aux1d(3,i)) * dt

            ! Calculate matrix components
            a(1,1) = 1.d0 - 0.5d0 * fdt**2 + fdt**4 / 24.d0
            a(1,2) =  fdt - fdt**3 / 6.d0
            a(2,1) = -fdt + fdt**3 / 6.d0
            a(2,2) = a(1,1)

            do m=1,num_layers
                q1d(layer_index + 2,i) = q1d(layer_index + 2,i) * a(1,1) &
                                       + q1d(layer_index + 3,i) * a(1,2)
                q1d(layer_index + 3,i) = q1d(layer_index + 2,i) * a(2,1) &
                                       + q1d(layer_index + 3,i) * a(2,2)
            enddo
        enddo

    endif

end subroutine src1d


      double precision function rcolor (iiord1,iiord2,idp)

* This function evaluates the color factor of two amplitudes
* with eight external fermions, given respectively in the order
* iiord1 and iiord2
* This means that, given the order 1 2 3 4 5 6 7 8 to which
* corresponds  particle identity idp(1) ...idp(8) and the momenta
* p1,p2,...p8,
* the first amplitude will have the order
*     iiord1(1), iiord1(2)....iiord1(8)
* and identities
*     idp(iiord1(1)), idp(iiord1(2))....idp(iiord1(8))
*
* This means that the particle iiord1(1) will form a fermion line
* with iiord1(2), iiord1(3) with iiord1(4) ...
* Analogous considerations for the second amplitude

* It is assumed that particles are given always in the order
* particle antiparticle, particle antiparticle, ....
* and the various couples form a W+, a W- or a Z

      implicit real *8 (a-h,o-z)

      dimension iiord1(8), iiord2(8), idp(8), iord1(8), iord2(8),icol(8)

* copy the non quarks in iord1 and iord2 and count them

      ncolor=0
      do i=1,8
        if (abs(idp(iiord1(i))).le.5) then
          ncolor=ncolor+1
          iord1(ncolor)=iiord1(i)
        endif
      enddo

      ncolor2=0
      do i=1,8
        if (abs(idp(iiord2(i))).le.5) then
          ncolor2=ncolor2+1
          iord2(ncolor2)=iiord2(i)
        endif
      enddo

      if (ncolor.ne.ncolor2) then
        print*, 'ERROR in color assignment'
        stop
      endif

ctest      print*, 'ncolor', ncolor

ctest      print*, 'iord1', iord1
ctest      print*, 'iord2', iord2

      do j=2,ncolor,2

        icol(j)=iord1(j)

        i=1

        do while (iord2(i).ne.iord1(j-1))
          i=i+2
        enddo

        icol(j-1)=iord2(i+1)

      enddo

ctest      print*, icol

      n=ncolor

      rcolor=1.d0

      do while (n.gt.0)

        if (icol(n-1).eq.icol(n)) then
          rcolor=rcolor*3.d0
        else
          i=2
          do while (icol(i).ne.icol(n-1))
            i=i+2
          enddo
          icol(i)=icol(n)
        endif
        n=n-2
ctest        print*, 'rcolor',rcolor
ctest        print*, 'n',n
ctest        print*, 'icol',icol
      enddo

      return
      end


      SUBROUTINE ZD(UIC,VIC,DIVSC,ZETASC)
C
C THIS SUBROUTINE OBTAINS VORTICITY AND DIVERGENCE SPECTRAL
C COEFFICIENTS FROM THE GRIDPOINT VELOCITIES (UNSCALED BY COS(THETA))
C THE SUBROUTINE MAKES USE OF INFORMATION
C CONTAINED IN COMMON BLOCKS (POLYNOMIALS, COEFFICIENTS, ETC.)
C
C CALLED BY: INIT, STSWM
C CALLS: FFT991, GLAT
C
C---- Model Parameters -------------------------------------------------
C
      INCLUDE 'params.i'
C
C---- Common Blocks ----------------------------------------------------
C
C TRANSFORM ARRAYS
      INCLUDE 'trnsfm.i'
C WORKSPACE
      INCLUDE 'wrkspc.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C EASTWARD WIND FIELD
      REAL UIC(NLON+2,NLAT)
C NORTHWARD WIND FIELD
      REAL VIC(NLON+2,NLAT)
C
C     Output
C
C COMPUTED DIVERGENCE COEFFICIENTS
      COMPLEX DIVSC(NALP)
C COMPUTED VORTICITY COEFFICIENTS
      COMPLEX ZETASC(NALP)
C
C------ Local Variables ------------------------------------------------
C
C     EQUIVALENCE TO WORKSPACE STORAGE POOL /WRKSPC/
C
      REAL UTMP(NLON+2,NLAT),VTMP(NLON+2,NLAT)
      COMPLEX UTMPFC(NFC,NLAT),VTMPFC(NFC,NLAT)
      EQUIVALENCE (UTMP(1,1),UTMPFC(1,1),WS1(1,1)),
     $            (VTMP(1,1),VTMPFC(1,1),WS2(1,1))
C
      REAL STMP1(NLON+2), STMP2(NLON+2)
      EQUIVALENCE (STMP1(1),RVEC1(1)), (STMP2(1),RVEC2(1))
C
      COMPLEX CTMP1(MM+1), CTMP2(MM+1), CTMP3(MM+1), CTMP4(MM+1)
C
C     TEMPORARIES
C
      REAL RLAT, FAC
      INTEGER I,J,JM,JN,M,NL,IS,INDEX,SL
C
C----- Statement Function ----------------------------------------------
C
C     GRID LATITUDE
C
      EXTERNAL GLAT
      REAL GLAT
C
C----- Executable Statements -------------------------------------------
C
C     COMPUTE VORTICITY AND DIVERGENCE SPECTRAL COEFFICIENTS
C     FROM U AND V MOMENTUM COEFFICIENTS
C
C     FOURIER TRANSFORM U*COS(PHI) AND V*COS(PHI) FIELDS
C
      DO 20 J=1,NLAT
         RLAT = GLAT(J)
C
C        LATITUDE = RLAT = GLAT(J)
C
         DO 10 I=1,NLON
            UTMP(I,J)=UIC(I,J)*COS(RLAT)
            VTMP(I,J)=VIC(I,J)*COS(RLAT)
   10    CONTINUE
   20 CONTINUE
C
      CALL FFT991(UTMP,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
      CALL FFT991(VTMP,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
C
C     COMPUTE VORTICITY AND DIVERGENCE COEFFICIENTS FROM U AND V FOURIER
C     COEFFICIENTS. VARY M AND N SO THAT PROCEDURE MOVES ALONG DIAGONALS
C     DENOTED BY INDEX JN.  M IS GIVEN BY (JM-1); N IS GIVEN BY (JN+M).
C     TAKE ADVANTAGE OF SYMMETRIC CHARACTER OF LEGENDRE POLYNOMIALS
C
C     PROCEDURE FOR EVEN NUMBER OF GAUSSIAN LATITUDES ...
C
      DO 210 NL=1,NLAT/2
         SL = NLAT-NL+1
         FAC = WTS(NL)*WTACSJ(NL)
C
C        CALCULATE INTERMEDIATE QUANTITIES FOR COMPUTATIONL EFFICIENCY
C
C
         DO 100 M=0,MM
            JM=M+1
            STMP1(JM) = REAL(M)*FAC
C
            CTMP1(JM) = (UTMPFC(JM,NL) + UTMPFC(JM,SL)) *
     $                  CMPLX(0.0,STMP1(JM))
            CTMP2(JM) = (VTMPFC(JM,NL) - VTMPFC(JM,SL))*FAC
C
            CTMP3(JM) = (VTMPFC(JM,NL) + VTMPFC(JM,SL)) *
     $                  CMPLX(0.0,STMP1(JM))
            CTMP4(JM) = (UTMPFC(JM,NL) - UTMPFC(JM,SL))*FAC
  100    CONTINUE
C
C        SPECIAL HANDLING OF THE FIRST LATITUDE IN THE ACCUMULATIONS
C        DETOUR ELIMINATES THE NEED TO SEPARATELY ZERO DIVSC AND ZETASC
C
         IF (NL .EQ. 1) THEN
C
C        EVEN DIAGONALS FIRST LATITUDE
C
            DO 120 JN=0,NN,2
               IS = LDIAG(JN,2)
C
               DO 110 M=0,LDIAG(JN,1)-1
                  JM = M + 1
                  DIVSC(IS+JM) = CTMP1(JM)*ALP(IS+JM,NL)
     $                              - CTMP2(JM)*DALP(IS+JM,NL)
C
                  ZETASC(IS+JM) = CTMP3(JM)*ALP(IS+JM,NL)
     $                               + CTMP4(JM)*DALP(IS+JM,NL)
  110          CONTINUE
  120       CONTINUE
C
         ELSE
C
C        EVEN DIAGONALS OTHER LATITUDES
C
            DO 140 JN=0,NN,2
               IS = LDIAG(JN,2)
C
               DO 130 M=0,LDIAG(JN,1)-1
                  JM = M + 1
                  DIVSC(IS+JM) = DIVSC(IS+JM)
     $                            + CTMP1(JM)*ALP(IS+JM,NL)
     $                            - CTMP2(JM)*DALP(IS+JM,NL)
C
                  ZETASC(IS+JM) = ZETASC(IS+JM)
     $                             + CTMP3(JM)*ALP(IS+JM,NL)
     $                             + CTMP4(JM)*DALP(IS+JM,NL)
  130          CONTINUE
  140       CONTINUE
C
         ENDIF
C
C        CALCULATE INTERMEDIATE QUANTITIES FOR COMPUTATIONAL EFFICIENCY
C
         DO 160 M=0,MM
            JM=M+1
            STMP1(JM) = REAL(M)*FAC
C
            CTMP1(JM) = (UTMPFC(JM,NL) - UTMPFC(JM,SL)) *
     $                  CMPLX(0.0,STMP1(JM))
            CTMP2(JM) = (VTMPFC(JM,NL) + VTMPFC(JM,SL))*FAC
C
            CTMP3(JM) = (VTMPFC(JM,NL) - VTMPFC(JM,SL)) *
     $                  CMPLX(0.0,STMP1(JM))
            CTMP4(JM) = (UTMPFC(JM,NL) + UTMPFC(JM,SL))*FAC
  160    CONTINUE
C
C        SPECIAL HANDLING OF THE FIRST LATITUDE IN THE ACCUMULATIONS
C        DETOUR ELIMINATES THE NEED TO SEPARATELY ZERO DIVSC AND ZETASC
C
         IF (NL .EQ. 1) THEN
C
C        ODD DIAGONALS FIRST LATITUDE
C
            DO 180 JN=1,NN,2
               IS = LDIAG(JN,2)
C
               DO 170 M=0,LDIAG(JN,1)-1
                  JM = M + 1
                  DIVSC(IS+JM) = CTMP1(JM)*ALP(IS+JM,NL)
     $                              - CTMP2(JM)*DALP(IS+JM,NL)
C
                  ZETASC(IS+JM) = CTMP3(JM)*ALP(IS+JM,NL)
     $                               + CTMP4(JM)*DALP(IS+JM,NL)
  170          CONTINUE
  180       CONTINUE
C
         ELSE
C
C        ODD DIAGONALS REMAING LATITUDES
C
            DO 200 JN=1,NN,2
               IS = LDIAG(JN,2)
C
               DO 190 M=0,LDIAG(JN,1)-1
                  JM = M + 1
                  DIVSC(IS+JM) = DIVSC(IS+JM)
     $                            + CTMP1(JM)*ALP(IS+JM,NL)
     $                            - CTMP2(JM)*DALP(IS+JM,NL)
C
                  ZETASC(IS+JM) = ZETASC(IS+JM)
     $                             + CTMP3(JM)*ALP(IS+JM,NL)
     $                             + CTMP4(JM)*DALP(IS+JM,NL)
  190          CONTINUE
  200       CONTINUE
C
         ENDIF
C
  210 CONTINUE
C
C     ADD CORIOLIS TERM FOR ROTATED COORDINATE SYSTEM
C
C     WAVE M=0, N=1
      INDEX = LDIAG(1,2)+1
      ZETASC(INDEX) = ZETASC(INDEX) + CORSC1
C     WAVE M=1, N=1
      INDEX = LDIAG(0,2)+2
      ZETASC(INDEX) = ZETASC(INDEX) + CORSC2
C
      RETURN
      END