SUBROUTINE OUTWIN(A,B,nodes,VAL,SLO,REL,V,Rnot,dh,nrpt,EH,FL,Z)
  !         Integration of skalarrel. Schroedinger Equation
  ! ----------------------------------------------------------------
  !  Input:
  !    EH    Energy in Hartree
  !    FL    Angular momentum
  !    Z     Nuclear charge
  !    V     rad.sym. Potential in Hartree
  !    RNOT  first radial grid point
  !    DH    log. increment
  !    Nr    Number of radial mesh points
  !  Output:
  !    VAL,SLO:  Wave function and gradient at the spherical boundary
  !    Nodes:    number of nodes
  !
  !    Rydberg units
  !    A and B are the solution of the Schroedinger-like equation -a''+ (l(l+1)/r^2 -2*U(r)/r-enu)a=0
  !    Here a is normalize like Int[ a(r)**2, dr]=1
  !    VAL is u(r)/r at R_{MT} and SLO is derivative d(a/r) = ( da/dr - a/r)/r at R_MT
  ! ----------------------------------------------------------------
  IMPLICIT NONE
  !
  REAL*8,  intent(out) :: A(nrpt), B(nrpt)    ! solution with large and small component
  INTEGER, intent(out) :: nodes               ! number of nodes
  REAL*8,  intent(out) :: val, slo            ! value at the spherical boundary:
  LOGICAL, intent(in)  :: REL
  REAL*8,  intent(in)  :: V(*)
  REAL*8,  intent(in)  :: Rnot, dh, EH, Z, FL ! radial grid-points, log. increment, Energy in Rydbergs, nuclear charge
  INTEGER, intent(in)  :: nrpt                 ! Number of radial mesh points, Angular momentum l
  !    for large component u(r)=g(r,1) with psi=(u/r)*ylm
  !           val is u(rmax), i.e. (rmax * radial w.f.)
  !           slo is radial derivative of g at rmax (rmax * radial w.f.)'
  !
  ! Note: if r = b(exp(a*z)-1) then Jacobian dr=a(r+b) dz
  !
  ! locals
  INTEGER :: iiij, K
  REAL*8  :: Rnet(nrpt)
  REAL*8  :: D(2,3), E, C, FLLP1, R83SQ, R1, R2, R3, H83, G0, AA, X, Y, U, ZZ, DRDI
  REAL*8  :: DG1, DG2, DG3, DF1, DF2, DF3, F0, S, SF, B1, B2, DET, PHI, R
  !print *, 'Inside OUTWIN r0=', Rnot, 'Eh=', EH, 'FL=', FL, 'Z=', Z, 'NRAD=', NRAD
  !
  !print *, '**********outwin******'
  !print *, 'rel=', REL
  !print *, 'V(0)=', V(1)
  !print *, 'Rnot=', Rnot
  !print *, 'DH=', DH
  !print *, 'NRPT=', NRPT
  !print *, 'EH=', EH
  !print *, 'FL=',FL
  !print *, 'Z=', Z
  !print *, 'nrad=', nrad
  !print *, 'VAL=', VAL
  !print *, 'SLO=', SLO
  !print *, 'Nodes=', Nodes
  !
  E=EH*2.d0  ! Converts from Hartree to Rydbergs
  A(:)=0.d0
  B(:)=0.d0
  !
  DO iiij=1,NRPT
     Rnet(iiij)=RNOT*(exp(DH*(iiij-1.d0)))
  ENDDO
  !C
  Nodes = 0
  ZZ = Z + Z
  C = 2.d0*137.0359895d0
  !
  if(.not.rel) C=1e10   !  set to infinity
  !
  FLLP1 = FL*(FL + 1.d0)
  R83SQ = 64.D0/9.D0
  R1 = 1.D0/9.D0
  R2 = -5.D0*R1
  R3 = 19.D0*R1
  H83 = 8.D0/3.D0
  !
  G0 = 1.d0
  IF (Z .LT. 0.9D0) THEN
     S = FL+1.d0
     SF = FL
     F0 = FL/C
  ELSE
     AA = ZZ/C
     S = DSQRT(FLLP1 + 1.D0 - AA*AA)
     SF = S
     F0 = G0*(S - 1.D0)/AA
  ENDIF
  DO K = 1,3
     R = RNET(K)
     DRDI = DH*R
     A(K) = (R**S)*G0
     B(K) = (R**SF)*F0
     D(1,K) = DRDI*A(K)*S/R
     D(2,K) = DRDI*B(K)*SF/R
  ENDDO
  !
  !
  DG1 = D(1,1)
  DG2 = D(1,2)
  DG3 = D(1,3)
  DF1 = D(2,1)
  DF2 = D(2,2)
  DF3 = D(2,3)
  DO  K = 4, NRPT
     R = RNET(K)
     DRDI = DH*R
     !
     !       Factor two in front of V because of Hartree-Rdyberg units!
     !
     PHI = (E - 2.d0*V(K)/R)*DRDI/C
     U = DRDI*C + PHI
     X = -DRDI/R
     Y = -FLLP1*X*X/U + PHI
     DET = R83SQ - X*X + U*Y
     B1 = A(K-1)*H83 + R1*DG1 + R2*DG2 + R3*DG3
     B2 = B(K-1)*H83 + R1*DF1 + R2*DF2 + R3*DF3
     A(K) = (B1*(H83-X) + B2*U)/DET
     B(K) = (B2*(H83+X) - B1*Y)/DET
     IF (A(K)*A(K-1) .LT. 0D0) Nodes = Nodes + 1
     DG1 = DG2
     DG2 = DG3
     DG3 = U*B(K) - X*A(K)
     DF1 = DF2
     DF2 = DF3
     DF3 = X*B(K) - Y*A(K)
  ENDDO
  !
  !
  DO iiij=1,NRPT
     B(iiij)=B(iiij)*c/2.d0
  ENDDO
  !
  VAL = A(NRPT)/RNET(NRPT)
  SLO = DG3/(DH*RNET(NRPT))
  SLO = (SLO-VAL)/RNET(NRPT)
  RETURN
END SUBROUTINE OUTWIN

FUNCTION RINT13g(REL,A,B,X,Y,dh,nrpt,Rnot) result(S)
  ! C1=1, C2=[1.d0/137.0359895d0**2 or 0]
  IMPLICIT NONE
  !     PERFORM RADIAL INTEGRALS REQUIRED BY BHDK13
  !     Nornally C1=1 and C2=1/speed_of_light^2
  !        but here C1 and C2 are arbitrary
  !                            D.D.KOELLING
  REAL*8 :: S
  !REAL*8, intent(in) :: C1, C2  ! c1 fine structure constant = 1, c2 fine structure constant = [0 or 1/137^2 for scalar-relativistic calculations]
  LOGICAL,intent(in) :: REL
  REAL*8, intent(in) :: A(*) ! r * u (r) on the radial mesh
  REAL*8, intent(in) :: B(*) ! r * us(r) on the radial mesh
  REAL*8, intent(in) :: X(*) ! r * v (r) on the radial mesh
  REAL*8, intent(in) :: Y(*) ! r * vs(r) on the radial mesh
  INTEGER, intent(in):: nrpt
  REAL*8, intent(in) :: dh, Rnot
  ! locals
  INTEGER:: J, J1
  REAL*8 :: c1, c2
  REAL*8 :: D, P1, P2, R, R1, Z2, Z4

  c1 = 1.d0
  c2 = 1.d0/137.0359895d0**2
  if (.not.REL) c2 = 1e-22

  D = EXP(dh)
  J = 3-MOD(nrpt,2)
  J1=J-1
  R = rnot*(D**(J-1))
  R1 = R/D
  Z4 = 0
  Z2 = 0
  DO
     Z4=Z4+R*(C1*A(J)*X(J) + C2*B(J)*Y(J))     ! Z4 ~ R*A*X (r)
     R=R*D
     J=J+1
     IF (J .GE. nrpt) EXIT !GOTO 20
     Z2 = Z2 + R*(C1*A(J)*X(J) + C2*B(J)*Y(J))  ! Z2 ~ R*A*X (r+dr)
     R=R*D
     J=J+1
  enddo
  P1 = Rnot*(C1*A(1)*X(1) + C2*B(1)*Y(1))
  P2 = R1*(C1*A(J1)*X(J1) + C2*B(J1)*Y(J1))
  S = 2*Z2 + 4*Z4 + R*(C1*A(J)*X(J) + C2*B(J)*Y(J)) + P2
  S = (dh*S+P1)/3.0D+0
  IF (J1.GT.1) S=S+0.5D0*dh*(P1+P2)
  RETURN
END FUNCTION RINT13g

FUNCTION RINT13_nr(A,X,dh,nrpt,Rnot) result(S)
  ! This is non-relativistic version
  ! C1=1, C2=0
  IMPLICIT NONE
  !     PERFORM RADIAL INTEGRALS REQUIRED BY BHDK13
  !     Nornally C1=1 and C2=1/speed_of_light^2
  !        but here C1=1 and C2 =0
  !                            D.D.KOELLING
  REAL*8 :: S
  REAL*8, intent(in) :: A(*) ! r * u (r) on the radial mesh
  REAL*8, intent(in) :: X(*) ! r * v (r) on the radial mesh
  INTEGER, intent(in):: nrpt
  REAL*8, intent(in) :: dh, Rnot
  ! locals
  INTEGER:: J, J1
  !REAL*8 :: c1, c2
  REAL*8 :: D, P1, P2, R, R1, Z2, Z4

  !c1 = 1.d0
  !c2 = 1.d0/137.0359895d0**2
  !if (.not.REL) c2 = 1e-22

  D = EXP(dh)
  J = 3-MOD(nrpt,2)
  J1=J-1
  R = rnot*(D**(J-1))
  R1 = R/D
  Z4 = 0
  Z2 = 0
  DO
     Z4=Z4+R*A(J)*X(J)     ! Z4 ~ R*A*X (r)
     R=R*D
     J=J+1
     IF (J .GE. nrpt) EXIT !GOTO 20
     Z2 = Z2 + R*A(J)*X(J)  ! Z2 ~ R*A*X (r+dr)
     R=R*D
     J=J+1
  enddo
  P1 = Rnot*A(1)*X(1)
  P2 = R1*A(J1)*X(J1)
  S = 2*Z2 + 4*Z4 + R*A(J)*X(J) + P2
  S = (dh*S+P1)/3.0D+0
  IF (J1.GT.1) S=S+0.5D0*dh*(P1+P2)
  RETURN
END FUNCTION RINT13_nr


      subroutine reset_internal_e(lo,hi, &
                                  u,u_l1,u_l2,u_l3,u_h1,u_h2,u_h3, &
                                  d,d_l1,d_l2,d_l3,d_h1,d_h2,d_h3, &
                                  r,r_l1,r_l2,r_l3,r_h1,r_h2,r_h3, &
                                  print_fortran_warnings, comoving_a) &
                                  bind(C, name="reset_internal_e")

      use amrex_fort_module, only : rt => amrex_real
      use eos_module
      use meth_params_module, only : NVAR, URHO, UMX, UMY, UMZ, UEDEN, UEINT, small_temp, &
                                     NDIAG, NE_COMP
      use  eos_params_module

      implicit none

      integer          :: lo(3), hi(3)
      integer          :: print_fortran_warnings
      integer          :: u_l1,u_l2,u_l3,u_h1,u_h2,u_h3
      integer          :: d_l1,d_l2,d_l3,d_h1,d_h2,d_h3
      integer          :: r_l1,r_l2,r_l3,r_h1,r_h2,r_h3
      real(rt) :: u(u_l1:u_h1,u_l2:u_h2,u_l3:u_h3,NVAR)
      real(rt) :: d(d_l1:d_h1,d_l2:d_h2,d_l3:d_h3,NDIAG)
      real(rt) :: r(r_l1:r_h1,r_l2:r_h2,r_l3:r_h3)

      real(rt), intent(in   ) :: comoving_a

      ! Local variables
      integer          :: i,j,k
      real(rt) :: Up, Vp, Wp, ke, rho_eint, eint_new
      real(rt) :: dummy_pres, rhoInv

      ! Reset internal energy if necessary
      do k = lo(3),hi(3)
      do j = lo(2),hi(2)
      do i = lo(1),hi(1)

           rhoInv = 1.0d0 / u(i,j,k,URHO)
           Up     = u(i,j,k,UMX) * rhoInv
           Vp     = u(i,j,k,UMY) * rhoInv
           Wp     = u(i,j,k,UMZ) * rhoInv
           ke     = 0.5d0 * u(i,j,k,URHO) * (Up*Up + Vp*Vp + Wp*Wp)

           rho_eint = u(i,j,k,UEDEN) - ke

           ! Reset (e from e) if it's greater than 0.01% of big E.
           if (rho_eint .gt. 0.d0 .and. rho_eint / u(i,j,k,UEDEN) .gt. 1.d-6) then

              ! Create reset source so u(i,j,k,UEINT) = u(i,j,k,UEINT) + r(i,j,k) = rho_eint
               r(i,j,k) = rho_eint - u(i,j,k,UEINT)
               u(i,j,k,UEINT) = rho_eint

           ! If (e from E) < 0 or (e from E) < .0001*E but (e from e) > 0.
           else if (u(i,j,k,UEINT) .gt. 0.d0) then

              ! e is not updated, so reset source is zero
              r(i,j,k) = 0.d0
              u(i,j,k,UEDEN) = u(i,j,k,UEINT) + ke

           ! If not resetting and little e is negative ...
           else if (u(i,j,k,UEINT) .le. 0.d0) then

              call nyx_eos_given_RT(eint_new, dummy_pres, u(i,j,k,URHO), small_temp, &
                                    d(i,j,k,NE_COMP),comoving_a)

              if (print_fortran_warnings .gt. 0) then
                 print *,'   '
                 print *,'>>> Warning: Nyx_3d::reset_internal_energy  ',i,j,k
                 print *,'>>> ... Resetting neg. e from EOS using small_temp: ',small_temp,&
                         ' from ',u(i,j,k,UEINT)/u(i,j,k,URHO),' to ', eint_new
                 call flush(6)
              end if

              ! Create reset source so u(i,j,k,UEINT) = u(i,j,k,UEINT) + r(i,j,k) = u(i,j,k,URHO) * eint_new
              r(i,j,k) = u(i,j,k,URHO) *  eint_new - u(i,j,k,UEINT)
              u(i,j,k,UEINT) = u(i,j,k,URHO) *  eint_new

              u(i,j,k,UEDEN) = u(i,j,k,UEINT) + ke

           end if

           ! Scale reset source by 1/rho so src is in terms of e
!           r(i,j,k) = r(i,j,k) / u(i,j,k,URHO)

      enddo
      enddo
      enddo

      end subroutine reset_internal_e


c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
c RCS version control information:
c $Header: /home/users/buras/cvs2svn-2.3.0/cvs/libRadtran/libsrc_f/BDREF.f,v 1.16 2011-02-24 19:14:22 bernhard Exp $
c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      REAL FUNCTION RPV_REFLECTION (RHO0, K, THETA, SIGMA, T1, T2,
     &     SCALE, MU1EXT, MU2EXT, PHIEXT, BADMU)
C       Computes the Rahman, Pinty, Verstraete BRDF.  The incident
C     and outgoing cosine zenith angles are MU1 and MU2, respectively,
C     and the relative azimuthal angle is PHI.  In this case the incident
C     direction is where the radiation is coming from, so MU1>0 and
C     the hot spot is MU2=MU1 and PHI=180 (the azimuth convention is
C     different from the original Frank Evans code).
C     The reference is:
C       Rahman, Pinty, Verstraete, 1993: Coupled Surface-Atmosphere
C       Reflectance (CSAR) Model. 2. Semiempirical Surface Model Usable
C       With NOAA Advanced Very High Resolution Radiometer Data,
C       J. Geophys. Res., 98, 20791-20801.
      IMPLICIT  NONE

      REAL RHO0, K, THETA, SIGMA, T1, T2, SCALE, MU1EXT, MU2EXT
      REAL PHIEXT, BADMU

      REAL M, F, H, COSPHI, SIN1, SIN2, COSG, TAN1, TAN2, CAPG
      REAL HSPOT, T, G
      REAL MU1, MU2, PHI

