SUBROUTINE scell(x,y,sig,c,mu,eta,ord,incx,incy,i,j,g,outx,outy,b)

!-------------------------------------------------------------
!
!  scell solves the local system of equations that are
!  characteristic for the spatial discretization scheme
!  of a single cell.
!
!  Inputs:
!
!  ** x     - cell thickness in x-direction
!  ** y     - cell thickness in y-direction
!  ** sig   - total cross section
!  ** c     - scattering ratio
!  ** mu    - standard
!  ** eta   - standard
!  ** ord   - lambda
!  ** incx  - sweep direction x
!  ** incy  - sweep direction y
!  ** i,j   - cell index
!  ** g     - group index
!
!  In/Outputs
!
!  ** outx: upon input  - incoming flux moment  left/right
!           upon output - outgoing flux moments left/right
!  ** outy: upon input  - incoming flux moment  bottom/top
!           upon output - outgoing flux moments bottom/top
!
!  Outputs:
!
!  ** nodal moments: b
!
!  *** Available Methods ***
!
!  ** Case 0: AHOT-N
!  ** Case 1: AHOT-N with asymptotic weights
!  ** Case 2: WDD with fixed spatial weight
!  ** Case 3: AHOT-C
!  ** Case 4: Higher Order Diamond Difference
!
!-------------------------------------------------------------

