      SUBROUTINE BDTREXC( N, T, LDT, IFST, ILST, NITRAF, ITRAF,
     $                    NDTRAF, DTRAF, WORK, INFO )
      IMPLICIT NONE
*
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      INTEGER            IFST, ILST, INFO, LDT, N, NDTRAF, NITRAF
*     ..
*     .. Array Arguments ..
      INTEGER            ITRAF( * )
      DOUBLE PRECISION   DTRAF( * ), T( LDT, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  BDTREXC reorders the real Schur factorization of a real matrix
*  A = Q*T*Q**T, so that the diagonal block of T with row index IFST is
*  moved to row ILST.
*
*  The real Schur form T is reordered by an orthogonal similarity
*  transformation Z**T*T*Z. In contrast to the LAPACK routine DTREXC,
*  the orthogonal matrix Z is not explicitly constructed but
*  represented by paramaters contained in the arrays ITRAF and DTRAF,
*  see further details.
*
*  T must be in Schur canonical form (as returned by DHSEQR), that is,
*  block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
*  2-by-2 diagonal block has its diagonal elements equal and its
*  off-diagonal elements of opposite sign.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix T. N >= 0.
*
*  T       (input/output) DOUBLE PRECISION array, dimension (LDT,N)
*          On entry, the upper quasi-triangular matrix T, in Schur
*          Schur canonical form.
*          On exit, the reordered upper quasi-triangular matrix, again
*          in Schur canonical form.
*
*  LDT     (input) INTEGER
*          The leading dimension of the array T. LDT >= max(1,N).
*
*  IFST    (input/output) INTEGER
*  ILST    (input/output) INTEGER
*          Specify the reordering of the diagonal blocks of T.
*          The block with row index IFST is moved to row ILST, by a
*          sequence of transpositions between adjacent blocks.
*          On exit, if IFST pointed on entry to the second row of a
*          2-by-2 block, it is changed to point to the first row; ILST
*          always points to the first row of the block in its final
*          position (which may differ from its input value by +1 or -1).
*          1 <= IFST <= N; 1 <= ILST <= N.
*
*  NITRAF  (input/output) INTEGER
*          On entry, length of the array ITRAF.
*          As a minimum requirement, NITRAF >= max(1,|ILST-IFST|).
*          If there are 2-by-2 blocks in T then NITRAF must be larger;
*          a safe choice is NITRAF >= max(1,2*|ILST-IFST|).
*          On exit, actual length of the array ITRAF.
*
*  ITRAF   (output) INTEGER array, length NITRAF
*          List of parameters for representing the transformation
*          matrix Z, see further details.
*
*  NDTRAF  (input/output) INTEGER
*          On entry, length of the array DTRAF.
*          As a minimum requirement, NDTRAF >= max(1,2*|ILST-IFST|).
*          If there are 2-by-2 blocks in T then NDTRAF must be larger;
*          a safe choice is NDTRAF >= max(1,5*|ILST-IFST|).
*          On exit, actual length of the array DTRAF.
*
*  DTRAF   (output) DOUBLE PRECISION array, length NDTRAF
*          List of parameters for representing the transformation
*          matrix Z, see further details.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          = 1:  two adjacent blocks were too close to swap (the problem
*                is very ill-conditioned); T may have been partially
*                reordered, and ILST points to the first row of the
*                current position of the block being moved.
*          = 2:  the 2 by 2 block to be reordered split into two 1 by 1
*                blocks and the second block failed to swap with an
*                adjacent block. ILST points to the first row of the
*                current position of the whole block being moved.
*
*  Further Details
*  ===============
*
*  The orthogonal transformation matrix Z is a product of NITRAF
*  elementary orthogonal transformations. The parameters defining these
*  transformations are stored in the arrays ITRAF and DTRAF as follows:
*
*  Consider the i-th transformation acting on rows/columns POS,
*  POS+1, ... If this transformation is
*
*     (1) a Givens rotation with cosine C and sine S then
*
*           ITRAF(i) = POS,
*           DTRAF(j) = C,    DTRAF(j+1) = S;
*
*     (2) a Householder reflector H = I - tau * v * v' with
*         v = [ 1; v2; v3 ] then
*
*           ITRAF(i) = N + POS,
*           DTRAF(j) = tau,  DTRAF(j+1) = v2,  DTRAF(j+2) = v3;
*
*     (3) a Householder reflector H = I - tau * v * v' with
*         v = [ v1; v2; 1 ] then
*
*           ITRAF(i) = 2*N + POS,
*           DTRAF(j) = v1,  DTRAF(j+1) = v2,  DTRAF(j+2) = tau;
*
*  Note that the parameters in DTRAF are stored consecutively.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      INTEGER            DLNGTH(3), ILNGTH(3)
*     ..
*     .. Local Scalars ..
      INTEGER            CDTRAF, CITRAF, LDTRAF, LITRAF, HERE, I, NBF,
     $                   NBL, NBNEXT
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           BDLAEXC, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
*     .. Data Statements ..
c      DATA ( ILNGTH(I), I = 1, 3 ) / 1, 2, 4 /
c      DATA ( DLNGTH(I), I = 1, 3 ) / 2, 5, 10 /
      DATA ILNGTH(1)/1/, ILNGTH(2)/2/, ILNGTH(3)/4/
      DATA DLNGTH(1)/2/, DLNGTH(2)/5/, DLNGTH(3)/10/
*     ..
*     .. Executable Statements ..
*
*     Decode and test the input arguments.
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -3
      ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
         INFO = -4
      ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
         INFO = -5
      ELSE IF ( NITRAF.LT.MAX( 1, ABS( ILST-IFST ) ) ) THEN
         INFO = -6
      ELSE IF ( NDTRAF.LT.MAX( 1, 2*ABS( ILST-IFST ) ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTREXC', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.LE.1 )
     $   RETURN
      CITRAF = 1
      CDTRAF = 1
*
*     Determine the first row of specified block
*     and find out it is 1 by 1 or 2 by 2.
*
      IF( IFST.GT.1 ) THEN
         IF( T( IFST, IFST-1 ).NE.ZERO )
     $      IFST = IFST - 1
      END IF
      NBF = 1
      IF( IFST.LT.N ) THEN
         IF( T( IFST+1, IFST ).NE.ZERO )
     $      NBF = 2
      END IF
*
*     Determine the first row of the final block
*     and find out it is 1 by 1 or 2 by 2.
*
      IF( ILST.GT.1 ) THEN
         IF( T( ILST, ILST-1 ).NE.ZERO )
     $      ILST = ILST - 1
      END IF
      NBL = 1
      IF( ILST.LT.N ) THEN
         IF( T( ILST+1, ILST ).NE.ZERO )
     $      NBL = 2
      END IF
*
      IF( IFST.EQ.ILST )
     $   RETURN
*
      IF( IFST.LT.ILST ) THEN
*
*        Update ILST
*
         IF( NBF.EQ.2 .AND. NBL.EQ.1 )
     $      ILST = ILST - 1
         IF( NBF.EQ.1 .AND. NBL.EQ.2 )
     $      ILST = ILST + 1
*
         HERE = IFST
*
   10    CONTINUE
*
*        Swap block with next one below
*
         IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
*
*           Current block either 1 by 1 or 2 by 2
*
            NBNEXT = 1
            IF( HERE+NBF+1.LE.N ) THEN
               IF( T( HERE+NBF+1, HERE+NBF ).NE.ZERO )
     $            NBNEXT = 2
            END IF
*
            LITRAF = ILNGTH(NBF+NBNEXT-1)
            LDTRAF = DLNGTH(NBF+NBNEXT-1)
            IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
               INFO = -6
               CALL XERBLA( 'BDTREXC', -INFO )
               RETURN
            END IF
            IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
               INFO = -8
               CALL XERBLA( 'BDTREXC', -INFO )
               RETURN
            END IF
            CALL BDLAEXC( N, T, LDT, HERE, NBF, NBNEXT, ITRAF(CITRAF),
     $                    DTRAF(CDTRAF), WORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               NITRAF = CITRAF - 1
               NDTRAF = CDTRAF - 1
               RETURN
            END IF
            CITRAF = CITRAF + LITRAF
            CDTRAF = CDTRAF + LDTRAF
            HERE = HERE + NBNEXT
*
*           Test if 2 by 2 block breaks into two 1 by 1 blocks
*
            IF( NBF.EQ.2 ) THEN
               IF( T( HERE+1, HERE ).EQ.ZERO )
     $            NBF = 3
            END IF
*
         ELSE
*
*           Current block consists of two 1 by 1 blocks each of which
*           must be swapped individually
*
            NBNEXT = 1
            IF( HERE+3.LE.N ) THEN
               IF( T( HERE+3, HERE+2 ).NE.ZERO )
     $            NBNEXT = 2
            END IF
            LITRAF = ILNGTH(NBNEXT)
            LDTRAF = DLNGTH(NBNEXT)
            IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
               INFO = -6
               CALL XERBLA( 'BDTREXC', -INFO )
               RETURN
            END IF
            IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
               INFO = -8
               CALL XERBLA( 'BDTREXC', -INFO )
               RETURN
            END IF
            CALL BDLAEXC( N, T, LDT, HERE+1, 1, NBNEXT, ITRAF(CITRAF),
     $                    DTRAF(CDTRAF), WORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               NITRAF = CITRAF - 1
               NDTRAF = CDTRAF - 1
               RETURN
            END IF
            CITRAF = CITRAF + LITRAF
            CDTRAF = CDTRAF + LDTRAF
*
            IF( NBNEXT.EQ.1 ) THEN
*
*              Swap two 1 by 1 blocks, no problems possible
*
               LITRAF = ILNGTH(1)
               LDTRAF = DLNGTH(1)
               IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
                  INFO = -6
                  CALL XERBLA( 'BDTREXC', -INFO )
                  RETURN
               END IF
               IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
                  INFO = -8
                  CALL XERBLA( 'BDTREXC', -INFO )
                  RETURN
               END IF
               CALL BDLAEXC( N, T, LDT, HERE, 1, NBNEXT, ITRAF(CITRAF),
     $                       DTRAF(CDTRAF), WORK, INFO )
               CITRAF = CITRAF + LITRAF
               CDTRAF = CDTRAF + LDTRAF
               HERE = HERE + 1
            ELSE
*
*              Recompute NBNEXT in case 2 by 2 split
*
               IF( T( HERE+2, HERE+1 ).EQ.ZERO )
     $            NBNEXT = 1
               IF( NBNEXT.EQ.2 ) THEN
*
*                 2 by 2 Block did not split
*
                  LITRAF = ILNGTH(2)
                  LDTRAF = DLNGTH(2)
                  IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
                     INFO = -6
                     CALL XERBLA( 'BDTREXC', -INFO )
                     RETURN
                  END IF
                  IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
                     INFO = -8
                     CALL XERBLA( 'BDTREXC', -INFO )
                     RETURN
                  END IF
                  CALL BDLAEXC( N, T, LDT, HERE, 1, NBNEXT,
     $                          ITRAF(CITRAF), DTRAF(CDTRAF), WORK,
     $                          INFO )
                  IF( INFO.NE.0 ) THEN
                     INFO = 2
                     ILST = HERE
                     NITRAF = CITRAF - 1
                     NDTRAF = CDTRAF - 1
                     RETURN
                  END IF
                  CITRAF = CITRAF + LITRAF
                  CDTRAF = CDTRAF + LDTRAF
                  HERE = HERE + 2
               ELSE
*
*                 2 by 2 Block did split
*
                  LITRAF = ILNGTH(1)
                  LDTRAF = DLNGTH(1)
                  IF( CITRAF+2*LITRAF-1.GT.NITRAF ) THEN
                     INFO = -6
                     CALL XERBLA( 'BDTREXC', -INFO )
                     RETURN
                  END IF
                  IF( CDTRAF+2*LDTRAF-1.GT.NDTRAF ) THEN
                     INFO = -8
                     CALL XERBLA( 'BDTREXC', -INFO )
                     RETURN
                  END IF
                  CALL BDLAEXC( N, T, LDT, HERE, 1, 1, ITRAF(CITRAF),
     $                          DTRAF(CDTRAF), WORK, INFO )
                  CITRAF = CITRAF + LITRAF
                  CDTRAF = CDTRAF + LDTRAF
                  CALL BDLAEXC( N, T, LDT, HERE+1, 1, 1, ITRAF(CITRAF),
     $                          DTRAF(CDTRAF), WORK, INFO )
                  CITRAF = CITRAF + LITRAF
                  CDTRAF = CDTRAF + LDTRAF
                  HERE = HERE + 2
               END IF
            END IF
         END IF
         IF( HERE.LT.ILST )
     $      GO TO 10
*
      ELSE
*
         HERE = IFST
   20    CONTINUE
*
*        Swap block with next one above
*
         IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
*
*           Current block either 1 by 1 or 2 by 2
*
            NBNEXT = 1
            IF( HERE.GE.3 ) THEN
               IF( T( HERE-1, HERE-2 ).NE.ZERO )
     $            NBNEXT = 2
            END IF
*
            LITRAF = ILNGTH(NBF+NBNEXT-1)
            LDTRAF = DLNGTH(NBF+NBNEXT-1)
            IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
               INFO = -6
               CALL XERBLA( 'BDTREXC', -INFO )
               RETURN
            END IF
            IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
               INFO = -8
               CALL XERBLA( 'BDTREXC', -INFO )
               RETURN
            END IF
            CALL BDLAEXC( N, T, LDT, HERE-NBNEXT, NBNEXT, NBF,
     $                    ITRAF(CITRAF), DTRAF(CDTRAF), WORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               NITRAF = CITRAF - 1
               NDTRAF = CDTRAF - 1
               RETURN
            END IF
            CITRAF = CITRAF + LITRAF
            CDTRAF = CDTRAF + LDTRAF
            HERE = HERE - NBNEXT
*
*           Test if 2 by 2 block breaks into two 1 by 1 blocks
*
            IF( NBF.EQ.2 ) THEN
               IF( T( HERE+1, HERE ).EQ.ZERO )
     $            NBF = 3
            END IF
*
         ELSE
*
*           Current block consists of two 1 by 1 blocks each of which
*           must be swapped individually
*
            NBNEXT = 1
            IF( HERE.GE.3 ) THEN
               IF( T( HERE-1, HERE-2 ).NE.ZERO )
     $            NBNEXT = 2
            END IF
            LITRAF = ILNGTH(NBNEXT)
            LDTRAF = DLNGTH(NBNEXT)
            IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
               INFO = -6
               CALL XERBLA( 'BDTREXC', -INFO )
               RETURN
            END IF
            IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
               INFO = -8
               CALL XERBLA( 'BDTREXC', -INFO )
               RETURN
            END IF
            CALL BDLAEXC( N, T, LDT, HERE-NBNEXT, NBNEXT, 1,
     $                    ITRAF(CITRAF), DTRAF(CDTRAF), WORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               NITRAF = CITRAF - 1
               NDTRAF = CDTRAF - 1
               RETURN
            END IF
            CITRAF = CITRAF + LITRAF
            CDTRAF = CDTRAF + LDTRAF
*
            IF( NBNEXT.EQ.1 ) THEN
*
*              Swap two 1 by 1 blocks, no problems possible
*
               LITRAF = ILNGTH(1)
               LDTRAF = DLNGTH(1)
               IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
                  INFO = -6
                  CALL XERBLA( 'BDTREXC', -INFO )
                  RETURN
               END IF
               IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
                  INFO = -8
                  CALL XERBLA( 'BDTREXC', -INFO )
                  RETURN
               END IF
               CALL BDLAEXC( N, T, LDT, HERE, NBNEXT, 1, ITRAF(CITRAF),
     $                       DTRAF(CDTRAF), WORK, INFO )
               CITRAF = CITRAF + LITRAF
               CDTRAF = CDTRAF + LDTRAF
               HERE = HERE - 1
            ELSE
*
*              Recompute NBNEXT in case 2 by 2 split
*
               IF( T( HERE, HERE-1 ).EQ.ZERO )
     $            NBNEXT = 1
               IF( NBNEXT.EQ.2 ) THEN
*
*                 2 by 2 Block did not split
*
                  LITRAF = ILNGTH(2)
                  LDTRAF = DLNGTH(2)
                  IF( CITRAF+LITRAF-1.GT.NITRAF ) THEN
                     INFO = -6
                     CALL XERBLA( 'BDTREXC', -INFO )
                     RETURN
                  END IF
                  IF( CDTRAF+LDTRAF-1.GT.NDTRAF ) THEN
                     INFO = -8
                     CALL XERBLA( 'BDTREXC', -INFO )
                     RETURN
                  END IF
                  CALL BDLAEXC( N, T, LDT, HERE-1, 2, 1, ITRAF(CITRAF),
     $                          DTRAF(CDTRAF), WORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     INFO = 2
                     ILST = HERE
                     NITRAF = CITRAF - 1
                     NDTRAF = CDTRAF - 1
                     RETURN
                  END IF
                  CITRAF = CITRAF + LITRAF
                  CDTRAF = CDTRAF + LDTRAF
                  HERE = HERE - 2
               ELSE
*
*                 2 by 2 Block did split
*
                  LITRAF = ILNGTH(1)
                  LDTRAF = DLNGTH(1)
                  IF( CITRAF+2*LITRAF-1.GT.NITRAF ) THEN
                     INFO = -6
                     CALL XERBLA( 'BDTREXC', -INFO )
                     RETURN
                  END IF
                  IF( CDTRAF+2*LDTRAF-1.GT.NDTRAF ) THEN
                     INFO = -8
                     CALL XERBLA( 'BDTREXC', -INFO )
                     RETURN
                  END IF
                  CALL BDLAEXC( N, T, LDT, HERE, 1, 1, ITRAF(CITRAF),
     $                          DTRAF(CDTRAF), WORK, INFO )
                  CITRAF = CITRAF + LITRAF
                  CDTRAF = CDTRAF + LDTRAF
                  CALL BDLAEXC( N, T, LDT, HERE-1, 1, 1, ITRAF(CITRAF),
     $                          DTRAF(CDTRAF), WORK, INFO )
                  CITRAF = CITRAF + LITRAF
                  CDTRAF = CDTRAF + LDTRAF
                  HERE = HERE - 2
               END IF
            END IF
         END IF
         IF( HERE.GT.ILST )
     $      GO TO 20
      END IF
      ILST = HERE
      NITRAF = CITRAF - 1
      NDTRAF = CDTRAF - 1
*
      RETURN
*
*     End of BDTREXC
*
      END


! a driver that advects a Gaussian profile through a periodic domain
! in all possible coordinate directions.  This tests the advection
! scheme.
!
! The norm of the error (initial profile compared to final profile)
! should be the same for all directions, otherwise there is some
! directional bias in the advection solver.  Note: this does not mean
! that the final density profile cannot have an imprint from the
! advection in a particular direction, just that advecting in any
! direction should show that same pattern of imprinting.
!
! Here we compute the norm level-by-level.  This driver assume that
! the grid is static, so the initial and final grids agree.  This
! allows us to compute a meaningful norm.

subroutine varden()

  use BoxLib
  use f2kcli
  use list_box_module
  use ml_boxarray_module
  use layout_module
  use multifab_module
  use base_state_module
  use ml_cc_restriction_module
  use bc_module
  use define_bc_module
  use bl_mem_stat_module
  use bl_timer_module
  use box_util_module
  use bl_IO_module
  use fabio_module
  use variables, only: nscal, init_variables, rho_comp, spec_comp, ntrac, trac_comp
  use fill_3d_module, only: make_normal
  use geometry, only:  nlevs_radial, spherical, &
                       dr_fine, nr_fine, &
                       init_spherical, init_center, &
                       init_multilevel, init_radial, &
                       init_cutoff, initialize_dx, destroy_geometry
  use network, only: network_init, nspec
  use eos_module, only: eos_init
  use probin_module, only: dump_output, advect_test_tol, &
                           prob_lo, prob_hi, pmask, drdxfac, &
                           test_set, &
                           ppm_type, bds_type, do_bds, &
                           cflfac, &
                           stop_time
  use runtime_init_module, only: runtime_init, runtime_close
  use bl_constants_module
  use multifab_physbc_module
  use multifab_fill_ghost_module
  use test_advect_module, only: init_density_2d, init_density_3d
  use density_advance_module, only: density_advance

  implicit none

  real(dp_t) :: lenx,leny,lenz,max_dist

  integer :: i,n,p,comp
  integer :: ng_s
  integer :: nlevs, dm

  integer :: idir, idim, itest_dir, index_t
  integer :: imax

  type(ml_layout) :: mla

  type(multifab), allocatable :: sold(:), snew(:)
  type(multifab), allocatable :: umac(:,:)
  type(multifab), allocatable :: normal(:)

  type(multifab), allocatable :: sedge(:,:), sflux(:,:)
  type(multifab), allocatable :: scal_force(:), etarhoflux(:)
  type(multifab), allocatable :: w0mac(:,:)

  type(multifab), allocatable :: dens_orig(:), dens_final(:)
  type(multifab), allocatable :: error(:)
  type(multifab), allocatable :: temporary(:)

  real(kind=dp_t), pointer :: sp(:,:,:,:)

  real(dp_t), allocatable :: rho0_old(:,:), rho0_new(:,:), rhoh0(:,:), p0(:,:), w0(:,:)
  real(dp_t), allocatable :: rho0_predicted_edge(:,:)

  real(kind=dp_t), pointer :: dx(:,:)

  integer, allocatable :: lo(:),hi(:)

  type(ml_boxarray) :: mba

  type(bc_tower) ::  the_bc_tower

  real(kind=dp_t) :: t, dt

  character (len=32) :: outname

  character (len=20) :: plot_names(3)

  real(kind=dp_t), allocatable :: abs_norm(:,:,:), rel_norm(:,:,:)
  real(kind=dp_t) :: max_dabs_error, max_abs_error
  real(kind=dp_t) :: max_drel_error, max_rel_error

  logical :: wrote_init_file = .false.

  ! general Maestro initializations
  call runtime_init()
  call init_spherical()
  call init_center()

  call init_variables()

  call network_init()
  call eos_init()

  ! setup the grid
  call read_a_hgproj_grid(mba, test_set)

  call ml_layout_build(mla,mba,pmask)

  ! check for proper nesting
  if (.not. ml_boxarray_properly_nested(mla%mba, 3, pmask)) then
     call bl_error('fixed_grids not properly nested')
  end if

  ! initialize nlevs
  nlevs = mla%nlevel

  nlevs_radial = merge(1, nlevs, spherical .eq. 1)

  ! initialize dm
  dm = mla%dim

  ! initialize boundary conditions
  call initialize_bc(the_bc_tower,nlevs,pmask)
  do n = 1,nlevs
     call bc_tower_level_build(the_bc_tower,n,mla%la(n))
  end do

  ! allocate states
  allocate(sold(nlevs),snew(nlevs),umac(nlevs,dm))

  ! 4 ghostcells will work for all PPM types
  ng_s = 4

  if (spherical == 1) then
     call bl_error("ERROR: test_advect not defined for spherical = 1")
  endif

  ! build states
  do n = 1,nlevs
     call multifab_build(sold(n), mla%la(n), nscal, ng_s)
     call multifab_build(snew(n), mla%la(n), nscal, ng_s)
     do comp=1,dm
        call multifab_build_edge(umac(n,comp), mla%la(n),1,1,comp)
     end do
  end do

  ! initialize_dx
  call initialize_dx(dx,mba,nlevs)

  ! now that we have dx we can initialize nr_fine and dr_fine
  if (spherical .eq. 1) then

     ! for spherical, we will now require that dr_fine = dx
     dr_fine = dx(nlevs,1) / dble(drdxfac)

     lenx = HALF * (prob_hi(1) - prob_lo(1))
     leny = HALF * (prob_hi(2) - prob_lo(2))
     lenz = HALF * (prob_hi(3) - prob_lo(3))

     max_dist = sqrt(lenx**2 + leny**2 + lenz**2)
     nr_fine = int(max_dist / dr_fine) + 1

  else

     nr_fine = extent(mla%mba%pd(nlevs),dm)
     dr_fine = (prob_hi(dm)-prob_lo(dm)) / dble(nr_fine)

  end if

  ! create numdisjointchunks, r_start_coord, r_end_coord
  call init_multilevel(sold)

  ! now that we have nr_fine and dr_fine we can create nr, dr, r_cc_loc, r_edge_loc
  call init_radial(nlevs,mba)

  ! allocate the cutoff coordinate arrays
  call init_cutoff(nlevs)

  ! allocate normal
  allocate (normal(nlevs))
  if (dm == 3) then
     do n = 1,nlevs
        call multifab_build(normal(n), mla%la(n),    dm, 1)
     enddo
  endif

  call make_normal(normal,dx)

  ! the initial and final densities
  allocate(dens_orig(nlevs))
  allocate(dens_final(nlevs))
  allocate(error(nlevs))
  allocate(temporary(nlevs))

  do n = 1,nlevs
     call multifab_build(dens_orig(n), mla%la(n), 1, ng_s)
     call multifab_build(dens_final(n), mla%la(n), 1, ng_s)
     call multifab_build(error(n), mla%la(n), 1, ng_s)
     call multifab_build(temporary(n), mla%la(n), 3, ng_s)
  end do

  plot_names(1) = "density"
  plot_names(2) = "rel. error"
  plot_names(3) = "abs. error"

  ! allocate the base state
  allocate(           rho0_old(nlevs,0:nr_fine-1))
  allocate(           rho0_new(nlevs,0:nr_fine-1))
  allocate(              rhoh0(nlevs,0:nr_fine-1))
  allocate(                 p0(nlevs,0:nr_fine-1))
  allocate(                 w0(nlevs,0:nr_fine))
  allocate(rho0_predicted_edge(nlevs,0:nr_fine))

  ! other allocations
  allocate(lo(dm))
  allocate(hi(dm))

  allocate(sedge(nlevs,dm))
  allocate(sflux(nlevs,dm))

  allocate(scal_force(nlevs))
  allocate(etarhoflux(nlevs))

  allocate(w0mac(nlevs,dm))

  do n=1,nlevs
     do comp = 1,dm
        call multifab_build_edge(sedge(n,comp),mla%la(n),nscal,0,comp)
        call multifab_build_edge(sflux(n,comp),mla%la(n),nscal,0,comp)
        call multifab_build_edge(w0mac(n,comp),mla%la(n),1,1,comp)
        call setval(w0mac(n,comp),ZERO,all=.true.)
     end do

     call multifab_build(scal_force(n), mla%la(n), nscal, 1)
     call multifab_build_edge(etarhoflux(n), mla%la(n), 1, 0, dm)
     call setval(scal_force(n),ZERO,all=.true.)
     call setval(etarhoflux(n),ZERO,all=.true.)
  end do

  allocate(rel_norm(0:3,nlevs,2*dm))
  allocate(abs_norm(0:3,nlevs,2*dm))

  rel_norm = ZERO
  abs_norm = ZERO

  !---------------------------------------------------------------------------
  ! loop over all possible directions and all ppm_types
  !---------------------------------------------------------------------------
  if (do_bds) then
     imax = 3
  else
     imax = 2
  endif

  do p = 0, imax

     if (p <= 2) then
        ppm_type = p

        if (parallel_IOProcessor()) then
           print *, ' '
           print *, '<<< ppm_type ', p, ' >>>'
           print *, ' '
        endif

     else
        bds_type = 1

        if (parallel_IOProcessor()) then
           print *, ' '
           print *, '<<< bds_type ', 1, ' >>>'
           print *, ' '
        endif
     endif

     do idim = 1, dm
        do idir = -1, 1, 2

           itest_dir = idir * idim

           ! a unique index for indexing array by test
           index_t = idim
           if (idir < 0) then
              index_t = index_t + dm
           endif

           if (parallel_IOProcessor()) then
              print *, ' '
              print *, '<<< advection test in direction ', itest_dir, ' >>>'
              print *, 'index_t = ', index_t
           endif

           ! initialize the velocity field -- it is unity in the
           ! direction of propagation a negative itest_dir indicates
           ! negative velocity
           do n = 1, nlevs

              select case (itest_dir)

              case (-1)
                 call setval(umac(n,1), -ONE,  all=.true.)
                 call setval(umac(n,2), ZERO, all=.true.)
                 if (dm == 3) call setval(umac(n,3), ZERO, all=.true.)

              case (1)
                 call setval(umac(n,1), ONE,  all=.true.)
                 call setval(umac(n,2), ZERO, all=.true.)
                 if (dm == 3) call setval(umac(n,3), ZERO, all=.true.)

              case (-2)
                 call setval(umac(n,1), ZERO, all=.true.)
                 call setval(umac(n,2), -ONE,  all=.true.)
                 if (dm == 3) call setval(umac(n,3), ZERO, all=.true.)

              case (2)
                 call setval(umac(n,1), ZERO, all=.true.)
                 call setval(umac(n,2), ONE,  all=.true.)
                 if (dm == 3) call setval(umac(n,3), ZERO, all=.true.)

              case (-3)
                 call setval(umac(n,1), ZERO, all=.true.)
                 call setval(umac(n,2), ZERO, all=.true.)
                 call setval(umac(n,3), -ONE,  all=.true.)

              case (3)
                 call setval(umac(n,1), ZERO, all=.true.)
                 call setval(umac(n,2), ZERO, all=.true.)
                 call setval(umac(n,3), ONE,  all=.true.)

              end select

           enddo

           ! the base state will not carry any information in this test problem
           rho0_old(:,:) = ZERO
           rho0_new(:,:) = ZERO
           rhoh0(:,:) = ZERO
           p0(:,:) = ZERO
           w0(:,:) = ZERO
           rho0_predicted_edge(:,:) = ZERO

           ! initialize the density field and species
           do n=1,nlevs
              do i = 1, nfabs(sold(n))
                 sp => dataptr(sold(n), i)
                 lo = lwb(get_box(sold(n), i))
                 hi = upb(get_box(sold(n), i))

                 select case (dm)
                 case (2)
                    call init_density_2d(sp(:,:,1,rho_comp), &
                                         sp(:,:,1,spec_comp:spec_comp-1+nspec), &
                                         sp(:,:,1,trac_comp:trac_comp-1+ntrac), &
                                         sold(n)%ng, lo, hi, dx(n,:))

                 case (3)
                    call init_density_3d(sp(:,:,:,rho_comp), &
                                         sp(:,:,:,spec_comp:spec_comp-1+nspec), &
                                         sp(:,:,:,trac_comp:trac_comp-1+ntrac), &
                                         sold(n)%ng, lo, hi, dx(n,:))
                 end select
              end do
           end do

           ! ghost cell fill
           if (nlevs .eq. 1) then

              ! fill ghost cells for two adjacent grids at the same level
              ! this includes periodic domain boundary ghost cells
              call multifab_fill_boundary(sold(nlevs))

              ! fill non-periodic domain boundary ghost cells
              call multifab_physbc(sold(nlevs),rho_comp,dm+rho_comp,nscal, &
                                   the_bc_tower%bc_tower_array(nlevs))

           else

              ! the loop over nlevs must count backwards to make sure
              ! the finer grids are done first
              do n=nlevs,2,-1

                 ! set level n-1 data to be the average of the level n
                 ! data covering it
                 call ml_cc_restriction(sold(n-1),sold(n),mla%mba%rr(n-1,:))

                 ! fill level n ghost cells using interpolation from
                 ! level n-1 data note that multifab_fill_boundary and
                 ! multifab_physbc are called for both levels n-1 and
                 ! n
                 call multifab_fill_ghost_cells(sold(n),sold(n-1),sold(n)%ng, &
                                                mla%mba%rr(n-1,:), &
                                                the_bc_tower%bc_tower_array(n-1), &
                                                the_bc_tower%bc_tower_array(n), &
                                                rho_comp,dm+rho_comp,nscal)

              enddo

           end if

           ! store the initial density field
           do n = 1,nlevs
              call multifab_copy_c(dens_orig(n),1,sold(n),rho_comp,1,ng_s)
           enddo

           ! write out the initial density field
           if (dump_output .and. .not. wrote_init_file) then

              if (dm == 2) then
                 outname = "dens_2d_orig"

              else if (dm == 3) then
                 outname = "dens_3d_orig"

              endif

              call fabio_ml_multifab_write_d(dens_orig,mla%mba%rr(:,1), &
                                             trim(outname),names=plot_names(1:1))

              if (parallel_IOProcessor()) then
                 print *, 'wrote file: ', trim(outname)
                 print *, ' '
              endif

              wrote_init_file = .true.

           endif

           ! compute the initial timestep -- dt = dx / u
           dt = cflfac*dx(nlevs,1)/ONE

           ! advance the density using the constant velocity field
           t = ZERO
           do while (t < stop_time)

              if (parallel_IOProcessor()) then
                 print *, 't = ', t, 'dt = ', dt
              endif

              ! advance density according to rho_t + (rho U)_x = 0
              call density_advance(mla,1,sold,snew,sedge,sflux, &
                                   scal_force,umac,w0,w0mac,etarhoflux, &
                                   rho0_old,rho0_new,p0, &
                                   rho0_predicted_edge, &
                                   dx,dt,the_bc_tower%bc_tower_array)

              ! save the state for the next step
              do n = 1,nlevs
                 call multifab_copy_c(sold(n),1,snew(n),1,nscal,sold(n)%ng)
              enddo

              rho0_old = rho0_new

              ! update the time
              t = t + dt

              ! adjust the timestep, if necessary
              if (t + dt > stop_time) then
                 dt = stop_time - t
              endif

           end do

           if (parallel_IOProcessor()) then
              print *, 'finished evolution, t = ', t
           endif

           ! copy the final density field into a dummy multifab for
           ! output and analysis
           do n = 1,nlevs
              call multifab_copy_c(dens_final(n),1,snew(n),rho_comp,1,0)
           enddo

           ! compare the initial and final density

           ! compute dens_final - dens_orig
           do n = 1, nlevs
              call multifab_copy_c(error(n),1,dens_final(n),1,1,ng_s)
              call multifab_sub_sub(error(n), dens_orig(n))
           enddo

           do n = 1, nlevs
              abs_norm(p,n,index_t) = multifab_norm_l2(error(n))
           enddo

           ! now compute (dens_final - dens_orig)/dens_orig
           do n = 1, nlevs
              call multifab_div_div(error(n), dens_orig(n), 0)
           enddo

           do n = 1, nlevs
              rel_norm(p,n,index_t) = multifab_norm_l2(error(n))
           enddo

           if (dump_output) then

              do n = 1, nlevs
                 ! final density
                 call multifab_copy_c(temporary(n),1,dens_final(n),1,1,ng_s)

                 ! relative error
                 call multifab_copy_c(temporary(n),2,error(n),1,1,ng_s)

                 ! absolute error (reconstructed)
                 call multifab_mult_mult(error(n), dens_orig(n), 0)
                 call multifab_copy_c(temporary(n),3,error(n),1,1,ng_s)
              enddo

              ! write out the initial density field the output name will
              ! include the dimensionality, ppm_type, and advection
              ! direction

              if (dm == 2) then
                 outname = "dens_2d_"
              else if (dm == 3) then
                 outname = "dens_3d_"
              endif

              if (bds_type == 1) then
                 outname = trim(outname) // "bds_"
              else
                 select case (p)
                 case (0)
                    outname = trim(outname) // "ppm0_"

                 case (1)
                    outname = trim(outname) // "ppm1_"

                 case (2)
                    outname = trim(outname) // "ppm2_"

                 case (3)
                    outname = trim(outname) // "bds_"
                 end select
              endif

              select case (itest_dir)
              case (-1)
                 outname = trim(outname) // "xm_final"

              case (1)
                 outname = trim(outname) // "xp_final"

              case (-2)
                 outname = trim(outname) // "ym_final"

              case (2)
                 outname = trim(outname) // "yp_final"

              case (-3)
                 outname = trim(outname) // "zm_final"

              case (3)
                 outname = trim(outname) // "zp_final"
              end select

              call fabio_ml_multifab_write_d(temporary,mla%mba%rr(:,1), &
                                             trim(outname),names=plot_names, time=t)

              if (parallel_IOProcessor()) then
                 print *, 'wrote file: ', trim(outname)
              endif

           endif

        enddo    ! idir loop
     enddo    ! idim loop
  enddo   ! ppm_type

  if (parallel_IOProcessor()) then
     print *, ' '
     print *, ' '
  endif

  ! report
  do p = 0, imax   ! ppm_type

     if (p <= 2) then
        if (parallel_IOProcessor()) then
           print *, 'ppm_type = ', p
        endif
     else
        if (parallel_IOProcessor()) then
           print *, 'bds_type = ', 1
        endif
     endif

     do i = 1, 2*dm
        if (i <= dm) then
           itest_dir = i
        else
           itest_dir = -1*(i - dm)
        endif

        if (parallel_IOProcessor()) then
           print *, 'advection direction: ', itest_dir
           do n = 1,nlevs
              print *, '  level ', n
              print *, '    | rho_final - rho_init |_2              = ', abs_norm(p,n,i)
              print *, '    | (rho_final - rho_init) / rho_init |_2 = ', rel_norm(p,n,i)
           enddo
           print *, ' '
        endif

     enddo
  enddo  ! ppm_type

  max_dabs_error = -1.d30
  max_abs_error  = -1.d30

  max_drel_error = -1.d30
  max_rel_error  = -1.d30

  do p = 0, imax
     do n = 1, nlevs
        max_dabs_error = max(abs(maxval(abs_norm(p,n,:)) - minval(abs_norm(p,n,:))), &
                             max_dabs_error)
        max_abs_error = max(maxval(abs_norm(p,n,:)), max_abs_error)

        max_drel_error = max(abs(maxval(rel_norm(p,n,:)) - minval(rel_norm(p,n,:))), &
                             max_drel_error)
        max_rel_error = max(maxval(rel_norm(p,n,:)), max_rel_error)
     enddo
  enddo  ! ppm_type

  if (parallel_IOProcessor()) then
     if (max_dabs_error < advect_test_tol * max_abs_error .and. &
          max_drel_error < advect_test_tol * max_rel_error) then
        print *, "SUCCESS: advection errors for all directions agree with tolerance"
     else
        print *, "ERROR: advection errors across directions are too large"
        print *, "absolute error: ", max_dabs_error/max_abs_error
        print *, "relative error: ", max_drel_error/max_rel_error
     endif

     print *, " "
  endif

  ! clean-up
  do n = 1,nlevs
     call destroy(sold(n))
     call destroy(snew(n))
     do comp=1,dm
        call destroy(umac(n,comp))
     end do
     call destroy(dens_orig(n))
     call destroy(dens_final(n))
     call destroy(error(n))
     call destroy(temporary(n))
  end do

  call destroy(mla)
  call destroy(mba)

  deallocate(sold,snew,umac,dens_orig,dens_final,error,temporary)

  call bc_tower_destroy(the_bc_tower)

  call runtime_close()

  call destroy_geometry()

end subroutine varden


module mod_maps
  use mod_constants
  use mod_read_parameters
  use mod_variables

  implicit none

  integer           :: nb_S  ! The number of points along Sigma axis
  integer           :: nb_T  ! The number of points along T axis
  real(x_precision) :: T_min ! Lowest value of Temperature range
  real(x_precision) :: T_max ! Highest value of Temperature range
  real(x_precision) :: S_min ! Lowest value of Sigma range
  real(x_precision) :: S_max ! Highest value of Sigma range

contains

  subroutine set_conditions(nbS, nbT)
    implicit none

    integer, intent(in) :: nbS
    integer, intent(in) :: nbT

    nb_S = nbS
    nb_T = nbT
    T_min = Tmin / state_0%T_0
    T_max = Tmax / state_0%T_0
    S_min = Smin / state_0%S_0
    S_max = Smax / state_0%S_0

  end subroutine set_conditions

  ! Build the T, Sigma grid given the number of points along each axis and the ranges
  subroutine build_grid(Q_res, tau_res)
    implicit none

    real(x_precision), dimension(n_cell,nb_T,nb_S), intent(out) :: Q_res   ! The Q+-Q- grids, one for each position in the disk
    real(x_precision), dimension(n_cell,nb_T,nb_S), intent(out) :: tau_res ! The tau grids, one for each position in the disk

    type(state)       :: s   ! A temporary state to compute the variables
    real(x_precision) :: dT  ! Temperature steps in the grid
    real(x_precision) :: dS  ! Sigma steps in the grid
    integer           :: i,j ! Loop counters

    ! Compute the Temperature and Sigma steps
    dT = (log(T_max) - log(T_min)) / (nb_T - 1)
    dS = (log(S_max) - log(S_min)) / (nb_S - 1)

    s%Mdot(n_cell) = 1._x_precision

    do i = 1, nb_T
       s%T = exp(dT * (i-1) + log(T_min))
       do j = 1, nb_S
          s%S = exp(dS * (j-1) + log(S_min)) * x_state%x

          call compute_variables(s) ! Compute the variables in each position of the state
          Q_res(:,i,j) = s%Qplus - s%Qminus
          tau_res(:,i,j) = s%tau
       end do
    end do

    Q_res = Q_res * state_0%Q_0

  end subroutine build_grid

  subroutine save_data(Q_res, tau_res)
    implicit none

    real(x_precision), dimension(n_cell,nb_T,nb_S), intent(in) :: Q_res   ! The Q+-Q- grids, one for each position in the disk
    real(x_precision), dimension(n_cell,nb_T,nb_S), intent(in) :: tau_res ! The tau grids, one for each position in the disk

    character(len = 64) :: fname       ! Name of the output file
    character(len = 16) :: line_fmt    ! Format of lines in the output file
    character(len = 8)  :: cell_number ! Cell number, to use in filename
    integer             :: fid         ! File descriptor
    integer             :: ios         ! I/O status
    integer             :: i,j,k       ! Loop counters

    write(line_fmt,'(A,I4,A)') '(',nb_S,'(e11.3e2))'

    do k = 1, n_cell

      write(cell_number,'(I5.5)') k
      fid = 30 + k
      fname = 'maps/map_'//trim(cell_number)//'.dat'

      open(fid, file = fname, action='write', status = 'replace', iostat = ios)
      if (ios /= 0) then
        write(*,*)"Error while opening the ", fname," file."
        stop
      endif

      write(fid, fmt = '(A)') '# nb_T'
      write(fid, fmt = '(I5.5)') nb_T

      write(fid, fmt = '(A)') '# nb_S'
      write(fid, fmt = '(I5.5)') nb_S

      write(fid, fmt = '(A)') '# T bounds'
      write(fid, fmt = '(2(e11.3e2))') T_min*state_0%T_0, T_max*state_0%T_0

      write(fid, fmt = '(A)') '# Sigma bounds'
      write(fid, fmt = '(2(e11.3e2))') S_min*state_0%S_0, S_max*state_0%S_0

      write(fid, fmt = '(A)') '# Q grid'
      do i = 1, nb_T
        write(fid, fmt = line_fmt) (Q_res(k,nb_T+1-i,j), j = 1, nb_S)
      end do

      write(fid, fmt = '(A)') '# tau grid'
      do i = 1, nb_T
        write(fid, fmt = line_fmt) (tau_res(k,nb_T+1-i,j), j = 1, nb_S)
      end do

      close(fid)

    enddo

  end subroutine save_data

end module mod_maps


!     Convert between lat/long and cartesian coordinates
!     Input: <fname> (build pt format);lat/long must be in degrees
!     Depths are not changed.

!     ifort -Bstatic -O3 -o cpp_bp cpp_bp.f90
      program cpp_bp
      implicit real*8(a-h,o-z)
      character*70 fname

      pi=3.1415926
      print*, "Input file name:"
      read(*,'(a70)') fname
      print*, "1: from lat/long to cartesian; -1: from cartesian to lat/long:"
      read*, ifl
      if(iabs(ifl).ne.1) then
	print*, "Incorrect input of ifl",ifl
	stop
      endif
      print*, "Input center of projection (in degrees):"
      read*, rlambda0,phi0
      rlambda0=rlambda0*pi/180
      phi0=phi0*pi/180

      open(12,file=fname,status='old')
      open(13,file="out_"//fname)
      read(12,*)
      read(12,*)np
      write(13,*)
      write(13,*)np
      do i=1,np
	read(12,*)j,xtmp,ytmp,dp
 	call cpp(ifl,xtmp,ytmp,xout,yout,rlambda0,phi0)
	write(13,'(i8,2(1x,f24.10),1x,e22.12)')j,xout,yout,dp
      enddo !i
      close(12)
      close(13)

      stop
      end

      subroutine cpp(ifl,xin,yin,xout,yout,rlambda0,phi0)
      implicit real*8(a-h,o-z)
      parameter(r=6378206.4)
      parameter(pi=3.1415926)

      if(ifl.eq.1) then
	xin=xin*pi/180
	yin=yin*pi/180
        xout=r*(xin-rlambda0)*cos(phi0)
        yout=yin*r
      else !ifl=-1
	xout=rlambda0+xin/r/cos(phi0)
	yout=yin/r
        xout=xout/pi*180
        yout=yout/pi*180
      endif

      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id$
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE RFFT2B (LDIM, L, M, R, WSAVE, LENSAV, WORK,
     1  LENWRK, IER)
      INTEGER LDIM, L, M, LENSAV, LENWRK, IER
      REAL    R(LDIM,M), WSAVE(LENSAV), WORK(LENWRK)
C
C
C Initialize IER
C
      IER = 0
C
C Verify LENSAV
C
      LWSAV =   L + INT(LOG (REAL(L))) +4
      MWSAV =   2*M + INT(LOG (REAL(M))) +4
      IF (LENSAV .LT. LWSAV+MWSAV) THEN
        IER = 2
        CALL XERFFT ('RFFT2B', 6)
        GO TO 100
      ENDIF
C
C Verify LENWRK
C
      IF (LENWRK .LT. 2*(L/2+1)*M) THEN
        IER = 3
        CALL XERFFT ('RFFT2B', 8)
        GO TO 100
      ENDIF
C
C Verify LDIM is as big as L
C
      IF (LDIM .LT. 2*(L/2+1)) THEN
        IER = 5
        CALL XERFFT ('RFFT2B', -6)
        GO TO 100
      ENDIF
C
C transform second dimension of array
C
      CALL CFFTMB(L/2+1,1,M,LDIM/2,R,M*LDIM/2,
     .     WSAVE(L+INT(LOG(REAL(L)))+5),
     .     2*M+INT(LOG(REAL(M)))+4,WORK,2*(L/2+1)*M,IER1)
      IF(IER1.NE.0) THEN
         IER=20
         CALL XERFFT('RFFT2B',-5)
         GO TO 100
      ENDIF
C
C reshuffle
C
      DO J=1,M
         DO I=2,L
            R(I,J)=R(I+1,J)
         ENDDO
      ENDDO
C
C Transform first dimension of array
C
      CALL RFFTMB(M,LDIM,L,1,R,M*LDIM,WSAVE(1),
     .     L+INT(LOG(REAL(L)))+4,WORK,2*(L/2+1)*M,IER1)
      IF(IER1.NE.0) THEN
         IER=20
         CALL XERFFT('RFFT2F',-5)
         GO TO 100
      ENDIF
C
  100 CONTINUE
C
      RETURN
      END


! Copyright (c) 2013 Aubrey Barnard.  This is free software.  See
! LICENSE.txt for details.

! Simple implementation of gradient descent for Go-Fortran-Go interface
! prototyping.

module gd
  implicit none
  private

  ! Public constants, variables
  public dp
  ! Public types
  public point_value_gradient
  ! Public procedures
  public gradient_descent
  ! Should the interfaces be public?  Doesn't seem to matter.

  ! Double precision kind for reals
  integer, parameter :: dp = kind(0d0)

  ! Information about a point important for optimization: (x,f,g)
  type :: point_value_gradient
     real(dp) :: f
     real(dp), allocatable :: x(:), g(:)
  end type point_value_gradient

  abstract interface
     ! What an objective function looks like (f: R**n -> R)
     function func_rn_r(x, f) result(error_code)
       import :: dp
       implicit none
       real(dp), intent(in) :: x(:)
       real(dp), intent(out) :: f
       integer :: error_code
     end function func_rn_r

     ! What the gradient of an objective function looks like (f: R**n -> R**n)
     function func_rn_rn(x, g) result(error_code)
       import :: dp
       implicit none
       real(dp), intent(in) :: x(:)
       real(dp), intent(out) :: g(size(x))
       integer :: error_code
     end function func_rn_rn
  end interface

contains

  ! Version of gradient descent that only runs for a set number of
  ! iterations and uses a fixed step size (instead of a line search or a
  ! schedule, etc.).  These simplifications make for a very simple
  ! implementation that supports the goals of interfacing with different
  ! languages and calling user-specified procedures to compute the
  ! function and gradient.
  function gradient_descent(func, grad, x0, stepsize, iters, min) result(error_code)
    implicit none
    ! Signature
    procedure(func_rn_r) :: func
    procedure(func_rn_rn) :: grad
    real(dp), intent(in) :: x0(:), stepsize
    integer, intent(in) :: iters
    type(point_value_gradient), intent(out) :: min
    integer :: error_code

    ! Locals
    real(dp) :: x(size(x0)), g(size(x0)), f
    integer :: iteration

    !print *,"gradient_descent(", x0, stepsize, iters, "x:", min%x, "f:", min%f, "g:", min%g, ")"

    ! Init
    x = x0

    ! Loop to do a fixed number of gradient descent steps
    do iteration = 1, iters
       error_code = func(x, f)
       if (error_code /= 0) return
       error_code = grad(x, g)
       if (error_code /= 0) return
       !print *, iteration, "x:", x, "f:", f, "g:", g
       x = x - stepsize * g
    end do

    ! Compute and store the "minimum"
    if (.not. allocated(min%x)) allocate(min%x(size(x0)))
    if (.not. allocated(min%g)) allocate(min%g(size(x0)))
    min%x = x
    error_code = func(x, min%f)
    if (error_code /= 0) return
    error_code = grad(x, min%g)
    if (error_code /= 0) return
    !print *, iteration, "x:", min%x, "f:", min%f, "g:", min%g

    ! Success!
    error_code = 0
  end function gradient_descent

end module gd


program Test
  use LongMoltiplication

  type(longnum) :: a, b, r

  call longmolt_s2l("18446744073709551616", a)
  call longmolt_s2l("18446744073709551616", b)

  r = a * b
  call longmolt_print(r)
  write(*,*)

end program Test


!
! Copyright 2020 Fluid Numerics LLC
! Author : Joseph Schoonover (joe@fluidnumerics.com)
! Support : self@higherordermethods.org
!
! //////////////////////////////////////////////////////////////////////////////////////////////// !
MODULE SELF_Geometry

  USE SELF_Constants
  USE SELF_Lagrange
  USE SELF_Data
  USE SELF_SupportRoutines
  USE SELF_Mesh

  IMPLICIT NONE

#include "SELF_Macros.h"

  TYPE,PUBLIC :: Geometry1D
    INTEGER :: nElem
    TYPE(Scalar1D) :: x ! Physical Positions
    TYPE(Scalar1D) :: dxds ! Conversion from computational to physical space

  CONTAINS

    PROCEDURE,PUBLIC :: Init => Init_Geometry1D
    PROCEDURE,PUBLIC :: Free => Free_Geometry1D
    PROCEDURE,PUBLIC :: GenerateFromMesh => GenerateFromMesh_Geometry1D
    PROCEDURE,PUBLIC :: UpdateHost => UpdateHost_Geometry1D
    PROCEDURE,PUBLIC :: UpdateDevice => UpdateDevice_Geometry1D
    PROCEDURE,PUBLIC :: CalculateMetricTerms => CalculateMetricTerms_Geometry1D

    PROCEDURE :: Write => Write_Geometry1D
    PROCEDURE :: WriteTecplot => WriteTecplot_Geometry1D

  END TYPE Geometry1D

  TYPE,PUBLIC :: SEMQuad
    INTEGER :: nElem
    TYPE(Vector2D) :: x ! Physical positions
    TYPE(Tensor2D) :: dxds ! Covariant basis vectors
    TYPE(Tensor2D) :: dsdx ! Contavariant basis vectors
    TYPE(Vector2D) :: nHat ! Normal Vectors pointing across coordinate lines
    TYPE(Scalar2D) :: nScale ! Boundary scale
    TYPE(Scalar2D) :: J ! Jacobian of the transformation

  CONTAINS

    PROCEDURE,PUBLIC :: Init => Init_SEMQuad
    PROCEDURE,PUBLIC :: Free => Free_SEMQuad
    PROCEDURE,PUBLIC :: GenerateFromMesh => GenerateFromMesh_SEMQuad
    PROCEDURE,PUBLIC :: UpdateHost => UpdateHost_SEMQuad
    PROCEDURE,PUBLIC :: UpdateDevice => UpdateDevice_SEMQuad
    PROCEDURE,PUBLIC :: CalculateMetricTerms => CalculateMetricTerms_SEMQuad
    PROCEDURE,PRIVATE :: CalculateContravariantBasis => CalculateContravariantBasis_SEMQuad

    PROCEDURE :: Write => Write_SEMQuad
    PROCEDURE :: WriteTecplot => WriteTecplot_SEMQuad

  END TYPE SEMQuad

  TYPE,PUBLIC :: SEMHex
    INTEGER :: nElem
    TYPE(Vector3D) :: x ! Physical positions
    TYPE(Tensor3D) :: dxds ! Covariant basis vectors
    TYPE(Tensor3D) :: dsdx ! Contavariant basis vectors
    TYPE(Vector3D) :: nHat ! Normal Vectors pointing across coordinate lines
    TYPE(Scalar3D) :: nScale ! Boundary scale
    TYPE(Scalar3D) :: J ! Jacobian of the transformation

  CONTAINS

    PROCEDURE,PUBLIC :: Init => Init_SEMHex
    PROCEDURE,PUBLIC :: Free => Free_SEMHex
    PROCEDURE,PUBLIC :: GenerateFromMesh => GenerateFromMesh_SEMHex
    PROCEDURE,PUBLIC :: UpdateHost => UpdateHost_SEMHex
    PROCEDURE,PUBLIC :: UpdateDevice => UpdateDevice_SEMHex
    PROCEDURE,PUBLIC :: CalculateMetricTerms => CalculateMetricTerms_SEMHex
    PROCEDURE,PRIVATE :: CalculateContravariantBasis => CalculateContravariantBasis_SEMHex
    PROCEDURE,PRIVATE :: CheckSides => CheckSides_SEMHex

    PROCEDURE :: Write => Write_SEMHex
    PROCEDURE :: WriteTecplot => WriteTecplot_SEMHex

  END TYPE SEMHex

  INTERFACE
    SUBROUTINE CalculateContravariantBasis_SEMQuad_gpu_wrapper(dxds,dsdx,N,nEl) &
      bind(c,name="CalculateContravariantBasis_SEMQuad_gpu_wrapper")
      USE iso_c_binding
      IMPLICIT NONE
      TYPE(c_ptr) :: dxds,dsdx
      INTEGER(C_INT),VALUE :: N,nEl
    END SUBROUTINE CalculateContravariantBasis_SEMQuad_gpu_wrapper
  END INTERFACE

  INTERFACE
    SUBROUTINE AdjustBoundaryContravariantBasis_SEMQuad_gpu_wrapper(dsdx,J,N,nEl) &
      bind(c,name="AdjustBoundaryContravariantBasis_SEMQuad_gpu_wrapper")
      USE iso_c_binding
      IMPLICIT NONE
      TYPE(c_ptr) :: dsdx,J
      INTEGER(C_INT),VALUE :: N,nEl
    END SUBROUTINE AdjustBoundaryContravariantBasis_SEMQuad_gpu_wrapper
  END INTERFACE

  INTERFACE
    SUBROUTINE CalculateContravariantBasis_SEMHex_gpu_wrapper(dxds,dsdx,N,nEl) &
      bind(c,name="CalculateContravariantBasis_SEMHex_gpu_wrapper")
      USE iso_c_binding
      IMPLICIT NONE
      TYPE(c_ptr) :: dxds,dsdx
      INTEGER(C_INT),VALUE :: N,nEl
    END SUBROUTINE CalculateContravariantBasis_SEMHex_gpu_wrapper
  END INTERFACE

  INTERFACE
    SUBROUTINE AdjustBoundaryContravariantBasis_SEMHex_gpu_wrapper(dsdx,J,N,nEl) &
      bind(c,name="AdjustBoundaryContravariantBasis_SEMHex_gpu_wrapper")
      USE iso_c_binding
      IMPLICIT NONE
      TYPE(c_ptr) :: dsdx,J
      INTEGER(C_INT),VALUE :: N,nEl
    END SUBROUTINE AdjustBoundaryContravariantBasis_SEMHex_gpu_wrapper
  END INTERFACE

CONTAINS

  SUBROUTINE Init_Geometry1D(myGeom,interp,nElem)
    IMPLICIT NONE
    CLASS(Geometry1D),INTENT(out) :: myGeom
    TYPE(Lagrange),POINTER,INTENT(in) :: interp
    INTEGER,INTENT(in) :: nElem

    myGeom % nElem = nElem

    CALL myGeom % x % Init(interp=interp,&
                           nVar=1, &
                           nElem=nElem)

    CALL myGeom % dxds % Init(interp=interp,&
                              nVar=1, &
                              nElem=nElem)

  END SUBROUTINE Init_Geometry1D

  SUBROUTINE Free_Geometry1D(myGeom)
    IMPLICIT NONE
    CLASS(Geometry1D),INTENT(inout) :: myGeom

    CALL myGeom % x % Free()
    CALL myGeom % dxds % Free()

  END SUBROUTINE Free_Geometry1D

  SUBROUTINE UpdateHost_Geometry1D(myGeom)
    IMPLICIT NONE
    CLASS(Geometry1D),INTENT(inout) :: myGeom

    CALL myGeom % x % UpdateHost()
    CALL myGeom % dxds % UpdateHost()

  END SUBROUTINE UpdateHost_Geometry1D

  SUBROUTINE UpdateDevice_Geometry1D(myGeom)
    IMPLICIT NONE
    CLASS(Geometry1D),INTENT(inout) :: myGeom

    CALL myGeom % x % UpdateDevice()
    CALL myGeom % dxds % UpdateDevice()

  END SUBROUTINE UpdateDevice_Geometry1D

  SUBROUTINE GenerateFromMesh_Geometry1D(myGeom,mesh)
    ! Generates the geometry for a 1-D mesh ( set of line segments )
    ! Assumes that mesh is using Gauss-Lobatto quadrature and the degree is given by mesh % nGeo
    IMPLICIT NONE
    CLASS(Geometry1D),INTENT(inout) :: myGeom
    TYPE(Mesh1D),INTENT(in) :: mesh
    ! Local
    INTEGER :: iel,i,nid
    TYPE(Lagrange),TARGET :: meshToModel
    TYPE(Scalar1D) :: xMesh

    CALL meshToModel % Init(mesh % nGeo, mesh % quadrature,&
            myGeom % x % interp % N, &
            myGeom % x % interp % controlNodeType )

    CALL xMesh % Init(meshToModel,&
                      1,mesh % nElem)

    ! Set the element internal mesh locations
    nid = 1
    DO iel = 1,mesh % nElem
      DO i = 0,mesh % nGeo
        xMesh % interior % hostData(i,1,iel) = mesh % nodeCoords % hostData(nid)
        nid = nid + 1
      END DO
    END DO

    ! Interpolate from the mesh hopr_nodeCoords to the geometry (Possibly not gauss_lobatto quadrature)
    CALL xMesh % GridInterp(myGeom % x,.FALSE.)

    CALL myGeom % x % BoundaryInterp(gpuAccel=.FALSE.)

    CALL myGeom % CalculateMetricTerms()

    CALL myGeom % UpdateDevice()

    CALL xMesh % Free()

    CALL meshToModel % Free()

  END SUBROUTINE GenerateFromMesh_Geometry1D

  SUBROUTINE CalculateMetricTerms_Geometry1D(myGeom)
    IMPLICIT NONE
    CLASS(Geometry1D),INTENT(inout) :: myGeom

    CALL myGeom % x % Derivative(myGeom % dxds,gpuAccel=.FALSE.)
    CALL myGeom % dxds % BoundaryInterp(gpuAccel=.FALSE.)
    CALL myGeom % UpdateDevice()

  END SUBROUTINE CalculateMetricTerms_Geometry1D

  SUBROUTINE Write_Geometry1D(myGeom,fileName)
    IMPLICIT NONE
    CLASS(Geometry1D),INTENT(in) :: myGeom
    CHARACTER(*),OPTIONAL,INTENT(in) :: fileName
    ! Local
    INTEGER(HID_T) :: fileId
    ! Local
    CHARACTER(LEN=self_FileNameLength) :: pickupFile

    IF( PRESENT(filename) )THEN
      pickupFile = filename
    ELSE
      pickupFile = 'mesh.h5'
    ENDIF

    CALL Open_HDF5(pickupFile,H5F_ACC_TRUNC_F,fileId)

    CALL CreateGroup_HDF5(fileId,'/quadrature')

    CALL WriteArray_HDF5(fileId,'/quadrature/xi', &
                         myGeom % x % interp % controlPoints)

    CALL WriteArray_HDF5(fileId,'/quadrature/weights', &
                         myGeom % x % interp % qWeights)

    CALL WriteArray_HDF5(fileId,'/quadrature/dgmatrix', &
                         myGeom % x % interp % dgMatrix)

    CALL WriteArray_HDF5(fileId,'/quadrature/dmatrix', &
                         myGeom % x % interp % dMatrix)

    CALL CreateGroup_HDF5(fileId,'/mesh')

    CALL CreateGroup_HDF5(fileId,'/mesh/interior')

    CALL CreateGroup_HDF5(fileId,'/mesh/boundary')

    CALL WriteArray_HDF5(fileId,'/mesh/interior/x',myGeom % x % interior)

    CALL WriteArray_HDF5(fileId,'/mesh/interior/dxds',myGeom % dxds % interior)

    CALL WriteArray_HDF5(fileId,'/mesh/boundary/x',myGeom % x % boundary)

    CALL WriteArray_HDF5(fileId,'/mesh/boundary/dxds',myGeom % dxds % boundary)

    CALL Close_HDF5(fileId)

  END SUBROUTINE Write_Geometry1D

  SUBROUTINE WriteTecplot_Geometry1D(myGeom, filename)
    IMPLICIT NONE
    CLASS(Geometry1D), INTENT(inout) :: myGeom
    CHARACTER(*), INTENT(in), OPTIONAL :: filename
    ! Local
    CHARACTER(8) :: zoneID
    INTEGER :: fUnit
    INTEGER :: iEl, i
    CHARACTER(LEN=self_FileNameLength) :: tecFile

    IF( PRESENT(filename) )THEN
      tecFile = filename
    ELSE
      tecFile = 'mesh.tec'
    ENDIF

    ! Let's write some tecplot!!
     OPEN( UNIT=NEWUNIT(fUnit), &
      FILE= TRIM(tecFile), &
      FORM='formatted', &
      STATUS='replace')

    ! TO DO :: Create header from solution metadata
    WRITE(fUnit,*) 'VARIABLES = "x","dxds"'

    DO iEl = 1, myGeom % x % nElem

      ! TO DO :: Get the global element ID
      WRITE(zoneID,'(I8.8)') iEl
      WRITE(fUnit,*) 'ZONE T="el'//trim(zoneID)//'", I=',myGeom % x % interp % N+1

      DO i = 0, myGeom % x % interp % N

        WRITE(fUnit,'(2(E15.7,1x))') myGeom % x % interior % hostData(i,1,iEl), &
                                     myGeom % dxds % interior % hostData(i,1,iEl)

      ENDDO

    ENDDO

    CLOSE(UNIT=fUnit)

  END SUBROUTINE WriteTecplot_Geometry1D

  SUBROUTINE Init_SEMQuad(myGeom,interp,nElem)
    IMPLICIT NONE
    CLASS(SEMQuad),INTENT(out) :: myGeom
    TYPE(Lagrange),POINTER,INTENT(in) :: interp
    INTEGER,INTENT(in) :: nElem

    myGeom % nElem = nElem

    CALL myGeom % x % Init(interp=interp,&
                           nVar=1, &
                           nElem=nElem)

    CALL myGeom % dxds % Init(interp=interp,&
                              nVar=1, &
                              nElem=nElem)

    CALL myGeom % dsdx % Init(interp=interp,&
                              nVar=1, &
                              nElem=nElem)

    CALL myGeom % nHat % Init(interp=interp,&
                              nVar=1, &
                              nElem=nElem)

    CALL myGeom % nScale % Init(interp=interp,&
                              nVar=1, &
                              nElem=nElem)

    CALL myGeom % J % Init(interp=interp,&
                           nVar=1, &
                           nElem=nElem)

  END SUBROUTINE Init_SEMQuad

  SUBROUTINE Free_SEMQuad(myGeom)
    IMPLICIT NONE
    CLASS(SEMQuad),INTENT(inout) :: myGeom

    CALL myGeom % x % Free()
    CALL myGeom % dxds % Free()
    CALL myGeom % dsdx % Free()
    CALL myGeom % nHat % Free()
    CALL myGeom % nScale % Free()
    CALL myGeom % J % Free()

  END SUBROUTINE Free_SEMQuad

  SUBROUTINE UpdateHost_SEMQuad(myGeom)
    IMPLICIT NONE
    CLASS(SEMQuad),INTENT(inout) :: myGeom

    CALL myGeom % x % UpdateHost()
    CALL myGeom % dxds % UpdateHost()
    CALL myGeom % dsdx % UpdateHost()
    CALL myGeom % nHat % UpdateHost()
    CALL myGeom % nScale % UpdateHost()
    CALL myGeom % J % UpdateHost()

  END SUBROUTINE UpdateHost_SEMQuad

  SUBROUTINE UpdateDevice_SEMQuad(myGeom)
    IMPLICIT NONE
    CLASS(SEMQuad),INTENT(inout) :: myGeom

    CALL myGeom % x % UpdateDevice()
    CALL myGeom % dxds % UpdateDevice()
    CALL myGeom % dsdx % UpdateDevice()
    CALL myGeom % nHat % UpdateDevice()
    CALL myGeom % nScale % UpdateDevice()
    CALL myGeom % J % UpdateDevice()

  END SUBROUTINE UpdateDevice_SEMQuad

  SUBROUTINE GenerateFromMesh_SEMQuad(myGeom,mesh)
    IMPLICIT NONE
    CLASS(SEMQuad),INTENT(inout) :: myGeom
    TYPE(Mesh2D),INTENT(in) :: mesh
    ! Local
    INTEGER :: iel
    INTEGER :: i,j,nid
    TYPE(Lagrange),TARGET :: meshToModel
    TYPE(Vector2D) :: xMesh

    CALL meshToModel % Init(mesh % nGeo, &
            mesh % quadrature, &
            myGeom % x % interp % N, &
            myGeom % x % interp % controlNodeType )

    CALL xMesh % Init(meshToModel,1,mesh % nElem)

    ! Set the element internal mesh locations
    DO iel = 1, mesh % nElem
      DO j = 0, mesh % nGeo
        DO i = 0, mesh % nGeo
          xMesh % interior % hostData(1:2,i,j,1,iel) = mesh % nodeCoords % hostData(1:2,i,j,iel)
        END DO
      END DO
    END DO

    !IF (GPUAvailable()) THEN
    !  CALL xMesh % UpdateDevice()
    !  CALL xMesh % GridInterp(myGeom % x,.TRUE.)
    !  CALL myGeom % x % BoundaryInterp(gpuAccel=.TRUE.)
    !  CALL myGeom % CalculateMetricTerms()
    !  CALL myGeom % UpdateHost()
    !ELSE
      CALL xMesh % GridInterp(myGeom % x,.FALSE.)
      CALL myGeom % x % BoundaryInterp(gpuAccel=.FALSE.)
      CALL myGeom % CalculateMetricTerms()
    !END IF

    CALL myGeom % UpdateDevice()
    CALL xMesh % Free()
    CALL meshToModel % Free()

  END SUBROUTINE GenerateFromMesh_SEMQuad

  SUBROUTINE CalculateContravariantBasis_SEMQuad(myGeom)
    IMPLICIT NONE
    CLASS(SEMQuad),INTENT(inout) :: myGeom
    ! Local
    INTEGER :: iEl,i,j,k
    REAL(prec) :: fac
    REAL(prec) :: mag

    ! Now calculate the contravariant basis vectors
    ! In this convention, dsdx(j,i) is contravariant vector i, component j
    ! To project onto contravariant vector i, dot vector along the first dimension
    DO iEl = 1,myGeom % nElem
      DO j = 0,myGeom % dxds % interp % N
        DO i = 0,myGeom % dxds % interp % N

          myGeom % dsdx % interior % hostData(1,1,i,j,1,iEl) = myGeom % dxds % interior % hostData(2,2,i,j,1,iEl)
          myGeom % dsdx % interior % hostData(2,1,i,j,1,iEl) = -myGeom % dxds % interior % hostData(1,2,i,j,1,iEl)
          myGeom % dsdx % interior % hostData(1,2,i,j,1,iEl) = -myGeom % dxds % interior % hostData(2,1,i,j,1,iEl)
          myGeom % dsdx % interior % hostData(2,2,i,j,1,iEl) = myGeom % dxds % interior % hostData(1,1,i,j,1,iEl)

        END DO
      END DO
    END DO

    ! Interpolate the contravariant tensor to the boundaries
    CALL myGeom % dsdx % BoundaryInterp(gpuAccel=.FALSE.)

    ! Now, modify the sign of dsdx so that
    ! myGeom % dsdx % boundary is equal to the outward pointing normal vector
    DO iEl = 1,myGeom % nElem
      DO k = 1,4
        DO i = 0,myGeom % J % interp % N
          IF (k == selfSide2D_East .OR. k == selfSide2D_North) THEN
            fac = SIGN(1.0_prec,myGeom % J % boundary % hostData(i,1,k,iEl))
          ELSE
            fac = -SIGN(1.0_prec,myGeom % J % boundary % hostData(i,1,k,iEl))
          END IF

          IF( k == 1 )THEN ! South

            mag = SQRT( myGeom % dsdx % boundary % hostData(1,2,i,1,k,iEl)**2 +&
                        myGeom % dsdx % boundary % hostData(2,2,i,1,k,iEl)**2 )

            myGeom % nScale % boundary % hostData(i,1,k,iEl) = mag

            myGeom % nHat % boundary % hostData(1:2,i,1,k,iEl) = &
              fac*myGeom % dsdx % boundary % hostData(1:2,2,i,1,k,iEl)/mag

          ELSEIF( k == 2 )THEN ! East

            mag = SQRT( myGeom % dsdx % boundary % hostData(1,1,i,1,k,iEl)**2 +&
                        myGeom % dsdx % boundary % hostData(2,1,i,1,k,iEl)**2 )

            myGeom % nScale % boundary % hostData(i,1,k,iEl) = mag

            myGeom % nHat % boundary % hostData(1:2,i,1,k,iEl) = &
              fac*myGeom % dsdx % boundary % hostData(1:2,1,i,1,k,iEl)/mag

          ELSEIF( k == 3 )THEN ! North

            mag = SQRT( myGeom % dsdx % boundary % hostData(1,2,i,1,k,iEl)**2 +&
                        myGeom % dsdx % boundary % hostData(2,2,i,1,k,iEl)**2 )

            myGeom % nScale % boundary % hostData(i,1,k,iEl) = mag

            myGeom % nHat % boundary % hostData(1:2,i,1,k,iEl) = &
              fac*myGeom % dsdx % boundary % hostData(1:2,2,i,1,k,iEl)/mag

          ELSEIF( k == 4 )THEN ! West

            mag = SQRT( myGeom % dsdx % boundary % hostData(1,1,i,1,k,iEl)**2 +&
                        myGeom % dsdx % boundary % hostData(2,1,i,1,k,iEl)**2 )

            myGeom % nScale % boundary % hostData(i,1,k,iEl) = mag

            myGeom % nHat % boundary % hostData(1:2,i,1,k,iEl) = &
              fac*myGeom % dsdx % boundary % hostData(1:2,1,i,1,k,iEl)/mag

          ENDIF

          ! Set the directionality for dsdx on the boundaries
          myGeom % dsdx % boundary % hostData(1:2,1:2,i,1,k,iEl) = &
              myGeom % dsdx % boundary % hostData(1:2,1:2,i,1,k,iEl)*fac

        END DO
      END DO
    END DO

  END SUBROUTINE CalculateContravariantBasis_SEMQuad

  SUBROUTINE CalculateMetricTerms_SEMQuad(myGeom)
    IMPLICIT NONE
    CLASS(SEMQuad),INTENT(inout) :: myGeom

!    IF (GPUAvailable()) THEN
!      CALL myGeom % x % Gradient(myGeom % dxds,gpuAccel=.TRUE.)
!      CALL myGeom % dxds % BoundaryInterp(gpuAccel=.TRUE.)
!      CALL myGeom % dxds % Determinant(myGeom % J,gpuAccel=.TRUE.)
!      CALL myGeom % J % BoundaryInterp(gpuAccel=.TRUE.)
!      CALL myGeom % UpdateHost()
!    ELSE
      CALL myGeom % x % Gradient(myGeom % dxds,gpuAccel=.FALSE.)
      CALL myGeom % dxds % BoundaryInterp(gpuAccel=.FALSE.)
      CALL myGeom % dxds % Determinant(myGeom % J,gpuAccel=.FALSE.)
      CALL myGeom % J % BoundaryInterp(gpuAccel=.FALSE.)
!    END IF

    CALL myGeom % CalculateContravariantBasis()
    IF (GPUAvailable()) THEN
      CALL myGeom % dsdx % UpdateDevice()
      CALL myGeom % nHat % UpdateDevice()
      CALL myGeom % nScale % UpdateDevice()
    ENDIF

  END SUBROUTINE CalculateMetricTerms_SEMQuad

  SUBROUTINE Write_SEMQuad(myGeom,fileName)
    IMPLICIT NONE
    CLASS(SEMQuad),INTENT(in) :: myGeom
    CHARACTER(*),OPTIONAL,INTENT(in) :: fileName
    ! Local
    INTEGER(HID_T) :: fileId
    ! Local
    CHARACTER(LEN=self_FileNameLength) :: pickupFile

    IF( PRESENT(filename) )THEN
      pickupFile = filename
    ELSE
      pickupFile = 'mesh.h5'
    ENDIF

    CALL Open_HDF5(pickupFile,H5F_ACC_TRUNC_F,fileId)

    CALL CreateGroup_HDF5(fileId,'/quadrature')

    CALL WriteArray_HDF5(fileId,'/quadrature/xi', &
                         myGeom % x % interp % controlPoints)

    CALL WriteArray_HDF5(fileId,'/quadrature/weights', &
                         myGeom % x % interp % qWeights)

    CALL WriteArray_HDF5(fileId,'/quadrature/dgmatrix', &
                         myGeom % x % interp % dgMatrix)

    CALL WriteArray_HDF5(fileId,'/quadrature/dmatrix', &
                         myGeom % x % interp % dMatrix)

    CALL CreateGroup_HDF5(fileId,'/mesh')

    CALL CreateGroup_HDF5(fileId,'/mesh/interior')

    CALL CreateGroup_HDF5(fileId,'/mesh/boundary')

    CALL WriteArray_HDF5(fileId,'/mesh/interior/x',myGeom % x % interior)

    CALL WriteArray_HDF5(fileId,'/mesh/interior/dxds',myGeom % dxds % interior)

    CALL WriteArray_HDF5(fileId,'/mesh/interior/dsdx',myGeom % dsdx % interior)

    CALL WriteArray_HDF5(fileId,'/mesh/interior/J',myGeom % J % interior)

    CALL WriteArray_HDF5(fileId,'/mesh/boundary/x',myGeom % x % boundary)

    CALL WriteArray_HDF5(fileId,'/mesh/boundary/dxds',myGeom % dxds % boundary)

    CALL WriteArray_HDF5(fileId,'/mesh/boundary/dsdx',myGeom % dsdx % boundary)

    CALL WriteArray_HDF5(fileId,'/mesh/boundary/nHat',myGeom % nHat % boundary)

    CALL WriteArray_HDF5(fileId,'/mesh/boundary/nScale',myGeom % nScale % boundary)

    CALL WriteArray_HDF5(fileId,'/mesh/boundary/J',myGeom % J % boundary)

    CALL Close_HDF5(fileId)

  END SUBROUTINE Write_SEMQuad

  SUBROUTINE WriteTecplot_SEMQuad(myGeom, filename)
    IMPLICIT NONE
    CLASS(SEMQuad), INTENT(inout) :: myGeom
    CHARACTER(*), INTENT(in), OPTIONAL :: filename
    ! Local
    CHARACTER(8) :: zoneID
    INTEGER :: fUnit
    INTEGER :: iEl, i, j
    CHARACTER(LEN=self_FileNameLength) :: tecFile

    IF( PRESENT(filename) )THEN
      tecFile = filename
    ELSE
      tecFile = 'mesh.tec'
    ENDIF

     OPEN( UNIT=NEWUNIT(fUnit), &
      FILE= TRIM(tecFile), &
      FORM='formatted', &
      STATUS='replace')

    ! TO DO :: Create header from solution metadata
    WRITE(fUnit,*) 'VARIABLES = "X","Y",'//&
                   '"dxds1","dxds2",'//&
                   '"dyds1","dyds2",'//&
                   '"ds1dx","ds1dy",'//&
                   '"ds2dx","ds2dy",'//&
                   '"Jacobian"'

    DO iEl = 1, myGeom % x % nElem

      ! TO DO :: Get the global element ID
      WRITE(zoneID,'(I8.8)') iEl
      WRITE(fUnit,*) 'ZONE T="el'//trim(zoneID)//'", I=',myGeom % x % interp % N+1,&
                                                 ', J=',myGeom % x % interp % N+1

      DO j = 0, myGeom % x % interp % N
        DO i = 0, myGeom % x % interp % N

          WRITE(fUnit,'(11(E15.7,1x))') myGeom % x % interior % hostData(1,i,j,1,iEl), &
                                       myGeom % x % interior % hostData(2,i,j,1,iEl), &
                                       myGeom % dxds % interior % hostData(1,1,i,j,1,iEl), &
                                       myGeom % dxds % interior % hostData(1,2,i,j,1,iEl), &
                                       myGeom % dxds % interior % hostData(2,1,i,j,1,iEl), &
                                       myGeom % dxds % interior % hostData(2,2,i,j,1,iEl), &
                                       myGeom % dsdx % interior % hostData(1,1,i,j,1,iEl), &
                                       myGeom % dsdx % interior % hostData(2,1,i,j,1,iEl), &
                                       myGeom % dsdx % interior % hostData(1,2,i,j,1,iEl), &
                                       myGeom % dsdx % interior % hostData(2,2,i,j,1,iEl), &
                                       myGeom % J % interior % hostData(i,j,1,iEl)
        ENDDO
      ENDDO

    ENDDO

    CLOSE(UNIT=fUnit)

  END SUBROUTINE WriteTecplot_SEMQuad

  SUBROUTINE Init_SEMHex(myGeom,interp,nElem)
    IMPLICIT NONE
    CLASS(SEMHex),INTENT(out) :: myGeom
    TYPE(Lagrange),POINTER,INTENT(in) :: interp
    INTEGER,INTENT(in) :: nElem

    myGeom % nElem = nElem

    CALL myGeom % x % Init(interp=interp,&
                           nVar=1, &
                           nElem=nElem)

    CALL myGeom % dxds % Init(interp=interp,&
                              nVar=1, &
                              nElem=nElem)

    CALL myGeom % dsdx % Init(interp=interp,&
                              nVar=1, &
                              nElem=nElem)

    CALL myGeom % nHat % Init(interp=interp,&
                              nVar=1, &
                              nElem=nElem)

    CALL myGeom % nScale % Init(interp=interp,&
                              nVar=1, &
                              nElem=nElem)

    CALL myGeom % J % Init(interp=interp,&
                           nVar=1, &
                           nElem=nElem)

  END SUBROUTINE Init_SEMHex

  SUBROUTINE Free_SEMHex(myGeom)
    IMPLICIT NONE
    CLASS(SEMHex),INTENT(inout) :: myGeom

    CALL myGeom % x % Free()
    CALL myGeom % dxds % Free()
    CALL myGeom % dsdx % Free()
    CALL myGeom % nHat % Free()
    CALL myGeom % nScale % Free()
    CALL myGeom % J % Free()

  END SUBROUTINE Free_SEMHex

  SUBROUTINE UpdateHost_SEMHex(myGeom)
    IMPLICIT NONE
    CLASS(SEMHex),INTENT(inout) :: myGeom

    CALL myGeom % x % UpdateHost()
    CALL myGeom % dxds % UpdateHost()
    CALL myGeom % dsdx % UpdateHost()
    CALL myGeom % nHat % UpdateHost()
    CALL myGeom % nScale % UpdateHost()
    CALL myGeom % J % UpdateHost()

  END SUBROUTINE UpdateHost_SEMHex

  SUBROUTINE UpdateDevice_SEMHex(myGeom)
    IMPLICIT NONE
    CLASS(SEMHex),INTENT(inout) :: myGeom

    CALL myGeom % x % UpdateDevice()
    CALL myGeom % dxds % UpdateDevice()
    CALL myGeom % dsdx % UpdateDevice()
    CALL myGeom % nHat % UpdateDevice()
    CALL myGeom % nScale % UpdateDevice()
    CALL myGeom % J % UpdateDevice()

  END SUBROUTINE UpdateDevice_SEMHex

  SUBROUTINE GenerateFromMesh_SEMHex(myGeom,mesh)
    IMPLICIT NONE
    CLASS(SEMHex),INTENT(inout) :: myGeom
    TYPE(Mesh3D),INTENT(in) :: mesh
    ! Local
    INTEGER :: iel
    INTEGER :: i,j,k,nid
    TYPE(Lagrange),TARGET :: meshToModel
    TYPE(Vector3D) :: xMesh

    CALL meshToModel % Init(mesh % nGeo, mesh % quadrature,&
            myGeom % x % interp % N, &
            myGeom % x % interp % controlNodeType )

    CALL xMesh % Init(meshToModel,&
                      1,mesh % nElem)

    ! Set the element internal mesh locations
    DO iel = 1,mesh % nElem
      DO k = 0,mesh % nGeo
        DO j = 0,mesh % nGeo
          DO i = 0,mesh % nGeo
            xMesh % interior % hostData(1:3,i,j,k,1,iel) = mesh % nodeCoords % hostData(1:3,i,j,k,iel)
          END DO
        END DO
      END DO
    END DO

    ! Interpolate from the mesh hopr_nodeCoords to the geometry (Possibly not gauss_lobatto quadrature)
    !IF (GPUAvailable()) THEN
    !  CALL xMesh % UpdateDevice()
    !  CALL xMesh % GridInterp(myGeom % x,.TRUE.)
    !  CALL myGeom % x % BoundaryInterp(gpuAccel=.TRUE.)
    !  CALL myGeom % CalculateMetricTerms()
    !  CALL myGeom % UpdateHost()
    !ELSE
      CALL xMesh % GridInterp(myGeom % x,.FALSE.)
      CALL myGeom % x % BoundaryInterp(gpuAccel=.FALSE.)
      CALL myGeom % CalculateMetricTerms()
    !END IF
!    CALL myGeom % CheckSides(mesh)

    CALL myGeom % UpdateDevice()
    CALL xMesh % Free()
    CALL meshToModel % Free()

  END SUBROUTINE GenerateFromMesh_SEMHex

  SUBROUTINE CheckSides_SEMHex(myGeom,mesh)
    IMPLICIT NONE
    CLASS(SEMHex),INTENT(in) :: myGeom
    TYPE(Mesh3D),INTENT(in) :: mesh
    !
    INTEGER :: e1, s1
    INTEGER :: e2, s2
    INTEGER :: i1, j1
    INTEGER :: i2, j2
    INTEGER :: flip, bcid
    REAL(prec) :: rms

      DO e1 = 1,mesh % nElem
        DO s1 = 1,6

          e2 = mesh % sideInfo % hostData(3,s1,e1)
          s2 = mesh % sideInfo % hostData(4,s1,e1)/10
          flip = mesh % sideInfo % hostData(4,s1,e1) - s2*10
          bcid = mesh % sideInfo % hostData(5,s1,e1)

          IF (bcid == 0) THEN ! Interior

            rms = 0.0_prec

            IF (flip == 0) THEN

                DO j1 = 0,myGeom % x % interp % N
                  DO i1 = 0,myGeom % x % interp % N
                    rms = rms + &
                          sqrt( (myGeom % x % boundary % hostdata(1,i1,j1,1,s1,e1)-&
                                 myGeom % x % boundary % hostdata(1,i1,j1,1,s2,e2))**2+&
                                (myGeom % x % boundary % hostdata(2,i1,j1,1,s1,e1)-&
                                 myGeom % x % boundary % hostdata(2,i1,j1,1,s2,e2))**2+&
                                (myGeom % x % boundary % hostdata(3,i1,j1,1,s1,e1)-&
                                 myGeom % x % boundary % hostdata(3,i1,j1,1,s2,e2))**2 )
                  END DO
                END DO

            ELSEIF (flip == 1) THEN

                DO j1 = 0,myGeom % x % interp % N
                  DO i1 = 0,myGeom % x % interp % N
                    i2 = j1
                    j2 = myGeom % x % interp % N - i1
                    rms = rms + &
                          sqrt( (myGeom % x % boundary % hostdata(1,i1,j1,1,s1,e1)-&
                                 myGeom % x % boundary % hostdata(1,i2,j2,1,s2,e2))**2+&
                                (myGeom % x % boundary % hostdata(2,i1,j1,1,s1,e1)-&
                                 myGeom % x % boundary % hostdata(2,i2,j2,1,s2,e2))**2+&
                                (myGeom % x % boundary % hostdata(3,i1,j1,1,s1,e1)-&
                                 myGeom % x % boundary % hostdata(3,i2,j2,1,s2,e2))**2 )
                  END DO
                END DO

            ELSEIF (flip == 2) THEN

                DO j1 = 0,myGeom % x % interp % N
                  DO i1 = 0,myGeom % x % interp % N
                    i2 = myGeom % x % interp % N - i1
                    j2 = myGeom % x % interp % N - j1
                    rms = rms + &
                          sqrt( (myGeom % x % boundary % hostdata(1,i1,j1,1,s1,e1)-&
                                 myGeom % x % boundary % hostdata(1,i2,j2,1,s2,e2))**2+&
                                (myGeom % x % boundary % hostdata(2,i1,j1,1,s1,e1)-&
                                 myGeom % x % boundary % hostdata(2,i2,j2,1,s2,e2))**2+&
                                (myGeom % x % boundary % hostdata(3,i1,j1,1,s1,e1)-&
                                 myGeom % x % boundary % hostdata(3,i2,j2,1,s2,e2))**2 )
                  END DO
                END DO

            ELSEIF (flip == 3) THEN

                DO j1 = 0,myGeom % x % interp % N
                  DO i1 = 0,myGeom % x % interp % N
                    i2 = myGeom % x % interp % N - j1
                    j2 = i1
                    rms = rms + &
                          sqrt( (myGeom % x % boundary % hostdata(1,i1,j1,1,s1,e1)-&
                                 myGeom % x % boundary % hostdata(1,i2,j2,1,s2,e2))**2+&
                                (myGeom % x % boundary % hostdata(2,i1,j1,1,s1,e1)-&
                                 myGeom % x % boundary % hostdata(2,i2,j2,1,s2,e2))**2+&
                                (myGeom % x % boundary % hostdata(3,i1,j1,1,s1,e1)-&
                                 myGeom % x % boundary % hostdata(3,i2,j2,1,s2,e2))**2 )
                  END DO
                END DO

            ELSEIF (flip == 4) THEN

                DO j1 = 0,myGeom % x % interp % N
                  DO i1 = 0,myGeom % x % interp % N
                    i2 = j1
                    j2 = i1
                    rms = rms + &
                          sqrt( (myGeom % x % boundary % hostdata(1,i1,j1,1,s1,e1)-&
                                 myGeom % x % boundary % hostdata(1,i2,j2,1,s2,e2))**2+&
                                (myGeom % x % boundary % hostdata(2,i1,j1,1,s1,e1)-&
                                 myGeom % x % boundary % hostdata(2,i2,j2,1,s2,e2))**2+&
                                (myGeom % x % boundary % hostdata(3,i1,j1,1,s1,e1)-&
                                 myGeom % x % boundary % hostdata(3,i2,j2,1,s2,e2))**2 )
                  END DO
                END DO
            END IF

          END IF

        END DO
      END DO

  END SUBROUTINE CheckSides_SEMHex

  SUBROUTINE CalculateContravariantBasis_SEMHex(myGeom)
    IMPLICIT NONE
    CLASS(SEMHex),INTENT(inout) :: myGeom
    ! Local
    INTEGER :: iEl,i,j,k
    REAL(prec) :: fac
    REAL(prec) :: mag

    ! Now calculate the contravariant basis vectors
    ! In this convention, dsdx(j,i) is contravariant vector i, component j
    ! To project onto contravariant vector i, dot vector along the first dimension
    ! TO DO : Curl Invariant Form
    DO iEl = 1,myGeom % nElem
      DO k = 0,myGeom % dxds % interp % N
        DO j = 0,myGeom % dxds % interp % N
          DO i = 0,myGeom % dxds % interp % N

            ! Ja1
            myGeom % dsdx % interior % hostData(1,1,i,j,k,1,iEl) = &
              myGeom % dxds % interior % hostData(2,2,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(3,3,i,j,k,1,iEl) - &
              myGeom % dxds % interior % hostData(3,2,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(2,3,i,j,k,1,iEl)

            myGeom % dsdx % interior % hostData(2,1,i,j,k,1,iEl) = &
              myGeom % dxds % interior % hostData(1,3,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(3,2,i,j,k,1,iEl) - &
              myGeom % dxds % interior % hostData(3,3,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(1,2,i,j,k,1,iEl)

            myGeom % dsdx % interior % hostData(3,1,i,j,k,1,iEl) = &
              myGeom % dxds % interior % hostData(1,2,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(2,3,i,j,k,1,iEl) - &
              myGeom % dxds % interior % hostData(2,2,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(1,3,i,j,k,1,iEl)

            ! Ja2
            myGeom % dsdx % interior % hostData(1,2,i,j,k,1,iEl) = &
              myGeom % dxds % interior % hostData(2,3,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(3,1,i,j,k,1,iEl) - &
              myGeom % dxds % interior % hostData(3,3,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(2,1,i,j,k,1,iEl)

            myGeom % dsdx % interior % hostData(2,2,i,j,k,1,iEl) = &
              myGeom % dxds % interior % hostData(1,1,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(3,3,i,j,k,1,iEl) - &
              myGeom % dxds % interior % hostData(3,1,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(1,3,i,j,k,1,iEl)

            myGeom % dsdx % interior % hostData(3,2,i,j,k,1,iEl) = &
              myGeom % dxds % interior % hostData(1,3,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(2,1,i,j,k,1,iEl) - &
              myGeom % dxds % interior % hostData(2,3,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(1,1,i,j,k,1,iEl)

            ! Ja3
            myGeom % dsdx % interior % hostData(1,3,i,j,k,1,iEl) = &
              myGeom % dxds % interior % hostData(2,1,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(3,2,i,j,k,1,iEl) - &
              myGeom % dxds % interior % hostData(3,1,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(2,2,i,j,k,1,iEl)

            myGeom % dsdx % interior % hostData(2,3,i,j,k,1,iEl) = &
              myGeom % dxds % interior % hostData(1,2,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(3,1,i,j,k,1,iEl) - &
              myGeom % dxds % interior % hostData(3,2,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(1,1,i,j,k,1,iEl)

            myGeom % dsdx % interior % hostData(3,3,i,j,k,1,iEl) = &
              myGeom % dxds % interior % hostData(1,1,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(2,2,i,j,k,1,iEl) - &
              myGeom % dxds % interior % hostData(2,1,i,j,k,1,iEl)* &
              myGeom % dxds % interior % hostData(1,2,i,j,k,1,iEl)

          END DO
        END DO
      END DO
    END DO

    ! Interpolate the contravariant tensor to the boundaries
    CALL myGeom % dsdx % BoundaryInterp(gpuAccel=.FALSE.)

    ! Now, calculate nHat (outward pointing normal)
    DO iEl = 1,myGeom % nElem
      DO k = 1,6
        DO j = 0,myGeom % J % interp % N
          DO i = 0,myGeom % J % interp % N
            IF (k == selfSide3D_Top .OR. k == selfSide3D_East .OR. k == selfSide3D_North) THEN
              fac = SIGN(1.0_prec,myGeom % J % boundary % hostData(i,j,1,k,iEl))
            ELSE
              fac = -SIGN(1.0_prec,myGeom % J % boundary % hostData(i,j,1,k,iEl))
            END IF

            IF( k == 1 )THEN ! Bottom

              mag = SQRT( myGeom % dsdx % boundary % hostData(1,3,i,j,1,k,iEl)**2 +&
                          myGeom % dsdx % boundary % hostData(2,3,i,j,1,k,iEl)**2 +&
                          myGeom % dsdx % boundary % hostData(3,3,i,j,1,k,iEl)**2 )

              myGeom % nScale % boundary % hostData(i,j,1,k,iEl) = mag

              myGeom % nHat % boundary % hostData(1:3,i,j,1,k,iEl) = &
                fac*myGeom % dsdx % boundary % hostData(1:3,3,i,j,1,k,iEl)/mag

            ELSEIF( k == 2 )THEN  ! South

              mag = SQRT( myGeom % dsdx % boundary % hostData(1,2,i,j,1,k,iEl)**2 +&
                          myGeom % dsdx % boundary % hostData(2,2,i,j,1,k,iEl)**2 +&
                          myGeom % dsdx % boundary % hostData(3,2,i,j,1,k,iEl)**2 )

              myGeom % nScale % boundary % hostData(i,j,1,k,iEl) = mag

              myGeom % nHat % boundary % hostData(1:3,i,j,1,k,iEl) = &
                fac*myGeom % dsdx % boundary % hostData(1:3,2,i,j,1,k,iEl)/mag

            ELSEIF( k == 3 )THEN  ! East

              mag = SQRT( myGeom % dsdx % boundary % hostData(1,1,i,j,1,k,iEl)**2 +&
                          myGeom % dsdx % boundary % hostData(2,1,i,j,1,k,iEl)**2 +&
                          myGeom % dsdx % boundary % hostData(3,1,i,j,1,k,iEl)**2 )

              myGeom % nScale % boundary % hostData(i,j,1,k,iEl) = mag

              myGeom % nHat % boundary % hostData(1:3,i,j,1,k,iEl) = &
                fac*myGeom % dsdx % boundary % hostData(1:3,1,i,j,1,k,iEl)/mag

            ELSEIF( k == 4 )THEN  ! North

              mag = SQRT( myGeom % dsdx % boundary % hostData(1,2,i,j,1,k,iEl)**2 +&
                          myGeom % dsdx % boundary % hostData(2,2,i,j,1,k,iEl)**2 +&
                          myGeom % dsdx % boundary % hostData(3,2,i,j,1,k,iEl)**2 )

              myGeom % nScale % boundary % hostData(i,j,1,k,iEl) = mag

              myGeom % nHat % boundary % hostData(1:3,i,j,1,k,iEl) = &
                fac*myGeom % dsdx % boundary % hostData(1:3,2,i,j,1,k,iEl)/mag

            ELSEIF( k == 5 )THEN  ! West

              mag = SQRT( myGeom % dsdx % boundary % hostData(1,1,i,j,1,k,iEl)**2 +&
                          myGeom % dsdx % boundary % hostData(2,1,i,j,1,k,iEl)**2 +&
                          myGeom % dsdx % boundary % hostData(3,1,i,j,1,k,iEl)**2 )

              myGeom % nScale % boundary % hostData(i,j,1,k,iEl) = mag

              myGeom % nHat % boundary % hostData(1:3,i,j,1,k,iEl) = &
                fac*myGeom % dsdx % boundary % hostData(1:3,1,i,j,1,k,iEl)/mag

            ELSEIF( k == 6 )THEN  ! Top

              mag = SQRT( myGeom % dsdx % boundary % hostData(1,3,i,j,1,k,iEl)**2 +&
                          myGeom % dsdx % boundary % hostData(2,3,i,j,1,k,iEl)**2 +&
                          myGeom % dsdx % boundary % hostData(3,3,i,j,1,k,iEl)**2 )

              myGeom % nScale % boundary % hostData(i,j,1,k,iEl) = mag

              myGeom % nHat % boundary % hostData(1:3,i,j,1,k,iEl) = &
                fac*myGeom % dsdx % boundary % hostData(1:3,3,i,j,1,k,iEl)/mag

            ENDIF

            ! Set the directionality for dsdx on the boundaries
            ! This is primarily used for DG gradient calculations,
            ! which do not use nHat for the boundary terms.
            myGeom % dsdx % boundary % hostData(1:3,1:3,i,j,1,k,iEl) = &
                myGeom % dsdx % boundary % hostData(1:3,1:3,i,j,1,k,iEl)*fac

          END DO
        END DO
      END DO
    END DO

  END SUBROUTINE CalculateContravariantBasis_SEMHex

  SUBROUTINE CalculateMetricTerms_SEMHex(myGeom)
    IMPLICIT NONE
    CLASS(SEMHex),INTENT(inout) :: myGeom

    !IF (GPUAvailable()) THEN
    !  CALL myGeom % x % Gradient(myGeom % dxds,gpuAccel=.TRUE.)
    !  CALL myGeom % dxds % BoundaryInterp(gpuAccel=.TRUE.)
    !  CALL myGeom % dxds % Determinant(myGeom % J,gpuAccel=.TRUE.)
    !  CALL myGeom % J % BoundaryInterp(gpuAccel=.TRUE.)
    !  CALL myGeom % UpdateHost()
    !ELSE
      CALL myGeom % x % Gradient(myGeom % dxds,gpuAccel=.FALSE.)
      CALL myGeom % dxds % BoundaryInterp(gpuAccel=.FALSE.)
      CALL myGeom % dxds % Determinant(myGeom % J,gpuAccel=.FALSE.)
      CALL myGeom % J % BoundaryInterp(gpuAccel=.FALSE.)
    !END IF

    CALL myGeom % CalculateContravariantBasis()
    IF (GPUAvailable()) THEN
      CALL myGeom % UpdateDevice()
    ENDIF

  END SUBROUTINE CalculateMetricTerms_SEMHex

  SUBROUTINE Write_SEMHex(myGeom,fileName)
    IMPLICIT NONE
    CLASS(SEMHex),INTENT(in) :: myGeom
    CHARACTER(*),OPTIONAL,INTENT(in) :: fileName
    ! Local
    INTEGER(HID_T) :: fileId
    ! Local
    CHARACTER(LEN=self_FileNameLength) :: pickupFile

    IF( PRESENT(filename) )THEN
      pickupFile = filename
    ELSE
      pickupFile = 'mesh.h5'
    ENDIF

    CALL Open_HDF5(pickupFile,H5F_ACC_TRUNC_F,fileId)

    CALL CreateGroup_HDF5(fileId,'/quadrature')

    CALL WriteArray_HDF5(fileId,'/quadrature/xi', &
                         myGeom % x % interp % controlPoints)

    CALL WriteArray_HDF5(fileId,'/quadrature/weights', &
                         myGeom % x % interp % qWeights)

    CALL WriteArray_HDF5(fileId,'/quadrature/dgmatrix', &
                         myGeom % x % interp % dgMatrix)

    CALL WriteArray_HDF5(fileId,'/quadrature/dmatrix', &
                         myGeom % x % interp % dMatrix)

    CALL CreateGroup_HDF5(fileId,'/mesh')

    CALL CreateGroup_HDF5(fileId,'/mesh/interior')

    CALL CreateGroup_HDF5(fileId,'/mesh/boundary')

    CALL WriteArray_HDF5(fileId,'/mesh/interior/x',myGeom % x % interior)

    CALL WriteArray_HDF5(fileId,'/mesh/interior/dxds',myGeom % dxds % interior)

    CALL WriteArray_HDF5(fileId,'/mesh/interior/dsdx',myGeom % dsdx % interior)

    CALL WriteArray_HDF5(fileId,'/mesh/interior/J',myGeom % J % interior)

    CALL WriteArray_HDF5(fileId,'/mesh/boundary/x',myGeom % x % boundary)

    CALL WriteArray_HDF5(fileId,'/mesh/boundary/dxds',myGeom % dxds % boundary)

    CALL WriteArray_HDF5(fileId,'/mesh/boundary/dsdx',myGeom % dsdx % boundary)

    CALL WriteArray_HDF5(fileId,'/mesh/boundary/nHat',myGeom % nHat % boundary)

    CALL WriteArray_HDF5(fileId,'/mesh/boundary/nScale',myGeom % nScale % boundary)

    CALL WriteArray_HDF5(fileId,'/mesh/boundary/J',myGeom % J % boundary)

    CALL Close_HDF5(fileId)

  END SUBROUTINE Write_SEMHex

  SUBROUTINE WriteTecplot_SEMHex(myGeom, filename)
    IMPLICIT NONE
    CLASS(SEMHex), INTENT(inout) :: myGeom
    CHARACTER(*), INTENT(in), OPTIONAL :: filename
    ! Local
    CHARACTER(8) :: zoneID
    INTEGER :: fUnit
    INTEGER :: iEl, i, j, k
    CHARACTER(LEN=self_FileNameLength) :: tecFile

    IF( PRESENT(filename) )THEN
      tecFile = filename
    ELSE
      tecFile = 'mesh.tec'
    ENDIF

     OPEN( UNIT=NEWUNIT(fUnit), &
      FILE= TRIM(tecFile), &
      FORM='formatted', &
      STATUS='replace')

    ! TO DO :: Create header from solution metadata
    WRITE(fUnit,*) 'VARIABLES = "X","Y","Z",'//&
                   '"dxds1","dxds2","dxds3",'//&
                   '"dyds1","dyds2","dyds3",'//&
                   '"dzds1","dzds2","dzds3",'//&
                   '"ds1dx","ds1dy","ds1dz",'//&
                   '"ds2dx","ds2dy","ds2dz",'//&
                   '"ds3dx","ds3dy","ds3dz",'//&
                   '"Jacobian"'

    DO iEl = 1, myGeom % x % nElem

      ! TO DO :: Get the global element ID
      WRITE(zoneID,'(I8.8)') iEl
      WRITE(fUnit,*) 'ZONE T="el'//trim(zoneID)//'", I=',myGeom % x % interp % N+1,&
                                                 ', J=',myGeom % x % interp % N+1, &
                                                 ', K=',myGeom % x % interp % N+1

      DO k = 0, myGeom % x % interp % N
        DO j = 0, myGeom % x % interp % N
          DO i = 0, myGeom % x % interp % N

            WRITE(fUnit,'(22(E15.7,1x))') myGeom % x % interior % hostData(1,i,j,k,1,iEl), &
                                         myGeom % x % interior % hostData(2,i,j,k,1,iEl), &
                                         myGeom % x % interior % hostData(3,i,j,k,1,iEl), &
                                         myGeom % dxds % interior % hostData(1,1,i,j,k,1,iEl), &
                                         myGeom % dxds % interior % hostData(1,2,i,j,k,1,iEl), &
                                         myGeom % dxds % interior % hostData(1,3,i,j,k,1,iEl), &
                                         myGeom % dxds % interior % hostData(2,1,i,j,k,1,iEl), &
                                         myGeom % dxds % interior % hostData(2,2,i,j,k,1,iEl), &
                                         myGeom % dxds % interior % hostData(2,3,i,j,k,1,iEl), &
                                         myGeom % dxds % interior % hostData(3,1,i,j,k,1,iEl), &
                                         myGeom % dxds % interior % hostData(3,2,i,j,k,1,iEl), &
                                         myGeom % dxds % interior % hostData(3,3,i,j,k,1,iEl), &
                                         myGeom % dsdx % interior % hostData(1,1,i,j,k,1,iEl), &
                                         myGeom % dsdx % interior % hostData(2,1,i,j,k,1,iEl), &
                                         myGeom % dsdx % interior % hostData(3,1,i,j,k,1,iEl), &
                                         myGeom % dsdx % interior % hostData(1,2,i,j,k,1,iEl), &
                                         myGeom % dsdx % interior % hostData(2,2,i,j,k,1,iEl), &
                                         myGeom % dsdx % interior % hostData(3,2,i,j,k,1,iEl), &
                                         myGeom % dsdx % interior % hostData(1,3,i,j,k,1,iEl), &
                                         myGeom % dsdx % interior % hostData(2,3,i,j,k,1,iEl), &
                                         myGeom % dsdx % interior % hostData(3,3,i,j,k,1,iEl), &
                                         myGeom % J % interior % hostData(i,j,k,1,iEl)
          ENDDO
        ENDDO
      ENDDO

    ENDDO

    CLOSE(UNIT=fUnit)

  END SUBROUTINE WriteTecplot_SEMHex

END MODULE SELF_Geometry


c program disparity

      include 'VICMAIN_FOR'
      subroutine main44

      parameter (nlmax=1100,nsmax=1100)
      real*4 ldis(nsmax,nlmax),sdis(nsmax,nlmax)
      real*4 dis(nsmax,nlmax)
      real*4 unitv(2),rd(2),bounds(2)
      integer*4 count,def,status,unit(2),ounit
c      logical xvptst

      flag=-10

c parameters
      call xveaction('SA',' ')
      call xvparm('BOUNDS',bounds,count,def,2)
      if(flag.gt.bounds(1))flag=bounds(1)

c open inputs
      do i=1,2
        call xvunit(unit(i),'INP',i,status,' ')
        call xvopen(unit(i),status,'U_FORMAT','REAL',' ')
        call xvget(unit(i),status,'NL',nl,'NS',ns,' ')
        if(ns.gt.nsmax)then
          call xvmessage('Line length too long',' ')
          call abend
        endif
        if(nl.gt.nlmax)then
          call xvmessage('Line column too long',' ')
          call abend
        endif
      enddo

c open output
      call xvunit(ounit,'OUT',1,status,' ')
        call xvopen(ounit,status,'U_FORMAT','REAL',
     +              'OP','WRITE',' ')

c read input images
      do j=1,nl
        call xvread(unit(1),ldis(1,j),status,'LINE',j,' ')
      enddo
      do j=1,nl
        call xvread(unit(2),sdis(1,j),status,'LINE',j,' ')
      enddo

c compute radial disparity & put into buf.
      cs=ns/2.0
      cl=nl/2.0
      do j=1,nl
        do i=1,ns

          dis(i,j)=flag ! bad point flag
          if(ldis(i,j).eq.0.0.and.sdis(i,j).eq.0.0)goto 10

          rd(1)=sdis(i,j)-i
          rd(2)=ldis(i,j)-j

c         Radial disparity
          unitv(1)=i-cs
          unitv(2)=j-cl
          a=sqrt(unitv(1)**2+unitv(2)**2)
          if(a.eq.0.0)a=1.
          unitv(1)=unitv(1)/a
          unitv(2)=unitv(2)/a
c          disr=sqrt((rd(1)*unitv(1))**2+(rd(2)*unitv(2))**2)
          disr=sqrt(rd(1)**2+rd(2)**2)

c         Check angle between disparity vector and radial direction.
          a=sqrt(rd(1)**2+rd(2)**2)
          rd(1)=rd(1)/a
          rd(2)=rd(2)/a
          costh=rd(1)*unitv(1)+rd(2)*unitv(2)
          th=acos(costh)*57.3
          if(th.gt.20.)goto 10

          dis(i,j)=disr
10        continue
        enddo
      enddo

c remove radial geom
      j=nl/2
      n=0
      slope=0.0
      do j=1,nl,10
        do i=1,ns,10
          rad=sqrt((i-cs)**2+(j-cl)**2)
          if(dis(i,j).ne.flag.and.rad.gt.0.0)then
            slope=slope+dis(i,j)/rad
            n=n+1
          endif
        enddo
      enddo
      slope=slope/n
      do j=1,nl
        do i=1,ns
          rad=sqrt((i-cs)**2+(j-cl)**2)
          if(dis(i,j).ne.flag)then
            dis(i,j)=dis(i,j)-slope*rad
          endif
        enddo
      enddo

c fill in the out of bounds dn's
20    continue
      nc=0
      do j=2,nl-1
        do i=2,ns-1
          if(dis(i,j).gt.bounds(1).and.dis(i,j).lt.bounds(2))goto 21
          sum=0.0
          n=0
          do jj=j-1,j+1
            do ii=i-1,i+1
              if(i.eq.ii.and.j.eq.jj)goto 22
              if(dis(ii,jj).gt.bounds(1).and.dis(ii,jj).lt.
     +          bounds(2))then
                sum=sum+dis(ii,jj)
                n=n+1
              endif
22            continue
            enddo
          enddo
          if(n.gt.0)then
            dis(i,j)=sum/n
            nc=nc+1
          endif
21        continue
        enddo
      enddo
      if(nc.gt.0)then
        write(*,*)nc,' pixels interpolated'
        goto 20
      endif

c write radial disparity
      do j=1,nl
        call xvwrit(ounit,dis(1,j),status,' ')
      enddo

      end