C     Work on copies
      MU1 = MU1EXT
      MU2 = MU2EXT
      PHI = PHIEXT

C     Azimuth convention different from Frank Evans:
C     Here PHI=0 means the backward direction while
C     while in DISORT PHI=0 means forward.
      PHI = 3.1415926 - PHI

C     Don't allow mu's smaller than BADMU because
C     the albedo is larger than 1 for those
      IF (BADMU .GT. 0) THEN
         IF (MU1 .LT. BADMU) THEN
            MU1 = BADMU
         ENDIF

         IF (MU2 .LT. BADMU) THEN
            MU2 = BADMU
         ENDIF
      ENDIF

C     Special treatment of hot spot
      IF ( PHI .EQ. 0.0 .AND. MU1 .EQ. MU2) THEN
         HSPOT = RHO0 * ((2*MU1*MU1*MU1)**(K-1) *
     &        (1-THETA)/(1+THETA)/(1+THETA) * (2-RHO0)
     &        + SIGMA/MU1) * (T1*EXP(3.1415926*T2)+1.0)

         RPV_REFLECTION = HSPOT * SCALE
         RETURN
      ENDIF

      M = (MU1 * MU2 * (MU1 + MU2))**(K-1)
      COSPHI = COS(PHI)
      SIN1 = SQRT(1.0-MU1**2)
      SIN2 = SQRT(1.0-MU2**2)
      COSG = MU1*MU2 + SIN1*SIN2*COSPHI
      G = ACOS(COSG)
      F = (1-THETA**2) / (1 + 2*THETA*COSG + THETA**2)**1.5

      TAN1 = SIN1/MU1
      TAN2 = SIN2/MU2
      CAPG = SQRT( TAN1**2 + TAN2**2 - 2*TAN1*TAN2*COSPHI )
      H = 1 + (1-RHO0)/(1+CAPG)
      T = 1 + T1*EXP(T2*(3.1415926-G))

      RPV_REFLECTION = RHO0 * (M * F * H + SIGMA/MU1) * T * SCALE

      IF (RPV_REFLECTION .LE. 0.0) THEN
         RPV_REFLECTION = 0.0
      ENDIF

      RETURN
      END

      REAL FUNCTION  BDREF( WVNMLO, WVNMHI, MU, MUP, DPHI,
     &                      type,
     &                      rho0, k, theta, sigma, t1, t2, scale,
     &                      iso, vol, geo,
     &                      u10, pcl, xsal,
     &                      callnum, FAST_SURFACE )
c
c      Supplies surface bi-directional reflectivity.
c
c      NOTE 1: Bidirectional reflectivity in DISORT is defined
c              by Eq. 39 in STWL.
c      NOTE 2: Both MU and MU0 (cosines of reflection and incidence
c              angles) are positive.
c
c  INPUT:
c
c    WVNMLO : Lower wavenumber (inv cm) of spectral interval
c
c    WVNMHI : Upper wavenumber (inv cm) of spectral interval
c
c    MU     : Cosine of angle of reflection (positive)
c
c    MUP    : Cosine of angle of incidence (positive)
c
c    DPHI   : Difference of azimuth angles of incidence and reflection
c                (radians)
c
c
c   Called by- DREF, SURFAC

c +-------------------------------------------------------------------+
c
      IMPLICIT  NONE

c     .. Scalar Arguments ..
      REAL      DPHI, MU, MUP, WVNMHI, WVNMLO
      INTEGER   TYPE
      REAL      RHO0, K, THETA, SIGMA, T1, T2, SCALE
      REAL      ISO, VOL, GEO
      REAL      U10, PCL, XSAL
      INTEGER   CALLNUM
c     .. Internal variables
c     REAL CR, CI,
      LOGICAL INPERR, FAST_SURFACE
      INTEGER IRMU
      REAL WAVLEN, TEMP, FLXALB, RMU, BADMU
      REAL      SWVNMHI, SWVNMLO, SRHO0, SK, STHETA
      REAL      SSIGMA, ST1, ST2, SSCALE
      REAL      SISO, SVOL, SGEO
      REAL      SMU, SMUP, SDPHI

c     .. Function
      REAL RPV_REFLECTION, DREF2
      Logical WRTBAD2

      DATA BADMU    /-999.0/
      SAVE BADMU
      SAVE SWVNMHI, SWVNMLO, SRHO0, SK, STHETA
      SAVE SSIGMA, ST1, ST2, SSCALE
      SAVE SISO, SVOL, SGEO

c     ??? need to adapt FIRSTRPV as in ocean.c
c     ??? it's not just the first call - it's any call after a change
c
c     wavelength = 1 / average wavenumber
      WAVLEN = 2.E4 / (WVNMLO + WVNMHI)
      TEMP = 273.

      if (TYPE .EQ. 1) THEN

c     Apply DISORT2 test; use exactly the same angular grids etc.
c     Determine the smallest angle for which the albedo is lower
c     than 1 and use this angle as lower limit in the following
c     BDREF calls.
         if ( (SWVNMLO .NE. WVNMLO) .OR.
     &        (SWVNMHI .NE. WVNMHI) .OR.
     &        (SRHO0   .NE. RHO0)   .OR.
     &        (SK      .NE. K)      .OR.
     &        (STHETA  .NE. THETA)  .OR.
     &        (SSIGMA  .NE. SIGMA)  .OR.
     &        (ST1     .NE. T1)     .OR.
     &        (ST2     .NE. T2)     .OR.
     &        (SSCALE  .NE. SCALE)) THEN

            SWVNMLO = WVNMLO
            SWVNMHI = WVNMHI
            SRHO0   = RHO0
            SK      = K
            STHETA  = THETA
            SSIGMA  = SIGMA
            ST1     = T1
            ST2     = T2
            SSCALE  = SCALE

            BADMU = 0.0

            DO IRMU = 100,0,-1

               RMU  = IRMU*0.01

               FLXALB = DREF2( WVNMLO, WVNMHI, RMU,
     &              TYPE, RHO0, K, THETA,
     &              SIGMA, T1, T2,
     &              SCALE, ISO, VOL, GEO, U10, PCL, XSAL, CALLNUM,
     &              FAST_SURFACE )

               IF( FLXALB.LT.0.0 .OR. FLXALB.GT.1.0 ) THEN
                  BADMU = (IRMU+1)*0.01
                  IF (BADMU .GT. 1.0)  BADMU = 1.0
                  write (0,*) '*** Using',BADMU,
     &                 ' as limiting mu in AMBRALS'
                  GOTO 80
               ENDIF

            ENDDO

 80         CONTINUE

         ENDIF

         BDREF = RPV_REFLECTION (RHO0, K, THETA, SIGMA, T1, T2,
     &        SCALE, MUP, MU, DPHI, BADMU)
      ENDIF

      if (TYPE .EQ. 2) THEN

c    call C wrapper function
         call oceanfort( WVNMLO, WVNMHI, MU, MUP, DPHI,
     &        U10, PCL, XSAL, CALLNUM, BDREF )

c     Remove BRDFs smaller than 0
         if (BDREF .LT. 0)  BDREF = 0

c     Check for NaN
         if (BDREF .NE. BDREF) THEN
            write (0,*) 'BDREF', WVNMLO, WVNMHI, MU, MUP, DPHI, BDREF
            BDREF = 1
         ENDIF
      ENDIF

      if (TYPE .EQ. 3) THEN

c     mu=0 or dmu=0 cause problems
         if ( (SISO .NE. ISO) .OR.
     &        (SVOL .NE. VOL) .OR.
     &        (SGEO .NE. GEO)) THEN

            SISO = ISO
            SVOL = VOL
            SGEO = GEO

            BADMU = 0.0

            DO IRMU = 100,0,-1

               RMU  = IRMU*0.01

               FLXALB = DREF2( WVNMLO, WVNMHI, RMU,
     &              TYPE, RHO0, K, THETA,
     &              SIGMA, T1, T2,
     &              SCALE, ISO, VOL, GEO, U10, PCL, XSAL, CALLNUM,
     &              FAST_SURFACE )

               IF( FLXALB.LT.0.0 .OR. FLXALB.GT.1.0 ) THEN
                  BADMU = (IRMU+1)*0.01
                  IF (BADMU .GT. 1.0)  BADMU = 1.0
                  write (0,*) '*** Using',BADMU,
     &                 ' as limiting mu in AMBRALS'
                  GOTO 90
               ENDIF

            ENDDO

 90         CONTINUE

         ENDIF

c     convert phi to degrees
         SDPHI = DPHI
         SMUP = MUP
         SMU = MU

         dphi = dphi / 3.1415927 * 180.0

         IF (BADMU .GT. 0) THEN
            IF (MU .LT. BADMU) THEN
               MU = BADMU
            ENDIF

            IF (MUP .LT. BADMU) THEN
               MUP = BADMU
            ENDIF
         ENDIF

         call ambralsfort( iso, vol, geo, mu, mup, dphi, BDREF )

         DPHI = SDPHI
         MUP = SMUP
         MU = SMU

c     Check for NaN
         if (BDREF .NE. BDREF) THEN
            write (0,*) 'BDREF', iso, vol, geo, MU, MUP, DPHI, BDREF
            BDREF = 1
         ENDIF
      ENDIF

      RETURN
      END


      subroutine nplotter_ZZlept(p,wt,wt2,switch)
c--- Variable passed in to this routine:
c
c---      p:  4-momenta of particles in the format p(i,4)
c---          with the particles numbered according to the input file
c---          and components labelled by (px,py,pz,E)
c
c---     wt:  weight of this event
c
c---    wt2:  weight^2 of this event
c
c--- switch:  an integer equal to 0 or 1, depending on the type of event
c---                0  --> lowest order, virtual or real radiation
c---                1  --> counterterm for real radiation
      implicit none
      include 'vegas_common.f'
      include 'constants.f'
      include 'histo.f'
      include 'outputflags.f'
      include 'interference.f'
      double precision p(mxpart,4),wt,wt2,m3456,pt34,pttwo
      integer switch,n,nplotmax
      character*4 tag
      logical, save::first=.true.
      common/nplotmax/nplotmax
ccccc!$omp threadprivate(first,/nplotmax/)

************************************************************************
*                                                                      *
*     INITIAL BOOKKEEPING                                              *
*                                                                      *
************************************************************************

      if (first) then
c--- Initialize histograms, without computing any quantities; instead
c--- set them to dummy values
        tag='book'
        goto 99
      else
c--- Add event in histograms
        tag='plot'
      endif

************************************************************************
*                                                                      *
*     DEFINITIONS OF QUANTITIES TO PLOT                                *
*                                                                      *
************************************************************************

      m3456=(p(3,4)+p(4,4)+p(5,4)+p(6,4))**2
     &     -(p(3,1)+p(4,1)+p(5,1)+p(6,1))**2
     &     -(p(3,2)+p(4,2)+p(5,2)+p(6,2))**2
     &     -(p(3,3)+p(4,3)+p(5,3)+p(6,3))**2
      m3456=sqrt(max(m3456,0d0))

      pt34=pttwo(3,4,p)

************************************************************************
*                                                                      *
*     FILL HISTOGRAMS                                                  *
*                                                                      *
************************************************************************

c--- Call histogram routines
   99 continue

c--- Book and fill ntuple if that option is set, remembering to divide
c--- by # of iterations now that is handled at end for regular histograms
      if (creatent .eqv. .true.) then
        call bookfill(tag,p,wt/dfloat(itmx))
      endif

c--- "n" will count the number of histograms
      n=nextnplot

c--- Syntax of "bookplot" routine is:
c
c---   call bookplot(n,tag,titlex,var,wt,wt2,xmin,xmax,dx,llplot)
c
c---        n:  internal number of histogram
c---      tag:  "book" to initialize histogram, "plot" to fill
c---   titlex:  title of histogram
c---      var:  value of quantity being plotted
c---       wt:  weight of this event (passed in)
c---      wt2:  weight of this event (passed in)
c---     xmin:  lowest value to bin
c---     xmax:  highest value to bin
c---       dx:  bin width
c---   llplot:  equal to "lin"/"log" for linear/log scale

c--- Plots of m(3456) in specific regions
      call bookplot(n,tag,'10 < m(3456) < 2010',
     & m3456,wt,wt2,10d0,2010d0,20d0,'log')
      n=n+1

      call bookplot(n,tag,'130 < m(3456) < 2010',
     & m3456,wt,wt2,130d0,2010d0,20d0,'log')
      n=n+1

      call bookplot(n,tag,'300 < m(3456) < 2020',
     & m3456,wt,wt2,300d0,2020d0,20d0,'log')
      n=n+1

      call bookplot(n,tag,'10 < m(3456) < 130',
     & m3456,wt,wt2,10d0,130d0,5d0,'lin')
      n=n+1

      call bookplot(n,tag,'pt(Z)',
     & pt34,wt,wt2,0d0,2d0,0.02d0,'lin')
      n=n+1

      call bookplot(n,tag,'+INTEGRAL+ pt(Z)',
     & pt34,wt,wt2,0d0,10d0,0.1d0,'lin')
      n=n+1

      call bookplot(n,tag,'50 < m(3456) < 250',
     & m3456,wt,wt2,50d0,250d0,2d0,'log')
      n=n+1

c--- usual plots for 3+4
      call autoplot2(p,34,3,4,tag,wt,wt2,n)

c--- usual plots for 5+6
      call autoplot2(p,56,5,6,tag,wt,wt2,n)

      if (interference) then
c--- usual plots for 3+6
        call autoplot2(p,36,3,6,tag,wt,wt2,n)

c--- usual plots for 4+5
        call autoplot2(p,45,4,5,tag,wt,wt2,n)
      endif

c--- usual plots for 3+4+5+6
      call autoplot4(p,3456,3,4,5,6,tag,wt,wt2,n)

c--- additional plots that may be present at NLO
      if (abs(p(7,4)) .gt. 1d-8) then
        call autoplot1(p,7,tag,wt,wt2,n)
      else
        n=n+2
      endif

************************************************************************
*                                                                      *
*     FINAL BOOKKEEPING                                                *
*                                                                      *
************************************************************************

c--- We have over-counted the number of histograms by 1 at this point
      n=n-1

c--- Ensure the built-in maximum number of histograms is not exceeded
      call checkmaxhisto(n)

c--- Set the maximum number of plots, on the first call
      if (first) then
        first=.false.
        nplotmax=n
      endif

      return
      end


      SUBROUTINE TOEPLZ(R,X,Y,N)
      PARAMETER (NMAX=100)
      DIMENSION R(*),X(N),Y(N),G(NMAX),H(NMAX)
      IF(R(N).EQ.0.) GO TO 99
      X(1)=Y(1)/R(N)
      IF(N.EQ.1)RETURN
      G(1)=R(N-1)/R(N)
      H(1)=R(N+1)/R(N)
      DO 15 M=1,N
        M1=M+1
        SXN=-Y(M1)
        SD=-R(N)
        DO 11 J=1,M
          SXN=SXN+R(N+M1-J)*X(J)
          SD=SD+R(N+M1-J)*G(M-J+1)
11      CONTINUE
        IF(SD.EQ.0.)GO TO 99
        X(M1)=SXN/SD
        DO 12 J=1,M
          X(J)=X(J)-X(M1)*G(M-J+1)