USE invar
USE solvar
!
IMPLICIT NONE
!
! Input
!
REAL*8 ,INTENT(in) :: x,y
REAL*8 ,INTENT(in) :: sig,c
REAL*8 ,INTENT(in) :: mu,eta
INTEGER,INTENT(in) :: ord
INTEGER,INTENT(in) :: incx
INTEGER,INTENT(in) :: incy
INTEGER,INTENT(in) :: i,j
INTEGER,INTENT(in) :: g
!
! In/Output
!
REAL*8 :: outx(0:ord)
REAL*8 :: outy(0:ord)
REAL*8 :: b(ordsq)
!
! Local Variables
!
INTEGER :: k,l,n,m
REAL*8 :: a(ordsq,ordsq)
INTEGER, DIMENSION(ordsq) :: piv
REAL*8, DIMENSION (ordsq) :: wrk
INTEGER :: mltx,mlty
INTEGER :: ll,ieq,col,indx,jndx,info
REAL*8 :: sgn,factor
INTEGER :: sgm,sge
INTEGER :: kmin,kmax
REAL*8 :: xi,sum1,sum2,smi,sei,sel,source
REAL*8 :: fai,faj,fxp,fxn,fyp,fyn,oe
REAL*8 :: inx(ord+1),iny(ord+1)
REAL*8 :: fmom(ord+1,ord+1),oux(ord+1),ouy(ord+1)
!
! Switch between Discretization Schemes
!
SELECT CASE (ctype)
   CASE(0) ! AHOT-N
      ! Call for the calculation of the spatial weights
      CALL weitn(ord,x,y,sig,mu,eta)
      ! Begin constructing Matrix Equation
      sgm = incx
      sge = incy
      ieq = 0
      !
      ! Initialize 'a' matrix
      a = 0.0
      !
      DO k = 0, lambda
         mltx = sgm**k
         !
         DO l = 0, lambda
            mlty = sge**l
            ieq = ieq + 1
            !
            ! Contributions from outgoing fluxes
            ! Even summations
            DO ll = 0, lambda, 2
               ! x-constant surface
               col = order*ll + l + 1
               a(ieq,col) = a(ieq,col) + mltx*(2.0*ll+1.0)/(ex*(1.0+alpha))
               ! y-constant surface
               col = order*k + ll + 1
               a(ieq,col) = a(ieq,col) + mlty*(2.0*ll+1.0)/(ey*(1.0+beta))
            END DO
            !
            ! Odd summations
            DO ll = 1, lambda, 2
               ! x-constant surface
               col = order*ll + l + 1
               a(ieq,col) = a(ieq,col) + mltx*(2.0*ll+1.0)*sgm*alpha/(ex*(1.0+alpha))
               ! y-constant surface
               col = order*k + ll + 1
               a(ieq,col) = a(ieq,col) + mlty*(2.0*ll+1.0)*sge*beta/(ey*(1.0+beta))
            END DO
            !
            ! Contributions from two summations
            ! x-summations
            DO ll = MOD((k+1),2), (k-1), 2
              col = order*ll + l + 1
              a(ieq,col) = a(ieq,col) - sgm*(2.0*ll+1.0)/ex
            END DO
            ! y-summations
            DO ll = MOD((l+1),2), (l-1), 2
               col = order*k + ll + 1
               a(ieq,col) = a(ieq,col) - sge*(2.0*ll+1.0)/ey
            END DO
            !
            ! Contribution along the diagonal -- total interaction
            a(ieq,ieq) = a(ieq,ieq) + 1.0
            ! Finished calculating the 'a' matrix LHS
            ! Begin composing the RHS vector
            ! Initially set b to the scattering + fixed source
            b(ieq) = c*e(i,j,k,l) + s(i,j,k,l,g)/sig
            ! Add contributions from incoming fluxes due to elimination
            b(ieq) = b(ieq) + mltx*(1.0-alpha)*outx(l)/(2.0*ex*(1.0+alpha))
            b(ieq) = b(ieq) + mlty*(1.0-beta) *outy(k)/(2.0*ey*(1.0+beta))
            ! Add contributions from incoming fluxes
            b(ieq) = b(ieq) + mltx*((-1)**k)*outx(l)/(2.0*ex)
            b(ieq) = b(ieq) + mlty*((-1)**l)*outy(k)/(2.0*ey)
            ! Finished calculating the b vector, RHS
         END DO
      END DO
      !
      ! Make the matrix symmetric
      IF (order /= 1) THEN
         DO indx = 1, order
            sgn = 1.0
            jndx = indx/2
            jndx = indx - 2*jndx
            IF (jndx == 0) sgn = -1.0
            DO jndx = 1, order
               factor = sgn*(2.0*indx-1.0)*(2.0*jndx-1.0)
               ieq = jndx + (indx - 1)*order
               sgn = -sgn
               DO col = 1, ordsq
                  a(ieq,col) = factor*a(ieq,col)
               END DO
               b(ieq) = factor*b(ieq)
            END DO
         END DO
      END IF
      ! Asymmetric solver
      ! CALL dgesv(ordsq,1,a,ordsq,ipiv,b,ordsq,info)
      ! Symmetric solver
      ! Need to use different lapack solver for lambda>0 because of positive
      ! definite problem
      IF (lambda == 0) THEN
         CALL dposv('U',ordsq,1,a,ordsq,b,ordsq,info)
         IF (info /= 0) THEN
            WRITE (8,'(//,1X,A)') "WARNING: matrix either has illegal value or is singular."
            warn = warn + 1
            IF (info > 0) THEN
               WRITE (8,'(2X,A,/)') "a-Matrix may not be positive definite, use LAPACK routine for symmetric indefinite."
               CALL dsysv('U',ordsq,1,a,ordsq,piv,b,ordsq,wrk,ordsq,info)
               IF (info /= 0) THEN
                 WRITE (8,'(/,1X,A)') "ERROR: Unable to solve system of equations in sweep for current cell."
                 STOP
               END IF
            ELSE
               WRITE (8,'(//,1X,A)') "ERROR: matrix has unresolved error and problem not solved."
               STOP
            END IF
         END IF
      ELSE IF (lambda > 0) THEN
         CALL dsysv('U',ordsq,1,a,ordsq,piv,b,ordsq,wrk,ordsq,info)
         IF (info /= 0) THEN
            WRITE (8,'(/,1X,A)') "ERROR: matrix either has illegal value or is singular."
            STOP
         END IF
      END IF
      ! Compute the outgoing fluxes with the WDD equations
      ! Outgoing flux moments in x-dir
      DO l = 0, lambda
         ! Contribution from incoming flux
         ! Write(*,*) i,fx(0)
         outx(l) = -((1.0 - alpha)/(1.0 + alpha))*outx(l)
         ! Contribution from even summation
         DO ll = 0, lambda, 2
            indx = order*ll + l + 1
            outx(l) = outx(l) + 2.0*(2.0*ll + 1.0)*b(indx)/(1.0+alpha)
            !Write(*,*) i,b(i),fx(0)
            ! Contribution from odd summation
            IF ((ll+1) <= lambda) THEN
               outx(l) = outx(l) + 2.0*(2.0*ll+3.0)*sgm*alpha*b(indx+order)/(1.0+alpha)
            END IF
         END DO
      END DO
      ! Write(*,*)i,b(1),fx(0)
      ! Outgoing flux moments in y-dir
      DO k = 0, lambda
         ! Contribution from incoming flux
         outy(k) = -((1.0-beta)/(1.0+beta))*outy(k)
         ! Contribution from even summation
         DO ll = 0, lambda, 2
            indx = order*k + ll + 1
            outy(k) = outy(k) + 2.0*(2.0*ll+1.0)*b(indx)/(1.0+beta)
            ! Contribution from odd summation
            IF ((ll+1) <= lambda) THEN
               outy(k) = outy(k) + 2.0*(2.0*ll+3.0)*sge*beta*b(indx+1)/(1.0+beta)
            END IF
         END DO
      END DO
      !
   CASE(1) ! AHOT-N asymptotic
      ex = 0.5*sig*x/mu
      ey = 0.5*sig*y/eta
      IF (mod(lambda,2)==0) THEN ! even
         alpha = ex / REAL(2*lambda+3,8)
         beta  = ey / REAL(2*lambda+3,8)
      ELSE
         alpha = REAL(2*lambda+3,8) / ex
         beta  = REAL(2*lambda+3,8) / ey
      END IF
      ! Begin constructing Matrix Equation
      sgm = incx
      sge = incy
      ieq = 0
      !
      ! Initialize 'a' matrix
      a = 0.0
      !
      DO k = 0, lambda
         mltx = sgm**k
         !
         DO l = 0, lambda
            mlty = sge**l
            ieq = ieq + 1
            !
            ! Contributions from outgoing fluxes
            ! Even summations
            DO ll = 0, lambda, 2
               ! x-constant surface
               col = order*ll + l + 1
               a(ieq,col) = a(ieq,col) + mltx*(2.0*ll+1.0)/(ex*(1.0+alpha))
               ! y-constant surface
               col = order*k + ll + 1
               a(ieq,col) = a(ieq,col) + mlty*(2.0*ll+1.0)/(ey*(1.0+beta))
            END DO
            !
            ! Odd summations
            DO ll = 1, lambda, 2
               ! x-constant surface
               col = order*ll + l + 1
               a(ieq,col) = a(ieq,col) + mltx*(2.0*ll+1.0)*sgm*alpha/(ex*(1.0+alpha))
               ! y-constant surface
               col = order*k + ll + 1
               a(ieq,col) = a(ieq,col) + mlty*(2.0*ll+1.0)*sge*beta/(ey*(1.0+beta))
            END DO
            !
            ! Contributions from two summations
            ! x-summations
            DO ll = MOD((k+1),2), (k-1), 2
              col = order*ll + l + 1
              a(ieq,col) = a(ieq,col) - sgm*(2.0*ll+1.0)/ex
            END DO
            ! y-summations
            DO ll = MOD((l+1),2), (l-1), 2
               col = order*k + ll + 1
               a(ieq,col) = a(ieq,col) - sge*(2.0*ll+1.0)/ey
            END DO
            !
            ! Contribution along the diagonal -- total interaction
            a(ieq,ieq) = a(ieq,ieq) + 1.0
            ! Finished calculating the 'a' matrix LHS
            ! Begin composing the RHS vector
            ! Initially set b to the scattering + fixed source
            b(ieq) = c*e(i,j,k,l) + s(i,j,k,l,g)/sig
            ! Add contributions from incoming fluxes due to elimination
            b(ieq) = b(ieq) + mltx*(1.0-alpha)*outx(l)/(2.0*ex*(1.0+alpha))
            b(ieq) = b(ieq) + mlty*(1.0-beta) *outy(k)/(2.0*ey*(1.0+beta))
            ! Add contributions from incoming fluxes
            b(ieq) = b(ieq) + mltx*((-1)**k)*outx(l)/(2.0*ex)
            b(ieq) = b(ieq) + mlty*((-1)**l)*outy(k)/(2.0*ey)
            ! Finished calculating the b vector, RHS
         END DO
      END DO
      !
      ! Make the matrix symmetric
      IF (order /= 1) THEN
         DO indx = 1, order
            sgn = 1.0
            jndx = indx/2
            jndx = indx - 2*jndx
            IF (jndx == 0) sgn = -1.0
            DO jndx = 1, order
               factor = sgn*(2.0*indx-1.0)*(2.0*jndx-1.0)
               ieq = jndx + (indx - 1)*order
               sgn = -sgn
               DO col = 1, ordsq
                  a(ieq,col) = factor*a(ieq,col)
               END DO
               b(ieq) = factor*b(ieq)
            END DO
         END DO
      END IF
      ! Asymmetric solver
      ! CALL dgesv(ordsq,1,a,ordsq,ipiv,b,ordsq,info)
      ! Symmetric solver
      ! Need to use different lapack solver for lambda>0 because of positive
      ! definite problem
      IF (lambda == 0) THEN
         CALL dposv('U',ordsq,1,a,ordsq,b,ordsq,info)
         IF (info /= 0) THEN
            WRITE (8,'(//,1X,A)') "WARNING: matrix either has illegal value or is singular."
            warn = warn + 1
            IF (info > 0) THEN
               WRITE (8,'(2X,A,/)') "a-Matrix may not be positive definite, use LAPACK routine for symmetric indefinite."
               CALL dsysv('U',ordsq,1,a,ordsq,piv,b,ordsq,wrk,ordsq,info)
               IF (info /= 0) THEN
                 WRITE (8,'(/,1X,A)') "ERROR: Unable to solve system of equations in sweep for current cell."
                 STOP
               END IF
            ELSE
               WRITE (8,'(//,1X,A)') "ERROR: matrix has unresolved error and problem not solved."
               STOP
            END IF
         END IF
      ELSE IF (lambda > 0) THEN
         CALL dsysv('U',ordsq,1,a,ordsq,piv,b,ordsq,wrk,ordsq,info)
         IF (info /= 0) THEN
            WRITE (8,'(/,1X,A)') "ERROR: matrix either has illegal value or is singular."
            STOP
         END IF
      END IF
      ! Compute the outgoing fluxes with the WDD equations
      ! Outgoing flux moments in x-dir
      DO l = 0, lambda
         ! Contribution from incoming flux
         ! Write(*,*) i,fx(0)
         outx(l) = -((1.0 - alpha)/(1.0 + alpha))*outx(l)
         ! Contribution from even summation
         DO ll = 0, lambda, 2
            indx = order*ll + l + 1
            outx(l) = outx(l) + 2.0*(2.0*ll + 1.0)*b(indx)/(1.0+alpha)
            !Write(*,*) i,b(i),fx(0)
            ! Contribution from odd summation
            IF ((ll+1) <= lambda) THEN
               outx(l) = outx(l) + 2.0*(2.0*ll+3.0)*sgm*alpha*b(indx+order)/(1.0+alpha)
            END IF
         END DO
      END DO
      ! Write(*,*)i,b(1),fx(0)
      ! Outgoing flux moments in y-dir
      DO k = 0, lambda
         ! Contribution from incoming flux
         outy(k) = -((1.0-beta)/(1.0+beta))*outy(k)
         ! Contribution from even summation
         DO ll = 0, lambda, 2
            indx = order*k + ll + 1
            outy(k) = outy(k) + 2.0*(2.0*ll+1.0)*b(indx)/(1.0+beta)
            ! Contribution from odd summation
            IF ((ll+1) <= lambda) THEN
               outy(k) = outy(k) + 2.0*(2.0*ll+3.0)*sge*beta*b(indx+1)/(1.0+beta)
            END IF
         END DO
      END DO
   CASE(2) ! fixed weight, BPDG => 1.0
      alpha = fweights
      beta  = fweights
      ex = 0.5*sig*x/mu
      ey = 0.5*sig*y/eta
      ! Begin constructing Matrix Equation
      sgm = incx
      sge = incy
      ieq = 0
      !
      ! Initialize 'a' matrix
      a = 0.0
      !
      DO k = 0, lambda
         mltx = sgm**k
         !
         DO l = 0, lambda
            mlty = sge**l
            ieq = ieq + 1
            !
            ! Contributions from outgoing fluxes
            ! Even summations
            DO ll = 0, lambda, 2
               ! x-constant surface
               col = order*ll + l + 1
               a(ieq,col) = a(ieq,col) + mltx*(2.0*ll+1.0)/(ex*(1.0+alpha))
               ! y-constant surface
               col = order*k + ll + 1
               a(ieq,col) = a(ieq,col) + mlty*(2.0*ll+1.0)/(ey*(1.0+beta))
            END DO
            !
            ! Odd summations
            DO ll = 1, lambda, 2
               ! x-constant surface
               col = order*ll + l + 1
               a(ieq,col) = a(ieq,col) + mltx*(2.0*ll+1.0)*sgm*alpha/(ex*(1.0+alpha))
               ! y-constant surface
               col = order*k + ll + 1
               a(ieq,col) = a(ieq,col) + mlty*(2.0*ll+1.0)*sge*beta/(ey*(1.0+beta))
            END DO
            !
            ! Contributions from two summations
            ! x-summations
            DO ll = MOD((k+1),2), (k-1), 2
              col = order*ll + l + 1
              a(ieq,col) = a(ieq,col) - sgm*(2.0*ll+1.0)/ex
            END DO
            ! y-summations
            DO ll = MOD((l+1),2), (l-1), 2
               col = order*k + ll + 1
               a(ieq,col) = a(ieq,col) - sge*(2.0*ll+1.0)/ey
            END DO
            !
            ! Contribution along the diagonal -- total interaction
            a(ieq,ieq) = a(ieq,ieq) + 1.0
            ! Finished calculating the 'a' matrix LHS
            ! Begin composing the RHS vector
            ! Initially set b to the scattering + fixed source
            b(ieq) = c*e(i,j,k,l) + s(i,j,k,l,g)/sig
            ! Add contributions from incoming fluxes due to elimination
            b(ieq) = b(ieq) + mltx*(1.0-alpha)*outx(l)/(2.0*ex*(1.0+alpha))
            b(ieq) = b(ieq) + mlty*(1.0-beta) *outy(k)/(2.0*ey*(1.0+beta))
            ! Add contributions from incoming fluxes
            b(ieq) = b(ieq) + mltx*((-1)**k)*outx(l)/(2.0*ex)
            b(ieq) = b(ieq) + mlty*((-1)**l)*outy(k)/(2.0*ey)
            ! Finished calculating the b vector, RHS
         END DO
      END DO
      !
      ! Make the matrix symmetric
      IF (order /= 1) THEN
         DO indx = 1, order
            sgn = 1.0
            jndx = indx/2
            jndx = indx - 2*jndx
            IF (jndx == 0) sgn = -1.0
            DO jndx = 1, order
               factor = sgn*(2.0*indx-1.0)*(2.0*jndx-1.0)
               ieq = jndx + (indx - 1)*order
               sgn = -sgn
               DO col = 1, ordsq
                  a(ieq,col) = factor*a(ieq,col)
               END DO
               b(ieq) = factor*b(ieq)
            END DO
         END DO
      END IF
      ! Asymmetric solver
      ! CALL dgesv(ordsq,1,a,ordsq,ipiv,b,ordsq,info)
      ! Symmetric solver
      ! Need to use different lapack solver for lambda>0 because of positive
      ! definite problem
      IF (lambda == 0) THEN
         CALL dposv('U',ordsq,1,a,ordsq,b,ordsq,info)
         IF (info /= 0) THEN
            WRITE (8,'(//,1X,A)') "WARNING: matrix either has illegal value or is singular."
            warn = warn + 1
            IF (info > 0) THEN
               WRITE (8,'(2X,A,/)') "a-Matrix may not be positive definite, use LAPACK routine for symmetric indefinite."
               CALL dsysv('U',ordsq,1,a,ordsq,piv,b,ordsq,wrk,ordsq,info)
               IF (info /= 0) THEN
                 WRITE (8,'(/,1X,A)') "ERROR: Unable to solve system of equations in sweep for current cell."
                 STOP
               END IF
            ELSE
               WRITE (8,'(//,1X,A)') "ERROR: matrix has unresolved error and problem not solved."
               STOP
            END IF
         END IF
      ELSE IF (lambda > 0) THEN
         CALL dsysv('U',ordsq,1,a,ordsq,piv,b,ordsq,wrk,ordsq,info)
         IF (info /= 0) THEN
            WRITE (8,'(/,1X,A)') "ERROR: matrix either has illegal value or is singular."
            STOP
         END IF
      END IF
      ! Compute the outgoing fluxes with the WDD equations
      ! Outgoing flux moments in x-dir
      DO l = 0, lambda
         ! Contribution from incoming flux
         ! Write(*,*) i,fx(0)
         outx(l) = -((1.0 - alpha)/(1.0 + alpha))*outx(l)
         ! Contribution from even summation
         DO ll = 0, lambda, 2
            indx = order*ll + l + 1
            outx(l) = outx(l) + 2.0*(2.0*ll + 1.0)*b(indx)/(1.0+alpha)
            !Write(*,*) i,b(i),fx(0)
            ! Contribution from odd summation
            IF ((ll+1) <= lambda) THEN
               outx(l) = outx(l) + 2.0*(2.0*ll+3.0)*sgm*alpha*b(indx+order)/(1.0+alpha)
            END IF
         END DO
      END DO
      ! Write(*,*)i,b(1),fx(0)
      ! Outgoing flux moments in y-dir
      DO k = 0, lambda
         ! Contribution from incoming flux
         outy(k) = -((1.0-beta)/(1.0+beta))*outy(k)
         ! Contribution from even summation
         DO ll = 0, lambda, 2
            indx = order*k + ll + 1
            outy(k) = outy(k) + 2.0*(2.0*ll+1.0)*b(indx)/(1.0+beta)
            ! Contribution from odd summation
            IF ((ll+1) <= lambda) THEN
               outy(k) = outy(k) + 2.0*(2.0*ll+3.0)*sge*beta*b(indx+1)/(1.0+beta)
            END IF
         END DO
      END DO
   CASE(3) ! AHOT-C
      !
      ! Save incoming moments in inx and iny
      !
      inx(1:ord+1) = outx(0:ord)
      iny(1:ord+1) = outy(0:ord)
      !
      ex = 0.5*sig*x/mu
      ey = 0.5*sig*y/eta
      xi = ex / ey
      !
      ! Build matrix a
      !
      CALL weitc(ord,x,y,sig,mu,eta)
      !
      ! Calculate outgoing flux moments
      !
      IF(xi > 1.0) THEN
         !
         DO m = 1, ord+1
            !
            sum1 = 0.0
            sum2 = 0.0
            DO n = 1, ord+1
               !
               CALL odev(incx,n+1,smi)
               CALL odev(incy,n+1,sei)
               ! Incoming flux contribution
               sum1 = sum1 + smi*flml(n,m,1)*iny(n)
               sum2 = sum2 + smi*flml(n,m,2)*iny(n)+sei*flml(n,m,3)*inx(n)
               !
               ! Source Contributions
               DO l =1, ord+1
                  CALL odev(incy,l+1,sel)
                  source = c*e(i,j,n-1,l-1) + s(i,j,n-1,l-1,g)/sig
                  sum1 = sum1 + smi*sel*srml(n,l,m,1)*source
                  sum2 = sum2 + smi*sel*srml(n,l,m,2)*source
               END DO
               !
            END DO
            !
            CALL odev(incy,m+1,oe)
            oux(m) = sum1*oe
            CALL odev(incx,m+1,oe)
            ouy(m) = sum2*oe
            !
         END DO
         !
      ELSE
         !
         DO m = 1, ord+1
            !
            sum1 = 0.0
            sum2 = 0.0
            DO n = 1, ord+1
               !
               CALL odev(incx,n+1,smi)
               CALL odev(incy,n+1,sei)
               ! Incoming flux contribution
               sum1 = sum1 + sei*flml(n,m,1)*inx(n)
               sum2 = sum2 + sei*flml(n,m,2)*inx(n)+smi*flml(n,m,3)*iny(n)
               !
               ! Source Contributions
               DO l =1, ord+1
                  CALL odev(incy,l+1,sel)
                  source = c*e(i,j,n-1,l-1) + s(i,j,n-1,l-1,g)/sig
                  sum1 = sum1 + smi*sel*srml(n,l,m,1)*source
                  sum2 = sum2 + smi*sel*srml(n,l,m,2)*source
               END DO
               !
            END DO
            !
            CALL odev(incx,m+1,oe)
            ouy(m) = sum1*oe
            CALL odev(incy,m+1,oe)
            oux(m) = sum2*oe
            !
         END DO
         !
      END IF
      !
      ! Calculate Angular Flux-Cell Moments: Loop over all Moments
      !
      fai = -1.0
      DO n = 1, ord+1
         !
         fai = -fai
         faj = -1.0
         DO m = 1, ord+1
            !
            faj = -faj
            IF (incx > 0) THEN
               fxp =  oux(m)
               fxn =  inx(m)
            ELSE
               fxp =  inx(m)
               fxn =  oux(m)
            END IF
            !
            IF(incy > 0) THEN
               fyp =  ouy(n)
               fyn =  iny(n)
            ELSE
               fyp =  iny(n)
               fyn =  ouy(n)
            END IF
            ! Calculate Constribution from Incoming Flux Moments
            sum1 = 0.5*( REAL(incx,8)*(fxp-fai*fxn)/ex + REAL(incy,8)*(fyp-faj*fyn)/ey )
            ! Accumulate Sums of Lower Order Moments
            sum2=0.0
            kmin = 1-mod(n-1,2)
            kmax = n-2
            IF(kmax .ge. 0) THEN
               DO l = kmin,kmax,2
                  sum2=sum2+REAL(2*l+1,8) * fmom(l+1,m)
               END DO
            END IF
            !
            sum1 = sum1 - REAL(incx,8)*sum2/ex
            sum2 = 0.0
            kmin = 1-mod(m-1,2)
            kmax = m-2
            IF(kmax .ge.0) THEN
               DO l = kmin, kmax,2
                  sum2=sum2+REAL(2*l+1,8) * fmom(n,l+1)
               END DO
            END IF
            !
            sum1 = sum1 - REAL(incy,8)*sum2/ey
            ! Calculate Source
            source = c*e(i,j,n-1,m-1) + s(i,j,n-1,m-1,g)/sig
            ! Calculate Flux Moments
            fmom(n,m) = source - sum1
            !
         END DO
         !
      END DO
      ! Map fmom into b
      DO m = 1, ord+1
         DO n = 1, ord+1
            b( (n-1)*(ord+1) + m) = fmom(n,m)
         END DO
      END DO
      ! Fill outx, outy
      DO m = 1, ord+1
         outx(m-1) = oux(m)
         outy(m-1) = ouy(m)
      END DO
      !
   CASE(4) ! Higher Order Diamond Difference
      !
      ex = 0.5*sig*x/mu
      ey = 0.5*sig*y/eta
      ! Begin constructing Matrix Equation
      sgm = incx
      sge = incy
      ieq = 0
      !
      ! Initialize 'a' matrix
      a = 0.0
      !
      DO k = 0, lambda
         mltx = sgm**k
         !
         DO l = 0, lambda
            mlty = sge**l
            ieq = ieq + 1
            !
            ! Contributions from outgoing fluxes
            !
            ! If lambda even => only even contributions
            ! If lambda odd  => only odd  contributions
            !
            IF(mod(lambda,2)==0) THEN
               ! Even summations
               DO ll = 0, lambda, 2
                  ! x-constant surface
                  col = order*ll + l + 1
                  a(ieq,col) = a(ieq,col) + mltx*(2.0*ll+1.0)/ex
                  ! y-constant surface
                  col = order*k + ll + 1
                  a(ieq,col) = a(ieq,col) + mlty*(2.0*ll+1.0)/ey
               END DO
            ELSE
               !
               ! Odd summations
               DO ll = 1, lambda, 2
                  ! x-constant surface
                  col = order*ll + l + 1
                  a(ieq,col) = a(ieq,col) + mltx*(2.0*ll+1.0)*sgm/ex
                  ! y-constant surface
                  col = order*k + ll + 1
                  a(ieq,col) = a(ieq,col) + mlty*(2.0*ll+1.0)*sge/ey
               END DO
            END IF
            !
            ! Contributions from two summations
            ! x-summations
            DO ll = MOD((k+1),2), (k-1), 2
              col = order*ll + l + 1
              a(ieq,col) = a(ieq,col) - sgm*(2.0*ll+1.0)/ex
            END DO
            ! y-summations
            DO ll = MOD((l+1),2), (l-1), 2
               col = order*k + ll + 1
               a(ieq,col) = a(ieq,col) - sge*(2.0*ll+1.0)/ey
            END DO
            !
            ! Contribution along the diagonal -- total interaction
            a(ieq,ieq) = a(ieq,ieq) + 1.0
            ! Finished calculating the 'a' matrix LHS
            ! Begin composing the RHS vector
            ! Initially set b to the scattering + fixed source
            b(ieq) = c*e(i,j,k,l) + s(i,j,k,l,g)/sig
            ! Add contributions from incoming fluxes due to elimination
            b(ieq) = b(ieq) + (-1)**lambda*mltx*outx(l)/(2.0*ex)
            b(ieq) = b(ieq) + (-1)**lambda*mlty*outy(k)/(2.0*ey)
            ! Add contributions from incoming fluxes
            b(ieq) = b(ieq) + mltx*((-1)**k)*outx(l)/(2.0*ex)
            b(ieq) = b(ieq) + mlty*((-1)**l)*outy(k)/(2.0*ey)
            ! Finished calculating the b vector, RHS
         END DO
      END DO
      !
      ! Make the matrix symmetric
      IF (order /= 1) THEN
         DO indx = 1, order
            sgn = 1.0
            jndx = indx/2
            jndx = indx - 2*jndx
            IF (jndx == 0) sgn = -1.0
            DO jndx = 1, order
               factor = sgn*(2.0*indx-1.0)*(2.0*jndx-1.0)
               ieq = jndx + (indx - 1)*order
               sgn = -sgn
               DO col = 1, ordsq
                  a(ieq,col) = factor*a(ieq,col)
               END DO
               b(ieq) = factor*b(ieq)
            END DO
         END DO
      END IF
      ! Asymmetric solver
      ! CALL dgesv(ordsq,1,a,ordsq,ipiv,b,ordsq,info)
      ! Symmetric solver
      ! Need to use different lapack solver for lambda>0 because of positive
      ! definite problem
      IF (lambda == 0) THEN
         CALL dposv('U',ordsq,1,a,ordsq,b,ordsq,info)
         IF (info /= 0) THEN
            WRITE (8,'(//,1X,A)') "WARNING: matrix either has illegal value or is singular."
            warn = warn + 1
            IF (info > 0) THEN
               WRITE (8,'(2X,A,/)') "a-Matrix may not be positive definite, use LAPACK routine for symmetric indefinite."
               CALL dsysv('U',ordsq,1,a,ordsq,piv,b,ordsq,wrk,ordsq,info)
               IF (info /= 0) THEN
                 WRITE (8,'(/,1X,A)') "ERROR: Unable to solve system of equations in sweep for current cell."
                 STOP
               END IF
            ELSE
               WRITE (8,'(//,1X,A)') "ERROR: matrix has unresolved error and problem not solved."
               STOP
            END IF
         END IF
      ELSE IF (lambda > 0) THEN
         CALL dsysv('U',ordsq,1,a,ordsq,piv,b,ordsq,wrk,ordsq,info)
         IF (info /= 0) THEN
            WRITE (8,'(/,1X,A)') "ERROR: matrix either has illegal value or is singular."
            STOP
         END IF
      END IF
      ! Compute the outgoing fluxes with the WDD equations
      ! Outgoing flux moments in x-dir
      DO l = 0, lambda
         ! Contribution from incoming flux
         ! Write(*,*) i,fx(0)
         outx(l) = -(-1.0)**lambda*outx(l)
         !
         ! Split lambda <even>/<odd>
         !
         IF(mod(lambda,2)==0) THEN
            ! Contribution from even summation
            DO ll = 0, lambda, 2
               indx = order*ll + l + 1
               outx(l) = outx(l) + 2.0*(2.0*ll + 1.0)*b(indx)
               !Write(*,*) i,b(i),fx(0)
            END DO
         ELSE
            DO ll = 1, lambda, 2
               ! Contribution from odd summation
               indx = order*ll + l + 1
               outx(l) = outx(l) + 2.0*(2.0*ll + 1.0)*sgm*b(indx)
            END DO
         END IF
      END DO
      ! Write(*,*)i,b(1),fx(0)
      ! Outgoing flux moments in y-dir
      DO k = 0, lambda
         ! Contribution from incoming flux
         outy(k) = -(-1.0)**lambda*outy(k)
         !
         ! Split lambda <even>/<odd>
         !
         IF(mod(lambda,2)==0) THEN
         ! Contribution from even summation
            DO ll = 0, lambda, 2
               indx = order*k + ll + 1
               outy(k) = outy(k) + 2.0*(2.0*ll+1.0)*b(indx)
            END DO
         ELSE
         ! Contribution from odd summation
            DO ll = 1, lambda, 2
               indx = order*k + ll + 1
               outy(k) = outy(k) + 2.0*(2.0*ll+1.0)*sge*b(indx)
            END DO
         END IF
      END DO
      !
