*DECK RSP
      SUBROUTINE RSP (NM, N, NV, A, W, MATZ, Z, FV1, FV2, IERR)
C***BEGIN PROLOGUE  RSP
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a real symmetric matrix packed into a one dimensional
C            array.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A1
C***TYPE      SINGLE PRECISION (RSP-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     to find the eigenvalues and eigenvectors (if desired)
C     of a REAL SYMMETRIC PACKED matrix.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, Z, as declared in the calling program
C          dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        NV is an INTEGER variable set equal to the dimension of the
C          array A as specified in the calling program.  NV must not
C          be less than  N*(N+1)/2.
C
C        A contains the lower triangle, stored row-wise, of the real
C          symmetric packed matrix.  A is a one-dimensional REAL
C          array, dimensioned A(NV).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        A has been destroyed.
C
C        W contains the eigenvalues in ascending order.  W is a
C          one-dimensional REAL array, dimensioned W(N).
C
C        Z contains the eigenvectors if MATZ is not zero.  The eigen-
C          vectors are orthonormal.  Z is a two-dimensional REAL array,
C          dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          20*N       if NV is less than N*(N+1)/2,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C                     The eigenvalues and eigenvectors in the W and Z
C                     arrays should be correct for indices
C                     1, 2, ..., IERR-1.
C
C        FV1 and FV2 are one-dimensional REAL arrays used for temporary
C          storage, dimensioned FV1(N) and FV2(N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  TQL2, TQLRAT, TRBAK3, TRED3
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RSP
C
      INTEGER I,J,N,NM,NV,IERR,MATZ
      REAL A(*),W(*),Z(NM,*),FV1(*),FV2(*)
C
C***FIRST EXECUTABLE STATEMENT  RSP
      IF (N .LE. NM) GO TO 5
      IERR = 10 * N
      GO TO 50
    5 IF (NV .GE. (N * (N + 1)) / 2) GO TO 10
      IERR = 20 * N
      GO TO 50
C
   10 CALL  TRED3(N,NV,A,W,FV1,FV2)
      IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  TQLRAT(N,W,FV2,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 DO 40 I = 1, N
C
         DO 30 J = 1, N
            Z(J,I) = 0.0E0
   30    CONTINUE
C
         Z(I,I) = 1.0E0
   40 CONTINUE
C
      CALL  TQL2(NM,N,W,FV1,Z,IERR)
      IF (IERR .NE. 0) GO TO 50
      CALL  TRBAK3(NM,N,NV,A,N,Z)
   50 RETURN
      END


c PefrompgTmult calcula pe desde pg y T

	implicit real*4 (a-h,o-z)
        parameter (kk=100000)

	real*4 t(kk),pe(kk),pg(kk),ti,pei,psi,pp(10),pgasi
        character*100 fichabun
        common/fichabun/fichabun
        common/constantes/g,avog	!gravedad,n. avogadro/pmu
	common/mu/cth

        common/precisoitera/precitera
        common/nmaxitera/nmaxitera

        precitera=1.e-5
        nmaxitera=250

        fichabun='THEVENIN'

        open(1,file='entrada')
           read(1,*),n,(pg(i),i=1,n),(T(i),i=1,n)
        close(1)

c        do i=1,n
c           print*,i,t(i),pg(i)
c        enddo

        cth=1.
	g=cth*2.7414e+4		!gravedad cm/s^2 en fotosfera solar
       	avog=6.023e23

        do i=1,n
           pgi=pg(i)
           ti=t(i)
           pei=1.e-6*pgi
           iter=0
           dif=1.e8
	   do while(dif .gt. 1.e-3 .and. iter.lt.50)
             psi=pei
             call pefrompg11(ti,pgi,pei)  !en equisubmu.f
             call gasc(ti,pei,pgasi,pp)
             dif=abs(pei-psi)/(pei+psi)
             iter=iter+1
c            print*,iter,psi,pei,dif
             pe(i)=pei
          enddo
c          print*,pe(i)
       enddo
       open(1,file='salida')
           write(1,*),(pe(i),i=1,n)
       close(1)

       end


module head
implicit none

real(4),parameter::box=100.  ! box size in Mpc/h
integer(4),parameter::L=256   ! cells per dimension

character(512)::outsnname='./sncorr256-cic.txt'
character(512)::outwinname='./wincorr256-cic.txt'

logical(4)::sncorr=.true.   ! whether correct shot noise

logical(4)::interlace=.false.
integer(4)::painter=2  ! 1 for cic
logical(4)::wincorr=.true.   ! whether deconvolve window for field1

logical(4)::usedefaulkminkmax=.true.
real(4)::kmin=0.    ! input kmin kmax if usedefault=false
real(4)::kmax=0.    ! input kmin kmax if usedefault=false

logical(4)::logbin=.false.
integer(4)::kbin=64   ! kbin and dk can not be zero simuteneously
real(4)::dk=0.         ! kbin and dk can not be zero simuteneously
logical(4)::usecenter=.true.

integer(4)::NUM_THREADS=32

logical(4)::flag_pk2d=.false.
character(512)::outname2='./output/pk2D-rsd.txt'
real(4)::umin=0.
real(4)::umax=1.
integer(4)::ubin=5

!!!!!! second field
logical(4)::second=.false.

logical(4)::interlace2=.false.
integer(4)::painter2=2   ! 2 for cic
logical(4)::wincorr2=.true.   ! whether deconvolve window for field2, for auto, field2=field1

!!!!! other shot noise choice
logical(4)::othernpeff=.false.  ! set effective particle number to correct shot noise
real(4)::npeffinput=0.          !

endmodule head


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine bangle: calculates a bond angle between I-J-K
!
!     part of QMDFF
!
subroutine bangle(xyz,i,j,k,angle)
implicit none
real(kind=8)::xyz(3,*),angle
integer::i,j,k
real(kind=8)::d2ij,d2jk,d2ik,xy,temp

d2ij = (xyz(1,i)-xyz(1,j))**2+ &
  &    (xyz(2,i)-xyz(2,j))**2+ &
  &    (xyz(3,i)-xyz(3,j))**2
d2jk = (xyz(1,j)-xyz(1,k))**2+ &
  &    (xyz(2,j)-xyz(2,k))**2+ &
  &    (xyz(3,j)-xyz(3,k))**2
d2ik = (xyz(1,i)-xyz(1,k))**2+ &
  &    (xyz(2,i)-xyz(2,k))**2+ &
  &    (xyz(3,i)-xyz(3,k))**2
xy = sqrt(d2ij*d2jk)
temp = 0.5d0 * (d2ij+d2jk-d2ik) / xy
if (temp .gt. 1.0d0)  temp= 1.0d0
if (temp .lt. -1.0d0) temp=-1.0d0
angle = acos( temp )

end subroutine bangle


!-----------------------------------------------------------------------
!
! Header with QFunctions
!
      include 't500-operator-f.h'
!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceed/fortran.h'

      integer ceed,err,i,j
      integer stridesu(3)
      integer erestrictx,erestrictu,erestrictui
      integer bx,bu
      integer qf_setup,qf_mass
      integer op_setup,op_mass
      integer x,qdata
      integer nelem,p,q
      parameter(nelem=15)
      parameter(p=5)
      parameter(q=8)
      integer nx,nu
      parameter(nx=nelem+1)
      parameter(nu=nelem*(p-1)+1)
      integer indx(nelem*2)
      integer indu(nelem*p)

      character arg*32

! LCOV_EXCL_START
      external setup,mass
! LCOV_EXCL_STOP

      call getarg(1,arg)
      call ceedinit(trim(arg)//char(0),ceed,err)

      do i=0,nelem-1
        indx(2*i+1)=i
        indx(2*i+2)=i+1
      enddo

      call ceedelemrestrictioncreate(ceed,nelem,2,1,1,nx,ceed_mem_host,&
     & ceed_use_pointer,indx,erestrictx,err)

      do i=0,nelem-1
        do j=0,p-1
          indu(p*i+j+1)=2*(i*(p-1)+j)
        enddo
      enddo

      call ceedelemrestrictioncreate(ceed,nelem,p,2,1,2*nu,ceed_mem_host,&
     & ceed_use_pointer,indu,erestrictu,err)
      stridesu=[1,q,q]
      call ceedelemrestrictioncreatestrided(ceed,nelem,q,1,q*nelem,stridesu,&
     & erestrictui,err)

      call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q,ceed_gauss,bx,err)
      call ceedbasiscreatetensorh1lagrange(ceed,1,2,p,q,ceed_gauss,bu,err)

      call ceedqfunctioncreateinterior(ceed,1,setup,&
     &SOURCE_DIR&
     &//'t500-operator.h:setup'//char(0),qf_setup,err)
      call ceedqfunctionaddinput(qf_setup,'weight',1,ceed_eval_weight,err)
      call ceedqfunctionaddinput(qf_setup,'dx',1,ceed_eval_grad,err)
      call ceedqfunctionaddoutput(qf_setup,'rho',1,ceed_eval_none,err)

      call ceedqfunctioncreateinterior(ceed,1,mass,&
     &SOURCE_DIR&
     &//'t500-operator.h:mass'//char(0),qf_mass,err)
      call ceedqfunctionaddinput(qf_mass,'rho',1,ceed_eval_none,err)
      call ceedqfunctionaddinput(qf_mass,'u',2,ceed_eval_interp,err)
      call ceedqfunctionaddoutput(qf_mass,'v',2,ceed_eval_interp,err)

      call ceedoperatorcreate(ceed,qf_setup,ceed_qfunction_none,&
     & ceed_qfunction_none,op_setup,err)
      call ceedoperatorcreate(ceed,qf_mass,ceed_qfunction_none,&
     & ceed_qfunction_none,op_mass,err)

      call ceedvectorcreate(ceed,nx,x,err)
      call ceedvectorcreate(ceed,nelem*q,qdata,err)

      call ceedoperatorsetfield(op_setup,'weight',ceed_elemrestriction_none,&
     & bx,ceed_vector_none,err)
      call ceedoperatorsetfield(op_setup,'dx',erestrictx,bx,&
     & ceed_vector_active,err)
      call ceedoperatorsetfield(op_setup,'rho',erestrictui,&
     & ceed_basis_collocated,ceed_vector_active,err)
      call ceedoperatorsetfield(op_mass,'rho',erestrictui,&
     & ceed_basis_collocated,qdata,err)
      call ceedoperatorsetfield(op_mass,'u',erestrictu,bu,&
     & ceed_vector_active,err)
      call ceedoperatorsetfield(op_mass,'v',erestrictu,bu,&
     & ceed_vector_active,err)

      call ceedoperatorview(op_setup,err)
      call ceedoperatorview(op_mass,err)

      call ceedvectordestroy(qdata,err)
      call ceedoperatordestroy(op_mass,err)
      call ceedoperatordestroy(op_setup,err)
      call ceedqfunctiondestroy(qf_mass,err)
      call ceedqfunctiondestroy(qf_setup,err)
      call ceedbasisdestroy(bu,err)
      call ceedbasisdestroy(bx,err)
      call ceedelemrestrictiondestroy(erestrictu,err)
      call ceedelemrestrictiondestroy(erestrictx,err)
      call ceedelemrestrictiondestroy(erestrictui,err)
      call ceeddestroy(ceed,err)
      end
!-----------------------------------------------------------------------


module regcoil_init_plasma_mod

  use stel_kinds

  implicit none

  private

  public :: regcoil_init_plasma

  real(dp) :: theta_rootSolve_target, zeta

contains

  subroutine regcoil_init_plasma()

    use regcoil_variables
    use regcoil_read_efit_mod
    use read_wout_mod, only: nfp_vmec => nfp, xm_vmec => xm, xn_vmec => xn, &
         rmnc_vmec => rmnc, zmns_vmec => zmns, rmns_vmec => rmns, zmnc_vmec => zmnc, &
         lasym_vmec => lasym, mnmax_vmec => mnmax, ns, Rmajor, read_wout_file, &
         mpol_vmec => mpol, ntor_vmec => ntor, bvco, bsubvmnc
    use safe_open_mod
    use stel_constants

    implicit none

    integer :: i, itheta, izeta, imn, tic, toc, countrate, iflag, ierr, iopen, tic1, toc1, iunit
    real(dp) :: angle, sinangle, cosangle, dsinangledtheta, dsinangledzeta, dcosangledtheta, dcosangledzeta
    real(dp) :: angle2, sinangle2, cosangle2, dsinangle2dzeta, dcosangle2dzeta
    real(dp) :: weight1, weight2, theta, r_temp, z_temp, dnorm
    integer :: ntheta_coordTransform, nzeta_coordTransform
    real(dp), dimension(:,:), allocatable :: r_coordTransform, z_coordTransform, major_R_squared
    real(dp), dimension(:), allocatable :: rmnc_vmecLast, zmns_vmecLast
    real(dp) :: rootSolve_abserr, rootSolve_relerr, theta_rootSolve_min, theta_rootSolve_max, theta_rootSolve_soln
    integer :: fzeroFlag, mpol, ntor, jm, jn, index

    call system_clock(tic, countrate)
    if (verbose) print *,"Initializing plasma surface."

    select case (geometry_option_plasma)
    case (0,1)
       ! Plain circular torus
       if (verbose) print *,"  Building a plain circular torus."

       nfp = nfp_imposed
       mnmax_plasma = 2
       lasym = .false.

       call regcoil_allocate_plasma_surface_arrays()

       xm_plasma = (/0,1/)
       xn_plasma = (/0,0/)
       rmnc_plasma = (/ R0_plasma, a_plasma /)
       zmns_plasma = (/ 0.0d+0, a_plasma /)

    case(6)
       ! Read in an ASCII table
       call safe_open(iunit, ierr, trim(shape_filename_plasma), 'old', 'formatted')
       if (ierr .ne. 0) then
          stop 'Error opening nescin file'
       endif

       ! Skip first line
       read (iunit, *)
       read (iunit, *) mnmax_plasma

       call regcoil_allocate_plasma_surface_arrays()

       ! Skip a line
       read (iunit, *)
       do i = 1, mnmax_plasma
          read (iunit, *) xm_plasma(i), xn_plasma(i), rmnc_plasma(i), zmns_plasma(i), rmns_plasma(i), zmnc_plasma(i)
       end do

       close(iunit)

       nfp = nfp_imposed
       lasym = .true.

    case(7)
       ! Read in FOCUS format plasma boundary, for more information, please check
       ! https://princetonuniversity.github.io/FOCUS/rdsurf.pdf
       call safe_open(iunit, ierr, trim(shape_filename_plasma), 'old', 'formatted')
       if (ierr .ne. 0) then
          stop 'Error opening FOCUS file'
       endif
       if (verbose) print *,"Reading FOCUS format data from file:", trim(shape_filename_plasma)

       ! Skip first line
       read (iunit, *)
       read (iunit, *) mnmax_plasma, nfp, nbf

       if (allocated(xm_plasma)) deallocate(xm_plasma)
       allocate(xm_plasma(mnmax_plasma),stat=iflag)
       if (iflag .ne. 0) stop "regcoil_init_plasma Allocation error! 1"

       if (allocated(xn_plasma)) deallocate(xn_plasma)
       allocate(xn_plasma(mnmax_plasma),stat=iflag)
       if (iflag .ne. 0) stop "regcoil_init_plasma Allocation error!  2"

       if (allocated(rmnc_plasma)) deallocate(rmnc_plasma)
       allocate(rmnc_plasma(mnmax_plasma),stat=iflag)
       if (iflag .ne. 0) stop "regcoil_init_plasma Allocation error!  3"

       if (allocated(zmns_plasma)) deallocate(zmns_plasma)
       allocate(zmns_plasma(mnmax_plasma),stat=iflag)
       if (iflag .ne. 0) stop "regcoil_init_plasma Allocation error!  4"

       if (allocated(rmns_plasma)) deallocate(rmns_plasma)
       allocate(rmns_plasma(mnmax_plasma),stat=iflag)
       if (iflag .ne. 0) stop "regcoil_init_plasma Allocation error!  5"

       if (allocated(zmnc_plasma)) deallocate(zmnc_plasma)
       allocate(zmnc_plasma(mnmax_plasma),stat=iflag)
       if (iflag .ne. 0) stop "regcoil_init_plasma Allocation error!  6"

       ! Skip two lines
       read (iunit, *)
       read (iunit, *)
       do i = 1, mnmax_plasma
          read (iunit, *) xn_plasma(i), xm_plasma(i), rmnc_plasma(i), rmns_plasma(i), zmnc_plasma(i), zmns_plasma(i)
       end do

       xn_plasma = xn_plasma * nfp ! include nfp

       ! read bnorm coefficients if available
       if ( nbf > 0 ) then
          if (allocated(bfm)) deallocate(bfs)
          allocate(bfm(nbf),stat=iflag)
          if (iflag .ne. 0) stop "regcoil_init_plasma Allocation error!  7"

          if (allocated(bfn)) deallocate(bfc)
          allocate(bfn(nbf),stat=iflag)
          if (iflag .ne. 0) stop "regcoil_init_plasma Allocation error!  8"

          if (allocated(bfs)) deallocate(bfs)
          allocate(bfs(nbf),stat=iflag)
          if (iflag .ne. 0) stop "regcoil_init_plasma Allocation error!  9"

          if (allocated(bfc)) deallocate(bfc)
          allocate(bfc(nbf),stat=iflag)
          if (iflag .ne. 0) stop "regcoil_init_plasma Allocation error! 10"

          ! Skip two lines
          read (iunit, *)
          read (iunit, *) !empty line
          do i = 1, nbf
             read (iunit, *) bfn(i), bfm(i), bfc(i), bfs(i)
          enddo

          bfn = bfn * nfp ! include nfp

          if (verbose) print *,"Number of modes for Bnormal read from FOCUS file:", nbf
       endif

       close(iunit)

       lasym = .true.

    case (2,3)
       ! VMEC, "original" theta coordinate which is not a straight-field-line coordinate
       call read_wout_file(wout_filename, ierr, iopen)
       if (iopen .ne. 0) stop 'error opening wout file'
       if (ierr .ne. 0) stop 'error reading wout file'
       if (verbose) print *,"  Successfully read VMEC data from ",trim(wout_filename)

       if (geometry_option_plasma == 2) then
          ! Only use the outermost point in the full radial mesh:
          weight1 = 0
          weight2 = 1
          if (verbose) print *,"  Using outermost grid point in VMEC's FULL radial grid."
       else
          ! Average the two outermost points in the full radial mesh
          ! to get a value on the outermost point of the half radial mesh:
          weight1 = 0.5_dp
          weight2 = 0.5_dp
          if (verbose) print *,"  Using outermost grid point in VMEC's HALF radial grid."
       end if

       nfp = nfp_vmec
       mnmax_plasma = mnmax_vmec
       lasym = lasym_vmec
       R0_plasma = Rmajor

       call regcoil_allocate_plasma_surface_arrays()

       xm_plasma = xm_vmec
       xn_plasma = xn_vmec
       if (verbose) print *,"size of rmnc_vmec:",size(rmnc_vmec,1),size(rmnc_vmec,2)
       rmnc_plasma = rmnc_vmec(:,ns-1) * weight1 + rmnc_vmec(:,ns) * weight2
       zmns_plasma = zmns_vmec(:,ns-1) * weight1 + zmns_vmec(:,ns) * weight2
       if (lasym) then
          rmns_plasma = rmns_vmec(:,ns-1) * weight1 + rmns_vmec(:,ns) * weight2
          zmnc_plasma = zmnc_vmec(:,ns-1) * weight1 + zmnc_vmec(:,ns) * weight2
       end if

    case (4)
       ! VMEC, straight-field-line poloidal coordinate
       call read_wout_file(wout_filename, ierr, iopen)
       if (iopen .ne. 0) stop 'error opening wout file'
       if (ierr .ne. 0) stop 'error reading wout file'
       if (verbose) print *,"  Successfully read VMEC data from ",trim(wout_filename)

       nfp = nfp_vmec
       lasym = lasym_vmec
       if (lasym) then
          stop "Error! geometry_option_plasma=4 is not yet implemented for lasym=true"
       end if
       R0_plasma = Rmajor

       ! Average R and Z from the outermost 2 grid points in vmec's full mesh
       ! to get R and Z on the outermost point of vmec's half mesh:
       weight1 = 0.5_dp
       weight2 = 0.5_dp

       if (allocated(rmnc_vmecLast)) deallocate(rmnc_vmecLast)
       allocate(rmnc_vmecLast(mnmax_vmec),stat=iflag)
       if (iflag .ne. 0) stop 'regcoil_init_plasma Allocation error!'

       if (allocated(zmns_vmecLast)) deallocate(zmns_vmecLast)
       allocate(zmns_vmecLast(mnmax_vmec),stat=iflag)
       if (iflag .ne. 0) stop 'regcoil_init_plasma Allocation error!'

       rmnc_vmecLast = rmnc_vmec(:,ns-1) * weight1 + rmnc_vmec(:,ns) * weight2
       zmns_vmecLast = zmns_vmec(:,ns-1) * weight1 + zmns_vmec(:,ns) * weight2

       ! Since the "original" vmec poloidal angle is chosen to have a very condensed
       ! Fourier spectrum, we probably need more Fourier modes to represent the surface using the
       ! straight-field-line coordinate.
       mpol = mpol_vmec*mpol_transform_refinement
       ntor = ntor_vmec*ntor_transform_refinement

       ! Beginning of coordinate transformation.
       ! Set up high-resolution grid in the "new" theta coordinate:
       ntheta_coordTransform = mpol * 2
       nzeta_coordTransform = ntor * 2

       if (allocated(r_coordTransform)) deallocate(r_coordTransform)
       allocate(r_coordTransform(ntheta_coordTransform, nzeta_coordTransform), stat=iflag)
       if (iflag .ne. 0) stop 'regcoil_init_plasma Allocation error!'

       if (allocated(z_coordTransform)) deallocate(z_coordTransform)
       allocate(z_coordTransform(ntheta_coordTransform, nzeta_coordTransform), stat=iflag)
       if (iflag .ne. 0) stop 'regcoil_init_plasma Allocation error!'
       r_coordTransform = 0
       z_coordTransform = 0

       call system_clock(tic1)
       rootSolve_abserr = 1.0e-10_dp
       rootSolve_relerr = 1.0e-10_dp
       !open(unit=5,file="testStraightFieldLines",status='new',form='formatted')
       !write (5,*) ntheta_coordTransform, nzeta_coordTransform
       do izeta = 1,nzeta_coordTransform
          zeta = (izeta-1.0_dp)/nzeta_coordTransform
          do itheta = 1,ntheta_coordTransform
             ! For each value of the new coordinates, solve for the old theta:
             theta_rootSolve_target = (itheta-1.0_dp)/ntheta_coordTransform
             theta_rootSolve_min = theta_rootSolve_target - 0.3
             theta_rootSolve_max = theta_rootSolve_target + 0.3

             call regcoil_fzero(fzero_residual, theta_rootSolve_min, theta_rootSolve_max, theta_rootSolve_target, &
                  rootSolve_relerr, rootSolve_abserr, fzeroFlag)
             ! Note: fzero returns its answer in theta_rootSolve_min
             theta_rootSolve_soln = theta_rootSolve_min
             if (fzeroFlag == 4) then
                stop "ERROR: fzero returned error 4: no sign change in residual"
             else if (fzeroFlag > 2) then
                print *,"WARNING in irp: fzero returned an error code:",fzeroFlag
             end if
             ! Now that we have the old theta, evaluate r and z:
             r_temp = 0
             z_temp = 0
             do imn = 1, mnmax_vmec
                !angle = twopi*(xm_vmec(imn)*theta_rootSolve_soln - xn_vmec(imn)*zeta/nfp)
                angle = xm_vmec(imn)*theta_rootSolve_soln - xn_vmec(imn)*zeta
                r_temp = r_temp + rmnc_vmecLast(imn)*cos(angle)
                z_temp = z_temp + zmns_vmecLast(imn)*sin(angle)
             end do
             r_coordTransform(itheta,izeta) = r_temp
             z_coordTransform(itheta,izeta) = z_temp
             !write(5,*) theta_rootSolve_soln
          end do
       end do
       !close(unit=5)
       call system_clock(toc1)
       if (verbose) print *,"  Time for root solving:",real(toc1-tic1)/countrate

       ! Now that we have R and Z on a grid in the new coordinates, Fourier transform the results.

       ! The next bit of code is much like initFourierModesMod, but with 2 differences:
       ! 1. We need to keep the m=n=0 mode.
       ! 2. We follow VMEC convention that n includes the factor of nfp.

       ! xm is nonnegative.
       ! xn can be negative, zero, or positive.
       ! When xm is 0, xn must be positive.
       mnmax_plasma = mpol*(ntor*2+1) + ntor + 1
       call regcoil_allocate_plasma_surface_arrays()

       ! Handle the xm=0 modes:
       xm_plasma=0
       do jn=0,ntor
          xn_plasma(jn+1)=jn*nfp
       end do

       ! Handle the xm>0 modes:
       index = ntor + 1
       do jm = 1,mpol
          do jn = -ntor, ntor
             index = index + 1
             xn_plasma(index) = jn*nfp
             xm_plasma(index) = jm
          end do
       end do
       ! Initialization of xm and xn is now complete.

       call system_clock(tic1)
       do imn = 1, mnmax_plasma
          dnorm = (1.0_dp)/(ntheta_coordTransform*nzeta_coordTransform)
          if (xm_plasma(imn).ne.0 .or. xn_plasma(imn).ne.0) dnorm = 2*dnorm
          r_temp = 0
          z_temp = 0
          do izeta = 1, nzeta_coordTransform
             zeta = (izeta-1.0_dp)/nzeta_coordTransform
             do itheta = 1, ntheta_coordTransform
                theta = (itheta-1.0_dp)/ntheta_coordTransform
                angle = xm_plasma(imn)*theta-xn_plasma(imn)*zeta
                cosangle = cos(angle)
                sinangle = sin(angle)
                r_temp = r_temp + r_coordTransform(itheta,izeta) * cosangle
                z_temp = z_temp + z_coordTransform(itheta,izeta) * sinangle
             end do
          end do
          rmnc_plasma(imn) = r_temp*dnorm
          zmns_plasma(imn) = z_temp*dnorm
       end do
       call system_clock(toc1)
       if (verbose) print *,"  Time for Fourier transform:",real(toc1-tic1)/countrate

    case (5)
       ! EFIT

       lasym = .true.
       nfp = nfp_imposed
       mnmax_plasma = efit_num_modes

       call regcoil_allocate_plasma_surface_arrays()

       call regcoil_read_efit(efit_filename, efit_psiN, efit_num_modes, rmnc_plasma, zmns_plasma, rmns_plasma, zmnc_plasma)

       ! Set major radius equal to the zero-frequency component of R(theta)
       R0_plasma = rmnc_plasma(1)

       xn_plasma = 0
       do i=1,efit_num_modes
          xm_plasma(i) = i-1
       end do

    case default
       print *,"Error! Invalid setting for geometry_option_plasma:",geometry_option_plasma
       stop
    end select

    ! ---------------------------
    ! End of the parts of code specific to each geometry_option_plasma.
    ! Now comes the code that applies to all values of geometry_option_plasma.

    nzetal_plasma = nzeta_plasma * nfp

    if (allocated(theta_plasma)) deallocate(theta_plasma)
    allocate(theta_plasma(ntheta_plasma),stat=iflag)
    if (iflag .ne. 0) stop 'regcoil_init_plasma Allocation error!'

    if (allocated(zeta_plasma)) deallocate(zeta_plasma)
    allocate(zeta_plasma(nzeta_plasma),stat=iflag)
    if (iflag .ne. 0) stop 'regcoil_init_plasma Allocation error!'

    if (allocated(zetal_plasma)) deallocate(zetal_plasma)
    allocate(zetal_plasma(nzetal_plasma),stat=iflag)
    if (iflag .ne. 0) stop 'regcoil_init_plasma Allocation error!'

    do i=1,ntheta_plasma
       theta_plasma(i) = twopi*(i-1.0_dp)/ntheta_plasma
    end do

    do i=1,nzeta_plasma
       zeta_plasma(i) = twopi/nfp*(i-1.0_dp)/nzeta_plasma
    end do

    do i=1,nzetal_plasma
       zetal_plasma(i) = twopi*(i-1.0_dp)/nzetal_plasma
    end do

    ! First coordinate is the Cartesian component x, y, or z

    if (allocated(r_plasma)) deallocate(r_plasma)
    allocate(r_plasma(3,ntheta_plasma,nzetal_plasma),stat=iflag)
    if (iflag .ne. 0) stop 'regcoil_init_plasma Allocation error!'

    if (allocated(drdtheta_plasma)) deallocate(drdtheta_plasma)
    allocate(drdtheta_plasma(3,ntheta_plasma,nzetal_plasma),stat=iflag)
    if (iflag .ne. 0) stop 'regcoil_init_plasma Allocation error!'

    if (allocated(drdzeta_plasma)) deallocate(drdzeta_plasma)
    allocate(drdzeta_plasma(3,ntheta_plasma,nzetal_plasma),stat=iflag)
    if (iflag .ne. 0) stop 'regcoil_init_plasma Allocation error!'

    if (allocated(normal_plasma)) deallocate(normal_plasma)
    allocate(normal_plasma(3,ntheta_plasma,nzetal_plasma),stat=iflag)
    if (iflag .ne. 0) stop 'regcoil_init_plasma Allocation error!'

    r_plasma=0
    drdtheta_plasma=0
    drdzeta_plasma=0

    do izeta = 1,nzetal_plasma
       angle2 = zetal_plasma(izeta)
       sinangle2 = sin(angle2)
       cosangle2 = cos(angle2)
       dsinangle2dzeta = cosangle2
       dcosangle2dzeta = -sinangle2
       do itheta = 1,ntheta_plasma
          do imn = 1,mnmax_plasma
             angle = xm_plasma(imn)*theta_plasma(itheta) - xn_plasma(imn)*zetal_plasma(izeta)
             sinangle = sin(angle)
             cosangle = cos(angle)
             dsinangledtheta = cosangle*xm_plasma(imn)
             dcosangledtheta = -sinangle*xm_plasma(imn)
             dsinangledzeta = -cosangle*xn_plasma(imn)
             dcosangledzeta = sinangle*xn_plasma(imn)

             r_plasma(1,itheta,izeta) = r_plasma(1,itheta,izeta) + rmnc_plasma(imn) * cosangle * cosangle2
             r_plasma(2,itheta,izeta) = r_plasma(2,itheta,izeta) + rmnc_plasma(imn) * cosangle * sinangle2
             r_plasma(3,itheta,izeta) = r_plasma(3,itheta,izeta) + zmns_plasma(imn) * sinangle

             drdtheta_plasma(1,itheta,izeta) = drdtheta_plasma(1,itheta,izeta) + rmnc_plasma(imn) * dcosangledtheta * cosangle2
             drdtheta_plasma(2,itheta,izeta) = drdtheta_plasma(2,itheta,izeta) + rmnc_plasma(imn) * dcosangledtheta * sinangle2
             drdtheta_plasma(3,itheta,izeta) = drdtheta_plasma(3,itheta,izeta) + zmns_plasma(imn) * dsinangledtheta

             drdzeta_plasma(1,itheta,izeta) = drdzeta_plasma(1,itheta,izeta) + rmnc_plasma(imn) * (dcosangledzeta * cosangle2 + cosangle * dcosangle2dzeta)
             drdzeta_plasma(2,itheta,izeta) = drdzeta_plasma(2,itheta,izeta) + rmnc_plasma(imn) * (dcosangledzeta * sinangle2 + cosangle * dsinangle2dzeta)
             drdzeta_plasma(3,itheta,izeta) = drdzeta_plasma(3,itheta,izeta) + zmns_plasma(imn) * dsinangledzeta

             if (lasym) then
                r_plasma(1,itheta,izeta) = r_plasma(1,itheta,izeta) + rmns_plasma(imn) * sinangle * cosangle2
                r_plasma(2,itheta,izeta) = r_plasma(2,itheta,izeta) + rmns_plasma(imn) * sinangle * sinangle2
                r_plasma(3,itheta,izeta) = r_plasma(3,itheta,izeta) + zmnc_plasma(imn) * cosangle

                drdtheta_plasma(1,itheta,izeta) = drdtheta_plasma(1,itheta,izeta) + rmns_plasma(imn) * dsinangledtheta * cosangle2
                drdtheta_plasma(2,itheta,izeta) = drdtheta_plasma(2,itheta,izeta) + rmns_plasma(imn) * dsinangledtheta * sinangle2
                drdtheta_plasma(3,itheta,izeta) = drdtheta_plasma(3,itheta,izeta) + zmnc_plasma(imn) * dcosangledtheta

                drdzeta_plasma(1,itheta,izeta) = drdzeta_plasma(1,itheta,izeta) + rmns_plasma(imn) * (dsinangledzeta * cosangle2 + sinangle * dcosangle2dzeta)
                drdzeta_plasma(2,itheta,izeta) = drdzeta_plasma(2,itheta,izeta) + rmns_plasma(imn) * (dsinangledzeta * sinangle2 + sinangle * dsinangle2dzeta)
                drdzeta_plasma(3,itheta,izeta) = drdzeta_plasma(3,itheta,izeta) + zmnc_plasma(imn) * dcosangledzeta
             end if
          end do
       end do
    end do

    ! Evaluate cross product
    normal_plasma(1,:,:) = drdzeta_plasma(2,:,:) * drdtheta_plasma(3,:,:) - drdtheta_plasma(2,:,:) * drdzeta_plasma(3,:,:)
    normal_plasma(2,:,:) = drdzeta_plasma(3,:,:) * drdtheta_plasma(1,:,:) - drdtheta_plasma(3,:,:) * drdzeta_plasma(1,:,:)
    normal_plasma(3,:,:) = drdzeta_plasma(1,:,:) * drdtheta_plasma(2,:,:) - drdtheta_plasma(1,:,:) * drdzeta_plasma(2,:,:)

    if (allocated(norm_normal_plasma)) deallocate(norm_normal_plasma)
    allocate(norm_normal_plasma(ntheta_plasma, nzeta_plasma),stat=iflag)
    if (iflag .ne. 0) stop 'regcoil_init_plasma Allocation error!'
    norm_normal_plasma = sqrt(normal_plasma(1,:,1:nzeta_plasma)**2 &
         + normal_plasma(2,:,1:nzeta_plasma)**2 &
         + normal_plasma(3,:,1:nzeta_plasma)**2)

    dtheta_plasma = theta_plasma(2)-theta_plasma(1)
    dzeta_plasma = zeta_plasma(2)-zeta_plasma(1)

    area_plasma = nfp * dtheta_plasma * dzeta_plasma * sum(norm_normal_plasma)

    ! Compute plasma volume using \int (1/2) R^2 dZ dzeta.
    ! These quantities will be evaluated on the half theta grid, which is the natural grid for dZ,
    ! but we will need to interpolate R^2 from the full to half grid.
    allocate(major_R_squared(ntheta_plasma,nzetal_plasma))
    major_R_squared = r_plasma(1,:,:)*r_plasma(1,:,:) + r_plasma(2,:,:)*r_plasma(2,:,:)
    ! First handle the interior of the theta grid:
    volume_plasma = sum((major_R_squared(1:ntheta_plasma-1,:) + major_R_squared(2:ntheta_plasma,:)) * (0.5d+0) & ! R^2, interpolated from full to half grid
         * (r_plasma(3,2:ntheta_plasma,:)-r_plasma(3,1:ntheta_plasma-1,:))) ! dZ
    ! Add the contribution from the ends of the theta grid:
    volume_plasma = volume_plasma + sum((major_R_squared(1,:) + major_R_squared(ntheta_plasma,:)) * (0.5d+0) & ! R^2, interpolated from full to half grid
         * (r_plasma(3,1,:)-r_plasma(3,ntheta_plasma,:))) ! dZ
    volume_plasma = abs(volume_plasma * dzeta_plasma / 2) ! r_plasma includes all nfp periods already, so no factor of nfp needed.
    deallocate(major_R_squared)
    if (verbose) print "(a,es10.3,a,es10.3,a)"," Plasma surface area:",area_plasma," m^2. Volume:",volume_plasma," m^3."

    select case (geometry_option_plasma)
    case (2,3,4)
       ! A VMEC wout file is available
       ! VMEC stores the toroidal Boozer component B_zeta as "bvco", using the HALF mesh
       net_poloidal_current_Amperes = 2*pi/mu0*(1.5_dp*bvco(ns)-0.5_dp*bvco(ns-1))
       ! curpol is a number which multiplies the data in the bnorm file.
       curpol = (2*pi/nfp)*(1.5_dp*bsubvmnc(1,ns) - 0.5_dp*bsubvmnc(1,ns-1))

       if (verbose) print *,"Overriding net_poloidal_current_Amperes with value from the VMEC wout file."
       if (verbose) print *,"G = ", net_poloidal_current_Amperes, " ; curpol = ", curpol
    case default
       if (abs(net_poloidal_current_Amperes-1)<1e-12) then
          if (verbose) print *,"No VMEC file is available, and the default value of net_poloidal_current_Amperes (=1) will be used."
       else
          if (verbose) print *,"No VMEC file is available, so net_poloidal_current_Amperes will be taken from the bdistrib input file."
       end if
    end select

    call system_clock(toc)
    if (verbose) print *,"Done initializing plasma surface. Took ",real(toc-tic)/countrate," sec."

  end subroutine regcoil_init_plasma

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

  function fzero_residual(theta_old)

    use regcoil_variables, only: nfp
    use read_wout_mod, only: xm_vmec => xm, xn_vmec => xn, mnmax_vmec => mnmax, lmns, ns
    use stel_constants

    implicit none

    real(dp) :: theta_old, fzero_residual
    integer :: imn

    ! residual = twopi*(u_new - u_new_target) = (twopi*u_old + lambda) - u_new_target*twopi
    fzero_residual = theta_old - theta_rootSolve_target

    do imn = 1, mnmax_vmec
       fzero_residual = fzero_residual + lmns(imn,ns)*sin(xm_vmec(imn)*theta_old - xn_vmec(imn)*zeta)
    end do

  end function fzero_residual

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

  subroutine regcoil_allocate_plasma_surface_arrays()

    use regcoil_variables

    implicit none

    integer :: iflag

    if (allocated(xm_plasma)) deallocate(xm_plasma)
    allocate(xm_plasma(mnmax_plasma),stat=iflag)
    if (iflag .ne. 0) stop "regcoil_init_plasma Allocation error!  1"

    if (allocated(xn_plasma)) deallocate(xn_plasma)
    allocate(xn_plasma(mnmax_plasma),stat=iflag)
    if (iflag .ne. 0) stop "regcoil_init_plasma Allocation error!  2"

    if (allocated(rmnc_plasma)) deallocate(rmnc_plasma)
    allocate(rmnc_plasma(mnmax_plasma),stat=iflag)
    if (iflag .ne. 0) stop "regcoil_init_plasma Allocation error!  3"

    if (allocated(rmns_plasma)) deallocate(rmns_plasma)
    allocate(rmns_plasma(mnmax_plasma),stat=iflag)
    if (iflag .ne. 0) stop "regcoil_init_plasma Allocation error!  4"

    if (allocated(zmnc_plasma)) deallocate(zmnc_plasma)
    allocate(zmnc_plasma(mnmax_plasma),stat=iflag)
    if (iflag .ne. 0) stop "regcoil_init_plasma Allocation error!  5"

    if (allocated(zmns_plasma)) deallocate(zmns_plasma)
    allocate(zmns_plasma(mnmax_plasma),stat=iflag)
    if (iflag .ne. 0) stop "regcoil_init_plasma Allocation error!  6"

    xm_plasma = 0
    xn_plasma = 0
    rmnc_plasma = 0
    rmns_plasma = 0
    zmnc_plasma = 0
    zmns_plasma = 0

  end subroutine regcoil_allocate_plasma_surface_arrays

end module regcoil_init_plasma_mod


	SUBROUTINE GR_PLOC  ( gpoint, rgx, rgy, rlat, rlon, iret )
C************************************************************************
C* GR_PLOC								*
C*									*
C* This subroutine translates the user input for a grid point into an	*
C* actual grid point, x and y coordinates, and latitude and longitude.	*
C*									*
C* GR_PLOC  ( GPOINT, RGX, RGY, RLAT, RLON, IRET )			*
C*									*
C* Input parameters:							*
C*	GPOINT		CHAR*		User input for grid point	*
C*									*
C* Output parameters:							*
C*	RGX		REAL		X grid point			*
C*	RGY		REAL		Y grid point			*
C*	RLAT		REAL		Latitude			*
C*	RLON		REAL		Longitude			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					-12 = invalid grid point	*
C*					-13 = proj not set in GEMPLT	*
C**									*
C* Log:									*
C* M. desJardins/GSFC	11/85						*
C* M. desJardins/GSFC	 9/88	GEMPAK4					*
C* M. desJardins/GSFC	 4/89	Added LC_FLOC to get location		*
C* K. Brill/GSC          3/90   Added DG_KXKY and check againt KX and KY*
C* K. Brill/NMC         01/92   Replace GERROR with ER_WMSG             *
C* R. Tian/SAIC		10/02	Replace DG_KXKY with GQGPRJ		*
C* K. Brill/HPC		 4/04	Allow .005 slop in chck against grd bnds*
C************************************************************************
	CHARACTER*(*)	gpoint
C*
	REAL		rarr (2)
	CHARACTER	sep*1, gprj*4
C------------------------------------------------------------------------
	iret = 0
	rgx  = 0.
	rgy  = 0.
C
C*	Query grid projection from GEMPLT
C
	CALL GQGPRJ ( gprj, ag1, ag2, ag3, kx, ky, aglt1, agln1,
     +                aglt2, agln2, ier )

	IF ( ier .ne. 0 ) THEN
          CALL ER_WMSG ( 'GEMPLT', ier, ' ', ierr )
	  iret = -13
	  RETURN
	END IF
C
C*	Get location if no @ is used.
C
	IF  ( gpoint (1:1) .ne. '@' )  THEN
	    CALL LC_FLOC  ( gpoint, rlat, rlon, iret )
	    IF  ( iret .ne. 0 )  THEN
		iret = -12
		RETURN
	    END IF
	    CALL GTRANS  ( 'M', 'G', 1, rlat, rlon, rgx, rgy, ier )
	    IF  ( ier .ne. 0 )  THEN
		CALL ER_WMSG ( 'GEMPLT', ier, ' ', ierr )
		iret = -12
		RETURN
	    END IF
	  ELSE
C
C*	    Check whether user used ; or / as a separator.
C
	    islash = INDEX ( gpoint, '/' )
	    isemic = INDEX ( gpoint, ';' )
	    IF  ( isemic .ne. 0 )  THEN
		sep = ';'
	      ELSE IF  ( islash .ne. 0 )  THEN
		sep = '/'
	      ELSE
		iret = -12
		RETURN
	    END IF
C
C*	Translate rest of input as grid point.
C
	    CALL ST_RLST  ( gpoint (2:), sep, 0, 2, rarr, n, ier )
	    rgx = rarr (1)
	    rgy = rarr (2)
	    CALL GTRANS ( 'G', 'M', 1, rgx, rgy, rlat, rlon, ier )
	END IF
C
C*	Check that grid point values are valid.
C
	IF ( ABS (1. - rgx) .le. .005 ) rgx = 1.00000
	IF ( ABS (1. - rgy) .le. .005 ) rgy = 1.00000
	IF ( ABS (FLOAT(kx) - rgx) .le. .005 ) rgx = FLOAT (kx)
	IF ( ABS (FLOAT(ky) - rgy) .le. .005 ) rgy = FLOAT (ky)
	IF  ( ( rgx .lt. 1. ) .or. ( rgy .lt. 1. )   .or.
     +        ( rgx .gt. FLOAT ( kx ) )              .or.
     +        ( rgy .gt. FLOAT ( ky ) )            ) THEN
	    iret = -12
	END IF
C*
	RETURN
	END


      SUBROUTINE KFLUD2
C
C     THIS ROUTINE GENERATES THE PSUEDO STIFFNESS MATRIX TERMS
C     FOR THE CENTER PLUG FLUID ELEMENT
C
C     THE ECPT DATA BLOCK CONTAINS THE FOLLOWING DATA
C
C         FIELD    SYMBOL
C           1        ID
C           2        SIL1
C           3        SIL2
C           4        RHO
C           5        BULK
C           6        N
C           7        CSF
C           8        R1
C           9        Z1
C           10       -
C           11       CSF
C           12       R2
C           13       Z2
C           14       -
C           15       -
C
      LOGICAL          NOGO
      INTEGER          OUT,ELTYPE,NECPT(100)
      DOUBLE PRECISION R1,Z1,R2,Z2,CONSTD,DPI,
     1                 Z1P,Z2P,Z1P1,Z2P1,RK,RI,KFACT,F0,A,B,I2N0,I2N1,
     2                 I2N2,I2NP2,DZ,HPQ,PIRHO,TWOPR,KH,K1,K2
      CHARACTER        UFM*23
      COMMON  /XMSSG / UFM
      COMMON  /CONDAD/ CONSTD(5)
      COMMON  /SYSTEM/ SYSBUF,OUT,NOGO
      COMMON  /EMGDIC/ ELTYPE
      COMMON  /SMA1IO/ DUM1(10),IFKGG
      COMMON  /SMA1CL/ IOPT4,K4GGSW,NPVT
      COMMON  /SMA1DP/ Z1P,Z2P,RK,RI,KFACT,F0,A,B,I2N0,I2N1,I2N2,I2NP2,
     1                 DZ,HPQ(4),PIRHO,TWOPR,KH(4),K1,K2
      COMMON  /SMA1ET/ ECPT(100)
      EQUIVALENCE      (CONSTD(1),DPI),(ECPT(1),NECPT(1))
C
C
      IF (ECPT(13)-ECPT(9)) 5,10,10
    5 R1 = ECPT(12)
      R2 = ECPT(8)
      Z1 = ECPT(13)
      Z2 = ECPT(9)
      I  = NECPT(3)
      NECPT(3) = NECPT(2)
      NECPT(2) = I
      GO TO 15
   10 R1 = ECPT(8)
      Z1 = ECPT(9)
      R2 = ECPT(12)
      Z2 = ECPT(13)
   15 IF (R1.EQ.0.0D0 .OR. R2.EQ.0.0D0) GO TO 5000
      IF (Z1 .EQ. Z2) RETURN
C
C     CALCULATE THE INTEGRAL PARAMETERS I2N0,I2N1,I2N2,AND I2NP2
C
      K  = 2*NECPT(6)
      RK = K
      IF (K .GT. 0) GO TO 20
C
      I2N0 = 0.0
      I2N1 = 0.0
      I2N2 = 0.0
      I2NP2= (Z2-Z1)*(R2**2 + R2*R1 + R1**2)/6.0D0
C
      GO TO 300
C
   20 B    = (R2-R1)/(Z2-Z1)
      DUM  = DABS(B)
      IF (DUM .GT. 1.0E-6) GO TO 30
C
      Z1P  = ((R1+R2)/2.0D0)**K
      I2N0 = (Z1P/RK)*(Z2-Z1)
      I2N1 = I2N0*(Z2+Z1)/2.0D0
      I2N2 = I2N0*(Z2**2+Z2*Z1+Z1**2)/3.0D0
      I2NP2= I2N0*RK/(RK+2.0D0)*R1**2
      GO TO 300
   30 Z1P  = R1**(K+1)
      Z2P  = R2**(K+1)
      Z1P1 = Z1P*R1
      Z2P1 = Z2P*R2
C
      A    = 1.0D0/B
      I2N0 = A/(RK*(RK+1.0D0))*(Z2P-Z1P)
      I2N1 = A/(RK*(RK+1.0D0))*(Z2P*Z2-Z1P*Z1-A/(RK+2.0D0)*(Z2P1-Z1P1))
      I2N2 = A/(RK*(RK+1.0D0))*(Z2P*Z2**2-Z1P*Z1**2 -A/(RK+2.0D0)*2.0D0
     1     * (Z2P1*Z2-Z1P1*Z1-A/(RK+3.0D0)*(Z2P1*R2-Z1P1*R1)))
      I2NP2= A/((RK+2.0D0)*(RK+3.0D0))*(Z2P1*R2-Z1P1*R1)
  300 DZ   = Z2 - Z1
      N    = NECPT(6)
      Z1P  = R1**N
      Z2P  = R2**N
      HPQ(1) = Z2/(DZ*Z1P)
      HPQ(2) =-Z1/(DZ*Z2P)
      HPQ(3) =-1.0D0/(DZ*Z1P)
      HPQ(4) = 1.0D0/(DZ*Z2P)
      LP   = 1
      IF (NPVT .EQ. NECPT(2)) GO TO 320
      IF (NPVT .EQ. NECPT(3)) GO TO 310
      RETURN
C
  310 LP = 2
  320 IF (ECPT(4) .EQ. 0.0) RETURN
      PIRHO  = DPI/DBLE(ECPT(4))
      IF (N .EQ. 0) PIRHO = PIRHO*2.0D0
      RK = N
      TWOPR = 2.0*PIRHO*RK**2
      KH(1) = TWOPR*(I2N0*HPQ(LP)+I2N1*HPQ(LP+2))
      KH(2) = TWOPR*(I2N1*HPQ(LP)+I2N2*HPQ(LP+2)) +PIRHO*I2NP2*HPQ(LP+2)
      K1    = KH(1)*HPQ(1) + KH(2)*HPQ(3)
      K2    = KH(1)*HPQ(2) + KH(2)*HPQ(4)
      IFILE = IFKGG
      I     = NPVT
      J     = NECPT(2)
      CALL SMA1B (K1,J,I,IFILE,0.0D0)
      J     = NECPT(3)
      CALL SMA1B (K2,J,I,IFILE,0.0D0)
      RETURN
C
 5000 N = NECPT(1)
      IF (ELTYPE .EQ. 43) N = N/1000
      WRITE  (OUT,6000) UFM,N
 6000 FORMAT (A23,' 5000, NEGATIVE OR ZERO RADIUS DETECTED FOR ',
     1       'CFLUID2/CAXIF2 ELEMENT ID',I9)
      NOGO = .TRUE.
      RETURN
      END


! =============================================================================
!                               Parcel diagnostics
! =============================================================================
module parcel_diagnostics
    use constants, only : zero, one, f12, thousand
    use merge_sort
    use parameters, only : extent, lower, vcell, vmin, nx, nz
    use parcel_container, only : parcels, n_parcels
    use parcel_ellipsoid
    use omp_lib
    use timer, only : start_timer, stop_timer
    implicit none

    integer :: parcel_stats_timer

#ifndef NDEBUG
    double precision, parameter :: thres = thousand * epsilon(zero)
#endif

    ! peref : potential energy reference
    ! pe    : potential energy
    ! ke    : kinetic energy
    double precision :: peref, pe, ke

    ! psi : enstrophy
    double precision :: psi

    integer :: n_small

    ! avg_lam : mean aspect ratio over all parcels
    ! avg_vol : mean volume over all parcels
    ! std_lam : standard deviation of aspect ratio
    ! std_vol : standard deviation of volume
    double precision :: avg_lam, avg_vol
    double precision :: std_lam, std_vol

    double precision :: sum_vol

    ! rms vorticity
    double precision :: rms_zeta(3)

    contains

        ! Compute the reference potential energy
        subroutine init_parcel_diagnostics
            integer          :: ii(n_parcels), n
            double precision :: b(n_parcels)
            double precision :: gam, zmean

            call start_timer(parcel_stats_timer)

            b = parcels%buoyancy(1:n_parcels)

            ! sort buoyancy in ascending order
            call msort(b, ii)

            gam = one / (extent(1) * extent(2))
            zmean = gam * parcels%volume(ii(1))

            peref = - b(1) * parcels%volume(ii(1)) * zmean
            do n = 2, n_parcels
                zmean = zmean + gam * (parcels%volume(ii(n-1)) + parcels%volume(ii(n)))

                peref = peref &
                      - b(n) * parcels%volume(ii(n)) * zmean
            enddo

            call stop_timer(parcel_stats_timer)
        end subroutine init_parcel_diagnostics

        ! Calculate all parcel related diagnostics
        subroutine calculate_parcel_diagnostics(velocity)
            double precision :: velocity(:, :)
            integer          :: n
            double precision :: b, z, vel(3), vol, zmin, vor(3)
            double precision :: evals(3), lam, lsum, l2sum, v2sum

            call start_timer(parcel_stats_timer)

            ! reset
            ke = zero
            pe = zero
            psi = zero

            lsum = zero
            l2sum = zero
            v2sum = zero

            rms_zeta = zero

            n_small = zero

            zmin = lower(3)

            avg_lam = zero
            avg_vol = zero
            std_lam = zero
            std_vol = zero
            sum_vol = zero

            !$omp parallel default(shared)
            !$omp do private(n, vel, vol, b, z, evals, lam, vor) &
            !$omp& reduction(+: ke, pe, lsum, l2sum, sum_vol, v2sum, n_small, rms_zeta, psi)
            do n = 1, n_parcels

                vel = velocity(:, n)
                vor = parcels%vorticity(:, n)
                vol = parcels%volume(n)
                b   = parcels%buoyancy(n)
                z   = parcels%position(3, n) - zmin

                ! kinetic energy
                ke = ke + (vel(1) ** 2 + vel(2) ** 2 + vel(3) ** 2) * vol

                ! potential energy
                pe = pe - b * z * vol

                ! enstrophy
                psi = psi + (vor(1) ** 2 + vor(2) ** 2 + vor(3) ** 2) * vol

                evals = get_eigenvalues(parcels%B(:, n), parcels%volume(n))
                lam = get_aspect_ratio(evals)

                lsum = lsum + lam
                l2sum = l2sum + lam ** 2

                sum_vol = sum_vol + vol
                v2sum = v2sum + vol ** 2

                if (vol <= vmin) then
                    n_small = n_small + 1
                endif

#ifndef NDEBUG
                !$omp critical
                if (abs(get_determinant(parcels%B(:, n), vol) / get_abc(vol) ** 2 - one) > thres) then
                    print *, "Parcel determinant not preserved!"
                    stop
                endif
                !$omp end critical
#endif
                rms_zeta = rms_zeta + vol * vor ** 2

            enddo
            !$omp end do
            !$omp end parallel

            ke = f12 * ke
            pe = pe - peref
            psi = f12 * psi

            avg_lam = lsum / dble(n_parcels)
            std_lam = dsqrt(abs(l2sum / dble(n_parcels) - avg_lam ** 2))

            rms_zeta = dsqrt(rms_zeta / sum_vol)

            avg_vol = sum_vol / dble(n_parcels)
            std_vol = dsqrt(abs(v2sum / dble(n_parcels) - avg_vol ** 2))

            call stop_timer(parcel_stats_timer)

        end subroutine calculate_parcel_diagnostics

end module parcel_diagnostics


module mod_fluid
#include <messenger.h>
    use mod_kinds,              only: rk, ik
    use mod_constants,          only: ZERO, ONE
    implicit none

    ! Fluid equation constants
    real(rk), parameter :: Rgas  = 287.15_rk            ! Specific gas constant
    real(rk), parameter :: gam   = 1.4_rk               ! Ratio of specific heats
    real(rk), parameter :: cp    = Rgas*gam/(gam-ONE)   ! Specific heat capacity, constant pressure
    real(rk)            :: omega = 0._rk                ! Rotation rate (rad/s)
    real(rk)            :: Pr    = 0.72_rk              ! Prandtl number

end module mod_fluid


C$Procedure ZZGRAV ( SGP4 gravitational constants )

      SUBROUTINE ZZGRAV ( GRAV )

C$ Abstract
C
C      Constants assignments equivalent to 21 July 2006 "getgravconst"
C      by David Vallado, AIAA-2006-6753.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     None.
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE               'zzsgp4.inc'

      DOUBLE PRECISION      GRAV( NGRAVS, NGRAVC )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     GRAV       O   Array of geophysical constants.
C
C$ Detailed_Input
C
C     None.
C
C$ Detailed_Output
C
C     GRAV       An array of three geophysical constants vectors.
C
C$ Parameters
C
C     Refer to include file zzsgp4.inc.
C
C$ Exceptions
C
C     None.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     None.
C
C$ Examples
C
C           INCLUDE               'zzsgp4.inc'
C
C           CALL ZZGRAV ( GRAV )
C
C     C
C     C     Retrieve the constants set based on the WGS ID parameter.
C     C
C
C           MU   = GRAV( P_WGS, P_MU)
C           RAD  = GRAV( P_WGS, P_RAD)
C           XKE  = GRAV( P_WGS, P_XKE)
C           TUMN = GRAV( P_WGS, P_TUMN)
C           J2   = GRAV( P_WGS, P_J2)
C           J3   = GRAV( P_WGS, P_J3)
C           J4   = GRAV( P_WGS, P_J4)
C           J3OJ2= GRAV( P_WGS, P_J3J2)
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C   [1] Hoots, F. R., and Roehrich, R. L. 1980. "Models for
C       Propagation of the NORAD Element Sets." Spacetrack Report #3.
C       U.S. Air Force: Aerospace Defense Command.
C
C   [2] Hoots, Felix R. "Spacetrack Report #6: Models for Propagation
C       of Space Command Element Sets." Space Command,
C       U. S. Air Force, CO.
C
C   [3] Hoots, Felix R., P. W. Schumacher, and R. A. Glover. 2004.
C       History of Analytical Orbit Modeling in the U. S. Space
C       Surveillance System. Journal of Guidance, Control, and
C       Dynamics. 27(2):174-185.
C
C   [4] Vallado, David, Crawford, Paul, Hujsak, Richard,
C       and Kelso, T.S. 2006. Revisiting Spacetrack Report #3. Paper
C       AIAA 2006-6753 presented at the AIAA/AAS Astrodynamics
C       Specialist Conference, August 21-24, 2006. Keystone, CO.
C
C$ Author_and_Institution
C
C     David Vallado   (AGI)
C     E. D. Wright    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0 22-JUL-2014 (EDW)
C
C-&

C$ Index_Entries
C
C   SGP4
C
C-&

C
C     The definition of the MU constant is to allow calculation of
C     those constants which are functions of MU in the WGS72 and WGS84
C     assignments.
C

C
C     WGS72 low precision Spacetrack #3 constants. These values should
C     correspond to those in geophysical.ker. If not, something is
C     very wrong.
C

      GRAV( WGS721, P_RAD)  =  6378.135D0

      GRAV( WGS721, P_XKE)  =  0.0743669161D0

      GRAV( WGS721, P_MU)   =  398600.79964D0

      GRAV( WGS721, P_TUMN) =  1.0D0 / GRAV(WGS721, P_XKE)

      GRAV( WGS721, P_J2)   =  0.001082616D0

      GRAV( WGS721, P_J3)   =  -0.00000253881D0

      GRAV( WGS721, P_J4)   =  -0.00000165597D0

      GRAV( WGS721, P_J3J2) =  GRAV(WGS721, P_J3) / GRAV(WGS721, P_J2)

C
C     WGS 72 constants.
C

      GRAV( WGS72, P_MU)   = 398600.8D0

      GRAV( WGS72, P_RAD)  =  6378.135D0

      GRAV( WGS72, P_XKE)  =  60.0D0 /
     .                 DSQRT(GRAV(WGS72, P_RAD)**3/GRAV(WGS72, P_MU))

      GRAV( WGS72, P_TUMN) =  1.0D0 / GRAV(WGS72, P_XKE)

      GRAV( WGS72, P_J2)   =  0.001082616D0

      GRAV( WGS72, P_J3)   =  -0.00000253881D0

      GRAV( WGS72, P_J4)   =  -0.00000165597D0

      GRAV( WGS72, P_J3J2) =  GRAV(WGS72, P_J3) / GRAV(WGS72, P_J2)

C
C     WGS 84 constants.
C

      GRAV( WGS84, P_MU)   =  398600.5D0

      GRAV( WGS84, P_RAD)  =  6378.137D0

      GRAV( WGS84, P_XKE)  =  60.0D0 /
     .                 DSQRT(GRAV(WGS84, P_RAD)**3/GRAV(WGS84, P_MU))

      GRAV( WGS84, P_TUMN) =  1.0D0 / GRAV(WGS84, P_XKE)

      GRAV( WGS84, P_J2)   =  0.00108262998905D0

      GRAV( WGS84, P_J3)   =  -0.00000253215306D0

      GRAV( WGS84, P_J4)   =  -0.00000161098761D0

      GRAV( WGS84, P_J3J2) =  GRAV(WGS84, P_J3) / GRAV(WGS84, P_J2)

      END


!*******************************************************************************
!>  @file line_segment.f
!>  @brief Contains module @ref line_segment
!
!  Note separating the Doxygen comment block here so detailed decription is
!  found in the Module not the file.
!
!>  Module is part of the LIBSTELL. This module contains code to create a
!>  profile constructed of line sigments. These line segments are assumed to be
!>  specified such that xx(i) < xx(i + 1)
!*******************************************************************************

      MODULE line_segment
      USE stel_kinds
      USE stel_constants

!*******************************************************************************
!  INTERFACE BLOCKS
!*******************************************************************************
      PUBLIC line_seg, line_seg_int, line_seg_test
      PRIVATE get_indices, y_value, y_value_int, slope, offset, check

      CONTAINS

!*******************************************************************************
!  UTILITY SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Interpolate a point on a line.
!>
!>  Find the linearly interpolated value of y at position x from line sigments
!>  specified by yy(xx).
!>
!>  @param[in]  x  X point to interpolate the line at.
!>  @param[out] y  The value of the interpolated point.
!>  @param[in]  xx X positions defining the line segments.
!>  @param[in]  yy Y positions defining the line segments.
!>  @param[in]  n  Number of points defining the line.
!-------------------------------------------------------------------------------
      SUBROUTINE line_seg(x, y, xx, yy, n)

      IMPLICIT NONE

!  Declare Arguments
      REAL (rprec), INTENT(in)               :: x
      REAL (rprec), INTENT(out)              :: y
      REAL (rprec), DIMENSION(:), INTENT(in) :: xx
      REAL (rprec), DIMENSION(:), INTENT(in) :: yy
      INTEGER, INTENT(in)                    :: n

!  local variables
      INTEGER                                :: ilow, ihigh

!  Start of executable code
!  Check for valid line segments.
      IF (n .le. 1) THEN
         STOP "Line sigments require at least two points"
      ELSE IF (xx(1) .ge. xx(2)) THEN
         STOP "Line sigments must be specified in increasing order of x"
      END IF

!  If x is outside of array, linearly interprolate from the last two points.
      IF (x .lt. xx(1)) THEN
         ilow = 1; ihigh = 2
      ELSE IF (x .gt. xx(n)) THEN
         ilow = n - 1; ihigh = n
      ELSE
         CALL get_indices(x, xx, 1, n, ilow, ihigh)
      END IF

      y = y_value(x, yy, xx, ilow, ihigh)

      END SUBROUTINE

!-------------------------------------------------------------------------------
!>  @brief Integrate to a point on a line.
!>
!>  Find the linearly integrated value of y at position x from line sigments
!>  specified by yy(xx).
!>
!>  @param[in]  x  X point to interpolate the line at.
!>  @param[out] y  The value of the interpolated point.
!>  @param[in]  xx X positions defining the line segments.
!>  @param[in]  yy Y positions defining the line segments.
!>  @param[in]  n  Number of points defining the line.
!-------------------------------------------------------------------------------
      SUBROUTINE line_seg_int(x, y, xx, yy, n)

      IMPLICIT NONE

!  Declare Arguments
      REAL (rprec), INTENT(in)               :: x
      REAL (rprec), INTENT(out)              :: y
      REAL (rprec), DIMENSION(:), INTENT(in) :: xx
      REAL (rprec), DIMENSION(:), INTENT(in) :: yy
      INTEGER, INTENT(in)                    :: n

!  local variables
      INTEGER                                :: ilow, ihigh
      INTEGER                                :: i0low, i0high
      INTEGER                                :: i

!  Start of executable code
!  Check for valid line segments.
      IF (n .le. 1) THEN
         STOP "Line sigments require at least two points"
      ELSE IF (xx(1) .ge. xx(2)) THEN
         STOP "Line sigments must be specified in increasing order of x"
      END IF

!  If x is outside of array, linearly interprolate from the last two points.
      IF (x .lt. xx(1)) THEN
         ilow = 1; ihigh = 2
      ELSE IF (x .gt. xx(n)) THEN
         ilow = n - 1; ihigh = n
      ELSE
         CALL get_indices(x, xx, 1, n, ilow, ihigh)
      END IF

!  Determine where zero is.
      IF (zero .lt. xx(1)) THEN
         i0low = 1; i0high = 2
      ELSE IF (zero .gt. xx(n)) THEN
         i0low = n - 1; i0high = n
      ELSE
         CALL get_indices(zero, xx, 1, n, i0low, i0high)
      END IF

!  If 0 and x have the same low and high indices, then the integrate directly
!  from 0 to x. Other wise Integrate from:
!    0 to xx(i0high); xx(i0high) to xx(ilow); xx(ilow) to x
      IF (ilow .eq. i0low) THEN
         y = y_value_int(zero, x, yy, xx, ilow, ihigh)
      ELSE
         y = y_value_int(zero, xx(i0high), yy, xx, i0low, i0high)
         DO i = i0high, ilow - 1
             y = y + y_value_int(xx(i), xx(i+1), yy, xx, i, i+1)
         END DO
         y = y + y_value_int(xx(ilow), x, yy, xx, ilow, ihigh)
      END IF

      END SUBROUTINE

!*******************************************************************************
!  PRIVATE
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Find the bounding indicies of the array.
!>
!>  This performs a recursive search to find the upper and lower indices of the
!>  that bound a point x. This is performed by splitting the array in half and
!>  recursively calling the subroutine on the half that still bounda the point.
!>  Once the array is down to two elements, the bounding indicies have been
!>  found.
!>
!>  @param[in]  x      X point to find the bounds at.
!>  @param[in]  xx     X positions defining the line segments.
!>  @param[in]  lBound Lower bound value of the array.
!>  @param[in]  uBound Upper bound value of the array.
!>  @param[out] ilow   Index of the lower bound.
!>  @param[out] ihigh  Index of the upper bound.
!-------------------------------------------------------------------------------
      PURE RECURSIVE                                                           &
     &SUBROUTINE get_indices(x, xx, lBound, uBound, ilow, ihigh)

      IMPLICIT NONE

!  Declare Arguments
      REAL(rprec), INTENT(in)               :: x
      REAL(rprec), DIMENSION(:), INTENT(in) :: xx
      INTEGER, INTENT(in)                   :: lBound
      INTEGER, INTENT(in)                   :: uBound
      INTEGER, INTENT(out)                  :: ilow
      INTEGER, INTENT(out)                  :: ihigh

!  local variables
      INTEGER :: hBound ! Half way index of the xx array.

!  Start of executable code
!  Perform a tree search to find the interval that x falls between. This
!  algorthim works by dividing the array into two sub arrays then determining if
!  x is in the lower or upper array. Then the algortrim recurses on the sub array
!  until the size of the array equals 2. This assumes that the array xx is
!  correctly sorted.
      IF (uBound - lBound .eq. 1) THEN
         ilow = lBound; ihigh = uBound
         RETURN
      END IF

      hBound = (uBound + lBound)/2
      IF (x .ge. xx(lBound) .and. x .lt. xx(hBound)) THEN
         CALL get_indices(x, xx, lBound, hBound, ilow, ihigh)
      ELSE
         CALL get_indices(x, xx, hBound, uBound, ilow, ihigh)
      END IF
      END SUBROUTINE

!-------------------------------------------------------------------------------
!>  @brief Find the slope of the line.
!>
!>  This find the m of y = m*x + b where x is defined as xx and y is defined as
!>  yy. m is defined as dy/dx.
!>
!>  @param[in] xx    X positions defining the line segments.
!>  @param[in] yy    Y positions defining the line segments.
!>  @param[in] ilow  Index of the lower bound.
!>  @param[in] ihigh Index of the upper bound.
!>  @return The slope of the line between the indicies.
!-------------------------------------------------------------------------------
      PURE FUNCTION slope(yy, xx, ilow, ihigh)

      IMPLICIT NONE

!  Declare Arguments
      REAL(rprec)                           :: slope
      REAL(rprec), DIMENSION(:), INTENT(in) :: xx
      REAL(rprec), DIMENSION(:), INTENT(in) :: yy
      INTEGER, INTENT(in)                   :: ilow
      INTEGER, INTENT(in)                   :: ihigh

!  Start of executable code
      slope = (yy(ihigh) - yy(ilow))/(xx(ihigh) - xx(ilow))

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Find the y intercept of the line.
!>
!>  This finds the b of y = m*x + b where x is defined as xx and y is defined as
!>  yy. b is defined as (x2y1 - x1y2)/(x2 - x1).
!>
!>  @param[in] xx    X positions defining the line segments.
!>  @param[in] yy    Y positions defining the line segments.
!>  @param[in] ilow  Index of the lower bound.
!>  @param[in] ihigh Index of the upper bound.
!>  @returns The y intercept of the line between the indicies.
!-------------------------------------------------------------------------------
      PURE FUNCTION offset(yy, xx, ilow, ihigh)

      IMPLICIT NONE

!  Declare Arguments
      REAL(rprec)                           :: offset
      REAL(rprec), DIMENSION(:), INTENT(in) :: xx
      REAL(rprec), DIMENSION(:), INTENT(in) :: yy
      INTEGER, INTENT(in)                   :: ilow
      INTEGER, INTENT(in)                   :: ihigh

!  Start of executable code
      offset = (xx(ihigh)*yy(ilow) - xx(ilow)*yy(ihigh))                       &
     &       / (xx(ihigh) - xx(ilow))

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Evaluate the line.
!>
!>  Evaluates the line defined by the x and y at the indicies. Avoid a possible
!>  divide by zero when two xx indices have the same value. Handel this by
!>  taking the high index of yy.
!>
!>  @param[in] x     X point to evaluate the line at.
!>  @param[in] xx    X positions defining the line segments.
!>  @param[in] yy    Y positions defining the line segments.
!>  @param[in] ilow  Index of the lower bound.
!>  @param[in] ihigh Index of the upper bound.
!>  @returns y(x).
!-------------------------------------------------------------------------------
      PURE FUNCTION y_value(x, yy, xx, ilow, ihigh)

      IMPLICIT NONE

!  Declare Arguments
      REAL(rprec)                           :: y_value
      REAL(rprec), INTENT(in)               :: x
      REAL(rprec), DIMENSION(:), INTENT(in) :: xx
      REAL(rprec), DIMENSION(:), INTENT(in) :: yy
      INTEGER, INTENT(in)                   :: ilow
      INTEGER, INTENT(in)                   :: ihigh

!  Start of executable code
      IF (xx(ilow) .eq. xx(ihigh)) THEN
         y_value = yy(ihigh)
      ELSE
         y_value = slope(yy, xx, ilow, ihigh)*x                                &
     &           + offset(yy, xx, ilow, ihigh)
      END IF

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Integrate the line.
!>
!>  Evaluates the integral of line defined by the x and y at the indicies. Avoid
!>  a potential divide by zero error when two xx indices have the same value. In
!>  this case, the integral is zero.
!>
!>  @param[in] x0    Starting point of the integration.
!>  @param[in] x1    Ending point of the integration.
!>  @param[in] xx    X positions defining the line segments.
!>  @param[in] yy    Y positions defining the line segments.
!>  @param[in] ilow  Index of the lower bound.
!>  @param[in] ihigh Index of the upper bound.
!>  @returns Int[y(x),x].
!-------------------------------------------------------------------------------
      PURE FUNCTION y_value_int(x0, x1, yy, xx, ilow, ihigh)

      IMPLICIT NONE

!  Declare Arguments
      REAL(rprec)                           :: y_value_int
      REAL(rprec), INTENT(in)               :: x0
      REAL(rprec), INTENT(in)               :: x1
      REAL(rprec), DIMENSION(:), INTENT(in) :: xx
      REAL(rprec), DIMENSION(:), INTENT(in) :: yy
      INTEGER, INTENT(in)                   :: ilow
      INTEGER, INTENT(in)                   :: ihigh

!  Start of executable code
      IF (xx(ilow) .eq. xx(ihigh)) THEN
         y_value_int = 0.0
      ELSE
         y_value_int = slope(yy, xx, ilow, ihigh)                              &
     &               / 2.0*(x1**2.0 - x0**2.0)                                 &
     &               + offset(yy, xx, ilow, ihigh)*(x1 - x0)
      END IF

      END FUNCTION

!*******************************************************************************
!  UNIT TESTS
!*******************************************************************************
!*******************************************************************************
!  Main test function
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Line segment unit test function.
!>
!>  This runs the associated unit tests and returns the result.
!>
!>  @returns True if the tests pass and false otherwise.
!-------------------------------------------------------------------------------
      FUNCTION line_seg_test()

      IMPLICIT NONE

!  Declare Arguments
      LOGICAL     :: line_seg_test

!  local variables
      REAL(rprec) :: result

!  Start of executable code
!  Test slope function. yy(0.0,1.0) and xx(0.0,1.0) should have a slope of 1.0
      result = slope((/ 0.0d+0, 1.0d+0 /),                                     &
     &               (/ 0.0d+0, 1.0d+0 /),                                     &
     &               1, 2)
      line_seg_test = check(1.0d+0, result, 1, "slope()")
      IF (.not.line_seg_test) RETURN
!  Test slope function. yy(1.0,0.0) and xx(0.0,1.0) should have a slope of -1.0
      result = slope((/ 1.0d+0, 0.0d+0 /),                                     &
     &               (/ 0.0d+0, 1.0d+0 /),                                     &
     &               1, 2)
      line_seg_test = check(-1.0d+0, result, 2, "slope()")
      IF (.not.line_seg_test) RETURN
!  Test slope function. yy(1.0,1.0) and xx(0.0,1.0) should have a slope of 0.0
      result = slope((/ 1.0d+0, 1.0d+0 /),                                     &
     &               (/ 0.0d+0, 1.0d+0 /),                                     &
     &               1, 2)
      line_seg_test = check(0.0d+0, result, 3, "slope()")
      IF (.not.line_seg_test) RETURN

!  Test slope function. yy(0.0,1.0) and xx(1.0,2.0) should have a slope of 1.0
      result = slope((/ 0.0d+0, 1.0d+0 /),                                     &
     &               (/ 1.0d+0, 2.0d+0 /),                                     &
     &               1, 2)
      line_seg_test = check(1.0d+0, result, 4, "slope()")

!  Test offset function. yy(0.0,1.0) and xx(0.0,1.0) should have an offset of 0.0
      result = offset((/ 0.0d+0, 1.0d+0 /),                                    &
     &                (/ 0.0d+0, 1.0d+0 /),                                    &
     &                1, 2)
      line_seg_test = check(0.0d+0, result, 1, "offset()")
      IF (.not.line_seg_test) RETURN
!  Test offset function. yy(1.0,0.0) and xx(0.0,1.0) should have an offset of 1.0
      result = offset((/ 1.0d+0, 0.0d+0 /),                                    &
     &                (/ 0.0d+0, 1.0d+0 /),                                    &
     &                1, 2)
      line_seg_test = check(1.0d+0, result, 2, "offset()")
      IF (.not.line_seg_test) RETURN
!  Test offset function. yy(2.0,1.0) and xx(1.0,2.0) should have an offset of 3.0
      result = offset((/ 2.0d+0, 1.0d+0 /),                                    &
     &                (/ 1.0d+0, 2.0d+0 /),                                    &
     &                1, 2)
      line_seg_test = check(3.0d+0, result, 3, "offset()")
      IF (.not.line_seg_test) RETURN

!  Test y_value function. yy(0.0,2.0) and xx(0.0,2.0) should have a value of 1.0
!  at x = 1.0
      result = y_value(1.0d+0,                                                 &
     &                 (/ 0.0d+0, 2.0d+0 /),                                   &
     &                 (/ 0.0d+0, 2.0d+0 /),                                   &
     &                 1, 2)
      line_seg_test = check(1.0d+0, result, 1, "y_value()")
      IF (.not.line_seg_test) RETURN
!  Test y_value function. yy(1.0,2.0) and xx(1.0,2.0) should have a value of 0.0
!  at x = 0.0
      result = y_value(0.0d+0,                                                 &
     &                 (/ 1.0d+0, 2.0d+0 /),                                   &
     &                 (/ 1.0d+0, 2.0d+0 /),                                   &
     &                 1, 2)
      line_seg_test = check(0.0d+0, result, 2, "y_value()")
      IF (.not.line_seg_test) RETURN
!  Test y_value function. yy(0.0,1.0) and xx(0.0,1.0) should have a value of 3.0
!  at x = 3.0
      result = y_value(3.0d+0,                                                 &
     &                 (/ 0.0d+0, 1.0d+0 /),                                   &
     &                 (/ 0.0d+0, 1.0d+0 /),                                   &
     &                 1, 2)
      line_seg_test = check(3.0d+0, result, 3, "y_value()")
      IF (.not.line_seg_test) RETURN

!  Test y_value_int function. yy(1.0,1.0) and xx(0.0,1.0) should have a value of
!  1.0 at x1 = 1.0 to x0 = 0.0
      result = y_value_int(0.0d+0, 1.0d+0,                                     &
     &                    (/ 1.0d+0, 1.0d+0 /),                                &
     &                    (/ 0.0d+0, 1.0d+0 /),                                &
     &                    1, 2)
      line_seg_test = check(1.0d+0, result, 1, "y_value_int()")
      IF (.not.line_seg_test) RETURN

!  Test y_value_int function. yy(1.0,1.0) and xx(1.0,2.0) should have a value of
!  1.0 at x1 = 1.0 to x0 = 0.0
      result = y_value_int(0.0d+0, 1.0d+0,                                     &
     &                    (/ 1.0d+0, 1.0d+0 /),                                &
     &                    (/ 1.0d+0, 2.0d+0 /),                                &
     &                    1, 2)
      line_seg_test = check(1.0d+0, result, 2, "y_value_int()")
      IF (.not.line_seg_test) RETURN
!  Test y_value_int function. yy(1.0,1.0) and xx(0.0,1.0) should have a value of
!  1.0 at x1 = 2.0 to x0 = 1.0
      result = y_value_int(1.0d+0, 2.0d+0,                                     &
     &                    (/ 1.0d+0, 1.0d+0 /),                                &
     &                    (/ 0.0d+0, 1.0d+0 /),                                &
     &                    1, 2)
      line_seg_test = check(1.0d+0, result, 3, "y_value_int()")
      IF (.not.line_seg_test) RETURN
!  Test y_value_int function. yy(0.0,1.0) and xx(0.0,1.0) should have a value of
!  0.5 at x1 = 1.0 to x0 = 0.0
      result = y_value_int(0.0d+0, 1.0d+0,                                     &
     &                    (/ 0.0d+0, 1.0d+0 /),                                &
     &                    (/ 0.0d+0, 1.0d+0 /),                                &
     &                    1, 2)
      line_seg_test = check(0.5d+0, result, 4, "y_value_int()")
      IF (.not.line_seg_test) RETURN
!  Test y_value_int function. yy(1.0,2.0) and xx(0.0,1.0) should have a value of
!  1.5 at x1 = 1.0 to x0 = 0.0
      result = y_value_int(0.0d+0, 1.0d+0,                                     &
     &                    (/ 1.0d+0, 2.0d+0 /),                                &
     &                    (/ 0.0d+0, 1.0d+0 /),                                &
     &                    1, 2)
      line_seg_test = check(1.5d+0, result, 5, "y_value_int()")
      IF (.not.line_seg_test) RETURN
!  Test y_value_int function. yy(1.0,2.0) and xx(1.0,2.0) should have a value of
!  0.5 at x1 = 1.0 to x0 = 0.0
      result = y_value_int(0.0d+0, 1.0d+0,                                     &
     &                    (/ 1.0d+0, 2.0d+0 /),                                &
     &                    (/ 1.0d+0, 2.0d+0 /),                                &
     &                    1, 2)
      line_seg_test = check(0.5d+0, result, 6, "y_value_int()")
      IF (.not.line_seg_test) RETURN
!  Test y_value_int function. yy(0.0,1.0) and xx(0.0,1.0) should have a value of
!  1.5 at x1 = 2.0 to x0 = 1.0
      result = y_value_int(1.0d+0, 2.0d+0,                                     &
     &                    (/ 1.0d+0, 2.0d+0 /),                                &
     &                    (/ 1.0d+0, 2.0d+0 /),                                &
     &                    1, 2)
      line_seg_test = check(1.5d+0, result, 7, "y_value_int()")
      IF (.not.line_seg_test) RETURN

!  Test line_seg function. yy(1.0,1.0,0.0,0.0) and xx(0.0,1.0,2.0,3.0) should
!  have a value of 1.0 at x = 0.5
      CALL line_seg(0.5d+0, result,                                            &
     &              (/ 0.0d+0, 1.0d+0, 2.0d+0, 3.0d+0 /),                      &
     &              (/ 1.0d+0, 1.0d+0, 0.0d+0, 0.0d+0 /),                      &
     &              4)
      line_seg_test = check(1.0d+0, result, 1, "line_seg()")
      IF (.not.line_seg_test) RETURN
!  Test line_seg function. yy(1.0,1.0,0.0,0.0) and xx(0.0,1.0,2.0,3.0) should
!  have a value of 0.0 at x = 2.5
      CALL line_seg(2.5d+0, result,                                            &
     &              (/ 0.0d+0, 1.0d+0, 2.0d+0, 3.0d+0 /),                      &
     &              (/ 1.0d+0, 1.0d+0, 0.0d+0, 0.0d+0 /),                      &
     &              4)
      line_seg_test = check(0.0d+0, result, 2, "line_seg()")
      IF (.not.line_seg_test) RETURN
!  Test line_seg function. yy(1.0,1.0,0.0,0.0) and xx(0.0,1.0,2.0,3.0) should
!  have a value of 0.5 at x = 1.5
      CALL line_seg(1.5d+0, result,                                            &
     &              (/ 0.0d+0, 1.0d+0, 2.0d+0, 3.0d+0 /),                      &
     &              (/ 1.0d+0, 1.0d+0, 0.0d+0, 0.0d+0 /),                      &
     &              4)
      line_seg_test = check(0.5d+0, result, 3, "line_seg()")
      IF (.not.line_seg_test) RETURN
!  Test line_seg function. yy(1.0,1.0,0.0,0.0) and xx(1.0,2.0,3.0,4.0) should
!  have a value of 1.0 at x = 0.0
      CALL line_seg(0.0d+0, result,                                            &
     &              (/ 1.0d+0, 2.0d+0, 3.0d+0, 4.0d+0 /),                      &
     &              (/ 1.0d+0, 1.0d+0, 0.0d+0, 0.0d+0 /),                      &
     &              4)
      line_seg_test = check(1.0d+0, result, 4, "line_seg()")
      IF (.not.line_seg_test) RETURN
!  Test line_seg function. yy(1.0,1.0,0.0,0.0) and xx(0.0,1.0,2.0,3.0) should
!  have a value of 0.0 at x = 4.0
      CALL line_seg(4.0d+0, result,                                            &
     &              (/ 0.0d+0, 1.0d+0, 2.0d+0, 3.0d+0 /),                      &
     &              (/ 1.0d+0, 1.0d+0, 0.0d+0, 0.0d+0 /),                      &
     &              4)
      line_seg_test = check(0.0d+0, result, 5, "line_seg()")
      IF (.not.line_seg_test) RETURN

!  Test line_seg_int function. yy(1.0,1.0,0.0,0.0) and xx(0.0,1.0,2.0,3.0) should
!  have a value of 0.5 at x = 0.5
      CALL line_seg_int(0.5d+0, result,                                        &
     &                  (/ 0.0d+0, 1.0d+0, 2.0d+0, 3.0d+0 /),                  &
     &                  (/ 1.0d+0, 1.0d+0, 0.0d+0, 0.0d+0 /),                  &
     &                  4)
      line_seg_test = check(0.5d+0, result, 1, "line_seg_int()")
      IF (.not.line_seg_test) RETURN
!  Test line_seg_int function. yy(1.0,1.0,0.0,0.0) and xx(0.0,1.0,2.0,3.0) should
!  have a value of 1.375 at x = 1.5
      CALL line_seg_int(1.5d+0, result,                                        &
     &                  (/ 0.0d+0, 1.0d+0, 2.0d+0, 3.0d+0 /),                  &
     &                  (/ 1.0d+0, 1.0d+0, 0.0d+0, 0.0d+0 /),                  &
     &                  4)
      line_seg_test = check(1.375d+0, result, 2, "line_seg_int()")
      IF (.not.line_seg_test) RETURN
!  Test line_seg_int function. yy(1.0,1.0,0.0,0.0) and xx(0.0,1.0,2.0,3.0) should
!  have a value of 1.5 at x = 2.5
      CALL line_seg_int(2.5d+0, result,                                        &
     &                  (/ 0.0d+0, 1.0d+0, 2.0d+0, 3.0d+0 /),                  &
     &                  (/ 1.0d+0, 1.0d+0, 0.0d+0, 0.0d+0 /),                  &
     &                  4)
      line_seg_test = check(1.5d+0, result, 3, "line_seg_int()")
      IF (.not.line_seg_test) RETURN
!  Test line_seg_int function. yy(1.0,1.0,0.0,0.0) and xx(1.0,2.0,3.0,4.0) should
!  have a value of 0.5 at x = 0.5
      CALL line_seg_int(0.5d+0, result,                                        &
     &                  (/ 1.0d+0, 2.0d+0, 3.0d+0, 4.0d+0 /),                  &
     &                  (/ 1.0d+0, 1.0d+0, 0.0d+0, 0.0d+0 /),                  &
     &                  4)
      line_seg_test = check(0.5d+0, result, 4, "line_seg_int()")
      IF (.not.line_seg_test) RETURN
!  Test line_seg_int function. yy(1.0,0.0,0.0,1.0) and xx(0.0,1.0,2.0,3.0) should
!  have a value of 2.5 at x = 4.0
      CALL line_seg_int(4.0d+0, result,                                        &
     &                  (/ 0.0d+0, 1.0d+0, 2.0d+0, 3.0d+0 /),                  &
     &                  (/ 1.0d+0, 0.0d+0, 0.0d+0, 1.0d+0 /),                  &
     &                  4)
      line_seg_test = check(2.5d+0, result, 5, "line_seg_int()")
      IF (.not.line_seg_test) RETURN
!  Test line_seg_int function. yy(1.0,0.0,0.0,1.0) and xx(1.0,2.0,3.0,4.0) should
!  have a value of 4.0 at x = 5.0
      CALL line_seg_int(5.0d+0, result,                                        &
     &                  (/ 1.0d+0, 2.0d+0, 3.0d+0, 4.0d+0 /),                  &
     &                  (/ 1.0d+0, 0.0d+0, 0.0d+0, 1.0d+0 /),                  &
     &                  4)
      line_seg_test = check(4.0d+0, result, 6, "line_seg_int()")
      IF (.not.line_seg_test) RETURN

      END FUNCTION

!*******************************************************************************
!  CHECK FUNCTIONS
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Check a real value.
!>
!>  Checks that the expected value matches the recieved. Otherwise report an
!>  error.
!>
!>  @param[in] expected The known value.
!>  @param[in] received The known test value.
!>  @param[in] testNum  The number of the test.
!>  @param[in] name     The name of the test.
!>  @returns True if the check passes and false otherwise.
!-------------------------------------------------------------------------------
      FUNCTION check(expected, received, testNum, name)

      IMPLICIT NONE

!  Declare Arguments
      LOGICAL                       :: check
      REAL(rprec), INTENT(in)       :: expected
      REAL(rprec), INTENT(in)       :: received
      INTEGER, INTENT(in)           :: testNum
      CHARACTER (LEN=*), INTENT(in) :: name

!  Start of executable code
      check = expected .eq. received
      IF (.not.check) THEN
         WRITE(*,*) "line_segment_mod.f: ", name, " test", testNum,            &
     &              "failed."
         WRITE(*,*) "Expected", expected, "Received", received
      END IF

      END FUNCTION

      END MODULE line_segment


      subroutine dnherm1(x,nx,fherm,ilinx,ier)
C
C  create a data set for Hermite interpolation, based on simple
C  numerical differentiation using the given grid.
C
C  1d routine
C
C  input:
C
      integer nx                        ! array dimensions
      real x(nx)                        ! x coordinate array
      real fherm(0:1,nx)                ! data/Hermite array
C
C  fherm(0,i) = function value f at x(i)       **on input**
C
C  fherm(1,i) = derivative df/dx at x(i)       **on output**
C
C addl output:
C  ilinx=1 if x is "evenly spaced" ier=0 if no errors
C
C  ** x must be strict ascending **
C
C----------------------------
C
      ztol=1.0e-3
      call splinck(x,nx,ilinx,ztol,ier)
      if(ier.ne.0) then
         write(6,*) '?dnherm1:  x axis not strict ascending.'
         return
      endif
C
      do ix=1,nx
c
c  x div. diffs in vicinity
c
         ixp=min(nx,ix+1)
         ixm=max(1,ix-1)
         zd=(fherm(0,ixp)-fherm(0,ixm))/(x(ixp)-x(ixm))
c
         fherm(1,ix)=zd
      enddo
C
      return
      end


!
! Copyright 2020-2022 Fluid Numerics LLC
! Author : Joseph Schoonover (joe@fluidnumerics.com)
! Support : support@fluidnumerics.com
!
! //////////////////////////////////////////////////////////////////////////////////////////////// !
MODULE SELF_LinearShallowWater

  USE SELF_Metadata
  USE SELF_Mesh
  USE SELF_MappedData
  USE SELF_Model

  TYPE,EXTENDS(Model2D) :: LinearShallowWater
    !! iVar = 1 ~> u velocity component
    !! iVar = 2 ~> v velocity component
    !! iVar = 3 ~> free surface height
    REAL(prec) :: fCori ! coriolis parameter ( 1/s )
    REAL(prec) :: g     ! gravity ( m/s^2)
    REAL(prec) :: H     ! fluid thickness ( m )

    CONTAINS

    ! Overridden Methods
    PROCEDURE :: Init => Init_LinearShallowWater
    PROCEDURE :: CalculateEntropy => CalculateEntropy_LinearShallowWater

    ! Concretized Methods
    PROCEDURE :: SourceMethod => Source_LinearShallowWater
    PROCEDURE :: FluxMethod => Flux_LinearShallowWater
    PROCEDURE :: RiemannSolver => RiemannSolver_LinearShallowWater
    PROCEDURE :: SetBoundaryCondition => SetBoundaryCondition_LinearShallowWater

  END TYPE LinearShallowWater

  INTERFACE
    SUBROUTINE SetBoundaryCondition_LinearShallowWater_gpu_wrapper(solution, extBoundary, nHat, sideInfo, N, nVar, nEl) &
      bind(c,name="SetBoundaryCondition_LinearShallowWater_gpu_wrapper")
      USE iso_c_binding
      USE SELF_Constants
      IMPLICIT NONE
      TYPE(c_ptr) :: solution, extBoundary, nHat, sideInfo
      INTEGER(C_INT),VALUE :: N,nVar,nEl
    END SUBROUTINE SetBoundaryCondition_LinearShallowWater_gpu_wrapper
  END INTERFACE

  INTERFACE
    SUBROUTINE Source_LinearShallowWater_gpu_wrapper(source, solution, f, N, nVar, nEl) &
      bind(c,name="Source_LinearShallowWater_gpu_wrapper")
      USE iso_c_binding
      USE SELF_Constants
      IMPLICIT NONE
      TYPE(c_ptr) :: source, solution
      INTEGER(C_INT),VALUE :: N,nVar,nEl
      REAL(c_prec),VALUE :: f
    END SUBROUTINE Source_LinearShallowWater_gpu_wrapper
  END INTERFACE

  INTERFACE
    SUBROUTINE Flux_LinearShallowWater_gpu_wrapper(flux, solution, g, H, N, nVar, nEl) &
      bind(c,name="Flux_LinearShallowWater_gpu_wrapper")
      USE iso_c_binding
      USE SELF_Constants
      IMPLICIT NONE
      TYPE(c_ptr) :: flux, solution
      INTEGER(C_INT),VALUE :: N,nVar,nEl
      REAL(c_prec),VALUE :: g, H
    END SUBROUTINE Flux_LinearShallowWater_gpu_wrapper
  END INTERFACE

  INTERFACE
    SUBROUTINE RiemannSolver_LinearShallowWater_gpu_wrapper(flux, solution, extBoundary, nHat, nScale, g, H, N, nVar, nEl) &
      bind(c,name="RiemannSolver_LinearShallowWater_gpu_wrapper")
      USE iso_c_binding
      USE SELF_Constants
      IMPLICIT NONE
      TYPE(c_ptr) :: flux, solution, extBoundary, nHat, nScale
      INTEGER(C_INT),VALUE :: N,nVar,nEl
      REAL(c_prec),VALUE :: g, H
    END SUBROUTINE RiemannSolver_LinearShallowWater_gpu_wrapper
  END INTERFACE

CONTAINS

  SUBROUTINE Init_LinearShallowWater(this,nvar,mesh,geometry,decomp)
    IMPLICIT NONE
    CLASS(LinearShallowWater),INTENT(out) :: this
    INTEGER,INTENT(in) :: nvar
    TYPE(Mesh2D),INTENT(in),TARGET :: mesh
    TYPE(SEMQuad),INTENT(in),TARGET :: geometry
    TYPE(MPILayer),INTENT(in),TARGET :: decomp
    ! Local
    INTEGER :: ivar
    CHARACTER(LEN=3) :: ivarChar
    CHARACTER(LEN=25) :: varname
    INTEGER :: nvarloc

    ! Ensure that the number of variables is 3
    ! nvar is unused in this class extension
    nvarloc = 3

    this % decomp => decomp
    this % mesh => mesh
    this % geometry => geometry
    this % gpuAccel = .FALSE.
    this % fluxDivMethod = SELF_CONSERVATIVE_FLUX
    this % g = 1.0_prec
    this % H = 1.0_prec
    this % fCori = 0.0_prec

    CALL this % solution % Init(geometry % x % interp,nvarloc,this % mesh % nElem)
    CALL this % workSol % Init(geometry % x % interp,nVar,this % mesh % nElem)
    CALL this % velocity % Init(geometry % x % interp,1,this % mesh % nElem)
    CALL this % compVelocity % Init(geometry % x % interp,1,this % mesh % nElem)
    CALL this % dSdt % Init(geometry % x % interp,nvarloc,this % mesh % nElem)
    CALL this % solutionGradient % Init(geometry % x % interp,nvarloc,this % mesh % nElem)
    CALL this % flux % Init(geometry % x % interp,nvarloc,this % mesh % nElem)
    CALL this % source % Init(geometry % x % interp,nvarloc,this % mesh % nElem)
    CALL this % fluxDivergence % Init(geometry % x % interp,nvarloc,this % mesh % nElem)

    ! First three variables are treated as u, v, eta
    ! Any additional are treated as passive tracers
    CALL this % solution % SetName(1,"u")
    CALL this % solution % SetUnits(1,"m/s")
    CALL this % solution % SetDescription(1,"x-component of the barotropic velocity field")

    CALL this % solution % SetName(2,"v")
    CALL this % solution % SetUnits(2,"m/s")
    CALL this % solution % SetDescription(2,"y-component of the barotropic velocity field")

    CALL this % solution % SetName(3,"eta")
    CALL this % solution % SetUnits(3,"m")
    CALL this % solution % SetDescription(3,"Free surface height anomaly")

  END SUBROUTINE Init_LinearShallowWater

  SUBROUTINE CalculateEntropy_LinearShallowWater(this)
  !! Base method for calculating entropy of a model
  !! Calculates the entropy as the integration of the
  !! squared tracer over the domain
    IMPLICIT NONE
    CLASS(LinearShallowWater), INTENT(inout) :: this
    ! Local
    INTEGER :: i, j, iVar, iEl
    REAL(prec) :: Jacobian, u, v, eta
    REAL(prec) :: wi,wj

    ! TO DO : GPU reduction

    this % entropy = 0.0_prec

    DO iEl = 1, this % geometry % x % nElem
        DO j = 0, this % geometry % x % interp % N
          DO i = 0, this % geometry % x % interp % N

            ! Coordinate mapping Jacobian
            Jacobian = this % geometry % J % interior % hostData(i,j,1,iEl)

            ! Quadrature weights
            wi = this % geometry % x % interp % qWeights % hostData(i)
            wj = this % geometry % x % interp % qWeights % hostData(j)

            ! Solution
            u = this % solution % interior % hostData(i,j,1,iEl)
            v = this % solution % interior % hostData(i,j,2,iEl)
            eta = this % solution % interior % hostData(i,j,3,iEl)

            this % entropy = this % entropy + 0.5_prec*( this % H*(u*u + v*v) + this % g*eta*eta )*Jacobian*wi*wj

          ENDDO
        ENDDO
    ENDDO

  END SUBROUTINE CalculateEntropy_LinearShallowWater

  SUBROUTINE SetBoundaryCondition_LinearShallowWater(this)
    IMPLICIT NONE
    CLASS(LinearShallowWater),INTENT(inout) :: this
    ! Local
    INTEGER :: iEl, iSide, i
    INTEGER :: bcid, e2
    REAL(prec) :: u, v, nhat(1:2)

    IF( this % gpuAccel )THEN

      CALL SetBoundaryCondition_LinearShallowWater_gpu_wrapper( this % solution % boundary % deviceData,&
            this % solution % extBoundary % deviceData, &
            this % geometry % nHat % boundary % deviceData, &
            this % mesh % sideInfo % deviceData, &
            this % solution % interp % N, &
            this % solution % nVar, &
            this % solution % nElem)

    ELSE

      DO iEl = 1, this % solution % nElem
        DO iSide = 1, 4
            DO i = 0, this % solution % interp % N

              bcid = this % mesh % sideInfo % hostData(5,iSide,iEl) ! Boundary Condition ID
              e2 = this % mesh % sideInfo % hostData(3,iSide,iEl) ! Neighboring Element ID
              IF( e2 == 0 )THEN
                IF( bcid == SELF_BC_RADIATION )THEN

                  this % solution % extBoundary % hostData(i,1,iSide,iEl) = 0.0_prec
                  this % solution % extBoundary % hostData(i,2,iSide,iEl) = 0.0_prec
                  this % solution % extBoundary % hostData(i,3,iSide,iEl) = 0.0_prec

                ELSEIF( bcid == SELF_BC_NONORMALFLOW )THEN

                  nhat(1:2) = this % geometry % nHat % boundary % hostData(1:2,i,1,iSide,iEl)
                  u = this % solution % boundary % hostData(i,1,iSide,iEl)
                  v = this % solution % boundary % hostData(i,2,iSide,iEl)
                  this % solution % extBoundary % hostData(i,1,iSide,iEl) = (nhat(2)**2 - nhat(1)**2)*u - 2.0_prec*nhat(1)*nhat(2)*v
                  this % solution % extBoundary % hostData(i,2,iSide,iEl) = (nhat(1)**2 - nhat(2)**2)*v - 2.0_prec*nhat(1)*nhat(2)*u
                  this % solution % extBoundary % hostData(i,3,iSide,iEl) = this % solution % boundary % hostData(i,3,iSide,iEl)

                ELSE ! Default boundary condition is radiation

                  this % solution % extBoundary % hostData(i,1,iSide,iEl) = 0.0_prec
                  this % solution % extBoundary % hostData(i,2,iSide,iEl) = 0.0_prec
                  this % solution % extBoundary % hostData(i,3,iSide,iEl) = 0.0_prec

                ENDIF
              ENDIF

            ENDDO
        ENDDO
      ENDDO

    ENDIF

  END SUBROUTINE SetBoundaryCondition_LinearShallowWater

  SUBROUTINE Source_LinearShallowWater(this)
    IMPLICIT NONE
    CLASS(LinearShallowWater),INTENT(inout) :: this
    ! Local
    INTEGER :: i,j,iEl,iVar

    IF( this % gpuAccel )THEN

      CALL Source_LinearShallowWater_gpu_wrapper(this % source % interior % deviceData,&
             this % solution % interior % deviceData, &
             this % fCori,&
             this % source % interp % N, &
             this % solution % nVar, &
             this % solution % nElem )

    ELSE

      DO iEl = 1, this % source % nElem
        DO j = 0, this % source % interp % N
          DO i = 0, this % source % interp % N

            this % source % interior % hostData(i,j,1,iEl) = -this % fCori*this % solution % interior % hostData(i,j,2,iEl)
            this % source % interior % hostData(i,j,2,iEl) = this % fCori*this % solution % interior % hostData(i,j,1,iEl)
            this % source % interior % hostData(i,j,3,iEl) = 0.0_prec

          ENDDO
        ENDDO
      ENDDO

    ENDIF

  END SUBROUTINE Source_LinearShallowWater

  SUBROUTINE Flux_LinearShallowWater(this)
    IMPLICIT NONE
    CLASS(LinearShallowWater),INTENT(inout) :: this
    ! Local
    INTEGER :: i,j,iEl,iVar

    IF( this % gpuAccel )THEN

      CALL Flux_LinearShallowWater_gpu_wrapper(this % flux % interior % deviceData,&
                                               this % solution % interior % deviceData, &
                                               this % g, this % H, this % solution % interp % N, &
                                               this % solution % nVar, this % solution % nElem)

    ELSE
      DO iEl = 1, this % solution % nElem
        DO iVar = 1, this % solution % nVar
          DO j = 0, this % solution % interp % N
            DO i = 0, this % solution % interp % N

              IF ( iVar == 1 )THEN ! u-velocity
                this % flux % interior % hostData(1,i,j,iVar,iEl) = &
                      this % g*this % solution % interior % hostData(i,j,3,iEl)

                this % flux % interior % hostData(2,i,j,iVar,iEl) = 0.0_prec

              ELSEIF ( iVar == 2 )THEN ! v-velocity

                this % flux % interior % hostData(1,i,j,iVar,iEl) = 0.0_prec

                this % flux % interior % hostData(2,i,j,iVar,iEl) = &
                      this % g*this % solution % interior % hostData(i,j,3,iEl)

              ELSEIF ( iVar == 3 )THEN ! free surface height
                this % flux % interior % hostData(1,i,j,iVar,iEl) = &
                      this % H*this % solution % interior % hostData(i,j,1,iEl)

                this % flux % interior % hostData(2,i,j,iVar,iEl) = &
                      this % H*this % solution % interior % hostData(i,j,2,iEl)
              ENDIF

            ENDDO
          ENDDO
        ENDDO
      ENDDO
    ENDIF

  END SUBROUTINE Flux_LinearShallowWater

  SUBROUTINE RiemannSolver_LinearShallowWater(this)
    IMPLICIT NONE
    CLASS(LinearShallowWater),INTENT(inout) :: this
    ! Local
    INTEGER :: i,iSide,iEl
    REAL(prec) :: nhat(1:2), nmag
    REAL(prec) :: c, unL, unR, etaL, etaR, wL, wR

    IF( this % gpuAccel )THEN

      CALL RiemannSolver_LinearShallowWater_gpu_wrapper(this % flux % boundaryNormal % deviceData, &
             this % solution % boundary % deviceData, &
             this % solution % extBoundary % deviceData, &
             this % geometry % nHat % boundary % deviceData, &
             this % geometry % nScale % boundary % deviceData, &
             this % g, this % H, &
             this % solution % interp % N, &
             this % solution % nVar, &
             this % solution % nElem)

    ELSE

      DO iEl = 1, this % solution % nElem
        DO iSide = 1, 4
          DO i = 0, this % solution % interp % N

             ! Get the boundary normals on cell edges from the mesh geometry
             nhat(1:2) = this % geometry % nHat % boundary % hostData(1:2,i,1,iSide,iEl)
             nmag = this % geometry % nScale % boundary % hostData(i,1,iSide,iEl)
             c = sqrt( this % g * this % H )

             ! Calculate the normal velocity at the cell edges
             unL = this % solution % boundary % hostData(i,1,iSide,iEl)*nHat(1)+&
                   this % solution % boundary % hostData(i,2,iSide,iEl)*nHat(2)

             unR = this % solution % extBoundary % hostData(i,1,iSide,iEl)*nHat(1)+&
                   this % solution % extBoundary % hostData(i,2,iSide,iEl)*nHat(2)

             etaL = this % solution % boundary % hostData(i,3,iSide,iEl)
             etaR = this % solution % extBoundary % hostData(i,3,iSide,iEl)

             ! Pull external and internal state for the Riemann Solver (Lax-Friedrichs)
             wL = 0.5_prec*(unL/this % g + etaL/c)
             wR = 0.5_prec*(unR/this % g - etaR/c)

             this % flux % boundaryNormal % hostData(i,1,iSide,iEl) = this % g*c*( wL - wR )*nHat(1)*nmag
             this % flux % boundaryNormal % hostData(i,2,iSide,iEl) = this % g*c*( wL - wR )*nHat(2)*nmag
             this % flux % boundaryNormal % hostData(i,3,iSide,iEl) = c*c*( wL + wR )*nmag

          ENDDO
        ENDDO
      ENDDO

    ENDIF

  END SUBROUTINE RiemannSolver_LinearShallowWater

END MODULE SELF_LinearShallowWater