12      CONTINUE
        IF(M1.EQ.N)RETURN
        SGN=-R(N-M1)
        SHN=-R(N+M1)
        SGD=-R(N)
        DO 13 J=1,M
          SGN=SGN+R(N+J-M1)*G(J)
          SHN=SHN+R(N+M1-J)*H(J)
          SGD=SGD+R(N+J-M1)*H(M-J+1)
13      CONTINUE
        IF(SD.EQ.0..OR.SGD.EQ.0.)GO TO 99
        G(M1)=SGN/SGD
        H(M1)=SHN/SD
        K=M
        M2=(M+1)/2
        PP=G(M1)
        QQ=H(M1)
        DO 14 J=1,M2
          PT1=G(J)
          PT2=G(K)
          QT1=H(J)
          QT2=H(K)
          G(J)=PT1-PP*QT2
          G(K)=PT2-PP*QT1
          H(J)=QT1-QQ*PT2
          H(K)=QT2-QQ*PT1
          K=K-1
14      CONTINUE
15    CONTINUE
      PAUSE 'never get here'
99    PAUSE 'Levinson method fails: singular principal minor'
      END


subroutine Inital_strategies_not_equal()
    use global
    implicit none
    !randomly selected 50% cooperators and 50% defectors
    integer::indexA(NINT(initialFrequencyA * Ntotal))
    !integer::indexPositive(Ntotal / 5)
    !the nodes(index) that initially are cooperators
    integer::indexTotal(Ntotal)
    integer::indexCount
    !loop parameters
    integer::i, j
    !random number
    integer::randIntegerArray(1)
    integer::randInteger
    !!!!!
    if(mod(Ntotal,2) /= 0)then
        write(*,*) "The size of population is not multiples of 2!!"
        stop
    end if

    do i = 1, Ntotal
        indexTotal(i) = i
    end do
    !
    indexCount = 1

    ! A players
    do while (indexCount <= NINT(initialFrequencyA * Ntotal))
        call RNUND(Ntotal, randIntegerArray)
        randInteger = randIntegerArray(1)
        if(indexTotal(randInteger) /= -1)then
            indexA(indexCount) = randInteger
            indexCount = indexCount + 1
            indexTotal(randInteger) = -1
        end if
    end do

    !set the strategy arrary
    strategyPGG = 0
    do j = 1, NINT(initialFrequencyA * Ntotal)
        ! A player
        strategyPGG(indexA(j)) = 1
    end do

    !write(*,*) "Initial frequency of A:", sum(strategyPGG) * 1.0 / Ntotal
    !pause
    return
    end subroutine Inital_strategies_not_equal


C$Procedure      VSUB ( Vector subtraction, 3 dimensions )

      SUBROUTINE VSUB ( V1, V2, VOUT )