END SELECT
!
END SUBROUTINE


real pure function splint(XA,YA,Y2A,n,x)
  real, intent(in) :: XA(50), YA(50), Y2A(n)
  integer, intent(in) :: n, x

  integer :: klo, khi, k

  klo=1
  khi=n

  do
    if (khi-klo .le. 1) exit
    if (khi-klo .gt. 1) then
      k=(khi+klo)/2
      if (XA(k) .gt. x) then
        khi=k
      else
        klo=k
      end if
    end if
  end do

  H=XA(KHI)-XA(KLO)
  A=(XA(KHI)-X)/H
  B=(X-XA(KLO))/H
  splint=A*YA(KLO)+B*YA(KHI)+((A**3-A)*Y2A(KLO)+(B**3-B)*Y2A(KHI))*(H**2)/6.

end function

!subroutine SPLINT(XA,YA,Y2A,N,X,Y)
!  implicit none
!
!  integer :: n, x, klo, khi, k
!  real :: XA(N),YA(N),Y2A(N)
!  real :: A,B,Y,H
!
!  KLO=1
!  KHI=N
!! Replace this with a do while based on KHI-KLO
!1 IF (KHI-KLO.GT.1) THEN
!    K=(KHI+KLO)/2
!    IF(XA(K).GT.X)THEN
!      KHI=K
!    ELSE
!      KLO=K
!    end if
!    GOTO 1
!  end if
!  H=XA(KHI)-XA(KLO)
!! Pause statement has been deleted from language.  Replace with empty read.
!  if (H.EQ.0.) then
!    write(*,*) 'Bad XA input.'
!    write(*,*) 'Press a key to continue.'
!    read(*,*)
!  end if
!  A=(XA(KHI)-X)/H
!  B=(X-XA(KLO))/H
!  Y=A*YA(KLO)+B*YA(KHI)+((A**3-A)*Y2A(KLO)+(B**3-B)*Y2A(KHI))*(H**2)/6.
!  return
!end


C
C $Id: mdritd.f,v 1.8 2008-09-18 00:42:18 kennison Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE MDRITD (IAXS,ANGL,UCRD,VCRD,WCRD)
C
        INTEGER          IAXS
        DOUBLE PRECISION ANGL,UCRD,VCRD,WCRD
C
C Declare common block containing math constants.
C
        COMMON /MAPCM0/  COS1,DTOR,DTRH,OOPI,PI,PIOF,PIOT,RTDD,RTOD,
     +                   SROT,SIN1,TOPI,TSRT
        DOUBLE PRECISION COS1,DTOR,DTRH,OOPI,PI,PIOF,PIOT,RTDD,RTOD,
     +                   SROT,SIN1,TOPI,TSRT
        SAVE   /MAPCM0/
C
C Declare local variables.
C
        DOUBLE PRECISION SINA,COSA,UTMP,VTMP,WTMP
C
C This routine rotates the point with coordinates (UCRD,VCRD,WCRD) by
C the angle ANGL about the axis specified by IAXS (1 for the U axis,
C 2 for the V axis, 3 for the W axis).  A right-handed coordinate
C system is assumed.
C
        SINA=SIN(DTOR*ANGL)
        COSA=COS(DTOR*ANGL)
C
        UTMP=UCRD
        VTMP=VCRD
        WTMP=WCRD
C
        IF (IAXS.EQ.1) THEN
          VCRD=VTMP*COSA-WTMP*SINA
          WCRD=WTMP*COSA+VTMP*SINA
        ELSE IF (IAXS.EQ.2) THEN
          UCRD=UTMP*COSA+WTMP*SINA
          WCRD=WTMP*COSA-UTMP*SINA
        ELSE
          UCRD=UTMP*COSA-VTMP*SINA
          VCRD=VTMP*COSA+UTMP*SINA
        END IF
C
        RETURN
C
      END


      REAL FUNCTION LIMIT (MIN,MAX,X)
      IMPLICIT NONE

*     FORMAL_PARAMETERS:
      REAL MIN,MAX,X

**    local parameters
      CHARACTER MESSAG*52
      SAVE

      IF (MAX.LT.MIN) THEN
*        minimum is larger than maximum, should generate an error
         WRITE (MESSAG, '(2(A,G11.5))')
     &   'argument error, MIN = ',MIN,', MAX = ',MAX
         CALL FATALERR ('LIMIT',MESSAG)
      END IF

      IF (X.LT.MIN) THEN
*        X below allowed range ; return lower bound
         LIMIT = MIN

      ELSE IF (X.LE.MAX) THEN
*        X in range ; return X
         LIMIT = X

      ELSE
*        X above allowed range ; return upper bound
         LIMIT = MAX

      END IF

      RETURN
      END


C NCLFORTSTART
        subroutine wetbulbprofs(npts,t,td,p,twb,tmsg,tdmsg,pmsg,ier)
        implicit none
c                                      INPUT
        integer ier, npts
        double precision t(npts)
        double precision td(npts)
        double precision p(npts)
        double precision tmsg, tdmsg, pmsg
c                                      OUTPUT
        double precision twb(npts)
c NCLEND
c                                      LOCAL
        integer n
        external twbprofs
        double precision twbprofs

c       g.s. stipanuk     1973            original version.
c       reference stipanuk paper entitled:
c            "algorithms for generating a skew-t, log p
c            diagram and computing selected meteorological quantities."
c            atmospheric sciences laboratory
c            u.s. army electronics command
c            white sands missile range, new mexico 88002 : 33 pages
c       baker, schlatter  17-may-1982

c PROFS: Program for Regional Observing and Forecasting Services (NOAA)

        do n=1,npts
           if (t(n).ne.tmsg.and.td(n).ne.tdmsg.and.p(n).ne.pmsg) then
               twb(n) = twbprofs(t(n),td(n),p(n))
           else
               twb(n) = tmsg
           end if
        end do

c Note: ier isn't used for anything yet, so set to 0 here.
        ier = 0
        return
        end
c---
        double precision function twbprofs(t,td,p)
        implicit none
c                                      INPUT
        double precision t
        double precision td
        double precision p
c                                      LOCAL
        integer i
        double precision aw, ao, pi, x, ti, aos, eps

        external          wxprofs, oxprofs, tmrprofs, tmaprofs, tdaprofs
     +                 ,  osprofs, tsaprofs
        double precision  wxprofs, oxprofs , tmrprofs, tmaprofs,tdaprofs
     +                 ,  osprofs, tsaprofs

c   this function returns the wet-bulb temperature tw (celsius)
c   given the temperature t (celsius), dew point td (celsius)
c   and pressure p (mb).  see p.13 in stipanuk (1973), referenced
c   above, for a description of the technique.
c
c   determine the mixing ratio line thru td and p.

        aw = wxprofs(td,p)
c
c   determine the dry adiabat thru t and p.

        ao = oxprofs(t,p)

c   iterate to locate pressure pi at the intersection of the two
c   curves .  pi has been set to p for the initial guess.

        eps = 0.01d0
        pi  = p
        do i= 1,10
           x= 0.02d0*(tmrprofs(aw,pi)-tdaprofs(ao,pi))
           if (abs(x).lt.eps) exit
           pi= pi*(2**(x))
        end do

c   find the temperature on the dry adiabat ao at pressure pi.

        ti = tdaprofs(ao,pi)

c   the intersection has been located...now, find a saturation
c   adiabat thru this point. function os returns the equivalent
c   potential temperature (c) of a parcel saturated at temperature
c   ti and pressure pi.

        aos = osprofs(ti,pi)

c   function tsa returns the wet-bulb temperature (c) of a parcel at
c   pressure p whose equivalent potential temperature is aos.

        twbprofs = tsaprofs(aos,p)

        return
        end
c ---------------------------------------------------------------------

        double precision function oxprofs(t,p)
        implicit none
c                                      INPUT
        double precision t, p
c                                      LOCAL
        double precision  tk

c   this function returns potential temperature (celsius) given
c   temperature t (celsius) and pressure p (mb) by solving the poisson
c   equation.

        tk = t  + 273.15d0
        oxprofs = tk*((1000d0/p)**0.286) - 273.15d0

        return
        end
c ---------------------------------------------------------------------

        double precision function wxprofs(t,p)
        implicit none
c                                      INPUT
        double precision t, p
c                                      LOCAL
        double precision x

        external esatprofs
        double precision esatprofs

c  this function returns the mixing ratio (grams of water vapor per
c  kilogram of dry air) given the dew point (celsius) and pressure
c  (millibars). if the temperture  is input instead of the
c  dew point, then saturation mixing ratio (same units) is returned.
c  the formula is found in most meteorological texts.

        x       = esatprofs(t)
        wxprofs = 622d0*x/(p-x)

        return
        end
c ---------------------------------------------------------------------

        double precision function esatprofs(t)
        implicit none
c                                      INPUT
        double precision t

c   this function returns the saturation vapor pressure over
c   water (mb) given the temperature (celsius).
c   the algorithm is due to nordquist, w.s.,1973: "numerical approxima-
c   tions of selected meteorlolgical parameters for cloud physics prob-
c   lems," ecom-5475, atmospheric sciences laboratory, u.s. army
c   electronics command, white sands missile range, new mexico 88002.