C$ Abstract
C
C     Compute the difference between two 3-dimensional, double
C     precision vectors.
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     VECTOR
C
C$ Declarations

      DOUBLE PRECISION  V1   ( 3 )
      DOUBLE PRECISION  V2   ( 3 )
      DOUBLE PRECISION  VOUT ( 3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     V1         I     First vector (minuend).
C     V2         I     Second vector (subtrahend).
C     VOUT       O     Difference vector, V1 - V2.
C
C$ Detailed_Input
C
C     V1    This can be any 3-dimensional, double precision vector.
C
C     V2    Ditto.
C
C$ Detailed_Output
C
C     VOUT   This is a 3-dimensional, double precision vector which
C            represents the vector difference, V1 - V2.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine simply performs subtraction between components of V1
C     and V2.  No checking is performed to determine whether floating
C     point overflow has occurred.
C
C$ Examples
C
C     The following table shows the output VOUT as a function of the
C     the input V1 and V2 from the subroutine VSUB.
C
C     V1                  V2              ---> VOUT
C     --------------      --------------       --------------
C     ( 1.0, 2.0, 3.0)    ( 4.0,  5.0, 6.0)    (-3.0, -3.0, -3.0)
C     (1D-7, 1D23,0.0)    (1D24, 1D23, 0.0)    (-1D24, 0.0,  0.0)
C
C$ Restrictions
C
C     The user is required to determine that the magnitude each
C     component of the vectors is within the appropriate range so as
C     not to cause floating point overflow.  No error recovery or
C     reporting scheme is incorporated in this subroutine.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.M. Owen       (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.3, 22-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.0.2, 07-NOV-2003 (EDW)
C
C        Corrected a mistake in the second example's value
C        for VOUT, i.e. replaced (1D24, 2D23, 0.0) with
C        (-1D24, 0.0, 0.0).
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     3-dimensional vector subtraction
C
C-&

      VOUT(1) = V1(1) - V2(1)
      VOUT(2) = V1(2) - V2(2)
      VOUT(3) = V1(3) - V2(3)

      RETURN
      END


! { dg-do compile { target i?86-*-* x86_64-*-* } }
! { dg-require-effective-target ilp32 }
! { dg-require-effective-target sse2 }
! { dg-options "-O2 -floop-strip-mine -fprefetch-loop-arrays -msse2" }

subroutine blts ( ldmx, ldmy, v, tmp1, i, j, k)
  implicit none
  integer ldmx, ldmy, i, j, k, ip, m, l
  real*8 tmp, tmp1, v( 5, ldmx, ldmy, *), tmat(5,5)

  do ip = 1, 4
     do m = ip+1, 5
        tmp = tmp1 * tmat( m, ip )
        do l = ip+1, 5
           tmat( m, l ) =  tmat( m, l ) - tmat( ip, l )
        end do
        v( m, i, j, k ) = tmp
     end do
  end do
  return
end subroutine blts

subroutine phasad(t,i,ium)
  implicit none
  real t(5,4)
  integer i,l,ll,ium

  do l=1,2
     ll=2*l
     do i=1,ium
        t(i,ll-1)=t(i,ll-1)+t(i,ll)
     enddo
  enddo
  return
end subroutine phasad


! Bug reported by Brian Helinski <bjh@absoft.com> on 4 Feb 2003
      module numerical_libraries
      interface

      subroutine a2ald (nf, nl, y, nrf, indrf, nef, nfef, indef, conper, iprint&
         , model, aov, ems, vc, ldvc, ymeans, wk, iwk, c13ksp)
      integer, intent(in) :: nf
      integer, dimension(*), intent(in) :: nl
      real(kind(1e0)), dimension(*) :: y
      integer, intent(in) :: nrf
      integer, dimension(*), intent(in) :: indrf
      integer, intent(in) :: nef
      integer, dimension(*), intent(in) :: nfef
      integer, dimension(*), intent(in) :: indef
      real(kind(1e0)), intent(in) :: conper
      integer, intent(in) :: iprint
      integer, intent(in) :: model
      real(kind(1e0)), dimension(*), intent(in) :: aov
      real(kind(1e0)), dimension(*), intent(inout) :: ems
      real(kind(1e0)), dimension(ldvc,*), intent(inout) :: vc
      integer, intent(in) :: ldvc
      real(kind(1e0)), dimension(*), intent(in) :: ymeans
      real(kind(1e0)), dimension(*), intent(inout) :: wk
      integer, dimension(*), intent(in) :: iwk
      character (len = 13), dimension(*), intent(out) :: c13ksp
      end subroutine

      subroutine b2lsf (fcn, m, n, xguess, ibtype, xlb, xub, xscale, fscale&
         , iparam, rparam, x, fvec, fjac, ldfjac, wk, iwk)
      integer, intent(in) :: m
      integer, intent(in) :: n
      real(kind(1e0)), dimension(*) :: xguess
      integer, intent(in) :: ibtype
      real(kind(1e0)), dimension(*), intent(inout) :: xlb
      real(kind(1e0)), dimension(*), intent(inout) :: xub
      real(kind(1e0)), dimension(*) :: xscale
      real(kind(1e0)), dimension(*) :: fscale
      integer, dimension(*) :: iparam
      real(kind(1e0)), dimension(*) :: rparam
      real(kind(1e0)), dimension(*) :: x
      real(kind(1e0)), dimension(*) :: fvec
      real(kind(1e0)), dimension(*) :: fjac
      integer, intent(in) :: ldfjac
      real(kind(1e0)), dimension(*) :: wk
      integer, dimension(*) :: iwk
      interface
         subroutine fcn(m, n, x, f)
         integer, intent(in) :: m, n
         real(kind(1e0)), intent(in) :: x(*)
         real(kind(1e0)), intent(out) :: f(*)
         end subroutine
      end interface
      end subroutine

      END INTERFACE
      end module


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
module hpsi
  use global_variables
  implicit none

  private
! temporary
  real(dp),allocatable :: tmp_wfn_b(:,:)
  complex(zp),allocatable :: ztmp_wfn_b(:,:)

  public :: initialize_hpsi &
           ,rhpsi &
           ,zhpsi

contains
!-----------------------------------------------------------------------------------------
  subroutine initialize_hpsi
    implicit none

    allocate(tmp_wfn_b(-4:Nx+4,-4:Nx+4))
    allocate(ztmp_wfn_b(-4:Nx+4,-4:Nx+4))
    tmp_wfn_b = 0d0
    ztmp_wfn_b = 0d0

  end subroutine initialize_hpsi
!-----------------------------------------------------------------------------------------
  subroutine rhpsi(tmp_wfn,tmp_hwfn)
    implicit none
    real(dp),intent(in) :: tmp_wfn(0:Nx,0:Nx)
    real(dp),intent(out) :: tmp_hwfn(0:Nx,0:Nx)
! finite difference
    integer :: ix,iy
    real(dp) :: c0,c1,c2,c3,c4
! nine-points formula
    c0=-0.5d0*cN0/(dx**2)
    c1=-0.5d0*cN1/(dx**2)
    c2=-0.5d0*cN2/(dx**2)
    c3=-0.5d0*cN3/(dx**2)
    c4=-0.5d0*cN4/(dx**2)

!$omp parallel do private(ix,iy)
    do iy = 0,Nx
      do ix = 0,Nx
        tmp_wfn_b(ix,iy) = tmp_wfn(ix,iy)
      end do
    end do

!$omp parallel do private(ix,iy)
    do iy=0,Nx
      do ix=0,Nx
        tmp_hwfn(ix,iy)=2d0*c0*tmp_wfn_b(ix,iy) &
          + c1*(tmp_wfn_b(ix+1,iy) + tmp_wfn_b(ix-1,iy) + tmp_wfn_b(ix,iy+1) + tmp_wfn_b(ix,iy-1)) &
          + c2*(tmp_wfn_b(ix+2,iy) + tmp_wfn_b(ix-2,iy) + tmp_wfn_b(ix,iy+2) + tmp_wfn_b(ix,iy-2)) &
          + c3*(tmp_wfn_b(ix+3,iy) + tmp_wfn_b(ix-3,iy) + tmp_wfn_b(ix,iy+3) + tmp_wfn_b(ix,iy-3)) &
          + c4*(tmp_wfn_b(ix+4,iy) + tmp_wfn_b(ix-4,iy) + tmp_wfn_b(ix,iy+4) + tmp_wfn_b(ix,iy-4))
      end do
    end do

!$omp parallel do private(ix,iy)
    do iy = 0,Nx
      do ix = 0,Nx
        tmp_hwfn(ix,iy) = tmp_hwfn(ix,iy) + v_all(ix,iy)*tmp_wfn(ix,iy)
      end do
    end do
    return
  end subroutine rhpsi
  !-----------------------------------------------------------------------------------------
  subroutine zhpsi(ztmp_wfn,ztmp_hwfn,ft)
    implicit none
    complex(zp),intent(in) :: ztmp_wfn(0:Nx,0:Nx)
    complex(zp),intent(out) :: ztmp_hwfn(0:Nx,0:Nx)
    real(dp),intent(in) :: ft
    integer :: ix,iy
    real(dp) :: c0,c1,c2,c3,c4

! nine-points formula
    c0=-0.5d0*cN0/(dx**2)
    c1=-0.5d0*cN1/(dx**2)
    c2=-0.5d0*cN2/(dx**2)
    c3=-0.5d0*cN3/(dx**2)
    c4=-0.5d0*cN4/(dx**2)

!$omp parallel do private(ix,iy)
    do iy = 0,Nx
      do ix = 0,Nx
        ztmp_wfn_b(ix,iy) = ztmp_wfn(ix,iy)
      end do
    end do

!$omp parallel do private(ix,iy)
    do iy=0,Nx
      do ix=0,Nx
        ztmp_hwfn(ix,iy)=2d0*c0*ztmp_wfn_b(ix,iy) &
          + c1*(ztmp_wfn_b(ix+1,iy) + ztmp_wfn_b(ix-1,iy) + ztmp_wfn_b(ix,iy+1) + ztmp_wfn_b(ix,iy-1)) &
          + c2*(ztmp_wfn_b(ix+2,iy) + ztmp_wfn_b(ix-2,iy) + ztmp_wfn_b(ix,iy+2) + ztmp_wfn_b(ix,iy-2)) &
          + c3*(ztmp_wfn_b(ix+3,iy) + ztmp_wfn_b(ix-3,iy) + ztmp_wfn_b(ix,iy+3) + ztmp_wfn_b(ix,iy-3)) &
          + c4*(ztmp_wfn_b(ix+4,iy) + ztmp_wfn_b(ix-4,iy) + ztmp_wfn_b(ix,iy+4) + ztmp_wfn_b(ix,iy-4))
      end do
    end do

!$omp parallel do private(ix,iy)
    do iy = 0,Nx
      do ix = 0,Nx
        ztmp_hwfn(ix,iy) = ztmp_hwfn(ix,iy) + (v_all(ix,iy)+ft*xyn(ix,iy))*ztmp_wfn(ix,iy)
      end do
    end do

    return
  end subroutine zhpsi
!-----------------------------------------------------------------------------------------

end module hpsi


      subroutine mwtr(ne,kspec,nser,jack,evalu,mxfreq,mxspec,
     $                yk,mxwt,wt,work,c2,trans,c2lo,c2hi,trerr)
c
c  subroutine to compute transfer function and squared multiple
c  coherence between n input and one output time series using
c  multiple prolate window expansion along with jackknife estimates
c  of their standard error and 95% confidence limits respectively
c
c  inputs:
c    ne     - number of elements in yk to process
c    kspec  - number of windows
c    nser   - number of series including output
c    jack   - logical switch for computation of jackknife error
c             estimates on transfer functions and coherence,
c             .true. to compute
c    evalu  - double precision vector of the dpss eigenvalues
c    mxfreq - leading dimension of yk
c    mxspec - second dimension of yk
c    yk     - complex array containing kspec ffts
c             for the nser time series
c    mxwt   - leading dimension of wt, trans, and trerr
c    wt     - real array containing normalized adaptive weights
c    work   - work vector of length at least 10*kspec*nser+
c             8*kspec+9*nser+8*nser**2
c
c  outputs:
c
c    c2     - squared multiple coherence
c    trans  - complex array containing the transfer functions
c             between the output and nser-1 input time series
c    c2lo   - lower 95% confidence limit on the coherence
c    c2hi   - upper 95% confidence limit on the coherence
c    trerr  - one standard error for the transfer functions
c
c  calls mwtr1
c
c*****************************************************************
c
      double precision evalu
      complex yk,trans
      logical jack
      dimension evalu(kspec),yk(mxfreq,mxspec,nser),
     $          wt(mxwt,mxspec,nser),work(1),c2(ne),
     $          trans(mxwt,nser-1),c2lo(ne),
     $          c2hi(ne),trerr(mxwt,nser-1)
      nsqev=2*kspec
      na=nsqev+8*kspec*nser
      nb=na+4*kspec
      nx=nb+4*nser
      nrr=nx+8*nser*nser
      ntrd1=nrr+2*nser*kspec
      ntrd1s=ntrd1+2*nser
      ntrd1ws=ntrd1s+2*nser
      nwtj=ntrd1ws+kspec
      call mwtr1(ne,kspec,nser,jack,evalu,mxfreq,mxspec,yk,mxwt,
     $           wt,work,work(nsqev+1),work(na+1),
     $           work(nb+1),work(nx+1),work(nrr+1),work(ntrd1+1),
     $           work(ntrd1s+1),work(ntrd1ws+1),
     $           work(nwtj+1),c2,trans,c2lo,c2hi,trerr)
      return
      end

c $Id$


c     # ----------------------------------------------
c     # Scaling routines
c     # ----------------------------------------------

c      subroutine set_scale(scale)
c      implicit none
c      double precision scale(3), scale_com(3)
c      integer m
c
c      common /comscale/ scale_com
c
c      do m = 1,3
c         scale_com(m) = scale(m)
c      enddo
c
c      end
c
c
c      subroutine  get_scale(scale)
c      implicit none
c      double precision scale_com(3), scale(3)
c      integer m
c      common /comscale/ scale_com
c
c      do m = 1,3
c         scale(m) = scale_com(m)
c      enddo
c
c
c      end
c
c      subroutine scale_map(xp,yp,zp)
c      implicit none
c
c      double precision xp,yp,zp
c      double precision s(3)
c
c      call get_scale(scale)
c
c      xp = s(1)*xp
c      yp = s(2)*yp
c      zp = s(3)*zp
c
c      end

c     # ----------------------------------------------
c     # Shift routines
c     # ----------------------------------------------
c
c      subroutine set_shift(shift)
c      implicit none
c
c      double precision shift(3), shift_com(3)
c      integer m
c
c      common /comshift/ shift_com
c
c      do m = 1,3
c         shift_com(m) = shift(m)
c      enddo
c
c
c      end
c
c      subroutine get_shift(shift)
c      implicit none
c
c      double precision shift(3), shift_com(3)
c      integer m
c
c      common /comshift/ shift_com
c
c      do m = 1,3
c         shift(m) = shift_com(m)
c      enddo
c
c
c      end
c
c      subroutine shift_map(xp,yp,zp)
c      implicit none
c
c      double precision xp,yp,zp
c      double precision shift(3)
c      integer m
c
c
c      call get_shift(shift)
c
c      xp = xp + shift(1)
c      yp = yp + shift(2)
c      zp = zp + shift(3)
c      end

c     # ----------------------------------------------
c     # Rotation routines
c     # ----------------------------------------------
      subroutine set_rotation_matrix(rot_angle,rrot)
      implicit none

      double precision rot_angle(2)
      double precision rrot(3,3)

      double precision r1(3,3), r2(3,3)

      double precision th, phi
      integer i,j,k

c      double precision rrot_com(3,3)
c      common /comrot/ rrot_com

c     # Rotates map so as to not bias the solution.
      do i = 1,3
         do j = 1,3
            r1(i,j) = 0
         enddo
         r1(i,i) = 1
      enddo

      th = rot_angle(1)
      r1(1,1) = cos(th)
      r1(1,2) = -sin(th)
      r1(2,1) = -r1(1,2)
      r1(2,2) = r1(1,1)

c     # rotate in second direction (for full 3d map)
      do i = 1,3
         do j = 1,3
            r2(i,j) = 0
         enddo
         r2(i,i) = 1
      enddo
      phi = rot_angle(2)
      r2(1,1) = cos(phi)
      r2(1,3) = -sin(phi)
      r2(3,1) = -r2(1,3)
      r2(3,3) = r2(1,1)
      do i = 1,3
         do j = 1,3
            rrot(i,j) = 0
            do k = 1,3
               rrot(i,j) = rrot(i,j) + r2(i,k)*r1(k,j)
            enddo
         enddo
      enddo

c      do j = 1,3
c         do i = 1,3
c            rrot_com(i,j) = rrot(i,j)
c         enddo
c      enddo

      end

c      subroutine get_rotation(rrot)
c      implicit none
c
c      double precision rrot(3,3), rrot_com(3,3)
c      common /comrot/ rrot_com
c
c      integer i,j
c
c      do j = 1,3
c         do i = 1,3
c            rrot(i,j) = rrot_com(i,j)
c         enddo
c      enddo
c
c      end

c      subroutine rotate_mapping(rrot,xp,yp,zp)
c      implicit none
c
c      double precision xp,yp,zp
c      double precision v(3), vrot(3)
c      integer i,k
c      double precision rrot(3,3)
c
c      v(1) = xp
c      v(2) = yp
c      v(3) = zp
c
c      call get_rotation(rrot)
c
c      do i = 1,3
c         vrot(i) = v(i)
c      enddo
c
cc     # Rotate mapping
c      do i = 1,3
c         vrot(i) = 0
c         do k = 1,3
c            vrot(i) = vrot(i) + rrot(i,k)*v(k)
c         enddo
c      enddo
c
c      xp = vrot(1)
c      yp = vrot(2)
c      zp = vrot(3)
c
c      end


!! To enable compilation without dependencies on Blas libraries
!! wrap DA code in compiler flag sepecified
#ifdef key_da
SUBROUTINE HMATRIX(NL,NR,CODAR_I,CODAR_J,MODEL_I,MODEL_J,H)
    IMPLICIT NONE
    INTEGER,PARAMETER::ip=4,wp=8

    INTEGER(ip),INTENT(in):: NL,NR
    INTEGER(ip),DIMENSION(NL),INTENT(in) :: MODEL_I,MODEL_J
    INTEGER(ip),DIMENSION(NR),INTENT(in) :: CODAR_I,CODAR_J
    INTEGER(ip),ALLOCATABLE,DIMENSION(:,:) :: C
    INTEGER(ip),INTENT(OUT),DIMENSION(2*NR,2*NL) :: H

    INTEGER(ip)I,J
    ALLOCATE(C(NR,NL))
    H(:,:) = 0
    DO I = 1,NR
      DO J = 1,NL
        IF (CODAR_I(I) == model_I(J) .AND. CODAR_J(I) == MODEL_J(J)) THEN
           C(I,J) = 1
        ELSE
           C(I,J) = 0
        END IF
      END DO
    END DO

      DO I =1,NR
        DO J = 1,NL
          H(I,J) = C(I,J)
          H(NR+I,NL+J) = C(I,J)
        END DO
      END DO

END SUBROUTINE HMATRIX

SUBROUTINE PMATRIX(NL,model_i,model_j,P, R1, R2, A)
    IMPLICIT NONE
    INTEGER,PARAMETER::ip=4,wp=8
    INTEGER(ip) n,i,j
    REAL R1, R2, A
    INTEGER(ip),INTENT(in):: NL
    INTEGER(ip),DIMENSION(NL),INTENT(in) :: MODEL_I,MODEL_J
    REAL(wp),DIMENSION(2*NL,2*NL) :: P
    REAL(wp),ALLOCATABLE,DIMENSION(:,:) :: P1

    N=0

    ALLOCATE(P1(NL,NL))
    DO I = 1,NL
        N=N+1
        DO J =1,NL
            P1(I,J)=A*EXP(-1.* ABS(((MODEL_I(I)-MODEL_I(I+J-N))/R1)**2 + &
                       ((MODEL_J(I)-MODEL_J(I+J-N))/R2)**2))
        END DO
    END DO

    DO I = 1,NL
      DO J = 1,NL
        P(I,J) = P1(I,J)
        P(NL+I,NL+J) = P1(I,J)
        P(NL+I,J) = P1(I,J)
        P(I,NL+J) = P1(I,J)
      END DO
    END DO

END SUBROUTINE PMATRIX

SUBROUTINE RMATRIX(NR,SIGMAU,SIGMAV,R)
    IMPLICIT NONE
    INTEGER,PARAMETER::ip=4,wp=8
    INTEGER(ip) NR,i,j
    REAL(wp),DIMENSION(NR),INTENT(in) :: SIGMAU,SIGMAV
    REAL(wp),DIMENSION(2*NR,2*NR) :: R

    R = 0.
      DO I = 1,NR
        R(I,I) = sigmau(I)
        R(NR+I,NR+I) = sigmav(i)
      END DO

END SUBROUTINE RMATRIX

! BUILDS H MATRIX
SUBROUTINE HMATRIX_3D(NL,NR,VP_I,VP_J,VP_K,MODEL_I,MODEL_J,MODEL_K,H)
    IMPLICIT NONE
    INTEGER,PARAMETER::IP=4,WP=8
    INTEGER(IP),INTENT(IN)::NL,NR
    INTEGER(IP),DIMENSION(NL),INTENT(in)::MODEL_I,MODEL_J,MODEL_K
    INTEGER(IP),DIMENSION(NR),INTENT(in)::VP_I,VP_J,VP_K
    INTEGER(IP),ALLOCATABLE,DIMENSION(:,:)::C
    INTEGER(IP),DIMENSION(NR,NL)::H

    INTEGER(IP)I,J
    ALLOCATE(C(NR,NL))
    H = 0
    DO I=1,NR
        DO J=1,NL
            IF (VP_I(I)==MODEL_I(j) .AND. VP_J(I)==MODEL_J(J) .AND. VP_K(I)==MODEL_K(J)) then
                H(I,J) = 1
            ELSE
                H(I,J) = 0
            END IF
        END DO
    END DO

END SUBROUTINE HMATRIX_3D

! BUILDS THE STATE ERROR COVARIANCE MATRIX P
SUBROUTINE PMATRIX_3D(NL,MODEL_I,MODEL_J,MODEL_K,P, &
                    PMATRIX_R1, PMATRIX_R2, PMATRIX_R3, PMATRIX_A )
    IMPLICIT NONE
    INTEGER,PARAMETER::IP=4,WP=8
    INTEGER(IP) N,I,J
    REAL(WP) R1,R2,R3,A
    INTEGER(IP),INTENT(IN)::NL
    INTEGER(IP),DIMENSION(NL),INTENT(IN)::MODEL_I,MODEL_J,MODEL_K
    REAL(WP),DIMENSION(NL,NL)::P
    REAL(WP),ALLOCATABLE,DIMENSION(:,:)::P1
    REAL PMATRIX_R1, PMATRIX_R2, PMATRIX_R3, PMATRIX_A

    R1 = PMATRIX_R1
    R2 = PMATRIX_R2
    R3 = PMATRIX_R3
    A  = PMATRIX_A
    N=0

    DO I=1,NL
        N=N+1
        DO J=1,NL
            P(I,J) = A*EXP(-1.*(((MODEL_I(I) - MODEL_I(I+J-N))/R1)**2 + &
                ((MODEL_J(I) - MODEL_J(I+J-N))/R2)**2 + &
                ((MODEL_K(I) - MODEL_K(I+J-N))/R3)**2))
        END DO
    END DO

END SUBROUTINE PMATRIX_3D

! BUILDS THE OBSERVATION ERROR COVARIANCE MATRIX R
SUBROUTINE RMATRIX_3D(NR,SIGMAT,R)
    IMPLICIT NONE
    INTEGER,PARAMETER::IP=4,WP=8
    INTEGER(IP) NR,I,J
    REAL(WP),DIMENSION(NR),INTENT(IN)::SIGMAT
    REAL(WP),DIMENSION(NR,NR)::R

    R=0.
    DO I=1,NR
        R(I,I) = SIGMAT(I)
    END DO

END SUBROUTINE RMATRIX_3D
#endif


    module InterpolationTests
    use Interpolation
    use FileUtils
    use FileTests
    implicit None
    integer, parameter, private :: sp= KIND(1.d0)

    contains

    function func(x)
    real(sp) func,x

    func = (x/47.2_sp)**3  + (x/5.5_sp)**2 +x*3.5_sp+4.4579_sp
    end function

    function funcderiv(x)
    real(sp) funcderiv,x

    funcderiv = 3*(x/47.2_sp)**2/47.2_sp  + 2*(x/5.5_sp)/5.5_sp +3.5_sp
    end function

    function RunInterpolationTests() result(fails)
    real(sp), allocatable :: x(:),f(:)
    integer i
    integer fails
    Type(TCubicSpline) :: Irreg, IrregLoad
    Type(TRegularCubicSpline) :: Reg, RegLoad
    Type(TLogRegularCubicSpline) :: Reglog
    real(sp) xx
    real(sP), parameter:: testval = 13.2623_sp
    real(sP), parameter:: testarrayval(3) = [7.3_sp, 9._sp,34.34643_sp]
    real(sp) :: outarray(3), funcarray(3)
    Type(TBinaryFile) :: FB

    fails = 0
    allocate(x(100),f(100))
    do i=1, 100
        x(i) = 0.5367_sp*real(i,sp) + 0.3_sp
        f(i) = func(x(i))
    end do
    call Irreg%Init(x,f)
    call Reg%Init(x(1),x(size(x)),100,values=f)
    call RegLog%init(x(1),x(size(x)),100)
    do i=1, 100
        xx= exp(log(x(1)) + RegLog%delta_x*(i-1))
        RegLog%F(i) = func(xx)
    end do

    if (all(abs([Reg%Value(testval), Irreg%Value(testval), RegLog%Value(testval)]-func(testval))<1e-5)) then
        print *,'Value OK'
    else
        fails = fails+1
        print *, 'error'
        print *, Reg%Value(testval), Irreg%Value(testval),RegLog%Value(testval), func(testval)
    end if

    if (all(abs([Reg%Value(x(1)), Irreg%Value(x(1)), RegLog%Value(x(1))]-func(x(1)))<1e-5)) then
        print *,'bottom end value OK'
    else
        fails = fails+1
        print *, 'end error'
        print *, Reg%Value(testval), Irreg%Value(testval),RegLog%Value(testval), func(testval)
    end if

    if (all(abs([Reg%Value(x(100)), Irreg%Value(x(100)), RegLog%Value(x(100))]-func(x(100)))<1e-5)) then
        print *,'top end value OK'
    else
        fails = fails+1
        print *, 'end error'
        print *, Reg%Value(testval), Irreg%Value(testval),RegLog%Value(testval), func(testval)
    end if

    if (all(abs([Reg%Derivative(testval), Irreg%Derivative(testval), RegLog%Derivative(testval)]-funcderiv(testval))<1e-5)) then
        print *,'Derivative OK'
    else
        fails = fails+1
        print *, 'derivative error'
        print *, Reg%Derivative(testval), Irreg%Derivative(testval),RegLog%Derivative(testval), funcderiv(testval)
    end if

    do i=1,3
        funcarray(i) = func(testarrayval(i))
    end do
    call Reg%Array(testarrayval, outarray)
    if (all(abs(outarray-funcarray)<1e-7)) then
        print *, 'array value OK'
    else
        fails = fails+1
        print *, 'array error'
        print *, outarray
        print *, funcarray
    end if

    call FB%CreateFile(temp_file)
    call Irreg%SaveState(FB)
    call FB%Close()
    call FB%Open(temp_file)
    call IrregLoad%loadState(FB)
    call FB%Close()
    if (abs( IrregLoad%Value(testval) -Irreg%Value(testval))<1e-8) then
        print *,'Load bin OK'
    else
        fails = fails+1
        print *, 'Load bin error'
    end if
    call FB%CreateFile(temp_file)
    call Reg%SaveState(FB)
    call FB%Close()
    call FB%Open(temp_file)
    call RegLoad%loadState(FB)
    call FB%Close()
    if (abs( RegLoad%Value(testval) -Reg%Value(testval))<1e-8) then
        print *,'Load bin2 OK'
    else
        fails = fails+1
        print *, 'Load bin2 error'
    end if
    call File%Delete(temp_file)

    end function RunInterpolationTests

    end module InterpolationTests


! Fortran 90 DAXPY using arrays
SUBROUTINE f90daxpy(a, x, y, n, iters)
  IMPLICIT NONE
  INTEGER, INTENT( IN ) :: n, iters
  DOUBLE PRECISION, DIMENSION (n) :: x, y
  DOUBLE PRECISION, INTENT( IN ) :: a
  DOUBLE PRECISION :: b

  b = - a

  DO i=1,iters
    y = y + a * y
    y = y + b * y
  END DO
END SUBROUTINE


      real             function SGAMMA(X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 2001-05-25 SGAMMA Krogh Minor change for making .f90 version.
c>> 1996-03-30 SGAMMA Krogh  Added external statement.
C>> 1994-10-20 SGAMMA Krogh  Changes to use M77CON
C>> 1991-10-21 SGAMMA CLL Eliminated DGAM1 as a separate subroutine.
C>> 1991-01-16 SGAMMA Lawson  Replaced D2MACH/R2MACH with DGAM1.
C>> 1985-08-02 SGAMMA Lawson  Initial code.
c--S replaces "?": ?GAMMA, ?ERM1, ?ERV1
C
C ----------------------------------------------------------------------
C
C  THIS ROUTINE CALCULATES THE GAMMA FUNCTION FOR A double precision
C      ARGUMENT X. PERMITS NEGATIVE AS WELL AS POSITIVE X. NOTE
C      THAT THE GAMMA FUNCTION HAS POLES AT ZERO AND AT NEGATIVE
C      ARGUMENTS. COMPUTATION IS BASED ON AN ALGORITHN OUTLINED IN
C      W.J.CODY, 'AN OVERVIEW OF SOFTWARE DEVELOPMENT FOR SPECIAL
C      FUNCTIONS', LECTURE NOTES IN MATHEMATICS, 506, NUMERICAL ANALYSIS
C      DUNDEE, 1975, G. A. WATSON (ED.),SPRINGER VERLAG, BERLIN, 1976.
C      THE PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE THE GAMMA
C      FUNCTION TO AT LEAST 20 SIGNIFICANT DECIMAL DIGITS. COEFFICIENTS
C      FOR THE APPROXIMATION OVER THE INTERVAL (1,2) ARE UNPUBLISHED.
C      THOSE FOR THE APPROXIMATION FOR X .GE. 12 ARE FROM HART, ET. AL.,
C      COMPUTER APPROXIMATIONS, WILEY AND SONS, NEW YORK, 1968.
C      LOWER ORDER APPROXIMATIONS CAN BE SUBSTITUTED FOR THESE ON
C      MACHINES WITH LESS PRECISE ARITHMETIC.
C
C  Designed & programmed by W.J.CODY, Argonne National Lab.,1982.
C  Minor changes for the JPL library by C.L.LAWSON & S.CHAN,JPL,1983.
C
C***********************************************************************
C
c-- Begin mask code changes
C  EXPLANATION OF MACHINE-DEPENDENT CONSTANTS
C
C  EPS    - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
C           1.0 + EPS .GT. 1.0
C  XINF   - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER.
C  XMININ - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
c           both XMININ and 1/XMININ are representable.
C  XGBIG  - A value such that    Gamma(XGBIG) = 0.875 * XINF.
c           (Computed and used in [D/S]GAMMA.)
C  XLBIG  - A value such that LogGamma(XLBIG) = 0.875 * XINF.
c           (Computed and used in [D/S]LGAMA.)
C
C      Values of XINF, XGBIG, and XLBIG for some machines:
C
c        XINF              XGBIG     XLBIG       Machines
c
c  2**127  = 0.170e39      34.81  0.180e37     Vax SP & DP; Unisys SP
c  2**128  = 0.340e39      35.00  0.358e37     IEEE SP
c  2**252  = 0.723e76      57.54  0.376e74     IBM30xx DP
c  2**1023 = 0.899e308    171.46  0.112e306    Unisys DP
c  2**1024 = 0.180e309    171.60  0.2216e306   IEEE DP
c  2**1070 = 0.126e323    177.78  0.1501e320   CDC/7600 SP
c  2**8191 = 0.550e2466   966.94  0.8464e2462  Cray SP & DP
c-- End mask code changes
c
C***********************************************************************
C
C  ERROR RETURNS
C
C  THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR
C     WHEN OVERFLOW WOULD OCCUR. THE COMPUTATION IS BELIEVED
C     TO BE FREE OF UNDERFLOW AND OVERFLOW.
C
C  AUTHOR:W. J. CODY
C         APPLIED MATHMATICS DIVISION
C         ARGONNE NATIONAL LABORATORY
C         ARGONNE, IL 60439
C
C  LATEST MODIFICATION by Cody: MAY 18, 1982
C
C     ------------------------------------------------------------------
      external R1MACH
      real             R1MACH
      real             C(7), CONST, DEL, EPS, F, FACT, FP, HALF
      real             ONE,P(8), PI,Q(8), RES,C1
      real             SUM,TEMP, TWELVE,TWO
      real             X,X1, X2, XGBIG,XDEN,XINF,XMININ,XNUM
      real             Y,Y1,YSQ,Z,ZERO
      integer I,J,N
      logical PARITY
C
      save EPS, XGBIG, XMININ, XINF
C
      parameter( ONE = 1.0E0, HALF = 0.5E0, TWO = 2.0e0)
      parameter( ZERO = 0.0E0, TWELVE = 12.0E0)
C
C                      C1 = LOG base e of SQRT(2*PI)
C
      parameter( C1 = 0.9189385332046727417803297E0)
C
      parameter( PI = 3.1415926535897932384626434E0)
C
      data XINF/0.0E0/
C
C ----------------------------------------------------------------------
C  NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX
C     APPROXIMATION OVER (1,2).
C ----------------------------------------------------------------------
      DATA P/-1.71618513886549492533811E+0,2.47656508055759199108314E+1,
     *       -3.79804256470945635097577E+2,6.29331155312818442661052E+2,
     *       8.66966202790413211295064E+2,-3.14512729688483675254357E+4,
     *       -3.61444134186911729807069E+4,6.64561438202405440627855E+4/
      DATA Q/-3.08402300119738975254353E+1,3.15350626979604161529144E+2,
     *      -1.01515636749021914166146E+3,-3.10777167157231109440444E+3,
     *        2.25381184209801510330112E+4,4.75584627752788110767815E+3,
     *      -1.34659959864969306392456E+5,-1.15132259675553483497211E+5/
C ----------------------------------------------------------------------
C  COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF).
C ----------------------------------------------------------------------
      DATA C/-1.910444077728E-03,8.4171387781295E-04,
     *     -5.952379913043012E-04,7.93650793500350248E-04,
     *     -2.777777777777681622553E-03,8.333333333333333331554247E-02,
     *      5.7083835261E-03/
C ----------------------------------------------------------------------
C
      IF (XINF .EQ. ZERO) THEN
        EPS = R1MACH(4)
        XINF = R1MACH(2)
         if(R1MACH(1) * R1MACH(2) .ge. ONE) then
            XMININ = R1MACH(1)
         else
            XMININ = ONE / R1MACH(2)
         endif
c
c                         Compute XGBIG
c
c        XGBIG will satisfy Gamma(XGBIG) = 0.875 * XINF.
c        Use a Newton iteration and the following approximation for
c        the gamma function:
c        log(gamma(x)) ~ (x - .5)*log(x) - x + 0.5 * log(2 * PI)
c
         TEMP = log(0.875e0 * XINF)
         CONST = HALF * log(TWO * PI) - TEMP
         X1 = TEMP * 0.34e0
         do 40 J=1,7
            F = (X1-HALF)*log(X1) - X1 + CONST
            FP = ((X1-HALF)/X1)  + log(X1) - ONE
            DEL = -F/FP
            X2 = X1+DEL
            if(abs(DEL) .lt. 0.5e-5 * X2) go to 45
            X1 = X2
   40    continue
   45    continue
         XGBIG = X2
      END IF
      PARITY = .FALSE.
      FACT = ONE
      N = 0
      Y = X
      IF (Y .GT. ZERO) GO TO 200
C ----------------------------------------------------------------------
C  ARGUMENT IS NEGATIVE OR ZERO
C ----------------------------------------------------------------------
      Y = -X
      J = INT(Y)
      RES = Y - real(J)
      IF (RES .EQ. ZERO) GO TO 700
      IF (J .NE. (J/2)*2) PARITY = .TRUE.
      FACT = -PI / sin(PI*RES)
      Y = Y + ONE
C ----------------------------------------------------------------------
C  ARGUMENT IS POSITIVE
C ----------------------------------------------------------------------
  200 IF (Y .LT. EPS) GO TO 650
      IF (Y .GE. TWELVE) GO TO 300
      Y1 = Y
      IF (Y .GE. ONE) GO TO 210
C ----------------------------------------------------------------------
C  0.0 .LT. ARGUMENT .LT. 1.0
C ----------------------------------------------------------------------
      Z = Y
      Y = Y + ONE
      GO TO 250
C ----------------------------------------------------------------------
C  1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY
C ----------------------------------------------------------------------
  210 N= int(Y) - 1
      Y = Y - real(N)
      Z = Y - ONE
C ----------------------------------------------------------------------
C  EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0
C ----------------------------------------------------------------------
  250 XNUM = ZERO
      XDEN = ONE
      DO 260 I = 1, 8
         XNUM = (XNUM + P(I)) * Z
         XDEN = XDEN * Z + Q(I)
  260 CONTINUE
      RES = (XNUM / XDEN + HALF) + HALF
      IF (Y .EQ. Y1) GO TO 900
      IF (Y1 .GT. Y) GO TO 280
C ----------------------------------------------------------------------
C  ADJUST RESULT FOR CASE 0.0 .LT. ARGUMENT .LT. 1.0
C ----------------------------------------------------------------------
      RES = RES / Y1
      GO TO 900
C ----------------------------------------------------------------------
C  ADJUST RESULT FOR CASE 2.0 .LT. 12.0
C ----------------------------------------------------------------------
  280 DO 290 I = 1, N
         RES = RES * Y
         Y = Y + ONE
  290 CONTINUE
      GO TO 900
C ----------------------------------------------------------------------
C  EVALUATE FOR ARGUMENT .GE. 12.0
C ----------------------------------------------------------------------
  300 IF (Y .GT. XGBIG) GO TO 720
      YSQ = Y * Y
      SUM = C(7)
      DO 350 I = 1, 6
         SUM = SUM / YSQ + C(I)
  350 CONTINUE
      SUM = ((SUM/Y + C1) - Y) + (Y - HALF) * log(Y)
      RES = exp(SUM)
      GO TO 900
C ----------------------------------------------------------------------
C  ARGUMENT .LT. EPS
C ----------------------------------------------------------------------
  650 IF (Y .LT. XMININ) GO TO 740
      RES = ONE / Y
      GO TO 900
C ----------------------------------------------------------------------
C  RETURN FOR SINGULARITIES,EXTREME ARGUMENTS, ETC.
C ----------------------------------------------------------------------
  700 CALL SERM1('SGAMMA',1,0,'POLE AT 0 AND NEG INTEGERS',
     *           'X',X,'.')
      GO TO 780
C
  720 CALL SERM1('SGAMMA',2,0,'X SO LARGE VALUE WOULD OVERFLOW',
     *           'X',X,',')
      CALL SERV1('LIMIT',XGBIG,'.')
      GO TO 780
C
  740 CALL SERM1('SGAMMA',3,0,'X TOO NEAR TO A SINGULARITY.'//
     *           'VALUE WOULD OVERFLOW.','X',X,'.')
C
  780 SGAMMA = XINF
      GO TO 950
C ----------------------------------------------------------------------
C  FINAL ADJUSTMENTS AND RETURN
C ----------------------------------------------------------------------
  900 IF (PARITY) RES = -RES
      IF (FACT .NE. ONE) RES = FACT / RES
      SGAMMA = RES
  950 RETURN
      END


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of kz in reverse (adjoint) mode (with options noISIZE i8):
!   gradient     of useful results: *temp *propunit kz
!   with respect to varying inputs: *temp *propunit
!   Plus diff mem management of: temp:in propunit:in
! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! 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.
!>    @brief assign permeability in z direction to cell
!>    @param[in] i grid indices
!>    @param[in] j grid indices
!>    @param[in] k grid indices
!>    @param[in] ismpl local sample index
!>    @return  permeability                        (m^2)
!>    @details
SUBROUTINE KZ_AD(i, j, k, ismpl, kz_adv)
  use arrays

  USE ARRAYS_AD

  USE ICE
  USE MOD_TEMP
  IMPLICIT NONE
  double precision :: kz_adv
  INTEGER :: i, j, k, ismpl
  EXTERNAL POR
  EXTERNAL POR_AD
  DOUBLE PRECISION :: t0, theta, dtheta, w0, tlocal, permi, ff, fi, &
& porlocal, POR
  DOUBLE PRECISION :: theta_ad, dtheta_ad, tlocal_ad, permi_ad, ff_ad, &
& fi_ad, porlocal_ad
  INTRINSIC ABS
  DOUBLE PRECISION :: abs0
  DOUBLE PRECISION :: temp0
  DOUBLE PRECISION :: temporary_ad
  INTEGER :: branch
  DOUBLE PRECISION :: kz
  tlocal = temp(i, j, k, ismpl)
  t0 = liq(i, j, k)
  IF (liq(i, j, k) - sol(i, j, k) .GE. 0.) THEN
    abs0 = liq(i, j, k) - sol(i, j, k)
  ELSE
    abs0 = -(liq(i, j, k)-sol(i, j, k))
  END IF
  w0 = abs0/2.d0
  CALL FTHETA(tlocal, t0, w0, theta, dtheta, ismpl)
  porlocal = POR(i, j, k, ismpl)
  ff = porlocal*theta
  fi = porlocal - ff
  permi = 10.d0**(-(100.d0*fi/(porlocal+1.d-12)))
  IF (permi .LT. 1.0d-6) THEN
    permi = 1.0d-6
    CALL PUSHCONTROL1B(0)
  ELSE
    CALL PUSHCONTROL1B(1)
  END IF
  propunit_ad(uindex(i, j, k), idx_kz, ismpl) = propunit_ad(uindex(i, j&
&   , k), idx_kz, ismpl) + permi*kz_adv
  permi_ad = propunit(uindex(i, j, k), idx_kz, ismpl)*kz_adv
  CALL POPCONTROL1B(branch)
  IF (branch .EQ. 0) permi_ad = 0.D0
  temp0 = fi/(porlocal+1.d-12)
  temporary_ad = -(100.d0*10.d0**(-(100.d0*temp0))*LOG(10.d0)*permi_ad/(&
&   porlocal+1.d-12))
  fi_ad = temporary_ad
  ff_ad = -fi_ad
  porlocal_ad = fi_ad - temp0*temporary_ad + theta*ff_ad
  theta_ad = porlocal*ff_ad
  CALL POR_AD(i, j, k, ismpl, porlocal_ad)
  tlocal_ad = 0.D0
  dtheta_ad = 0.D0
  CALL FTHETA_AD(tlocal, tlocal_ad, t0, w0, theta, theta_ad, dtheta, &
&          dtheta_ad, ismpl)
  temp_ad(i, j, k, ismpl) = temp_ad(i, j, k, ismpl) + tlocal_ad
END SUBROUTINE KZ_AD


      subroutine runY_0000i1i2(k,l,i1,i2,Xtwiddle,Gtwiddle,Shat6zz,N0)
      implicit none
C---  Expression for Eq. 5.58c
C---  Calculates D0000i1i2, requires D0000li1,D0000li2
C---  Small terms of order Xtwiddle(0,k)*D00iii,Xtwiddle(0,0)*D00iiii
C---  Denominator Gtwiddle(k,l)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,i1,i2,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat6zz(np,z3max,-2:0)

      if (  (i1 .eq. l) .or. (i2 .eq. l)
     . .or. (i1 .eq. 0) .or. (i2 .eq. 0)) then
      return
      endif

      do ep=-2,0

      Dv(dzzzzii(z2(i1,i2))+N0,ep)=
     .(-2d0*Gtwiddle(k,i1)*Dv(dzzzzii(z2(l,i2))+N0,ep)
     . -2d0*Gtwiddle(k,i2)*Dv(dzzzzii(z2(l,i1))+N0,ep)
     . +Gtwiddle(k,1)*Shat6zz(1,z3(l,i1,i2),ep)
     . +Gtwiddle(k,2)*Shat6zz(2,z3(l,i1,i2),ep)
     . +Gtwiddle(k,3)*Shat6zz(3,z3(l,i1,i2),ep)
     . +Xtwiddle(0,k)*Dv(dzziii(z3(l,i1,i2))+N0,ep)
     . -Xtwiddle(0,0)*Dv(dzziiii(z4(k,l,i1,i2))+N0,ep)
     . )/(2d0*Gtwiddle(k,l))
      enddo

      return
      end


!==========================================================================
elemental function gsw_entropy_from_t (sa, t, p)
!==========================================================================
!
! Calculates the specific entropy of seawater
!
! sa     : Absolute Salinity                               [g/kg]
! t      : in-situ temperature                             [deg C]
! p      : sea pressure                                    [dbar]
!
! gsw_entropy_from_t : specific entropy                    [J/(kg K)]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_gibbs

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, t, p

real (r8) :: gsw_entropy_from_t

integer, parameter :: n0=0, n1=1

gsw_entropy_from_t = -gsw_gibbs(n0,n1,n0,sa,t,p)

return
end function

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


C     LAST UPDATE 27/07/95
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE MRQMIN(X,Y,SIG,NDATA,A,MA,LISTA,MFIT,COVAR,ALPHA,NCA,
     &                  CHISQ,FUNCS,ALAMDA)
      IMPLICIT NONE
C
C Purpose: Non-linear least-squares by Levenberg-Marquardt method.
C          Attempts to reduce the value of CHISQ of a fit between a set
C          of NDATA points X(I),Y(I) with individual standard deviations
C          SIG(I) and a non-linear function dependent on MA coefficients
C          A. The array LISTA numbers the parameters A such that the
C          first MFIT elements correspond to values actually being
C          adjusted; the remaining MA-MFIT parameters are held fixed at
C          their input values. The program returns current best-fit
C          values for the  MA fit parameters A and CHISQ. The arrays
C          COVAR(NCA,NCA), ALPHA(NCA,NCA) with physical dimension NCA
C          (>= MFIT) are used as working space during most iterations.
C          Supply a subroutine FUNCS(X,A,YFIT,DYDA,MA) that evaluates
C          the fitting function YFIT and its derivatives DYDA with
C          respect to the fitting parameters A at X. On the first call
C          provide an initial guess for the parameters A and set ALAMDA
C          < 0 for initialization (which then sets ALAMDA=0.001). If a
C          step succeeds CHISQ becomes smaller and ALAMDA decreases by a
C          factor of 10. You must call this routine repeatedly until
C          convergence is achieved. Then make one final call with
C          ALAMDA=0.0, so that COVAR(I,J) returns the covariance matrix.
C
      INTEGER NDATA,MA,NCA,MFIT
      REAL X(NDATA),Y(NDATA),SIG(NDATA)
      DOUBLE PRECISION A(NCA)
      INTEGER LISTA(NCA)
      DOUBLE PRECISION COVAR(NCA,NCA),ALPHA(NCA,NCA)
      REAL CHISQ,ALAMDA
      EXTERNAL FUNCS
C
C Calls   6: TRED2 , TQLI , TBKSB , SYMINV , COVSRT , MRQCOF
C Called by:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      INTEGER NMAX
      DOUBLE PRECISION TINY,RMIN,FACTOR,ALAMIN,ALAMAX,DELMIN,DELMAX
      PARAMETER (NMAX=50,TINY=1.0D-30,RMIN=1.0D-06,FACTOR=10.0D0)
      PARAMETER (ALAMIN=1.0D-04,ALAMAX=1.0D+10,DELMIN=1.0D-30,
     &           DELMAX=1.0D+30)
      DOUBLE PRECISION ATRY(NMAX),BETA(NMAX),DA(NMAX),D(NMAX),E(NMAX),
     &                 PSCALE(NMAX)
      REAL DCHISQ,OCHISQ,RATIO,FAC,EPS
      DOUBLE PRECISION DELTA,DELTST,THRESH,DMAX,TEMP
      INTEGER J,K,KK,IHIT,ICOUNT,JCOUNT
      LOGICAL START,GOOD1
      SAVE ATRY,DELTA,BETA,OCHISQ,PSCALE,GOOD1
C
C---------------------------------------------------------------------
C
C========Do initializations
C
      START = .FALSE.
      ICOUNT = 0
      JCOUNT = 0
      FAC = 1.0
      EPS = 10.0
      IF(ALAMDA.LT.0.0)THEN
         KK = MFIT + 1
         DO 20 J=1,MA
            IHIT = 0
            DO 10 K=1,MFIT
               IF(LISTA(K).EQ.J)IHIT = IHIT + 1
 10         CONTINUE
            IF(IHIT.EQ.0)THEN
               LISTA(KK) = J
               KK = KK + 1
            ELSEIF(IHIT.GT.1)THEN
               STOP' Improper permutation in LISTA'
            ENDIF
 20      CONTINUE
         IF(KK.NE.(MA+1))STOP' Improper permutation in LISTA'
C
C========Fill out ALPHA and BETA arrays
C
         CALL MRQCOF(X,Y,SIG,NDATA,A,MA,LISTA,MFIT,ALPHA,BETA,NCA,
     &               CHISQ,FUNCS,PSCALE)
         OCHISQ = CHISQ
         DO 30 J=1,MA
            ATRY(J) = A(J)
 30      CONTINUE
         START = .TRUE.
         GOOD1 = .FALSE.
C
C========Initialize step limit scaling to the current gradient
C
         DELTA = 0.0D0
         DO 32 J=1,MFIT
            DELTA = DELTA + (A(J)*PSCALE(J))**2
 32      CONTINUE
         DELTA = MIN(FACTOR*SQRT(DELTA),DELMAX)
         IF(DELTA.LT.DELMIN)DELTA = DELMIN
         ALAMDA = ALAMIN
      ENDIF
C
C========Copy ALPHA into COVAR
C
      DO 50 J=1,MFIT
         DO 40 K=1,J-1
            TEMP = ALPHA(K,J)
            COVAR(K,J) = TEMP
            COVAR(J,K) = TEMP
 40      CONTINUE
 50   CONTINUE
C
C========Apply L-M factor to diagonal elements
C
 51   DO 52 J=1,MFIT
         TEMP = DBLE(1.0+ALAMDA)
         COVAR(J,J) = ALPHA(J,J)*TEMP
 52   CONTINUE
C
C========Find eigenvalues and eigenvectors of COVAR
C
      CALL TRED2(COVAR,MFIT,NCA,D,E)
      CALL TQLI(D,E,MFIT,NCA,COVAR)
C
C========Filter eigenvalues
C
      DMAX = 0.0D0
      DO 53 J=1,MFIT
         IF(ABS(D(J)).GT.DMAX)DMAX = D(J)
 53   CONTINUE
      IF(ALAMDA.GT.0.0)THEN
         THRESH = RMIN*DMAX
      ELSE
         THRESH = TINY
      ENDIF
      DO 54 J=1,MFIT
         IF(ABS(D(J)).LT.THRESH)D(J) = 0.0D0
 54   CONTINUE
      IF(ALAMDA.EQ.0.0)THEN
C
C========User wishes to call a halt - copy eigenvectors into ALPHA
C
         DO 56 J=1,MFIT
            DO 55 K=1,MFIT
               ALPHA(K,J) = COVAR(K,J)/PSCALE(K)
 55         CONTINUE
 56      CONTINUE
C
C========Construct covariance matrix from D and ALPHA
C
         CALL SYMINV(COVAR,D,ALPHA,MFIT,NCA)
C
C========Calculate covariances
C
         CALL COVSRT(COVAR,NCA,MA,LISTA,MFIT)
C
C========Will need to initialize ALPHA if called again
C
         ALAMDA = -1.0
         RETURN
      ENDIF
C
C========Back substitute to solve for BETA - result in DA
C
      CALL TBKSB(D,COVAR,MFIT,NCA,BETA,DA)
C
C========Test step against step limit and calculate expected reduction
C========in CHISQ
C
      DELTST = 0.0D0
      DCHISQ = 0.0D0
      DO 57 J=1,MFIT
         TEMP = DA(J)
         DELTST = DELTST + TEMP*TEMP
         DCHISQ = DCHISQ + TEMP*BETA(J)
 57   CONTINUE
      DELTST = SQRT(DELTST)
C
C========Reinitialize DELTA to first stepsize if necessary
C
      IF(START)THEN
         DELTA = MIN(DELTA,DELTST)
         DELTA = MAX(DELTA,DELMIN)
      ENDIF
C
C========Try to find a solution close to the boundary of trust region
C
      ICOUNT = ICOUNT + 1
      IF(DELTST.GT.DELTA)THEN
         IF(FAC.LT.1.0)THEN
            JCOUNT = JCOUNT + 1
            EPS = SQRT(EPS)
         ENDIF
         FAC = EPS
         ALAMDA = FAC*ALAMDA
         IF(ALAMDA.LT.ALAMAX)THEN
            GOTO 51
         ELSE
            ALAMDA = ALAMAX
         ENDIF
      ELSEIF(DELTST.LT.0.9*DELTA)THEN
         IF(FAC.GT.1.0)THEN
            JCOUNT = JCOUNT + 1
            EPS = SQRT(EPS)
         ENDIF
         FAC = 1.0/EPS
         ALAMDA = FAC*ALAMDA
         IF(ALAMDA.GT.ALAMIN)THEN
            IF(ICOUNT.LT.20.AND.JCOUNT.LT.10)GOTO 51
         ELSE
            ALAMDA = ALAMIN
         ENDIF
      ENDIF
C
C========Calculate actual reduction in CHISQ
C
      DO 60 J=1,MFIT
         ATRY(LISTA(J)) = A(LISTA(J)) + DA(J)/PSCALE(J)
 60   CONTINUE
      CALL MRQCOF(X,Y,SIG,NDATA,ATRY,MA,LISTA,MFIT,COVAR,DA,NCA,CHISQ,
     &            FUNCS,PSCALE)
C
C========Find ratio and test
C
      IF(DCHISQ.GT.0.0)THEN
         RATIO = (OCHISQ-CHISQ)/DCHISQ
      ELSE
         RATIO = 0.0
      ENDIF
      IF(RATIO.GT.0.0001)THEN
C
C========Good enough to accept this step
C
         GOOD1 = .TRUE.
         DO 80 J=1,MFIT
            DO 70 K=1,J-1
               TEMP = COVAR(K,J)
               ALPHA(K,J) = TEMP
               ALPHA(J,K) = TEMP
 70         CONTINUE
            ALPHA(J,J) = COVAR(J,J)
            BETA(J) = DA(J)
            A(LISTA(J)) = ATRY(LISTA(J))
 80      CONTINUE
         OCHISQ = CHISQ
         IF(RATIO.GT.0.75)THEN
C
C========Good enough to reset ALAMDA and double step size
C
            ALAMDA = MAX(ALAMDA/2.0,ALAMIN)
            DELTA = MIN(2.0D0*DELTA,2.0D0*DELTST,DELMAX)
         ELSEIF(RATIO.LT.0.25)THEN
C
C========Not so good - double ALAMDA and half step size
C
            ALAMDA = MIN(2.0*ALAMDA,ALAMAX)
            DELTA = MIN(DELTA,DELTST)/2.0D0
            DELTA = MAX(DELTA,DELMIN)
         ENDIF
      ELSE
C
C========This step is no good.
C========Increase ALAMDA by a factor of 10 and reduce DELTA likewise
C========Negate ALAMDA to signal possible convergence if we've had at
C========least one good step
C
         IF(RATIO.GT.0.0)THEN
            DELTA = MIN(DELTA,DELTST)/2.0D0
            ALAMDA = MIN(2.0*ALAMDA,ALAMAX)
         ELSE
            DELTA = MIN(DELTA,DELTST)/10.0D0
            ALAMDA = MIN(10.0*ALAMDA,ALAMAX)
         ENDIF
         DELTA = MAX(DELTA,DELMIN)
         IF(GOOD1)ALAMDA = -ALAMDA
      ENDIF
      RETURN
      END

C     LAST UPDATE 03/12/92
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE MRQCOF(X,Y,SIG,NDATA,A,MA,LISTA,MFIT,ALPHA,BETA,NALP,
     &                  CHISQ,FUNCS,PSCALE)
      IMPLICIT NONE
C
C Purpose: Used by MRQMIN to evaluate the linearized fitting matrix
C          ALPHA and vector BETA.
C
      INTEGER NDATA,NALP,MA,MFIT
      REAL X(NDATA),Y(NDATA),SIG(NDATA)
      REAL*8 ALPHA(NALP,NALP)
      REAL*8 BETA(MA),A(NALP),PSCALE(MA)
      INTEGER LISTA(NALP)
      REAL CHISQ
      EXTERNAL FUNCS
C
C Calls   1: FUNCS
C Called by: MRQMIN
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      INTEGER NMAX
      PARAMETER(NMAX=50)
      DOUBLE PRECISION TINY
      PARAMETER(TINY=1.0D-10)
      DOUBLE PRECISION DYDA(NMAX)
      DOUBLE PRECISION DY,SIG2I,WT,YMOD,XI
      INTEGER I,J,K
C
C---------------------------------------------------------------------
      DO 20 J=1,MFIT
         DO 10 K=1,J
            ALPHA(J,K) = 0.0D0
 10      CONTINUE
         BETA(J) = 0.0D0
         PSCALE(J) = 0.0D0
 20   CONTINUE
      CHISQ = 0.0
      DO 50 I=1,NDATA
         IF(Y(I).GT.-0.99E+30)THEN
            XI = DBLE(X(I))
            CALL FUNCS(XI,A,YMOD,DYDA,MA)
            SIG2I = 1.0D0/(DBLE(SIG(I))*DBLE(SIG(I)))
            DY = DBLE(Y(I)) - YMOD
            DO 40 J=1,MFIT
               WT = DYDA(LISTA(J))*SIG2I
               PSCALE(J) = PSCALE(J) + WT*DYDA(LISTA(J))
               DO 30 K=1,J
                  ALPHA(J,K) = ALPHA(J,K) + WT*DYDA(LISTA(K))
 30            CONTINUE
               BETA(J) = BETA(J) + DY*WT
 40         CONTINUE
            CHISQ = CHISQ + SNGL(DY*DY*SIG2I)
         ENDIF
 50   CONTINUE
      DO 70 J=1,MFIT
         IF(PSCALE(J).GT.TINY)THEN
            PSCALE(J) = SQRT(PSCALE(J))
         ELSE
            PSCALE(J) = 1.0D0
         ENDIF
         BETA(J) = BETA(J)/PSCALE(J)
         DO 60 K=1,J
            ALPHA(J,K) = ALPHA(J,K)/(PSCALE(J)*PSCALE(K))
            ALPHA(K,J) = ALPHA(J,K)
 60      CONTINUE
 70   CONTINUE
      RETURN
      END


MODULE Euler_SlopeLimiterModule_NonRelativistic_TABLE

  USE KindModule, ONLY: &
    DP, &
    Zero, &
    One
  USE UnitsModule, ONLY: &
    AtomicMassUnit
  USE ProgramHeaderModule, ONLY: &
    nDOFX, &
    nDimsX, &
    nNodes, &
    nNodesX, &
    bcX
  USE ReferenceElementModuleX, ONLY: &
    WeightsX_q
  USE UtilitiesModule, ONLY: &
    MinModB, &
    NodeNumberX
  USE PolynomialBasisModule_Legendre, ONLY: &
    P_X1, &
    P_X2, &
    P_X3, &
    IndPX_Q
  USE PolynomialBasisMappingModule, ONLY: &
    MapNodalToModal_Fluid, &
    MapModalToNodal_Fluid
  USE MeshModule, ONLY: &
    MeshX
  USE GeometryFieldsModule, ONLY: &
    nGF, &
    iGF_Gm_dd_11, &
    iGF_Gm_dd_22, &
    iGF_Gm_dd_33, &
    iGF_SqrtGm
  USE FluidFieldsModule, ONLY: &
    nCF, &
    iCF_D, &
    iCF_Ne, &
    iDF_TCI
  USE Euler_BoundaryConditionsModule, ONLY: &
    ApplyInnerBC_Euler,  &
    ApplyOuterBC_Euler,  &
    iApplyBC_Euler_Both, &
    ApplyBoundaryConditions_Euler
  USE Euler_CharacteristicDecompositionModule_NonRelativistic_TABLE, ONLY: &
    ComputeCharacteristicDecomposition_Euler_NonRelativistic_TABLE
  USE Euler_DiscontinuityDetectionModule, ONLY: &
    InitializeTroubledCellIndicator_Euler, &
    FinalizeTroubledCellIndicator_Euler, &
    LimiterThreshold, &
    DetectTroubledCells_Euler
  USE TimersModule_Euler, ONLY: &
    TimersStart_Euler, &
    TimersStop_Euler, &
    Timer_Euler_SlopeLimiter

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: InitializeSlopeLimiter_Euler_NonRelativistic_TABLE
  PUBLIC :: FinalizeSlopeLimiter_Euler_NonRelativistic_TABLE
  PUBLIC :: ApplySlopeLimiter_Euler_NonRelativistic_TABLE

  LOGICAL  :: UseSlopeLimiter
  LOGICAL  :: UseCharacteristicLimiting
  LOGICAL  :: UseConservativeCorrection
  LOGICAL  :: Verbose
  REAL(DP) :: BetaTVD, BetaTVB
  REAL(DP) :: SlopeTolerance
  REAL(DP) :: I_6x6(1:6,1:6)

CONTAINS

  SUBROUTINE InitializeSlopeLimiter_Euler_NonRelativistic_TABLE &
    ( BetaTVD_Option, BetaTVB_Option, SlopeTolerance_Option, &
      UseSlopeLimiter_Option, UseCharacteristicLimiting_Option, &
      UseTroubledCellIndicator_Option, LimiterThresholdParameter_Option, &
      UseConservativeCorrection_Option, Verbose_Option )

    REAL(DP), INTENT(in), OPTIONAL :: &
      BetaTVD_Option, BetaTVB_Option
    REAL(DP), INTENT(in), OPTIONAL :: &
      SlopeTolerance_Option
    LOGICAL,  INTENT(in), OPTIONAL :: &
      UseSlopeLimiter_Option, &
      UseCharacteristicLimiting_Option, &
      UseTroubledCellIndicator_Option, &
      UseConservativeCorrection_Option, &
      Verbose_Option
    REAL(DP), INTENT(in), OPTIONAL :: &
      LimiterThresholdParameter_Option

    INTEGER  :: i
    LOGICAL  :: UseTroubledCellIndicator
    REAL(DP) :: LimiterThresholdParameter

    IF( PRESENT( BetaTVD_Option ) )THEN
      BetaTVD = BetaTVD_Option
    ELSE
      BetaTVD = One
    END IF

    IF( PRESENT( BetaTVB_Option ) )THEN
      BetaTVB = BetaTVB_Option
    ELSE
      BetaTVB = Zero
    END IF

    IF( PRESENT( SlopeTolerance_Option ) )THEN
      SlopeTolerance = SlopeTolerance_Option
    ELSE
      SlopeTolerance = 1.0d-3
    END IF

    IF( PRESENT( UseSlopeLimiter_Option ) )THEN
      UseSlopeLimiter = UseSlopeLimiter_Option
    ELSE
      UseSlopeLimiter = .TRUE.
    END IF

    IF( PRESENT( UseCharacteristicLimiting_Option ) )THEN
      UseCharacteristicLimiting = UseCharacteristicLimiting_Option
    ELSE
      UseCharacteristicLimiting = .FALSE.
    END IF

    IF( PRESENT( UseTroubledCellIndicator_Option ) )THEN
      UseTroubledCellIndicator = UseTroubledCellIndicator_Option
    ELSE
      UseTroubledCellIndicator = .TRUE.
    END IF

    IF( PRESENT( LimiterThresholdParameter_Option ) )THEN
      LimiterThresholdParameter = LimiterThresholdParameter_Option
    ELSE
      LimiterThresholdParameter = 0.03_DP
    END IF

    IF( PRESENT( UseConservativeCorrection_Option ) )THEN
      UseConservativeCorrection = UseConservativeCorrection_Option
    ELSE
      UseConservativeCorrection = .TRUE.
    END IF

    IF( PRESENT( Verbose_Option ) )THEN
      Verbose = Verbose_Option
    ELSE
      Verbose = .TRUE.
    END IF

    CALL InitializeTroubledCellIndicator_Euler &
           ( UseTroubledCellIndicator_Option = UseTroubledCellIndicator, &
             LimiterThresholdParameter_Option = LimiterThresholdParameter )

    IF( Verbose )THEN
      WRITE(*,*)
      WRITE(*,'(A)') '  INFO: InitializeSlopeLimiter_Euler_NonRelativistic_TABLE:'
      WRITE(*,'(A)') '  ---------------------------------------------------------'
      WRITE(*,*)
      WRITE(*,'(A4,A27,L1)'      ) '', 'UseSlopeLimiter: ' , &
        UseSlopeLimiter
      WRITE(*,*)
      WRITE(*,'(A4,A27,ES9.3E2)' ) '', 'BetaTVD: ' , &
        BetaTVD
      WRITE(*,'(A4,A27,ES9.3E2)' ) '', 'BetaTVB: ' , &
        BetaTVB
      WRITE(*,'(A4,A27,ES9.3E2)' ) '', 'SlopeTolerance: ' , &
        SlopeTolerance
      WRITE(*,'(A4,A27,L1)'      ) '', 'UseCharacteristicLimiting: ' , &
        UseCharacteristicLimiting
      WRITE(*,*)
      WRITE(*,'(A4,A27,L1)'      ) '', 'UseTroubledCellIndicator: ' , &
        UseTroubledCellIndicator
      WRITE(*,*)
      WRITE(*,'(A4,A27,ES9.3E2)' ) '', 'LimiterThreshold: ' , &
        LimiterThreshold
    END IF

    I_6x6 = Zero
    DO i = 1, 6
      I_6x6(i,i) = One
    END DO

  END SUBROUTINE InitializeSlopeLimiter_Euler_NonRelativistic_TABLE

  SUBROUTINE FinalizeSlopeLimiter_Euler_NonRelativistic_TABLE

    CALL FinalizeTroubledCellIndicator_Euler

  END SUBROUTINE FinalizeSlopeLimiter_Euler_NonRelativistic_TABLE

  SUBROUTINE ApplySlopeLimiter_Euler_NonRelativistic_TABLE &
    ( iX_B0, iX_E0, iX_B1, iX_E1, G, U, D, SuppressBC_Option, iApplyBC_Option )

    INTEGER,  INTENT(in)           :: &
      iX_B0(3), iX_E0(3), iX_B1(3), iX_E1(3)
    REAL(DP), INTENT(in)           :: &
      G(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    REAL(DP), INTENT(inout)        :: &
      U(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    REAL(DP), INTENT(inout)        :: &
      D(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    LOGICAL,  INTENT(in), OPTIONAL :: &
      SuppressBC_Option
    INTEGER,  INTENT(in), OPTIONAL :: &
      iApplyBC_Option(3)

    LOGICAL  :: LimitedCell(nCF,iX_B0(1):iX_E0(1), &
                                iX_B0(2):iX_E0(2), &
                                iX_B0(3):iX_E0(3))
    LOGICAL  :: SuppressBC
    LOGICAL  :: LimitField(nCF)
    LOGICAL  :: ExcludeInnerGhostCell(3), ExcludeOuterGhostCell(3)
    INTEGER  :: iX1, iX2, iX3, iGF, iCF
    INTEGER  :: iApplyBC(3)
    REAL(DP) :: dX1, dX2, dX3
    REAL(DP) :: dY(nDimsX)
    REAL(DP) :: SlopeDifference(nCF)
    REAL(DP) :: a(nCF), b(nCF), c(nCF) ! --- Arguments for MinMod (fluid)
    REAL(DP) :: aY    , bY    , cY     ! --- Arguments for MinMod (Ye)
    REAL(DP) :: G_K(nGF)
    REAL(DP) :: dU (nCF,nDimsX)
    REAL(DP) :: U_M(nCF,0:2*nDimsX,nDOFX)
    REAL(DP) :: Y_N(    0:2*nDimsX,nDOFX) ! --- Nodal Ye
    REAL(DP) :: Y_M(    0:2*nDimsX,nDOFX) ! --- Modal Ye
    REAL(DP) :: R_X1(nCF,nCF), invR_X1(nCF,nCF)
    REAL(DP) :: R_X2(nCF,nCF), invR_X2(nCF,nCF)
    REAL(DP) :: R_X3(nCF,nCF), invR_X3(nCF,nCF)
    REAL(DP) :: V_K(iX_B0(1):iX_E0(1),iX_B0(2):iX_E0(2),iX_B0(3):iX_E0(3))
    REAL(DP) :: U_K(nCF,iX_B0(1):iX_E0(1),iX_B0(2):iX_E0(2),iX_B0(3):iX_E0(3))

    IF( nDOFX == 1 ) RETURN

    IF( .NOT. UseSlopeLimiter ) RETURN

    CALL TimersStart_Euler( Timer_Euler_SlopeLimiter )

    U_M = Zero

    iApplyBC = iApplyBC_Euler_Both
    IF( PRESENT( iApplyBC_Option ) ) &
      iApplyBC = iApplyBC_Option

    SuppressBC = .FALSE.
    IF( PRESENT( SuppressBC_Option ) ) &
      SuppressBC = SuppressBC_Option

    IF( .NOT. SuppressBC ) &
      CALL ApplyBoundaryConditions_Euler &
             ( iX_B0, iX_E0, iX_B1, iX_E1, U )

    CALL DetectTroubledCells_Euler &
           ( iX_B0, iX_E0, iX_B1, iX_E1, U, D )

    LimitedCell = .FALSE.

    ExcludeInnerGhostCell = .FALSE.
    ExcludeOuterGhostCell = .FALSE.
    IF( ApplyInnerBC_Euler( iApplyBC(1) ) .AND. bcX(1) .NE. 1 ) &
      ExcludeInnerGhostCell(1) = .TRUE.
    IF( ApplyOuterBC_Euler( iApplyBC(1) ) .AND. bcX(1) .NE. 1 ) &
      ExcludeOuterGhostCell(1) = .TRUE.
    IF( ApplyInnerBC_Euler( iApplyBC(2) ) .AND. bcX(2) .NE. 1 ) &
      ExcludeInnerGhostCell(2) = .TRUE.
    IF( ApplyOuterBC_Euler( iApplyBC(2) ) .AND. bcX(2) .NE. 1 ) &
      ExcludeOuterGhostCell(2) = .TRUE.
    IF( ApplyInnerBC_Euler( iApplyBC(3) ) .AND. bcX(3) .NE. 1 ) &
      ExcludeInnerGhostCell(3) = .TRUE.
    IF( ApplyOuterBC_Euler( iApplyBC(3) ) .AND. bcX(3) .NE. 1 ) &
      ExcludeOuterGhostCell(3) = .TRUE.

    DO iX3 = iX_B0(3), iX_E0(3)
    DO iX2 = iX_B0(2), iX_E0(2)
    DO iX1 = iX_B0(1), iX_E0(1)

      IF( ALL( D(:,iX1,iX2,iX3,iDF_TCI) < LimiterThreshold ) ) CYCLE

      dX1 = MeshX(1) % Width(iX1)
      dX2 = MeshX(2) % Width(iX2)
      dX3 = MeshX(3) % Width(iX3)

      ! --- Cell Volume ---

      V_K(iX1,iX2,iX3) &
        = DOT_PRODUCT( WeightsX_q(:), G(:,iX1,iX2,iX3,iGF_SqrtGm) )

      ! --- Cell Average of Conserved Fluid ---

      DO iCF = 1, nCF

        U_K(iCF,iX1,iX2,iX3) &
          = SUM( WeightsX_q(:) * G(:,iX1,iX2,iX3,iGF_SqrtGm) &
                   * U(:,iX1,iX2,iX3,iCF) ) / V_K(iX1,iX2,iX3)

      END DO

      ! --- Map to Modal Representation ---

      DO iCF = 1, nCF

        CALL MapNodalToModal_Fluid &
               ( U(:,iX1,iX2,iX3,iCF), U_M(iCF,0,:) )

        ! --- Cell Average of Neighbors in X1 Direction ---

        U_M(iCF,1,1) &
          = DOT_PRODUCT( WeightsX_q(:), U(:,iX1-1,iX2,iX3,iCF) )

        U_M(iCF,2,1) &
          = DOT_PRODUCT( WeightsX_q(:), U(:,iX1+1,iX2,iX3,iCF) )

        IF( nDimsX > 1 )THEN

          ! --- Cell Average of Neighbors in X2 Direction ---

          U_M(iCF,3,1) &
            = DOT_PRODUCT( WeightsX_q(:), U(:,iX1,iX2-1,iX3,iCF) )

          U_M(iCF,4,1) &
            = DOT_PRODUCT( WeightsX_q(:), U(:,iX1,iX2+1,iX3,iCF) )

        END IF

        IF( nDimsX > 2 )THEN

          ! --- Cell Average of Neighbors in X3 Direction ---

          U_M(iCF,5,1) &
            = DOT_PRODUCT( WeightsX_q(:), U(:,iX1,iX2,iX3-1,iCF) )

          U_M(iCF,6,1) &
            = DOT_PRODUCT( WeightsX_q(:), U(:,iX1,iX2,iX3+1,iCF) )

        END IF

      END DO

      IF( UseCharacteristicLimiting )THEN

        ! --- Cell Average of Geometry (Spatial Metric Only) ---

        DO iGF = iGF_Gm_dd_11, iGF_Gm_dd_33

          G_K(iGF) = DOT_PRODUCT( WeightsX_q(:), G(:,iX1,iX2,iX3,iGF) )

        END DO

        ! --- Compute Eigenvectors ---

        CALL ComputeCharacteristicDecomposition_Euler_NonRelativistic_TABLE &
               ( 1, G_K(:), U_M(:,0,1), R_X1, invR_X1 )

        IF( nDimsX > 1 )THEN

          CALL ComputeCharacteristicDecomposition_Euler_NonRelativistic_TABLE &
                 ( 2, G_K(:), U_M(:,0,1), R_X2, invR_X2 )

        END IF

        IF( nDimsX > 2 )THEN

          CALL ComputeCharacteristicDecomposition_Euler_NonRelativistic_TABLE &
                 ( 3, G_K(:), U_M(:,0,1), R_X3, invR_X3 )

        END IF

      ELSE

        ! --- Componentwise Limiting ---

        R_X1 = I_6x6; invR_X1 = I_6x6
        R_X2 = I_6x6; invR_X2 = I_6x6
        R_X3 = I_6x6; invR_X3 = I_6x6

      END IF

      ! --- Compute Limited Slopes ---
      IF( UseCharacteristicLimiting ) &
        U_M(iCF_Ne,:,:) = U_M(iCF_Ne,:,:) * AtomicMassUnit

      a = MATMUL( invR_X1, U_M(:,0,2) )

      IF     ( iX1 .EQ. iX_B0(1) .AND. ExcludeInnerGhostCell(1) )THEN

        c = BetaTVD * MATMUL( invR_X1, ( U_M(:,2,1) - U_M(:,0,1) ) )
        b = c

      ELSE IF( iX1 .EQ. iX_E0(1) .AND. ExcludeOuterGhostCell(1) )THEN

        b = BetaTVD * MATMUL( invR_X1, ( U_M(:,0,1) - U_M(:,1,1) ) )
        c = b

      ELSE

        b = BetaTVD * MATMUL( invR_X1, ( U_M(:,0,1) - U_M(:,1,1) ) )
        c = BetaTVD * MATMUL( invR_X1, ( U_M(:,2,1) - U_M(:,0,1) ) )

      END IF

      dU(:,1) = MinModB( a, b, c, dX1, BetaTVB )

      IF( nDimsX > 1 )THEN

        a = MATMUL( invR_X2, U_M(:,0,3) )

        IF     ( iX2 .EQ. iX_B0(2) .AND. ExcludeInnerGhostCell(2) )THEN

          c = BetaTVD * MATMUL( invR_X2, ( U_M(:,4,1) - U_M(:,0,1) ) )
          b = c

        ELSE IF( iX2 .EQ. iX_E0(2) .AND. ExcludeOuterGhostCell(2) )THEN

          b = BetaTVD * MATMUL( invR_X2, ( U_M(:,0,1) - U_M(:,3,1) ) )
          c = b

        ELSE

          b = BetaTVD * MATMUL( invR_X2, ( U_M(:,0,1) - U_M(:,3,1) ) )
          c = BetaTVD * MATMUL( invR_X2, ( U_M(:,4,1) - U_M(:,0,1) ) )

        END IF

        dU(:,2) = MinModB( a, b, c, dX2, BetaTVB )

      END IF

      IF( nDimsX > 2 )THEN

        a = MATMUL( invR_X3, U_M(:,0,4) )

        IF     ( iX3 .EQ. iX_B0(3) .AND. ExcludeInnerGhostCell(3) )THEN

          c = BetaTVD * MATMUL( invR_X3, ( U_M(:,6,1) - U_M(:,0,1) ) )
          b = c

        ELSE IF( iX3 .EQ. iX_E0(3) .AND. ExcludeOuterGhostCell(3) )THEN

          b = BetaTVD * MATMUL( invR_X3, ( U_M(:,0,1) - U_M(:,5,1) ) )
          c = b

        ELSE

          b = BetaTVD * MATMUL( invR_X3, ( U_M(:,0,1) - U_M(:,5,1) ) )
          c = BetaTVD * MATMUL( invR_X3, ( U_M(:,6,1) - U_M(:,0,1) ) )

        END IF

        dU(:,3) = MinModB( a, b, c, dX3, BetaTVB )

      END IF

      IF( UseCharacteristicLimiting )THEN

        ! --- Transform Back from Characteristic Variables ---

        dU(:,1) = MATMUL( R_X1, dU(:,1) )

        dU(iCF_Ne,1) = dU(iCF_Ne,1) / AtomicMassUnit
        U_M(iCF_Ne,:,:) = U_M(iCF_Ne,:,:) / AtomicMassUnit !hack

        IF( nDimsX > 1 )THEN

          dU(:,2) = MATMUL( R_X2, dU(:,2) )

        END IF

        IF( nDimsX > 2 )THEN

          dU(:,3) = MATMUL( R_X3, dU(:,3) )

        END IF

      END IF

      ! --- Compute Ye Slopes ---

      Y_N(0,:) = U(:,iX1,iX2,iX3,iCF_Ne) * AtomicMassUnit &
                 / U(:,iX1,iX2,iX3,iCF_D)

      CALL MapNodalToModal_Fluid( Y_N(0,:), Y_M(0,:) )

      Y_N(1,:) = U(:,iX1-1,iX2,iX3,iCF_Ne) * AtomicMassUnit &
                   / U(:,iX1-1,iX2,iX3,iCF_D)
      Y_N(2,:) = U(:,iX1+1,iX2,iX3,iCF_Ne) * AtomicMassUnit &
                   / U(:,iX1+1,iX2,iX3,iCF_D)

      Y_M(1,1) = DOT_PRODUCT( WeightsX_q, Y_N(1,:) )
      Y_M(2,1) = DOT_PRODUCT( WeightsX_q, Y_N(2,:) )

      aY = Y_M(0,2)

      IF( .NOT. ExcludeOuterGhostCell(1) &
            .AND. .NOT. ExcludeInnerGhostCell(1) )THEN

        bY = BetaTVD * ( Y_M(0,1) - Y_M(1,1) )
        cY = BetaTVD * ( Y_M(2,1) - Y_M(0,1) )

      ELSE IF( ExcludeInnerGhostCell(1) )THEN

        cY = BetaTVD * ( Y_M(2,1) - Y_M(0,1) )
        bY = cY

      ELSE IF( ExcludeOuterGhostCell(1) )THEN

        cY = BetaTVD * ( Y_M(0,1) - Y_M(1,1) )
        bY = cY

      END IF

      dY(1) = MinModB( aY, bY, cY, dX1, BetaTVB )

      IF( nDimsX > 1 )THEN

        Y_N(3,:) = U(:,iX1,iX2-1,iX3,iCF_Ne) * AtomicMassUnit &
                     / U(:,iX1,iX2-1,iX3,iCF_D)
        Y_N(4,:) = U(:,iX1,iX2+1,iX3,iCF_Ne) * AtomicMassUnit &
                     / U(:,iX1,iX2+1,iX3,iCF_D)

        Y_M(3,1) = DOT_PRODUCT( WeightsX_q, Y_N(3,:) )
        Y_M(4,1) = DOT_PRODUCT( WeightsX_q, Y_N(4,:) )

        aY = Y_M(0,3)

        IF( .NOT. ExcludeOuterGhostCell(2) &
              .AND. .NOT. ExcludeInnerGhostCell(2) )THEN

          bY = BetaTVD * ( Y_M(0,1) - Y_M(3,1) )
          cY = BetaTVD * ( Y_M(4,1) - Y_M(0,1) )

        ELSE IF( ExcludeInnerGhostCell(2) )THEN

          cY = BetaTVD * ( Y_M(4,1) - Y_M(0,1) )
          bY = cY

        ELSE IF( ExcludeOuterGhostCell(1) )THEN

          bY = BetaTVD * ( Y_M(0,1) - Y_M(3,1) )
          cY = bY

        END IF

        dY(2) = MinModB( aY, bY, cY, dX2, BetaTVB )

      END IF

      IF( nDimsX > 2 )THEN

        Y_N(5,:) = U(:,iX1,iX2,iX3-1,iCF_Ne) * AtomicMassUnit &
                     / U(:,iX1,iX2,iX3-1,iCF_D)
        Y_N(6,:) = U(:,iX1,iX2,iX3+1,iCF_Ne) * AtomicMassUnit &
                     / U(:,iX1,iX2,iX3+1,iCF_D)

        Y_M(5,1) = DOT_PRODUCT( WeightsX_q, Y_N(5,:) )
        Y_M(6,1) = DOT_PRODUCT( WeightsX_q, Y_N(6,:) )

        aY = Y_M(0,4)

        IF( .NOT. ExcludeOuterGhostCell(3) &
              .AND. .NOT. ExcludeInnerGhostCell(3) )THEN

          bY = BetaTVD * ( Y_M(0,1) - Y_M(5,1) )
          cY = BetaTVD * ( Y_M(6,1) - Y_M(0,1) )

        ELSE IF( ExcludeInnerGhostCell(3) )THEN

          cY = BetaTVD * ( Y_M(6,1) - Y_M(0,1) )
          bY = cY

        ELSE IF( ExcludeOuterGhostCell(3) )THEN

          bY = BetaTVD * ( Y_M(0,1) - Y_M(5,1) )
          cY = bY

        END IF

        dY(3) = MinModB( aY, bY, cY, dX3, BetaTVB )

      END IF

      ! --- Compare Limited Slopes to Original Slopes ---

      DO iCF = 1, nCF

        SlopeDifference(iCF) &
          = ABS( U_M(iCF,0,2) - dU(iCF,1) )

        IF( nDimsX > 1 )THEN

          SlopeDifference(iCF) &
            = MAX( SlopeDifference(iCF), &
                   ABS( U_M(iCF,0,3) - dU(iCF,2) ) )

        END IF

        IF( nDimsX > 2 )THEN

          SlopeDifference(iCF) &
            = MAX( SlopeDifference(iCF), &
                   ABS( U_M(iCF,0,4) - dU(iCF,3) ) )

        END IF

      END DO

      ! --- Replace Slopes and Discard High-Order Components ---
      ! --- if Limited Slopes Deviate too Much from Original ---

      LimitField = SlopeDifference > SlopeTolerance * ABS( U_M(:,0,1) )

      IF( LimitField(iCF_D) .NEQV. LimitField(iCF_Ne) )THEN

        LimitField(iCF_D)  = .TRUE.
        LimitField(iCF_Ne) = .TRUE.

      END IF

      IF( ABS( Y_M(0,2) - dY(1) ) > SlopeTolerance * ABS( Y_M(0,1) ) )THEN

        LimitField(iCF_D)  = .TRUE.
        LimitField(iCF_Ne) = .TRUE.

      END IF

      IF( nDimsX > 1 )THEN

        IF( ABS( Y_M(0,3) - dY(2) ) > SlopeTolerance * ABS( Y_M(0,1) ) )THEN

          LimitField(iCF_D)  = .TRUE.
          LimitField(iCF_Ne) = .TRUE.

        END IF

      END IF

      IF( nDimsX > 2 )THEN

        IF( ABS( Y_M(0,4) - dY(3) ) > SlopeTolerance * ABS( Y_M(0,1) ) )THEN

          LimitField(iCF_D)  = .TRUE.
          LimitField(iCF_Ne) = .TRUE.

        END IF

      END IF

      DO iCF = 1, nCF

        IF( LimitField(iCF) )THEN

          U_M(iCF,0,2:nDOFX) = Zero

          IF( iCF .NE. iCF_Ne )THEN

            U_M(iCF,0,2) = dU(iCF,1)

            IF( nDimsX > 1 ) &
              U_M(iCF,0,3) = dU(iCF,2)

            IF( nDimsX > 2 ) &
              U_M(iCF,0,4) = dU(iCF,3)

          ELSE

            ! --- Electron Density ---

            U_M(iCF,0,2) &
              = ( U_M(iCF_D,0,1) * dY(1) + Y_M(0,1) * dU(iCF_D,1) ) &
                  / AtomicMassUnit

            IF( nDimsX > 1 ) &
              U_M(iCF,0,3) &
                = ( U_M(iCF_D,0,1) * dY(2) + Y_M(0,1) * dU(iCF_D,2) ) &
                    / AtomicMassUnit

            IF( nDimsX > 2 ) &
              U_M(iCF,0,4) &
                = ( U_M(iCF_D,0,1) * dY(3) + Y_M(0,1) * dU(iCF_D,3) ) &
                    / AtomicMassUnit

          END IF

          CALL MapModalToNodal_Fluid &
                 ( U(:,iX1,iX2,iX3,iCF), U_M(iCF,0,:) )

          LimitedCell(iCF,iX1,iX2,iX3) = .TRUE.

        END IF

      END DO

    END DO
    END DO
    END DO

    CALL ApplyConservativeCorrection &
           ( iX_B0, iX_E0, iX_B1, iX_E1, G, V_K, U, U_K, LimitedCell )

    CALL TimersStop_Euler( Timer_Euler_SlopeLimiter )

  END SUBROUTINE ApplySlopeLimiter_Euler_NonRelativistic_TABLE

  SUBROUTINE ApplyConservativeCorrection &
    ( iX_B0, iX_E0, iX_B1, iX_E1, G, V_K, U, U_K, LimitedCell )

    INTEGER, INTENT(in)     :: &
      iX_B0(3), iX_E0(3), iX_B1(3), iX_E1(3)
    REAL(DP), INTENT(in)    :: &
      G(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    REAL(DP), INTENT(in)    :: &
      V_K(iX_B0(1):iX_E0(1),iX_B0(2):iX_E0(2),iX_B0(3):iX_E0(3))
    REAL(DP), INTENT(in)    :: &
      U_K(1:nCF,iX_B0(1):iX_E0(1),iX_B0(2):iX_E0(2),iX_B0(3):iX_E0(3))
    REAL(DP), INTENT(inout) :: &
      U(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    LOGICAL, INTENT(in)     :: &
      LimitedCell(nCF,iX_B0(1):iX_E0(1),iX_B0(2):iX_E0(2),iX_B0(3):iX_E0(3))

    INTEGER  :: iX1, iX2, iX3, iCF, iPol, iDimX
    INTEGER  :: iNodeX1, iNodeX2, iNodeX3, iNodeX
    REAL(DP) :: Correction
    REAL(DP) :: LegendreX(nDOFX,nDOFX)
    REAL(DP) :: U_M(nCF,0:2**nDimsX,nDOFX)

    IF( .NOT. UseConservativeCorrection ) RETURN

    DO iPol = 1, nDOFX ! Only need for iPol = 2,3,4 (FIXME)

      DO iNodeX3 = 1, nNodesX(3)
      DO iNodeX2 = 1, nNodesX(2)
      DO iNodeX1 = 1, nNodesX(1)

        iNodeX = NodeNumberX( iNodeX1, iNodeX2, iNodeX3 )

        LegendreX(iNodeX,iPol) &
          = P_X1  (IndPX_Q(1,iPol)) % P( MeshX(1) % Nodes(iNodeX1) ) &
            * P_X2(IndPX_Q(2,iPol)) % P( MeshX(2) % Nodes(iNodeX2) ) &
            * P_X3(IndPX_Q(3,iPol)) % P( MeshX(3) % Nodes(iNodeX3) )

      END DO
      END DO
      END DO

    END DO

    ! --- Applies a correction to the 0-th order ---
    ! --- mode to maintain the cell average.     ---

    DO iX3 = iX_B0(3), iX_E0(3)
    DO iX2 = iX_B0(2), iX_E0(2)
    DO iX1 = iX_B0(1), iX_E0(1)

      DO iCF = 1, nCF

        IF( LimitedCell(iCF,iX1,iX2,iX3) )THEN

          CALL MapNodalToModal_Fluid( U(:,iX1,iX2,iX3,iCF), U_M(iCF,0,:) )

          Correction = Zero
          DO iDimX = 1, nDimsX

            Correction &
              = Correction &
                  + ( U_M(iCF,0,iDimX+1) &
                      * SUM( WeightsX_q(:) * LegendreX(:,iDimX+1) &
                             * G(:,iX1,iX2,iX3,iGF_SqrtGm) ) ) &
                    / V_K(iX1,iX2,iX3)

          END DO

          U_M(iCF,0,1) = U_K(iCF,iX1,iX2,iX3) - Correction

          CALL MapModalToNodal_Fluid( U(:,iX1,iX2,iX3,iCF), U_M(iCF,0,:) )

        END IF

      END DO

    END DO
    END DO
    END DO

  END SUBROUTINE ApplyConservativeCorrection

END MODULE Euler_SlopeLimiterModule_NonRelativistic_TABLE