c                                      LOCAL
        double precision tk, p1, p2, c1

        tk = t+273.15d0
        p1 = 11.344d0-0.0303998d0*tk
        p2 = 3.49149d0-1302.8844d0/tk
        c1 = 23.832241d0-5.02808d0*log10(tk)

        esatprofs = 10.**(c1-1.3816d-7*10.**p1
     +                      +8.1328d-3*10.**p2-2949.076d0/tk)

        return
        end
c ---------------------------------------------------------------------
        double precision function tsaprofs(os,p)
        implicit none
c                                      INPUT
        double precision os, p

c   this function returns the temperature tsa (celsius) on a saturation
c   adiabat at pressure p (millibars). os is the equivalent potential
c   temperature of the parcel (celsius). sign(a,b) replaces the
c   algebraic sign of a with that of b.
c   b is an empirical constant approximately equal to 0.001 of the
c   latent heat of vaporization for water divided by the specific heat
c   at constant pressure for dry air.
c                                      LOCAL
        integer i
        double precision a, b, d, tq, tqk, x, eps
        data b/2.6518986d0/

        external wxprofs
        double precision wxprofs

        a  = os+273.15d0

c   tq is the first guess for tsa.

        tq = 253.15d0

c   d is an initial value used in the iteration below.

        d = 120d0

c   iterate to obtain sufficient accuracy....see table 1, p.8
c   of stipanuk (1973) for equation used in iteration.

        eps = 1d-1
        do 1 i= 1,12
           tqk = tq-273.15d0
           d   = d/2d0
           x   = a*exp(-b*wxprofs(tqk,p)/tq)-tq*((1000d0/p)**.286)
           if (abs(x).lt.eps) go to 2
           tq  = tq+sign(d,x)
 1      continue

 2      tsaprofs= tq-273.15d0

        return
        end
c -------------------------------------------------------------------

        double precision function tdaprofs(o,p)
        implicit none
c                                      INPUT
        double precision o, p
c                                      LOCAL
        double precision ok, tdak

c   this function returns the temperature tda (celsius) on a dry adiabat
c   at pressure p (millibars). the dry adiabat is given by
c   potential temperature o (celsius). the computation is based on
c   poisson's equation.

        ok       = o+273.15d0
        tdak     = ok*((p*0.001d0)**0.286)
        tdaprofs = tdak-273.15d0

        return
        end

c -------------------------------------------------------------------

        double precision function osprofs(t,p)
        implicit none
c                                      INPUT
        double precision t, p

c   this function returns the equivalent potential temperature os
c   (celsius) for a parcel of air saturated at temperature t (celsius)
c   and pressure p (millibars).

c                                      LOCAL
c   b is an empirical constant approximately equal to the latent heat
c   of vaporization for water divided by the specific heat at constant
c   pressure for dry air.

        double precision b, tk, osk
        data b/2.6518986d0/

        external wxprofs
        double precision wxprofs

        tk      = t+273.15d0
        osk     = tk*((1000d0/p)**.286)*(exp(b*wxprofs(t,p)/tk))
        osprofs = osk-273.15d0

        return
        end
c ---------------------------------------------------------------------

        double precision function tmrprofs(w,p)
        implicit none
c                                      INPUT
        double precision w, p
c                                      LOCAL
        double precision c1, c2, c3, c4, c5, c6, x, tmrk

c   this function returns the temperature (celsius) on a mixing
c   ratio line w (g/kg) at pressure p (mb). the formula is given in
c   table 1 on page 7 of stipanuk (1973).
c
c   initialize constants

        data c1/.0498646455/,c2/2.4082965/,c3/7.07475/
        data c4/38.9114/,c5/.0915/,c6/1.2035/

        x    = log10(w*p/(622d0+w))
        tmrk = 10.**(c1*x+c2)-c3+c4*((10.**(c5*x)-c6)**2.)
        tmrprofs = tmrk-273.15d0

        return
        end


!
! Copyright 2009 Max Staufer
! All Rights Reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
! http://www.dolfyn.net/license.html
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an
! "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND,
! either express or implied. See the License for the specific
! language governing permissions and limitations under the License.
!
subroutine CalculateSmagorinskyViscosity

   use constants
   use geometry
   use variables

   implicit none

   real :: betaij(3,3), alpha

   real :: Cs = 0.1
   real :: C
   real :: FilterLength, mutsgs

   integer :: ip

   C = 2.5*Cs**2

   do ip=1,Ncel

     FilterLength = (Cell(ip)%vol)**(1./3.)
     FL2 = FilterLength*FilterLength

     betaij(1,1) = FL2*( dudx(ip,1)*dudx(ip,1) + dudx(ip,2)*dudx(ip,2) + dudx(ip,3)*dudx(ip,3) )
     betaij(1,2) = FL2*( dudx(ip,1)*dvdx(ip,1) + dudx(ip,2)*dvdx(ip,2) + dudx(ip,3)*dvdx(ip,3) )
     betaij(1,3) = FL2*( dudx(ip,1)*dwdx(ip,1) + dudx(ip,2)*dwdx(ip,2) + dudx(ip,3)*dwdx(ip,3) )

     betaij(2,1) = FL2*( dvdx(ip,1)*dudx(ip,1) + dvdx(ip,2)*dudx(ip,2) + dvdx(ip,3)*dudx(ip,3) )
     betaij(2,2) = FL2*( dvdx(ip,1)*dvdx(ip,1) + dvdx(ip,2)*dvdx(ip,2) + dvdx(ip,3)*dvdx(ip,3) )
     betaij(2,3) = FL2*( dvdx(ip,1)*dwdx(ip,1) + dvdx(ip,2)*dwdx(ip,2) + dvdx(ip,3)*dwdx(ip,3) )

     betaij(3,1) = FL2*( dwdx(ip,1)*dudx(ip,1) + dwdx(ip,2)*dudx(ip,2) + dwdx(ip,3)*dudx(ip,3) )
     betaij(3,2) = FL2*( dwdx(ip,1)*dvdx(ip,1) + dwdx(ip,2)*dvdx(ip,2) + dwdx(ip,3)*dvdx(ip,3) )
     betaij(3,3) = FL2*( dwdx(ip,1)*dwdx(ip,1) + dwdx(ip,2)*dwdx(ip,2) + dwdx(ip,3)*dwdx(ip,3) )

     alpha = dudx(ip,1)*dudx(ip,1) + dudx(ip,2)*dudx(ip,2) + dudx(ip,3)*dudx(ip,3) + &
             dvdx(ip,1)*dvdx(ip,1) + dvdx(ip,2)*dvdx(ip,2) + dvdx(ip,3)*dvdx(ip,3) + &
             dwdx(ip,1)*dwdx(ip,1) + dwdx(ip,2)*dwdx(ip,2) + dwdx(ip,3)*dwdx(ip,3)

     mutsgs = abs(&
                  betaij(1,1)*betaij(2,2) - betaij(1,2)*betaij(1,2) + &
                  betaij(1,1)*betaij(3,3) - betaij(1,3)*betaij(1,3) + &
                  betaij(2,2)*betaij(3,3) - betaij(2,3)*betaij(2,3)     )/alpha

     mutsgs =den(ip)*C*sqrt(mutsgs)

     if (alpha == 0.0 ) mutsgs = 0.0

     Viseff(ip) = Vislam + mutsgs

   end do

end subroutine CalculateSmagorinskyViscosity


      subroutine shpMeasure (x, ien, meshq, tetVolm)
c---------------------------------------------------------
c This subroutine calculate the shape quality
c based on the mean ratio method.
c
c---------------------------------------------------------
c
        include "common.h"
c
        real*8    meshq(npro)
        dimension x(numnp, nsd),        ien(npro, nshl),
     &            xl(npro, nenl, nsd)
c
        dimension tetEdge(npro, 6, nsd),
     &            tetVolm(npro),
     &            tetSumEdge(npro)
c
c---------------------------------------------------------
c
       call localx(x,      xl,     ien,    nsd,    'gather  ')
c
       tetEdge(:,1,:) = xl(:,1,:) - xl(:,4,:)
       tetEdge(:,2,:) = xl(:,2,:) - xl(:,4,:)
       tetEdge(:,3,:) = xl(:,3,:) - xl(:,4,:)
       tetEdge(:,4,:) = xl(:,1,:) - xl(:,3,:)
       tetEdge(:,5,:) = xl(:,2,:) - xl(:,3,:)
       tetEdge(:,6,:) = xl(:,1,:) - xl(:,2,:)
c
       tetVolm(:) = 1.0/6.0 * (
     &       tetEdge(:,1,1) * ( tetEdge(:,2,2) * tetEdge(:,3,3)
     &                        - tetEdge(:,2,3) * tetEdge(:,3,2) )
     &     - tetEdge(:,1,2) * ( tetEdge(:,2,1) * tetEdge(:,3,3)
     &                        - tetEdge(:,2,3) * tetEdge(:,3,1) )
     &     + tetEdge(:,1,3) * ( tetEdge(:,2,1) * tetEdge(:,3,2)
     &                        - tetEdge(:,2,2) * tetEdge(:,3,1) ) )
c
       tetSumEdge(:) = tetEdge(:,1,1) * tetEdge(:,1,1)
     &               + tetEdge(:,1,2) * tetEdge(:,1,2)
     &               + tetEdge(:,1,3) * tetEdge(:,1,3)
     &               + tetEdge(:,2,1) * tetEdge(:,2,1)
     &               + tetEdge(:,2,2) * tetEdge(:,2,2)
     &               + tetEdge(:,2,3) * tetEdge(:,2,3)
     &               + tetEdge(:,3,1) * tetEdge(:,3,1)
     &               + tetEdge(:,3,2) * tetEdge(:,3,2)
     &               + tetEdge(:,3,3) * tetEdge(:,3,3)
     &               + tetEdge(:,4,1) * tetEdge(:,4,1)
     &               + tetEdge(:,4,2) * tetEdge(:,4,2)
     &               + tetEdge(:,4,3) * tetEdge(:,4,3)
     &               + tetEdge(:,5,1) * tetEdge(:,5,1)
     &               + tetEdge(:,5,2) * tetEdge(:,5,2)
     &               + tetEdge(:,5,3) * tetEdge(:,5,3)
     &               + tetEdge(:,6,1) * tetEdge(:,6,1)
     &               + tetEdge(:,6,2) * tetEdge(:,6,2)
     &               + tetEdge(:,6,3) * tetEdge(:,6,3)
c
       meshq(:) = 15552.0 * tetVolm(:) * abs(tetVolm(:))
     &          / ( tetSumEdge(:) * tetSumEdge(:) * tetSumEdge(:) )
c
       do i = 1, npro
          if (meshq(i) .gt. 1.0 ) write(*,*) 'Meshq larger than one.'
          if (meshq(i) .lt. 0.0 ) then
             write(*,*) 'Meshq smaller than zero.'
             tetVolm(i) = abs (tetVolm(i))
          endif
       enddo
c
c.... return
c
       return
       end


!**
!* This module solves a non-smooth optimization problems involving a binary labour choice using the non-concave EGM algorithm provided by ncegm.
!**
module demo_binary_labour_choice
    use kinds, only: dp
    use ncegm, only: ncegm_setup, ncegm_solve, ncegm_model, ncegm_getPolicy_c, ncegm_getPolicy_d, ncegm_getValueFunction, ncegm_getPolicy_aprime
    use grids, only: build_grid
    implicit none
    private
    public :: start_demo_blc
    save

    ! *******************************************************************************************************
    ! ** Model parameters
    ! *******************************************************************************************************
    real(dp), parameter                         :: tau    = 3_dp
    real(dp), parameter                         :: delta  = 6_dp
    real(dp), parameter                         :: roa    = 1.05_dp
    real(dp), parameter                         :: w      = 5.0_dp
    real(dp), parameter                         :: beta   = 0.95_dp

    ! *******************************************************************************************************
    ! ** Numerical parameters
    ! *******************************************************************************************************
    integer, parameter                          :: glen_a = 500
    real(dp), parameter                         :: a_min  = 0
    real(dp), parameter                         :: a_max  = 20
    integer, parameter                          :: glen_d = 2

    contains
        ! **
        ! * Sets up the household model and solves it using ncegm_solve(). Note that no state variable s (and hence no s_grid) is present in this model.
        ! **
        subroutine start_demo_blc()
            type(ncegm_model)                   :: model
            logical                             :: status
            real(dp), dimension(glen_a,1,1)     :: vfinitial,choice_d,cf,vf,ap
            integer                             :: i1

            ! Allocate required grids
            allocate(model%a_grid(glen_a),model%d_grid(glen_d))

            ! Specifies the grid for A and D
            model%a_grid = build_grid(glen_a,a_min,a_max,0) ! Uniform grid over assets a
            model%d_grid = (/ 0.0_dp , 1.0_dp /)

            ! construct a guess for the value function by assuming a consumption policy linear in available assets
            vfinitial(:,1,1) = u(0.05_dp*model%a_grid,1.0_dp,0.0_dp,0.0_dp)

            ! Specifies the functions of the model
            model%F => u
            model%dF => du
            model%d2F => d2u
            model%dF_inv => du_inv
            model%Lambda => Lambda
            model%dLambda => dLambda

            ! Specifies the discount factor Beta
            model%beta = beta

            ! Specifies an initial guess (computed above) for the value function
            model%V_initial = vfinitial

            ! Now initialize the module
            call ncegm_setup(model,status)
            if (status) then
                ! If the model is valid, the model is solved
                call ncegm_solve()
            else
                stop
            end if

            ! The computed value function and the policy functions are retrieved
            vf = ncegm_getValueFunction()
            cf = ncegm_getPolicy_c()
            ap = ncegm_getPolicy_aprime()
            choice_d = ncegm_getPolicy_d()

            ! The result is printed
            print *, "Value function V(a) & policy functions:"
            print *, ""
            print "(a12,a27,a27,a27,a27)", "a", "V(a)", "c*(a)", "a'*(a)", "d*(a)"
            print "(a12,a27,a27,a27,a27)", "----","----","----","----","----"

            do i1=1,glen_a
                print *, model%a_grid(i1), vf(i1,1,1), cf(i1,1,1), ap(i1,1,1), choice_d(i1,1,1)
            end do

        end subroutine

        ! *******************************************************************************************************
        ! ** Model functions
        ! *******************************************************************************************************

        function u(c,d,s,z)
            real(dp), dimension(:), intent(in)  :: c
            real(dp), intent(in)                :: d,s,z
            real(dp), dimension(size(c))        :: u

            u =  c**(1-tau)/(1-tau) - delta*d

        end function u

        function du(c,d,s,z)
            real(dp), dimension(:), intent(in)  :: c
            real(dp), intent(in)                :: d,s,z
            real(dp), dimension(size(c))        :: du

            du = c**(-tau)

        end function du

        function du_inv(mret,d,s,z)
            real(dp), intent(in)                :: mret,d,s,z
            real(dp)                            :: du_inv

            du_inv = (1/mret)**(1/tau)
        end function du_inv

        function d2u(c,d,s,z)
            real(dp), dimension(:), intent(in)  :: c
            real(dp), intent(in)                :: d,s,z
            real(dp), dimension(size(c))        :: d2u

            d2u = -tau*c**(-1-tau)

        end function d2u

        function Lambda(a,d,s,z)
            real(dp), dimension(:), intent(in) :: a
            real(dp), intent(in)               :: d,s,z
            real(dp), dimension(size(a))       :: Lambda

            Lambda = roa*a+w*d

        end function Lambda

        function dLambda(a,d,s,z)
            real(dp), dimension(:), intent(in) :: a
            real(dp), intent(in)               :: d,s,z
            real(dp), dimension(size(a))       :: dLambda

            dLambda = roa

        end function dLambda
end module demo_binary_labour_choice


MODULE B85_scattNES
!---------------------------------------------------------------------
!
!    File:         B85_scattNES.f90
!    Module:       B85_scattNES
!    Type:         Module w/ Routines
!    Author:       R. Chu, Dept. Phys. & Astronomy
!                  U. Tennesee, Knoxville
!
!    Created:      8/16/18
!
!    WeakLib ver:  weaklib/External/Utilities/Opacities/Bruenn85
!
!    Purpose:      The zero and first legendre coefs for the n-type
!                  neutrino electron scattering kernel considering the
!                  physics in Bruenn 85.
!
!    CONTAINS:     Routine  TotalNESKernel
!
!    Input arguments:
!                  energygrid : neutrino energy array [MeV]
!                  TMeV       : matter temperature [MeV]
!                  chem_e     : electron chemical potential
!                                      (including rest mass) [MeV]
!                  nquad      : number of quadarture
!                  l          : order of the legendre coefs/moment
!                  species    : neutrino flavor index
!
!    Output arguments:
!                  NESK
!
!    Modules used:
!                  wlKindModule
!                  wlExtPhysicalConstantsModule
!                  wlExtNumericalModule
!                  ( function fexp is called )
!
!---------------------------------------------------------------------

  USE wlKindModule, ONLY: dp
  USE wlExtPhysicalConstantsModule, ONLY: &
      h, kMeV, therm1, therm2, dmnp, me, mbG, mp, mn, cvel_inv, &
      cvel, ergmev, cv_p, cv_n, ca_p, ca_n, gf, hbarc, cv, ca
  USE wlExtNumericalModule, ONLY: &
      pi, half, twpi, zero, one

  IMPLICIT NONE

  PUBLIC TotalNESKernel

CONTAINS

  SUBROUTINE TotalNESKernel &
               ( energygrid, TMeV, chem_e, nquad, l, NESK, species )
!---------------------------------------------------------------------
! Purpose:
!   To compute the zero and first legendre coefs for the neutrino-
!   electron scattering kernel for electron-type neutrino and
!   antineutrino
! Ref:
!   Mezzacappa & Bruenn(1993) AJ 410
!   Bruenn(1985) AJSS 58
!---------------------------------------------------------------------
  IMPLICIT NONE

  REAL(dp), DIMENSION(:), INTENT(in)      :: energygrid
  REAL(dp), INTENT(in)                    :: TMeV, chem_e
  INTEGER , INTENT(in)                    :: nquad, l, species
  REAL(dp), DIMENSION(:,:), INTENT(out)   :: NESK

  REAL(dp), DIMENSION(nquad)              :: roots, weights
  REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: NESK_ome
  INTEGER                                 :: ii, jj, kk, nPointsE
  REAL(dp)                                :: outcome
  REAL(dp)                                :: UnitConvertConstant

  UnitConvertConstant  =  cvel_inv**4.0 / h**3.0
  nPointsE             =  SIZE(energygrid)

  ALLOCATE( NESK_ome( nquad, nPointsE, nPointsE ) )

  CALL gaquad( nquad, roots, weights, -1.0_dp , 1.0_dp )

  CALL NESKernelWithOmega &
         ( energygrid, roots, TMeV, chem_e, NESK_ome, species )

  IF ( l == 0 ) THEN

    DO jj = 1, nPointsE
      DO kk = 1, nPointsE

         outcome = zero
         DO ii = 1, nquad
           outcome = outcome + NESK_ome(ii,jj,kk) * weights(ii)
         END DO
         NESK( jj, kk ) = UnitConvertConstant * outcome * 0.5_dp

      END DO
    END DO

  ELSE IF ( l == 1 ) THEN

    DO jj = 1, nPointsE
      DO kk = 1, nPointsE
         outcome = 0.0_dp
         DO ii = 1, nquad
           outcome = outcome &
                     + NESK_ome(ii,jj,kk) * weights(ii) * roots(ii)
         END DO
         NESK( jj, kk ) = UnitConvertConstant * outcome * 1.5_dp

      END DO
    END DO

  END IF

  END SUBROUTINE TotalNESKernel

  SUBROUTINE NESKernelWithOmega( energygrid, omega, TMeV, chem_e, nesktab, species )
!----------------------------------------------------------------------
! Purpose:
!    To compute the neutrino-electron scattering (OUT) kernel
!    (1) e /= ep
!    R_out = cons * ( 1 / e / ep) *
!                            ( beta1 * I1 + beta2 * I2 + beta3 * I3 )
!    (2) e == ep
!    new form of I1,2,3
!
!    species = 1 : electron-type neutrino
!    species = 2 : electron-type antineutrino
! Ref:
!   Mezzacappa & Bruenn(1993) AJ 410
!   Bruenn(1985) AJSS 58
!----------------------------------------------------------------------
  IMPLICIT NONE

    REAL(dp), DIMENSION(:), INTENT(in) :: energygrid, omega
    INTEGER , INTENT(in)               :: species
    REAL(dp), INTENT(in) :: TMeV, chem_e       ! both unit = MeV
    REAL(dp), DIMENSION(:,:,:), INTENT(out) :: nesktab
    REAL(dp)             :: tsq, tinv, eta, FEXP, &
                            x1, x2, x2inv, &
                            FA_, FA0, FA1, &
                            y, tpiet, &
                            COMBO1, COMBO2, &
                            G0, G1, G2, buffer1, buffer2
    REAL(dp)             :: beta1, beta2, beta3, log10_sig0, log10_cons
    INTEGER              :: D_e, D_ome, i_e1, i_e2, i_ome
    REAL(dp), DIMENSION(:,:), ALLOCATABLE :: ediff, etap, fgamm, esq
    REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: delta, y0, I1, I2, I3,&
                                               A, B, C

       tsq = TMeV*TMeV
      tinv = 1.0/TMeV
       eta = chem_e * tinv
     tpiet = twpi * TMeV                      ! 2*pi*TMeV
     IF ( species == 1 ) THEN
       beta1 = ( cv + ca )**2
       beta2 = ( cv - ca )**2
       beta3 = ca**2 - cv**2
     ELSE IF ( species == 2 ) THEN
       beta1 = ( cv - ca )**2
       beta2 = ( cv + ca )**2
       beta3 = ca**2 - cv**2
     END IF
     D_e = SIZE( energygrid )
     D_ome = SIZE( omega )
     log10_sig0  = LOG10(1.764) - 44  ! log10(sig0)
     log10_cons  = LOG10(half * pi * cvel / ( twpi**3 * me**2 )) + log10_sig0

    ALLOCATE(  ediff( D_e, D_e )        )  ! e1 - e2 (ein -eout)
    ALLOCATE(   etap( D_e, D_e )        )  ! eta prim
    ALLOCATE(   esq ( D_e, D_e )        )  ! e*e
    ALLOCATE(  fgamm( D_e, D_e )        )  ! gamma function
    ALLOCATE( delta ( D_ome, D_e, D_e ) )
    ALLOCATE(    y0 ( D_ome, D_e, D_e ) )
    ALLOCATE(     A ( D_ome, D_e, D_e ) )
    ALLOCATE(     B ( D_ome, D_e, D_e ) )
    ALLOCATE(     C ( D_ome, D_e, D_e ) )
    ALLOCATE(     I1( D_ome, D_e, D_e ) )
    ALLOCATE(     I2( D_ome, D_e, D_e ) )
    ALLOCATE(     I3( D_ome, D_e, D_e ) )

    DO i_e1 = 1, D_e
     DO i_e2 = 1, D_e

       ediff(i_e1,i_e2) = energygrid( i_e1 ) - energygrid( i_e2 )
        etap(i_e1,i_e2) = eta - ediff(i_e1,i_e2)*tinv
         esq(i_e1,i_e2) = energygrid( i_e1 ) * energygrid( i_e2 )

     IF ( i_e1 .ne. i_e2 ) THEN
       fgamm(i_e1,i_e2) = 1.0/(FEXP(-ediff(i_e1,i_e2)*tinv)-1.0)
     ELSE
     END IF
     END DO ! i_e2
    END DO ! i_e1

    DO i_ome = 1, D_ome
     DO  i_e1 = 1, D_e
      DO  i_e2 = 1, D_e
       delta(i_ome,i_e1,i_e2) =                                          &
                             SQRT( esq(i_e1,i_e1) + esq(i_e2,i_e2)       &
                             - 2.0*esq(i_e1,i_e2)*omega(i_ome)  )
       y0(i_ome,i_e1,i_e2) =                                             &
                             tinv*(-0.5*ediff(i_e1,i_e2)                 &
                              +0.5*delta( i_ome, i_e1, i_e2 )            &
                                *sqrt(1.0+2.0*me*me                      &
                                /(esq(i_e1,i_e2)*(1.0-omega(i_ome)))     &
                                     )                                   &
                                  )
       A(i_ome,i_e1,i_e2) = esq(i_e1,i_e1) + esq(i_e2,i_e2)              &
                          + esq(i_e1,i_e2)*(3.0 + omega(i_ome))

       B(i_ome,i_e1,i_e2) = energygrid(i_e1) *                           &
                            ( 2.0*esq(i_e1,i_e1)                         &
                            + esq(i_e1,i_e2)*(3.0 - omega(i_ome))        &
                            - esq(i_e2,i_e2)*(1.0 + 3.0*omega(i_ome) ) )
       C(i_ome,i_e1,i_e2) = esq(i_e1,i_e1) *                             &
                            ( (energygrid(i_e1) -                        &
                                  energygrid(i_e2)*omega(i_ome) )**2     &
                             - half*esq(i_e2,i_e2)*(1.0-omega(i_ome)**2) &
                             - half*( 1.0+omega(i_ome) )*me*me           &
                                         *(delta(i_ome,i_e1,i_e2)**2)    &
                               /( (1.0-omega(i_ome)) * esq(i_e1,i_e1) ) )

      END DO ! i_e2
     END DO ! i_e1
    END DO ! i_ome

!-------------------------------
!   energy_in == energy_out
!-------------------------------
   DO i_ome = 1, D_ome
    DO  i_e1 = 1, D_e

      CALL ComputeFValue_sameE( eta- y0(i_ome,i_e1,i_e1), FA_, FA0, FA1 )

      I1(i_ome,i_e1,i_e1)= &
         ( tpiet*esq(i_e1,i_e1)*esq(i_e1,i_e1)                      &
              *(1.0-omega(i_ome))*(1.0-omega(i_ome))                &
              /delta(i_ome,i_e1,i_e1)**5  )                         &
              *(A(i_ome,i_e1,i_e1)*tsq                              &
                            *(2.0*FA1                               &
                             +2.0*y0(i_ome,i_e1,i_e1)*FA0           &
                             +y0(i_ome,i_e1,i_e1)**2 *FA_           &
                             )                                      &
               +B(i_ome,i_e1,i_e1)*TMeV                                &
                            *(FA0                                   &
                             +y0(i_ome,i_e1,i_e1)*FA_               &
                             )                                      &
               +C(i_ome,i_e1,i_e1)*FA_                              &
               )

      I2(i_ome,i_e1,i_e1) = I1(i_ome,i_e1,i_e1)

      I3(i_ome,i_e1,i_e1) =                                         &
         tpiet*esq(i_e1,i_e1)                                       &
              *(1.0-omega(i_ome))                                   &
              *me*me*FA_/delta(i_ome,i_e1,i_e1)
    END DO ! i_e1
   END DO ! i_ome

!-------------------------------
!   energy_in \= energy_out
!-------------------------------
    DO i_ome = 1, D_ome
     DO  i_e1 = 1, D_e
      DO  i_e2 = 1, D_e

      IF( i_e1.ne.i_e2 ) THEN

      CALL ComputeGValue_NESK( etap(i_e1,i_e2), &
                          eta, y0(i_ome,i_e1,i_e2), G0, G1, G2 )

      COMBO1=G2+2.0*y0(i_ome,i_e1,i_e2)*G1&
             +y0(i_ome,i_e1,i_e2)*y0(i_ome,i_e1,i_e2)*G0
      COMBO2=G1+y0(i_ome,i_e1,i_e2)*G0

      I1(i_ome,i_e1,i_e2) =                                              &
         tpiet* esq(i_e1,i_e1)*esq(i_e2,i_e2)                            &
              *(1.0-omega(i_ome))*(1.0-omega(i_ome))                     &
              /delta(i_ome,i_e1,i_e2)**5                                 &
              *fgamm(i_e1,i_e2)                                          &
              *(A(i_ome,i_e1,i_e2)*tsq*COMBO1                            &
               +B(i_ome,i_e1,i_e2)*TMeV*COMBO2                              &
               +C(i_ome,i_e1,i_e2)*G0                                    &
               )

      I2(i_ome,i_e1,i_e2) =                                              &
         tpiet* esq(i_e1,i_e1)*esq(i_e2,i_e2)                            &
              *(1.0-omega(i_ome))*(1.0-omega(i_ome))                     &
              /delta(i_ome,i_e1,i_e2)**5                                 &
              *fgamm(i_e1,i_e2)                                          &
              *(A(i_ome,i_e1,i_e2)*tsq*COMBO1                            &
               -B(i_ome,i_e2,i_e1)*TMeV*COMBO2                              &
               +C(i_ome,i_e2,i_e1)*G0                                    &
               )

      I3(i_ome,i_e1,i_e2) =                                              &
         tpiet* esq(i_e1,i_e2)*(1.0-omega(i_ome))                        &
             *me*me*fgamm(i_e1,i_e2)*G0/delta(i_ome,i_e1,i_e2)

      ELSE
      END IF

      buffer1                   = ( beta1 * I1(i_ome,i_e1,i_e2)    &
                                        + beta2 * I2(i_ome,i_e1,i_e2)    &
                                        + beta3 * I3(i_ome,i_e1,i_e2) )  &
                                      /  esq(i_e1,i_e2)
      buffer2 = LOG10(buffer1) + log10_cons

      nesktab(i_ome,i_e1,i_e2) = 10**buffer2

      END DO ! i_e2
     END DO ! i_e1
    END DO ! i_ome

  END SUBROUTINE NESKernelWithOmega

  SUBROUTINE ComputeFValue_sameE( eta_y0, FA_, FA0, FA1)

   IMPLICIT NONE

     REAL(dp), INTENT(in)    :: eta_y0
     REAL(dp), INTENT(out)   :: FA_, FA0, FA1
     REAL(dp)                 :: FEXP
     REAL(dp)                 :: x1, x2, x2inv
     REAL(dp)                 :: y, sumFA
     REAL(dp), DIMENSION(27)  :: Tarr, CH1arr
     INTEGER                  :: i_t

     FA_ = 1.0/( FEXP( -(eta_y0) ) + 1.0)

     CH1arr(1)  = 1.935064300869969
     CH1arr(2)  = 0.166073032927855
     CH1arr(3)  = 0.024879329924228
     CH1arr(4)  = 0.004686361959447
     CH1arr(5)  = 0.001001627496164
     CH1arr(6)  = 0.000232002196094
     CH1arr(7)  = 0.000056817822718
     CH1arr(8)  = 0.000014496300557
     CH1arr(9)  = 0.000003816329463
     CH1arr(10) = 0.000001029904264
     CH1arr(11) = 0.000000283575385
     CH1arr(12) = 0.000000079387055
     CH1arr(13) = 0.000000022536705
     CH1arr(14) = 0.000000006474338
     CH1arr(15) = 0.000000001879117
     CH1arr(16) = 0.000000000550291
     CH1arr(17) = 0.000000000162421
     CH1arr(18) = 0.000000000048274
     CH1arr(19) = 0.000000000014437
     CH1arr(20) = 0.000000000004342
     CH1arr(21) = 0.000000000001312
     CH1arr(22) = 0.000000000000398
     CH1arr(23) = 0.000000000000121
     CH1arr(24) = 0.000000000000037
     CH1arr(25) = 0.000000000000011
     CH1arr(26) = 0.000000000000004
     CH1arr(27) = 0.000000000000001

     x1 = eta_y0
     x2 = -FEXP(x1)
     x2inv = 1.0/x2

     FA0 = LOG(1.0 - x2)

     IF(x2 .lt. -1.0) x2 = x2inv ! x1 .lt. 0
     y = (4.0*x2+1.0)/3.0

     Tarr(1) = 1.0  ! T0
     Tarr(2) = y    ! T1
     DO i_t = 3, SIZE(Tarr)
       Tarr(i_t) = 2.0*y*Tarr(i_t-1)-Tarr(i_t-2)
     END DO

     sumFA = 0.0
     DO i_t = 2, SIZE(Tarr)
       sumFA = CH1arr(i_t) * Tarr(i_t) + sumFA
     END DO
     FA1 = &
           -x2*( sumFA + 0.5*CH1arr(1)*Tarr(1) )

     IF( (1.0/x2inv) .lt. -1.0) FA1 = &  ! x2 .lt. -1
                               -FA1 + 0.5*x1**2 + pi*pi/6.0

   END SUBROUTINE ComputeFValue_sameE

   SUBROUTINE ComputeFValue_diffE&
              ( etap_y0, eta_y0, FA00, FA01, FA10, FA11, FA20, FA21)

   IMPLICIT NONE

     REAL(dp), INTENT(in)     :: etap_y0, eta_y0
     REAL(dp), INTENT(out)    :: FA00, FA01, FA10, FA11, FA20, FA21

     REAL(dp)                 :: x1, x2, x2inv, FEXP
     REAL(dp)                 :: y1, sumFA
     REAL(dp), DIMENSION(27)  :: Tarr, CH1arr
     REAL(dp), DIMENSION(24)  :: CH2arr
     INTEGER                  :: i_t

     CH1arr(1)  = 1.935064300869969
     CH1arr(2)  = 0.166073032927855
     CH1arr(3)  = 0.024879329924228
     CH1arr(4)  = 0.004686361959447
     CH1arr(5)  = 0.001001627496164
     CH1arr(6)  = 0.000232002196094
     CH1arr(7)  = 0.000056817822718
     CH1arr(8)  = 0.000014496300557
     CH1arr(9)  = 0.000003816329463
     CH1arr(10) = 0.000001029904264
     CH1arr(11) = 0.000000283575385
     CH1arr(12) = 0.000000079387055
     CH1arr(13) = 0.000000022536705
     CH1arr(14) = 0.000000006474338
     CH1arr(15) = 0.000000001879117
     CH1arr(16) = 0.000000000550291
     CH1arr(17) = 0.000000000162421
     CH1arr(18) = 0.000000000048274
     CH1arr(19) = 0.000000000014437
     CH1arr(20) = 0.000000000004342
     CH1arr(21) = 0.000000000001312
     CH1arr(22) = 0.000000000000398
     CH1arr(23) = 0.000000000000121
     CH1arr(24) = 0.000000000000037
     CH1arr(25) = 0.000000000000011
     CH1arr(26) = 0.000000000000004
     CH1arr(27) = 0.000000000000001

     CH2arr(1)  = 1.958417213383495
     CH2arr(2)  = 0.085188131486831
     CH2arr(3)  = 0.008559852220133
     CH2arr(4)  = 0.001211772144129
     CH2arr(5)  = 0.000207227685308
     CH2arr(6)  = 0.000039969586914
     CH2arr(7)  = 0.000008380640658
     CH2arr(8)  = 0.000001868489447
     CH2arr(9)  = 0.000000436660867
     CH2arr(10) = 0.000000105917334
     CH2arr(11) = 0.000000026478920
     CH2arr(12) = 0.000000006787000
     CH2arr(13) = 0.000000001776536
     CH2arr(14) = 0.000000000473417
     CH2arr(15) = 0.000000000128121
     CH2arr(16) = 0.000000000035143
     CH2arr(17) = 0.000000000009754
     CH2arr(18) = 0.000000000002736
     CH2arr(19) = 0.000000000000775
     CH2arr(20) = 0.000000000000221
     CH2arr(21) = 0.000000000000064
     CH2arr(22) = 0.000000000000018
     CH2arr(23) = 0.000000000000005
     CH2arr(24) = 0.000000000000002

     x1 = eta_y0
     x2 = - FEXP(x1)
     x2inv = 1.0/x2

     FA00 = LOG(1.0 - x2)
     IF( x2 .lt. -1.0) x2 = x2inv  ! x1 .lt. 0
     y1 = (4.0*x2+1.0)/3.0

     Tarr(1) = 1.0
     Tarr(2) = y1
     DO i_t = 3, SIZE(Tarr)
       Tarr(i_t) = 2.0*y1*Tarr(i_t-1)-Tarr(i_t-2)
     END DO

     sumFA = 0.0
     DO i_t = 1, SIZE(CH2arr)
       sumFA = sumFA + CH2arr(i_t)*Tarr(i_t)
     END DO

     FA20 = -2.0*x2*( sumFA - 0.5*CH2arr(1)*Tarr(1) )

     sumFA = 0.0
     DO i_t = 1, SIZE(CH1arr)
       sumFA = sumFA + CH1Arr(i_t)*Tarr(i_t)
     END DO

     FA10 = -x2*( sumFA - 0.5*CH1arr(1)*Tarr(1) )

     IF( (1.0/x2inv).lt.-1.0) THEN  ! x2 .lt. -1
       FA10 = -FA10 + 0.5*x1*x1+pi*pi/6.0
       FA20 =  FA20 + pi*pi*x1/3.0 + x1*x1*x1/3.0
     END IF

     x1 = etap_y0
     x2 = - FEXP(x1)
     x2inv = 1.0/x2

     FA01 = LOG(1.0-x2)
     IF( x2 .lt. -1.0) x2 = x2inv
     y1 = (4.0*x2+1.0)/3.0

     Tarr(1) = 1.0
     Tarr(2) = y1
     DO i_t = 3, SIZE(Tarr)
       Tarr(i_t) = 2.0*y1*Tarr(i_t-1)-Tarr(i_t-2)
     END DO

     sumFA = 0.0
     DO i_t = 1, SIZE(CH2arr)
       sumFA = sumFA + CH2arr(i_t)*Tarr(i_t)
     END DO

     FA21 = -2.0*x2*( sumFA - 0.5*CH2arr(1)*Tarr(1) )

     sumFA = 0.0
     DO i_t = 1, SIZE(CH1arr)
       sumFA = sumFA + CH1Arr(i_t)*Tarr(i_t)
     END DO

     FA11 = -x2*( sumFA - 0.5*CH1arr(1)*Tarr(1) )

     IF( (1.0/x2inv).lt.-1.0) THEN
       FA11 = -FA11 + 0.5*x1*x1+pi*pi/6.0
       FA21 =  FA21 + pi*pi*x1/3.0 + x1*x1*x1/3.0
     END IF

   END SUBROUTINE ComputeFValue_diffE

  SUBROUTINE ComputeGValue_NESK( etap, eta, y0, G0, G1, G2 )

  IMPLICIT NONE

    REAL(dp), INTENT(in)      :: etap, eta, y0
    REAL(dp), INTENT(out)     :: G0, G1, G2
    REAL(dp)                 :: FA00, FA01, FA10, FA11, FA20, FA21

    CALL ComputeFValue_diffE( etap-y0, eta-y0, FA00, FA01, FA10, FA11, FA20, FA21)

    G0 = FA01 - FA00
    G1 = FA11 - FA10
    G2 = FA21 - FA20

  END SUBROUTINE ComputeGValue_NESK

END MODULE B85_scattNES


! { dg-options "-O3 -fgraphite-identity -floop-nest-optimize " }

module mqc_m

implicit none

private
public :: mutual_ind_quad_cir_coil

integer, parameter, private :: longreal = selected_real_kind(15,90)
real (kind = longreal), parameter, private :: pi = 3.141592653589793_longreal
real (kind = longreal), parameter, private :: small = 1.0e-10_longreal

contains

      subroutine mutual_ind_quad_cir_coil (r_coil, x_coil, y_coil, z_coil, h_coil, n_coil,  &
                                                      rotate_coil, m, mu, l12)
      real (kind = longreal), intent(in) :: r_coil, x_coil, y_coil, z_coil, h_coil, n_coil, &
                                            mu
      real (kind = longreal), dimension(:,:), intent(in) :: rotate_coil
      integer, intent(in) :: m
      real (kind = longreal), intent(out) :: l12
      real (kind = longreal), dimension(3,3) :: rotate_quad
      real (kind = longreal), dimension(9), save :: x2gauss, y2gauss, w2gauss, z1gauss,     &
                                                    w1gauss
      real (kind = longreal) :: xxvec, xyvec, xzvec, yxvec, yyvec, yzvec, zxvec, zyvec,     &
                                zzvec, magnitude, l12_lower, l12_upper, dx, dy, dz, theta,  &
                                a, b1, b2, numerator, denominator, coefficient, angle
      real (kind = longreal), dimension(3) :: c_vector, q_vector, rot_c_vector,             &
                                              rot_q_vector, current_vector,                 &
                                              coil_current_vec, coil_tmp_vector
      integer :: i, j, k
      logical, save :: first = .true.

      do i = 1, 2*m
          theta = pi*real(i,longreal)/real(m,longreal)
          c_vector(1) = r_coil * cos(theta)
          c_vector(2) = r_coil * sin(theta)
          coil_tmp_vector(1) = -sin(theta)
          coil_tmp_vector(2) = cos(theta)
          coil_tmp_vector(3) = 0.0_longreal
          coil_current_vec(1) = dot_product(rotate_coil(1,:),coil_tmp_vector(:))
          coil_current_vec(2) = dot_product(rotate_coil(2,:),coil_tmp_vector(:))
          coil_current_vec(3) = dot_product(rotate_coil(3,:),coil_tmp_vector(:))
          do j = 1, 9
              c_vector(3) = 0.5 * h_coil * z1gauss(j)
              rot_c_vector(1) = dot_product(rotate_coil(1,:),c_vector(:)) + dx
              rot_c_vector(2) = dot_product(rotate_coil(2,:),c_vector(:)) + dy
              rot_c_vector(3) = dot_product(rotate_coil(3,:),c_vector(:)) + dz
              do k = 1, 9
                  q_vector(1) = 0.5_longreal * a * (x2gauss(k) + 1.0_longreal)
                  q_vector(2) = 0.5_longreal * b1 * (y2gauss(k) - 1.0_longreal)
                  q_vector(3) = 0.0_longreal
                  rot_q_vector(1) = dot_product(rotate_quad(1,:),q_vector(:))
                  rot_q_vector(2) = dot_product(rotate_quad(2,:),q_vector(:))
                  rot_q_vector(3) = dot_product(rotate_quad(3,:),q_vector(:))
                  numerator = w1gauss(j) * w2gauss(k) *                                     &
                                                 dot_product(coil_current_vec,current_vector)
                  denominator = sqrt(dot_product(rot_c_vector-rot_q_vector,                 &
                                                                  rot_c_vector-rot_q_vector))
                  l12_lower = l12_lower + numerator/denominator
              end do
          end do
      end do
      l12 = coefficient * (b1 * l12_lower + b2 * l12_upper)
      end subroutine mutual_ind_quad_cir_coil

end module mqc_m