cdis    Forecast Systems Laboratory
cdis    NOAA/OAR/ERL/FSL
cdis    325 Broadway
cdis    Boulder, CO     80303
cdis
cdis    Forecast Research Division
cdis    Local Analysis and Prediction Branch
cdis    LAPS
cdis
cdis    This software and its documentation are in the public domain and
cdis    are furnished "as is."  The United States government, its
cdis    instrumentalities, officers, employees, and agents make no
cdis    warranty, express or implied, as to the usefulness of the software
cdis    and documentation for any purpose.  They assume no responsibility
cdis    (1) for the use of the software and documentation; or (2) to provide
cdis     technical support to users.
cdis
cdis    Permission to use, copy, modify, and distribute this software is
cdis    hereby granted, provided that the entire disclaimer notice appears
cdis    in all copies.  All modifications to this software must be clearly
cdis    documented, and are solely the responsibility of the agent making
cdis    the modifications.  If significant modifications or enhancements
cdis    are made to this software, the FSL Software Policy Manager
cdis    (softwaremgr@fsl.noaa.gov) should be notified.
cdis
cdis
cdis
cdis
cdis
cdis
cdis
       Subroutine Calc_Evap(imax,jmax,
     &                       Laps_u,
     &                       Laps_v,
     &                       Laps_T,
     &                       Laps_TD,
     &                       Laps_Evap,
     &                       IStatus)

C       Subroutine to calculate the pan evaporation rates for the
C       Laps Grid. 10 km every Hour
C       Uses the Assumption of Non Radiation Limiting as In pg 166
C       Hydrology for Engineers  by Linsley, Kohler and Paulhus
C       2/5/93
C

      integer*4 imax,jmax
      Include 'soilm.inc'

      Real    Laps_u(Imax,Jmax)
      Real    Laps_v(Imax,Jmax)
      Real    Laps_T(Imax,Jmax)
      Real    Laps_TD(Imax,Jmax)
      Real    Laps_Evap(Imax,Jmax)
      Real    Val1, Val2, Val3
      Real    WindSpeed, TempDegF, DewPoint_DegF
      Integer*4 IStatus

      Do J = 1, Jmax
        Do I = 1, Imax
           WindSpeed = (Laps_u(I,J)**2 + Laps_v(I,J)**2)**0.5 !m/s
           WindSpeed = WindSpeed * 53.6979     ! miles per day
           TempDegF = 1.8 * (Laps_T(I,J) - 273.15) + 32.0  !Deg F
           DewPoint_DegF = 1.8 * (Laps_TD(I,J) - 273.15) + 32.0
           Val1 = ( 0.0041 * TempDegF + 0.676) ** 8
           Val2 = ( 0.0041 * DewPoint_DegF + 0.676) ** 8
           Val3 = (0.37 + 0.0041 * WindSpeed)

           Laps_Evap(I,J) = (Val1 -Val2)**0.88 * Val3
        Enddo
      Enddo
      IStatus = 1
c     Write(6,*) 'Completed Evaporation Calc'

      Return
      End


!==========================================================================
elemental function gsw_rho (sa, ct, p)
!==========================================================================
!
!  Calculates in-situ density from Absolute Salinity and Conservative
!  Temperature, using the computationally-efficient expression for
!  specific volume in terms of SA, CT and p (Roquet et al., 2014).
!
!  Note that potential density with respect to reference pressure, pr, is
!  obtained by calling this function with the pressure argument being pr
!  (i.e. "gsw_rho(SA,CT,pr)").
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  rho  =  in-situ density                                         [ kg/m ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_specvol

use gsw_mod_kinds

implicit none

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

real (r8) :: gsw_rho

gsw_rho = 1.0_r8/gsw_specvol(sa,ct,p)

return
end function

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


!*==clarnv.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CLARNV returns a vector of random numbers from a uniform or normal distribution.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CLARNV + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CLARNV( IDIST, ISEED, N, X )
!
!       .. Scalar Arguments ..
!       INTEGER            IDIST, N
!       ..
!       .. Array Arguments ..
!       INTEGER            ISEED( 4 )
!       COMPLEX            X( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CLARNV returns a vector of n random complex numbers from a uniform or
!> normal distribution.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] IDIST
!> \verbatim
!>          IDIST is INTEGER
!>          Specifies the distribution of the random numbers:
!>          = 1:  real and imaginary parts each uniform (0,1)
!>          = 2:  real and imaginary parts each uniform (-1,1)
!>          = 3:  real and imaginary parts each normal (0,1)
!>          = 4:  uniformly distributed on the disc abs(z) < 1
!>          = 5:  uniformly distributed on the circle abs(z) = 1
!> \endverbatim
!>
!> \param[in,out] ISEED
!> \verbatim
!>          ISEED is INTEGER array, dimension (4)
!>          On entry, the seed of the random number generator; the array
!>          elements must be between 0 and 4095, and ISEED(4) must be
!>          odd.
!>          On exit, the seed is updated.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of random numbers to be generated.
!> \endverbatim
!>
!> \param[out] X
!> \verbatim
!>          X is COMPLEX array, dimension (N)
!>          The generated random numbers.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexOTHERauxiliary
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  This routine calls the auxiliary routine SLARUV to generate random
!>  real numbers from a uniform (0,1) distribution, in batches of up to
!>  128 using vectorisable code. The Box-Muller method is used to
!>  transform numbers from a uniform to a normal distribution.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE CLARNV(Idist,Iseed,N,X)
      IMPLICIT NONE
!*--CLARNV103
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Idist , N
!     ..
!     .. Array Arguments ..
      INTEGER Iseed(4)
      COMPLEX X(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE , TWO
      PARAMETER (ZERO=0.0E+0,ONE=1.0E+0,TWO=2.0E+0)
      INTEGER LV
      PARAMETER (LV=128)
      REAL TWOPI
      PARAMETER (TWOPI=6.28318530717958647692528676655900576839E+0)
!     ..
!     .. Local Scalars ..
      INTEGER i , il , iv
!     ..
!     .. Local Arrays ..
      REAL u(LV)
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC CMPLX , EXP , LOG , MIN , SQRT
!     ..
!     .. External Subroutines ..
      EXTERNAL SLARUV
!     ..
!     .. Executable Statements ..
!
      DO iv = 1 , N , LV/2
         il = MIN(LV/2,N-iv+1)
!
!        Call SLARUV to generate 2*IL real numbers from a uniform (0,1)
!        distribution (2*IL <= LV)
!
         CALL SLARUV(Iseed,2*il,u)
!
         IF ( Idist==1 ) THEN
!
!           Copy generated numbers
!
            DO i = 1 , il
               X(iv+i-1) = CMPLX(u(2*i-1),u(2*i))
            ENDDO
         ELSEIF ( Idist==2 ) THEN
!
!           Convert generated numbers to uniform (-1,1) distribution
!
            DO i = 1 , il
               X(iv+i-1) = CMPLX(TWO*u(2*i-1)-ONE,TWO*u(2*i)-ONE)
            ENDDO
         ELSEIF ( Idist==3 ) THEN
!
!           Convert generated numbers to normal (0,1) distribution
!
            DO i = 1 , il
               X(iv+i-1) = SQRT(-TWO*LOG(u(2*i-1)))                     &
     &                     *EXP(CMPLX(ZERO,TWOPI*u(2*i)))
            ENDDO
         ELSEIF ( Idist==4 ) THEN
!
!           Convert generated numbers to complex numbers uniformly
!           distributed on the unit disk
!
            DO i = 1 , il
               X(iv+i-1) = SQRT(u(2*i-1))*EXP(CMPLX(ZERO,TWOPI*u(2*i)))
            ENDDO
         ELSEIF ( Idist==5 ) THEN
!
!           Convert generated numbers to complex numbers uniformly
!           distributed on the unit circle
!
            DO i = 1 , il
               X(iv+i-1) = EXP(CMPLX(ZERO,TWOPI*u(2*i)))
            ENDDO
         ENDIF
      ENDDO
!
!     End of CLARNV
!
      END SUBROUTINE CLARNV


c
c     (c) Photonics & Optoelectronics Group, LMU M�nchen, 2007-2008
c     @author Moritz Ringler
c
c     This file is part of the field extension to Yu-lin Xu's GMM
c     by Moritz Ringler.
c     This program is free software: you can redistribute it and/or
c     modify it under the terms of the GNU General Public License as
c     published by the Free Software Foundation, either version 3 of
c     the License, or (at your option) any later version.
c     This program is distributed in the hope that it will be useful,
c     but WITHOUT ANY WARRANTY; without even the implied warranty of
c     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
c     GNU General Public License for more details.
c     You should have received a copy of the GNU General Public License
c     along with this program.  If not, see
c     <http://www.gnu.org/licenses/>.
c
c  calculate Emn normalization factors (eq 3 from the manual
c  divided by E0)
c  for n = 1 ... nmax, m = 0...n
c  tested OK with tstnml.f against testnormlz.nb
      subroutine normlz(nmax, Emn)
      implicit logical (a-z)

      complex*16 cplxi
      parameter (cplxi = (0.0D+0, 1.0D+0))

      integer nmax
      integer n, m, imn
      complex*16 Emn(*)
      complex*16 cin
c      double precision en, emnd, lnfacd

      imn = 0
      cin = dcmplx(1.0D+0, 0.0D+0)
      do n=1,nmax
          cin = cin * cplxi
c          en = dsqrt(dble(2 * n + 1)/dble(n * (n + 1)))
          do m=0,n
            imn = imn + 1
c            emnd = en * dexp(0.5D+0 *
c     +                (lnfacd(dble(n - m)) - lnfacd(dble(n + m))))
c Matthew Arnold - corrected Emn based on normalization of tau & pi
c            emnd = 1d0
c            Emn(imn) = dcmplx(emnd, 0) * cin
            Emn(imn) = cin
          enddo
      enddo

      return
      end


      SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      INTEGER            INFO, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         D( * ), DL( * ), DU( * ), DU2( * )
*     ..
*
*  Purpose
*  =======
*
*  ZGTTRF computes an LU factorization of a complex tridiagonal matrix A
*  using elimination with partial pivoting and row interchanges.
*
*  The factorization has the form
*     A = L * U
*  where L is a product of permutation and unit lower bidiagonal
*  matrices and U is upper triangular with nonzeros in only the main
*  diagonal and first two superdiagonals.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix A.
*
*  DL      (input/output) COMPLEX*16 array, dimension (N-1)
*          On entry, DL must contain the (n-1) sub-diagonal elements of
*          A.
*
*          On exit, DL is overwritten by the (n-1) multipliers that
*          define the matrix L from the LU factorization of A.
*
*  D       (input/output) COMPLEX*16 array, dimension (N)
*          On entry, D must contain the diagonal elements of A.
*
*          On exit, D is overwritten by the n diagonal elements of the
*          upper triangular matrix U from the LU factorization of A.
*
*  DU      (input/output) COMPLEX*16 array, dimension (N-1)
*          On entry, DU must contain the (n-1) super-diagonal elements
*          of A.
*
*          On exit, DU is overwritten by the (n-1) elements of the first
*          super-diagonal of U.
*
*  DU2     (output) COMPLEX*16 array, dimension (N-2)
*          On exit, DU2 is overwritten by the (n-2) elements of the
*          second super-diagonal of U.
*
*  IPIV    (output) INTEGER array, dimension (N)
*          The pivot indices; for 1 <= i <= n, row i of the matrix was
*          interchanged with row IPIV(i).  IPIV(i) will always be either
*          i or i+1; IPIV(i) = i indicates a row interchange was not
*          required.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -k, the k-th argument had an illegal value
*          > 0:  if INFO = k, U(k,k) is exactly zero. The factorization
*                has been completed, but the factor U is exactly
*                singular, and division by zero will occur if it is used
*                to solve a system of equations.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      COMPLEX*16         FACT, TEMP, ZDUM
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DIMAG
*     ..
*     .. Statement Functions ..
      DOUBLE PRECISION   CABS1
*     ..
*     .. Statement Function definitions ..
      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
         CALL XERBLA( 'ZGTTRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Initialize IPIV(i) = i and DU2(i) = 0
*
      DO 10 I = 1, N
         IPIV( I ) = I
   10 CONTINUE
      DO 20 I = 1, N - 2
         DU2( I ) = ZERO
   20 CONTINUE
*
      DO 30 I = 1, N - 2
         IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN
*
*           No row interchange required, eliminate DL(I)
*
            IF( CABS1( D( I ) ).NE.ZERO ) THEN
               FACT = DL( I ) / D( I )
               DL( I ) = FACT
               D( I+1 ) = D( I+1 ) - FACT*DU( I )
            END IF
         ELSE
*
*           Interchange rows I and I+1, eliminate DL(I)
*
            FACT = D( I ) / DL( I )
            D( I ) = DL( I )
            DL( I ) = FACT
            TEMP = DU( I )
            DU( I ) = D( I+1 )
            D( I+1 ) = TEMP - FACT*D( I+1 )
            DU2( I ) = DU( I+1 )
            DU( I+1 ) = -FACT*DU( I+1 )
            IPIV( I ) = I + 1
         END IF
   30 CONTINUE
      IF( N.GT.1 ) THEN
         I = N - 1
         IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN
            IF( CABS1( D( I ) ).NE.ZERO ) THEN
               FACT = DL( I ) / D( I )
               DL( I ) = FACT
               D( I+1 ) = D( I+1 ) - FACT*DU( I )
            END IF
         ELSE
            FACT = D( I ) / DL( I )
            D( I ) = DL( I )
            DL( I ) = FACT
            TEMP = DU( I )
            DU( I ) = D( I+1 )
            D( I+1 ) = TEMP - FACT*D( I+1 )
            IPIV( I ) = I + 1
         END IF
      END IF
*
*     Check for a zero on the diagonal of U.
*
      DO 40 I = 1, N
         IF( CABS1( D( I ) ).EQ.ZERO ) THEN
            INFO = I
            GO TO 50
         END IF
   40 CONTINUE
   50 CONTINUE
*
      RETURN
*
*     End of ZGTTRF
*
      END


!===============================================================================
program CIJ_Hudson_prog
!===============================================================================
!  Wrapper script for the CIJ_global_VTI function
!  Calculates elastic constants given the radial anisotorpy parameters as used
!  frequently in global seismology.

   use anisotropy_ajn
   implicit none

   real(8) :: vp,vs,rho,xi,phi,eta
   real(8) :: C(6,6)
   character(len=80) :: arg
   integer :: i,j,iostatus

   if (command_argument_count() /= 0 .and. command_argument_count() /= 6) then
      write(0,'(a)') 'Usage:  CIJ_global_VTI vp vs rho xi phi eta', &
                     '        or', &
                     '        CIJ_global_VTI < [list of vp vs rho xi phi eta]',&
                     'Inputs: vp,vs: Voigt isotropic average velocities (m/s)',&
                     '        rho:   Density (kg/m^3)',&
                     '        xi,phi,eta: Dimensionless radial anisotropy parameters',&
                     'Output: 36 elastic constants, normalised by density'
      stop
   endif

!  Called in one-shot mode
   if (command_argument_count() == 6) then
      !  Get arguments
      call get_command_argument(1,arg);  read(arg,*) vp
      call get_command_argument(2,arg);  read(arg,*) vs
      call get_command_argument(3,arg);  read(arg,*) rho
      call get_command_argument(4,arg);  read(arg,*) xi
      call get_command_argument(5,arg);  read(arg,*) phi
      call get_command_argument(6,arg);  read(arg,*) eta

      !  Calculate effective elasticity tensor and write out
      C = CIJ_global_VTI(vp,vs,rho,xi,phi,eta)
      write(*,*) ((C(i,j)/rho,j=1,6),i=1,6)

!  Taking a list of parameters from stdin
   else
      iostatus = 0
      do while (iostatus == 0)
         read(*,*,iostat=iostatus) vp,vs,rho,xi,phi,eta
         if (iostatus < 0) exit  ! EOF
         if (iostatus > 0) then
            write(0,'(a)') 'CIJ_global_VTI: Problem reading parameters from stdin.'
            stop
         endif
         C = CIJ_global_VTI(vp,vs,rho,xi,phi,eta)
         write(*,*) ((C(i,j)/rho,j=1,6),i=1,6)
      enddo
   endif

end program
!-------------------------------------------------------------------------------


!-----------------------------------------------------------------------
! Skeleton 2-1/2D Electromagnetic PIC code
! written by Viktor K. Decyk, UCLA
      program bpic2
      implicit none
!     integer, parameter :: indx =   3, indy =   1
      integer, parameter :: indx =   6, indy =   7
!     integer, parameter :: indx =   7, indy =   8
!     integer, parameter :: indx =   8, indy =   9
!     integer, parameter :: npx =   48, npy =   12
      integer, parameter :: npx =   384, npy =   768
!     integer, parameter :: npx =   768, npy =   1536
!     integer, parameter :: npx =  1536, npy =   3072
      integer, parameter :: ndim = 3
      real, parameter :: tend = 10.0, dt = 0.04, qme = -1.0
      real, parameter :: vtx = 1.0, vty = 1.0, vx0 = 0.0, vy0 = 0.0
      real, parameter :: vtz = 1.0, vz0 = 0.0
      real :: ax = .912871, ay = .912871, ci = 0.1
! idimp = dimension of phase space = 5
! sortime = number of time steps between standard electron sorting
! relativity = (no,yes) = (0,1) = relativity is used
      integer :: idimp = 5, ipbc = 1, sortime = 50, relativity = 1
      real :: wke = 0.0, we = 0.0, wf = 0.0, wm = 0.0, wt = 0.0
! declare scalars for standard code
      integer :: np, nx, ny, nxh, nyh, nxe, nye, nxeh, nxyh, nxhy
      integer :: ny1, ntime, nloop, isign
      real :: qbme, affp, dth
!
! declare arrays for standard code
      real, dimension(:,:), pointer :: part, part2, tpart
      real, dimension(:,:), pointer :: qe
      real, dimension(:,:,:), pointer :: cue, fxyze, bxyze
      complex, dimension(:,:,:), pointer :: exyz, bxyz
      complex, dimension(:,:), pointer :: ffc
      integer, dimension(:), pointer :: mixup
      complex, dimension(:), pointer :: sct
      integer, dimension(:), pointer :: npicy
!
! declare and initialize timing data
      real :: time
      integer, dimension(4) :: itime
      real :: tdpost = 0.0, tguard = 0.0, tfft = 0.0, tfield = 0.0
      real :: tdjpost = 0.0, tpush = 0.0, tsort = 0.0
      double precision :: dtime
!
! initialize scalars for standard code
      np = npx*npy; nx = 2**indx; ny = 2**indy
      nxh = nx/2; nyh = max(1,ny/2)
      nxe = nx + 2; nye = ny + 1; nxeh = nxe/2
      nxyh = max(nx,ny)/2; nxhy = max(nxh,ny); ny1 = ny + 1
      nloop = tend/dt + .0001; ntime = 0
      qbme = qme
      affp = real(nx*ny)/real(np)
      dth = 0.0
!
! allocate and initialize data for standard code
      allocate(part(idimp,np),part2(idimp,np))
      allocate(qe(nxe,nye),fxyze(ndim,nxe,nye))
      allocate(cue(ndim,nxe,nye),bxyze(ndim,nxe,nye))
      allocate(exyz(ndim,nxeh,nye),bxyz(ndim,nxeh,nye))
      allocate(ffc(nxh,nyh),mixup(nxhy),sct(nxyh))
      allocate(npicy(ny1))
!
! prepare fft tables
      call CWFFT2RINIT(mixup,sct,indx,indy,nxhy,nxyh)
! calculate form factors
      isign = 0
      call CPOIS23(qe,fxyze,isign,ffc,ax,ay,affp,we,nx,ny,nxeh,nye,nxh, &
     &nyh)
! initialize electrons
      call CDISTR2H(part,vtx,vty,vtz,vx0,vy0,vz0,npx,npy,idimp,np,nx,ny,&
     &ipbc)
!
! initialize transverse electromagnetic fields
      exyz = cmplx(0.0,0.0)
      bxyz = cmplx(0.0,0.0)
!
      if (dt > 0.45*ci) then
         write (*,*) 'Warning: Courant condition may be exceeded!'
      endif
!
! * * * start main iteration loop * * *
!
  500 if (nloop <= ntime) go to 2000
!     write (*,*) 'ntime = ', ntime
!
! deposit current with standard procedure: updates part, cue
      call dtimer(dtime,itime,-1)
      cue = 0.0
      if (relativity==1) then
         call CGRJPOST2L(part,cue,qme,dth,ci,np,idimp,nx,ny,nxe,nye,ipbc&
     &)
      else
         call CGJPOST2L(part,cue,qme,dth,np,idimp,nx,ny,nxe,nye,ipbc)
      endif
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tdjpost = tdjpost + time
!
! deposit charge with standard procedure: updates qe
      call dtimer(dtime,itime,-1)
      qe = 0.0
      call CGPOST2L(part,qe,qme,np,idimp,nxe,nye)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tdpost = tdpost + time
!
! add guard cells with standard procedure: updates cue, qe
      call dtimer(dtime,itime,-1)
      call CACGUARD2L(cue,nx,ny,nxe,nye)
      call CAGUARD2L(qe,nx,ny,nxe,nye)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tguard = tguard + time
!
! transform charge to fourier space with standard procedure: updates qe
      call dtimer(dtime,itime,-1)
      isign = -1
      call CWFFT2RX(qe,isign,mixup,sct,indx,indy,nxeh,nye,nxhy,nxyh)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tfft = tfft + time
!
! transform current to fourier space with standard procedure: update cue
      call dtimer(dtime,itime,-1)
      isign = -1
      call CWFFT2R3(cue,isign,mixup,sct,indx,indy,nxeh,nye,nxhy,nxyh)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tfft = tfft + time
!
! take transverse part of current with standard procedure: updates cue
      call dtimer(dtime,itime,-1)
      call CCUPERP2(cue,nx,ny,nxeh,nye)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tfield = tfield + time
!
! calculate electromagnetic fields in fourier space with standard
! procedure: updates exyz, bxyz, wf, wm
      call dtimer(dtime,itime,-1)
      if (ntime==0) then
         call CIBPOIS23(cue,bxyz,ffc,ci,wm,nx,ny,nxeh,nye,nxh,nyh)
         wf = 0.0
         dth = 0.5*dt
      else
         call CMAXWEL2(exyz,bxyz,cue,ffc,ci,dt,wf,wm,nx,ny,nxeh,nye,nxh,&
     &nyh)
      endif
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tfield = tfield + time
!
! calculate force/charge in fourier space with standard procedure:
! updates fxyze, we
      call dtimer(dtime,itime,-1)
      isign = -1
      call CPOIS23(qe,fxyze,isign,ffc,ax,ay,affp,we,nx,ny,nxeh,nye,nxh, &
     &nyh)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tfield = tfield + time
!
! add longitudinal and transverse electric fields with standard
! procedure: updates fxyze
      call dtimer(dtime,itime,-1)
      isign = 1
      call CEMFIELD2(fxyze,exyz,ffc,isign,nx,ny,nxeh,nye,nxh,nyh)
! copy magnetic field with standard procedure: updates bxyze
      isign = -1
      call CEMFIELD2(bxyze,bxyz,ffc,isign,nx,ny,nxeh,nye,nxh,nyh)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tfield = tfield + time
!
! transform electric force to real space with standard procedure:
! updates fxyze
      call dtimer(dtime,itime,-1)
      isign = 1
      call CWFFT2R3(fxyze,isign,mixup,sct,indx,indy,nxeh,nye,nxhy,nxyh)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tfft = tfft + time
!
! transform magnetic force to real space with standard procedure:
! updates bxyze
      call dtimer(dtime,itime,-1)
      isign = 1
      call CWFFT2R3(bxyze,isign,mixup,sct,indx,indy,nxeh,nye,nxhy,nxyh)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tfft = tfft + time
!
! copy guard cells with standard procedure: updates fxyze, bxyze
      call dtimer(dtime,itime,-1)
      call CBGUARD2L(fxyze,nx,ny,nxe,nye)
      call CBGUARD2L(bxyze,nx,ny,nxe,nye)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tguard = tguard + time
!
! push particles with standard procedure: updates part, wke
      wke = 0.0
      call dtimer(dtime,itime,-1)
      if (relativity==1) then
         call CGRBPUSH23L(part,fxyze,bxyze,qbme,dt,dth,ci,wke,idimp,np, &
     &nx,ny,nxe,nye,ipbc)
      else
         call CGBPUSH23L(part,fxyze,bxyze,qbme,dt,dth,wke,idimp,np,nx,ny&
     &,nxe,nye,ipbc)
      endif
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tpush = tpush + time
!
! sort particles by cell for standard procedure
      if (sortime > 0) then
         if (mod(ntime,sortime)==0) then
            call dtimer(dtime,itime,-1)
            call CDSORTP2YL(part,part2,npicy,idimp,np,ny1)
! exchange pointers
            tpart => part
            part => part2
            part2 => tpart
            call dtimer(dtime,itime,1)
            time = real(dtime)
            tsort = tsort + time
         endif
      endif
!
      if (ntime==0) then
         wt = we + wf + wm
         write (*,*) 'Initial Total Field, Kinetic and Total Energies:'
         write (*,'(3e14.7)') wt, wke, wke + wt
         write (*,*) 'Initial Electrostatic, Transverse Electric and Mag&
     &netic Field Energies:'
         write (*,'(3e14.7)') we, wf, wm
      endif
      ntime = ntime + 1
      go to 500
 2000 continue
!
! * * * end main iteration loop * * *
!
      write (*,*) 'ntime, relativity = ', ntime, relativity
      wt = we + wf + wm
      write (*,*) 'Final Total Field, Kinetic and Total Energies:'
      write (*,'(3e14.7)') wt, wke, wke + wt
      write (*,*) 'Final Electrostatic, Transverse Electric and Magnetic&
     & Field Energies:'
      write (*,'(3e14.7)') we, wf, wm
!
      write (*,*)
      write (*,*) 'deposit time = ', tdpost
      write (*,*) 'current deposit time = ', tdjpost
      tdpost = tdpost + tdjpost
      write (*,*) 'total deposit time = ', tdpost
      write (*,*) 'guard time = ', tguard
      write (*,*) 'solver time = ', tfield
      write (*,*) 'fft time = ', tfft
      write (*,*) 'push time = ', tpush
      write (*,*) 'sort time = ', tsort
      tfield = tfield + tguard + tfft
      write (*,*) 'total solver time = ', tfield
      time = tdpost + tpush + tsort
      write (*,*) 'total particle time = ', time
      wt = time + tfield
      write (*,*) 'total time = ', wt
      write (*,*)
!
      wt = 1.0e+09/(real(nloop)*real(np))
      write (*,*) 'Push Time (nsec) = ', tpush*wt
      write (*,*) 'Deposit Time (nsec) = ', tdpost*wt
      write (*,*) 'Sort Time (nsec) = ', tsort*wt
      write (*,*) 'Total Particle Time (nsec) = ', time*wt
!
      stop
      end program


!--------------------------------------------------------------------------------
! Copyright (c) 2018 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and avhttps://gcc.gnu.org/onlinedocs/gfortran/SQRT.htmlailable as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!------------------------------------------------------------------------------
! This routine calculates the magnetic moments and the corresponding directions
! (angles) according to the Atoms in the system.
!
!
! Robin Hilgers, Nov '19
! Modified for usability with the potential matrix; A. Neukirchen, Dec '19

MODULE m_magnMomFromDen

IMPLICIT NONE

CONTAINS
SUBROUTINE magnMomFromDen(input,atoms,noco,den,moments,theta_mt_avg,phi_mt_avg)
   USE m_constants
   USE m_types
   USE m_types_fleurinput
   USE m_intgr
   USE m_juDFT
   USE m_polangle
   USE m_constants

   TYPE(t_input), INTENT(IN)     ::  input
   TYPE(t_atoms), INTENT(IN)     ::  atoms
   TYPE(t_noco), INTENT(IN)      ::  noco
   TYPE(t_potden),INTENT(IN)     ::  den
   REAL, INTENT(OUT)             ::  moments(3,atoms%ntype)
   REAL,INTENT(OUT)              :: theta_mt_avg(atoms%ntype)
   REAL,INTENT(OUT)              :: phi_mt_avg(atoms%ntype)

   INTEGER                       ::  jsp,i,j,ir
   REAL                          ::  mx,my,mz

   TYPE(t_potden)                ::  denloc
   REAL, ALLOCATABLE             ::  dummyResults(:,:)

  ALLOCATE(dummyResults(SIZE(den%mt,3),SIZE(den%mt,4)))

  IF(noco%l_mtNocoPot) THEN
     jsp=4
  ELSE
     jsp=input%jspins
  END IF
!!Loop over Spins and Atoms
   DO i=1, atoms%ntype
      DO j=1, jsp
!!Integration over r
           IF (den%potdenType<=1000) THEN
              CALL denloc%copyPotDen(den)
              DO ir=1, atoms%jri(i)
                 denloc%mt(ir,:,i,j)=den%mt(ir,:,i,j)*atoms%rmsh(ir,i)**2
              END DO
           ELSE
              CALL denloc%copyPotDen(den)
           END IF
           CALL intgr3(denloc%mt(:,0,i,j), atoms%rmsh(:,i),atoms%dx(i),atoms%jri(i),dummyResults(i,j))
!!Considering Lattice harmonics integral (Only L=0 component does not vanish and has a factor of sqrt(4*Pi))
          dummyResults(i,j)=dummyResults(i,j)*sfp_const
      END DO
   END DO
!!Assign results
   DO i=1 , atoms%ntype
   IF (noco%l_mtNocoPot) THEN
      moments(1:2,i)=2*dummyResults(i,3:4)
   END IF
      moments(3,i)=dummyResults(i,1)-dummyResults(i,2)
   END DO

DEALLOCATE(dummyResults)

IF (den%potdenType<=1000) THEN
   moments=moments/2
ELSE
   moments(2,:)=-moments(2,:)
END IF

!!Calculation of Angles
   DO i=1 , atoms%ntype
      mx=moments(1,i)
      my=moments(2,i)
      mz=moments(3,i)
      IF (den%potdenType>1000) THEN
         CALL pol_angle(mx,my,mz,theta_mt_avg(i),phi_mt_avg(i))
      END IF
   ENDDO

END SUBROUTINE magnMomFromDen
END MODULE m_magnMomFromDen


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1994  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  function erf  --  evaluate the standard error function  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "erf" computes a numerical approximation to the value of
c     the error function via a Chebyshev approximation
c
c
      function erf (x)
      implicit none
      integer mode
      real*8 erf,x
      real*8 result
c
c
c     compute the error function via Chebyshev fitting
c
      mode = 0
      call erfcore (x,result,mode)
      erf = result
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function erfc  --  evaluate complementary error function  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "erfc" computes a numerical approximation to the value of the
c     complementary error function via a Chebyshev approximation
c
c
      function erfc (x)
      implicit none
      integer mode
      real*8 erfc,x
      real*8 result
c
c
c     get the complementary error function via Chebyshev fitting
c
      mode = 1
      call erfcore (x,result,mode)
      erfc = result
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine erfcore  --  erf and erfc via Chebyshev approx  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "erfcore" evaluates erf(x) or erfc(x) for a real argument x;
c     when called with mode set to 0 it returns erf, a mode of 1
c     returns erfc; uses rational functions that approximate erf(x)
c     and erfc(x) to at least 18 significant decimal digits
c
c     literature reference:
c
c     W. J. Cody, "Rational Chebyshev Approximations for the Error
c     Function", Mathematics of Computation, 631-638, 1969
c
c     adapted from an original program written by W. J. Cody,
c     Mathematics and Computer Science Division, Argonne National
c     Laboratory, Argonne, IL 60439
c
c     machine-dependent constants:
c
c     xtiny   argument below which erf(x) may be represented by
c             2*x/sqrt(pi) and above which x*x won't underflow;
c             a conservative value is the largest machine number
c             X such that 1.0 + X = 1.0 to machine precision
c
c     xbig    largest argument acceptable for erfc; solution to
c             the equation:  W(x) * (1-0.5/x**2) = XMIN, where
c             W(x) = exp(-x*x)/[x*sqrt(pi)]
c
c
      subroutine erfcore (arg,result,mode)
      implicit none
      integer i,mode
      real*8 arg,result
      real*8 x,y,ysq
      real*8 del,sqrpi
      real*8 xnum,xden
      real*8 xtiny,xbig
      real*8 a(5),b(4)
      real*8 c(9),d(8)
      real*8 p(6),q(5)
c
c     mathematical and machine-dependent constants
c
      data sqrpi  / 5.6418958354775628695d-1 /
      data xtiny  / 1.11d-16 /
      data xbig   / 26.543d0 /
c
c     coefficients for approximation to erf in first interval
c
      data a  / 3.16112374387056560d0,  1.13864154151050156d2,
     &          3.77485237685302021d2,  3.20937758913846947d3,
     &          1.85777706184603153d-1 /
      data b  / 2.36012909523441209d1,  2.44024637934444173d2,
     &          1.28261652607737228d3,  2.84423683343917062d3 /
c
c     coefficients for approximation to erfc in second interval
c
      data c  / 5.64188496988670089d-1, 8.88314979438837594d0,
     &          6.61191906371416295d1,  2.98635138197400131d2,
     &          8.81952221241769090d2,  1.71204761263407058d3,
     &          2.05107837782607147d3,  1.23033935479799725d3,
     &          2.15311535474403846d-8 /
      data d  / 1.57449261107098347d1,  1.17693950891312499d2,
     &          5.37181101862009858d2,  1.62138957456669019d3,
     &          3.29079923573345963d3,  4.36261909014324716d3,
     &          3.43936767414372164d3,  1.23033935480374942d3 /
c
c     coefficients for approximation to erfc in third interval
c
      data p  / 3.05326634961232344d-1, 3.60344899949804439d-1,
     &          1.25781726111229246d-1, 1.60837851487422766d-2,
     &          6.58749161529837803d-4, 1.63153871373020978d-2 /
      data q  / 2.56852019228982242d0,  1.87295284992346047d0,
     &          5.27905102951428412d-1, 6.05183413124413191d-2,
     &          2.33520497626869185d-3 /
c
c
c     store the argument and its absolute value
c
      x = arg
      y = abs(x)
c
c     evaluate error function for |x| less than 0.46875
c
      if (y .le. 0.46875d0) then
         ysq = 0.0d0
         if (y .gt. xtiny)  ysq = y * y
         xnum = a(5) * ysq
         xden = ysq
         do i = 1, 3
            xnum = (xnum + a(i)) * ysq
            xden = (xden + b(i)) * ysq
         end do
         result = x * (xnum + a(4)) / (xden + b(4))
         if (mode .ne. 0)  result = 1.0d0 - result
c
c     get complementary error function for 0.46875 <= |x| <= 4.0
c
      else if (y .le. 4.0d0) then
         xnum = c(9) * y
         xden = y
         do i = 1, 7
            xnum = (xnum + c(i)) * y
            xden = (xden + d(i)) * y
         end do
         result = (xnum + c(8)) / (xden + d(8))
         ysq = aint(16.0d0*y) / 16.0d0
         del = (y-ysq) * (y+ysq)
c        result = exp(-ysq*ysq) * exp(-del) * result
         result = exp(-ysq*ysq-del) * result
         if (mode .eq. 0) then
            result = 1.0d0 - result
            if (x .lt. 0.0d0)  result = -result
         else
            if (x .lt. 0.0d0)  result = 2.0d0 - result
         end if
c
c     get complementary error function for |x| greater than 4.0
c
      else
         result = 0.0d0
         if (y .lt. xbig) then
            ysq = 1.0d0 / (y * y)
            xnum = p(6) * ysq
            xden = ysq
            do i = 1, 4
               xnum = (xnum + p(i)) * ysq
               xden = (xden + q(i)) * ysq
            end do
            result = ysq * (xnum + p(5)) / (xden + q(5))
            result = (sqrpi - result) / y
            ysq = aint(16.0d0*y) / 16.0d0
            del = (y-ysq) * (y+ysq)
c           result = exp(-ysq*ysq) * exp(-del) * result
            result = exp(-ysq*ysq-del) * result
         end if
         if (mode .eq. 0) then
            result = 1.0d0 - result
            if (x .lt. 0.0d0)  result = -result
         else
            if (x .lt. 0.0d0)  result = 2.0d0 - result
         end if
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function erfinv  --  evaluate the error function inverse  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "erfinv" evaluates the inverse of the error function for
c     an argument in the range (-1,1) using a rational function
c     approximation followed by cycles of Newton-Raphson correction
c
c     adapted from the pseudocode for the Matlab function of the
c     same name; Matlab, version 4.2c, March 1995
c
c
      function erfinv (x)
      implicit none
      include 'iounit.i'
      include 'math.i'
      real*8 erfinv,erf
      real*8 x,y,z
      real*8 a(4),b(4)
      real*8 c(4),d(2)
      external erf
c
c     coefficients for approximation to erfinv in central range
c
      data a  /  0.886226899d0, -1.645349621d0,
     &           0.914624893d0, -0.140543331d0 /
      data b  / -2.118377725d0,  1.442710462d0,
     &          -0.329097515d0,  0.012229801d0 /
c
c     coefficients for approximation to erfinv near endpoints
c
      data c  / -1.970840454d0, -1.624906493d0,
     &           3.429567803d0,  1.641345311d0 /
      data d  /  3.543889200d0,  1.637067800d0 /
c
c
c     get an initial estimate for the inverse error function
c
      if (abs(x) .le. 0.7d0) then
         y = x * x
         z = x * (((a(4)*y+a(3))*y+a(2))*y+a(1))
     &              / ((((b(4)*y+b(3))*y+b(2))*y+b(1))*y+1.0d0)
      else if (x.gt.0.7d0 .and. x.lt.1.0d0) then
         y = sqrt(-log((1.0d0-x)/2.0d0))
         z = (((c(4)*y+c(3))*y+c(2))*y+c(1)) / ((d(2)*y+d(1))*y+1.0d0)
      else if (x.lt.-0.7d0 .and. x.gt.-1.0d0) then
         y = sqrt(-log((1.0d0+x)/2.0d0))
         z = -(((c(4)*y+c(3))*y+c(2))*y+c(1)) / ((d(2)*y+d(1))*y+1.0d0)
      else
         write (iout,10)
   10    format (/,' ERFINV  --  Illegal Argument to Inverse',
     &              ' Error Function')
         call fatal
      end if
c
c     use two steps of Newton-Raphson correction to increase accuracy
c
      z = z - (erf(z) - x) / (2.0d0/sqrtpi * exp(-z*z))
      z = z - (erf(z) - x) / (2.0d0/sqrtpi * exp(-z*z))
      erfinv = z
      return
      end


module mod_primitive_linearized_euler
    use mod_kinds,      only: rk, ik
    use mod_constants,  only: HALF, ONE, TWO, ZERO, PI
    implicit none

    !
    ! Azimuthal orther
    !
    integer(ik) :: mod_m = 0    ! Could get set by boundary conidtions
    integer(ik) :: mod_n = 1    ! Could get set by boundary conidtions

    !
    ! Nondimensionalization
    !
    real(rk), parameter :: u_r    = 1._rk
    real(rk), parameter :: rho_r  = 1._rk
    real(rk), parameter :: l_r    = 1._rk

    real(rk), parameter :: gam       = 1.4_rk
    !real(rk), parameter :: omega = 1432.945684_rk * TWO * PI
    real(rk), parameter :: omega     = 956._rk * TWO * PI
    real(rk), parameter :: thickness = 0.5_rk
    real(rk), parameter :: eps       = 2300_rk

    !
    ! Dimensional mean flow
    !
    real(rk), parameter :: rho_d = 1.225_rk
    real(rk), parameter :: u_d   = 0._rk
    real(rk), parameter :: v_d   = 0._rk
    real(rk), parameter :: w_d   = 0._rk
    real(rk), parameter :: p_d   = 101150.0_rk

!    !
!    ! Nondimensional mean flow
!    !
!    real(rk), parameter :: rho_c  = rho_d  * (l_r/(rho_r*u_r))
!    real(rk), parameter :: rhou_c = rhou_d * (l_r/(rho_r*u_r*u_r))
!    real(rk), parameter :: rhov_c = rhov_d * (l_r/(rho_r*u_r*u_r))
!    real(rk), parameter :: rhow_c = rhow_d * (l_r/(rho_r*u_r*u_r))
!    real(rk), parameter :: rhoE_c = rhoE_d * (l_r/(rho_r*u_r*u_r*u_r))

    !
    ! Mean primitives
    !
    real(rk), parameter :: rhobar = rho_d
    real(rk), parameter :: ubar   = u_d
    real(rk), parameter :: vbar   = v_d
    real(rk), parameter :: wbar   = w_d
    real(rk), parameter :: pbar   = p_d
    real(rk), parameter :: cbar   = sqrt(gam * pbar / rhobar)
    real(rk), parameter :: Mbar   = ubar/cbar

    !
    ! X-Matrix
    !
    real(rk), parameter :: rho_1_rho = ubar
    real(rk), parameter :: rho_1_u   = rhobar
    real(rk), parameter :: rho_1_v   = ZERO
    real(rk), parameter :: rho_1_w   = ZERO
    real(rk), parameter :: rho_1_p   = ZERO

    real(rk), parameter :: u_1_rho   = ZERO
    real(rk), parameter :: u_1_u     = ubar
    real(rk), parameter :: u_1_v     = ZERO
    real(rk), parameter :: u_1_w     = ZERO
    real(rk), parameter :: u_1_p     = ONE/rhobar

    real(rk), parameter :: v_1_rho   = ZERO
    real(rk), parameter :: v_1_u     = ZERO
    real(rk), parameter :: v_1_v     = ubar
    real(rk), parameter :: v_1_w     = ZERO
    real(rk), parameter :: v_1_p     = ZERO

    real(rk), parameter :: w_1_rho   = ZERO
    real(rk), parameter :: w_1_u     = ZERO
    real(rk), parameter :: w_1_v     = ZERO
    real(rk), parameter :: w_1_w     = ubar
    real(rk), parameter :: w_1_p     = ZERO

    real(rk), parameter :: p_1_rho   = ZERO
    real(rk), parameter :: p_1_u     = gam*pbar
    real(rk), parameter :: p_1_v     = ZERO
    real(rk), parameter :: p_1_w     = ZERO
    real(rk), parameter :: p_1_p     = ubar

    !
    ! Y-Matrix
    !
    real(rk), parameter :: rho_2_rho = vbar
    real(rk), parameter :: rho_2_u   = ZERO
    real(rk), parameter :: rho_2_v   = rhobar
    real(rk), parameter :: rho_2_w   = ZERO
    real(rk), parameter :: rho_2_p   = ZERO

    real(rk), parameter :: u_2_rho   = ZERO
    real(rk), parameter :: u_2_u     = vbar
    real(rk), parameter :: u_2_v     = ZERO
    real(rk), parameter :: u_2_w     = ZERO
    real(rk), parameter :: u_2_p     = ZERO

    real(rk), parameter :: v_2_rho   = ZERO
    real(rk), parameter :: v_2_u     = ZERO
    real(rk), parameter :: v_2_v     = vbar
    real(rk), parameter :: v_2_w     = ZERO
    real(rk), parameter :: v_2_p     = ONE/rhobar

    real(rk), parameter :: w_2_rho   = ZERO
    real(rk), parameter :: w_2_u     = ZERO
    real(rk), parameter :: w_2_v     = ZERO
    real(rk), parameter :: w_2_w     = vbar
    real(rk), parameter :: w_2_p     = ZERO

    real(rk), parameter :: p_2_rho   = ZERO
    real(rk), parameter :: p_2_u     = ZERO
    real(rk), parameter :: p_2_v     = gam*pbar
    real(rk), parameter :: p_2_w     = ZERO
    real(rk), parameter :: p_2_p     = vbar

    !
    ! Z-Matrix
    !
    real(rk), parameter :: rho_3_rho = wbar
    real(rk), parameter :: rho_3_u   = ZERO
    real(rk), parameter :: rho_3_v   = ZERO
    real(rk), parameter :: rho_3_w   = rhobar
    real(rk), parameter :: rho_3_p   = ZERO

    real(rk), parameter :: u_3_rho   = ZERO
    real(rk), parameter :: u_3_u     = wbar
    real(rk), parameter :: u_3_v     = ZERO
    real(rk), parameter :: u_3_w     = ZERO
    real(rk), parameter :: u_3_p     = ZERO

    real(rk), parameter :: v_3_rho   = ZERO
    real(rk), parameter :: v_3_u     = ZERO
    real(rk), parameter :: v_3_v     = wbar
    real(rk), parameter :: v_3_w     = ZERO
    real(rk), parameter :: v_3_p     = ZERO

    real(rk), parameter :: w_3_rho   = ZERO
    real(rk), parameter :: w_3_u     = ZERO
    real(rk), parameter :: w_3_v     = ZERO
    real(rk), parameter :: w_3_w     = wbar
    real(rk), parameter :: w_3_p     = ONE/rhobar

    real(rk), parameter :: p_3_rho   = ZERO
    real(rk), parameter :: p_3_u     = ZERO
    real(rk), parameter :: p_3_v     = ZERO
    real(rk), parameter :: p_3_w     = gam*pbar
    real(rk), parameter :: p_3_p     = wbar

contains

end module mod_primitive_linearized_euler


      subroutine runCY_00i1i2i3i4(k,l,i1,i2,i3,i4,Xtwiddle,Gtwiddle,
     . Shat6,N0)
      implicit none
C---  Expression for extension of Eq. 5.60c
C---  Calculates C00i1i2i3i4, requires C00li1i2i3
C---  Small terms of order Xtwiddle(0,k)*Ciiiii,Xtwiddle(0,0)*Ciiiiii
C---  Denominator Gtwiddle(k,l)
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,i1,i2,i3,i4,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat6(np,z5max,-2:0)

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

      do ep=-2,0
      Cv(czziiii(z4(i1,i2,i3,i4))+N0,ep)=
     .(-2d0*Gtwiddle(k,i1)*Cv(czziiii(z4(l,i2,i3,i4))+N0,ep)
     . -2d0*Gtwiddle(k,i2)*Cv(czziiii(z4(l,i1,i3,i4))+N0,ep)
     . -2d0*Gtwiddle(k,i3)*Cv(czziiii(z4(l,i1,i2,i4))+N0,ep)
     . -2d0*Gtwiddle(k,i4)*Cv(czziiii(z4(l,i1,i2,i3))+N0,ep)
     . +Gtwiddle(k,1)*Shat6(1,z5(l,i1,i2,i3,i4),ep)
     . +Gtwiddle(k,2)*Shat6(2,z5(l,i1,i2,i3,i4),ep)
     . +Xtwiddle(k,0)*Cv(ciiiii(z5(l,i1,i2,i3,i4))+N0,ep)
     . -Xtwiddle(0,0)*Cv(ciiiiii(z6(k,l,i1,i2,i3,i4))+N0,ep))
     . /(2d0*Gtwiddle(k,l))

      enddo

      return
      end


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1996  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine deflate  --  eigenvalues by method of deflation  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "deflate" uses the power method with deflation to compute the
c     few largest eigenvalues and eigenvectors of a symmetric matrix
c
c     n      dimension of the matrix to be diagonalized
c     nv     number of largest eigenvalues to be extracted
c     a      input with the matrix to be diagonalized; only
c               the lower triangle and diagonal are required
c     ev     returned with the eigenvalues in descending order
c     vec    returned with the eigenvectors of the matrix
c     work   local vector containing temporary work space
c
c
      subroutine deflate (n,nv,a,ev,vec)
      implicit none
      include 'iounit.i'
      integer i,j,k,n,nv
      integer iter,maxiter
      real*8 random,eps
      real*8 dot1,dot2,ratio
      real*8 ev(*)
      real*8, allocatable :: work(:)
      real*8 a(n,*)
      real*8 vec(n,*)
c
c
c     initialize number of iterations and convergence criteria
c
      maxiter = 500
      eps = 1.0d-6
c
c     use identity vector as initial guess for eigenvectors
c
      do j = 1, nv
         do i = 1, n
            vec(i,j) = 1.0d0
         end do
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (work(n))
c
c     find the few largest eigenvalues and eigenvectors
c
      do k = 1, nv
         ev(k) = 0.0d0
         dot1 = 0.0d0
         do i = 1, n
            work(i) = 0.0d0
            do j = 1, i-1
               work(i) = work(i) + a(i,j)*vec(j,k)
            end do
            do j = i, n
               work(i) = work(i) + a(j,i)*vec(j,k)
            end do
            dot1 = dot1 + work(i)**2
         end do
c
c     if in or near null space, use random guess as eigenvector
c
         if (dot1 .le. 100.0d0*eps*dble(n)) then
            do i = 1, n
               work(i) = random ()
            end do
         end if
c
c     find the current eigenvalue by iterating to convergence;
c     first multiply vector by matrix and compute dot products
c
         do iter = 1, maxiter
            dot1 = 0.0d0
            dot2 = 0.0d0
            do i = 1, n
               vec(i,k) = 0.0d0
               do j = 1, i-1
                  vec(i,k) = vec(i,k) + a(i,j)*work(j)
               end do
               do j = i, n
                  vec(i,k) = vec(i,k) + a(j,i)*work(j)
               end do
               dot1 = dot1 + vec(i,k)**2
               dot2 = dot2 + vec(i,k)*work(i)
            end do
c
c     normalize new eigenvector and substitute for old one
c
            ratio = abs((ev(k)-dot2) / dot2)
            ev(k) = dot2
            dot1 = sqrt(dot1)
            do i = 1, n
               vec(i,k) = vec(i,k) / dot1
               work(i) = vec(i,k)
            end do
            if (ratio .lt. eps)  goto 20
         end do
         write (iout,10)  k
   10    format (/,' DEFLATE  --  Eigenvalue',i3,' not Fully Converged')
c
c     eliminate the current eigenvalue from the matrix
c
   20    continue
         do i = 1, n
            do j = i, n
               a(j,i) = a(j,i) - ev(k)*vec(i,k)*vec(j,k)
            end do
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (work)
      return
      end


!##########################################################################
        subroutine eddyv_wale
!##########################################################################
        use vars
        use multidata
        implicit none
        integer :: i,j,k
        integer :: ib,is,ie,js,je,ks,ke
        double precision :: dudx,dudy,dudz,dvdx,dvdy,dvdz,dwdx,dwdy,dwdz
        double precision :: vr_a,vr_b,vr_c,vr_d
        double precision :: s12,s13,s23
        double precision :: s11d,s22d,s33d,s12d,s13d,s23d
        double precision :: ss,sdsd,eqnA,denom
        double precision :: rrey,h1,h2,h3,rh123
        double precision :: ufv_c,ufv_n1,ufv_n2
        double precision :: vfv_c,vfv_n1,vfv_n2
        double precision :: wfv_c,wfv_n1,wfv_n2
        double precision :: cw,delta_grid,l_s
        double precision :: dx,dy,dz
        integer :: sn
        character*8 :: chb1
        character*25 :: gf

        rrey=1.0/Re
        cw=0.46

        do ib=1,nbp

        delta_grid=(dom(ib)%dx*dom(ib)%dy*dom(ib)%dz)**(1.0/3.0)

        is=dom(ib)%isp; ie=dom(ib)%iep
        js=dom(ib)%jsp; je=dom(ib)%jep
        ks=dom(ib)%ksp; ke=dom(ib)%kep

        do k=ks,ke
           do j=js,je
              do i=is,ie

!====================================================
        vr_a = 0.25*( dom(ib)%u(i,j,k)   + dom(ib)%u(i-1,j,k) +
     &	 	      dom(ib)%u(i,j+1,k) + dom(ib)%u(i-1,j+1,k) )
        vr_b = 0.25*( dom(ib)%u(i,j,k)   + dom(ib)%u(i-1,j,k) +
     &	 	      dom(ib)%u(i,j-1,k) + dom(ib)%u(i-1,j-1,k) )

        vr_c = 0.25*( dom(ib)%u(i,j,k)   + dom(ib)%u(i-1,j,k) +
     &	 	      dom(ib)%u(i,j,k+1) + dom(ib)%u(i-1,j,k+1) )
        vr_d = 0.25*( dom(ib)%u(i,j,k)   + dom(ib)%u(i-1,j,k) +
     &	 	      dom(ib)%u(i,j,k-1) + dom(ib)%u(i-1,j,k-1) )

        dudx = ( dom(ib)%u(i,j,k) - dom(ib)%u(i-1,j,k) )/dom(ib)%dx
        dudy = ( vr_a - vr_b )/dom(ib)%dy
        dudz = ( vr_c - vr_d )/dom(ib)%dz
!====================================================
        vr_a = 0.25*( dom(ib)%v(i,j,k)   + dom(ib)%v(i,j-1,k) +
     &	 	      dom(ib)%v(i+1,j,k) + dom(ib)%v(i+1,j-1,k) )
        vr_b = 0.25*( dom(ib)%v(i,j,k)   + dom(ib)%v(i,j-1,k) +
     &	 	      dom(ib)%v(i-1,j,k) + dom(ib)%v(i-1,j-1,k) )

        vr_c = 0.25*( dom(ib)%v(i,j,k)   + dom(ib)%v(i,j-1,k) +
     &	 	      dom(ib)%v(i,j,k+1) + dom(ib)%v(i,j-1,k+1) )
        vr_d = 0.25*( dom(ib)%v(i,j,k)   + dom(ib)%v(i,j-1,k) +
     &	 	      dom(ib)%v(i,j,k-1) + dom(ib)%v(i,j-1,k-1) )

        dvdy = ( dom(ib)%v(i,j,k) - dom(ib)%v(i,j-1,k) )/dom(ib)%dy
        dvdx = ( vr_a - vr_b )/dom(ib)%dx
        dvdz = ( vr_c - vr_d )/dom(ib)%dz
!====================================================
        vr_a = 0.25*( dom(ib)%w(i,j,k)   + dom(ib)%w(i,j,k-1) +
     &	 	      dom(ib)%w(i+1,j,k) + dom(ib)%w(i+1,j,k-1) )
        vr_b = 0.25*( dom(ib)%w(i,j,k)   + dom(ib)%w(i,j,k-1) +
     &	 	      dom(ib)%w(i-1,j,k) + dom(ib)%w(i-1,j,k-1) )

        vr_c = 0.25*( dom(ib)%w(i,j,k)   + dom(ib)%w(i,j,k-1) +
     &	 	      dom(ib)%w(i,j+1,k) + dom(ib)%w(i,j+1,k-1) )
        vr_d = 0.25*( dom(ib)%w(i,j,k)   + dom(ib)%w(i,j,k-1) +
     &	 	      dom(ib)%w(i,j-1,k) + dom(ib)%w(i,j-1,k-1) )

        dwdz = ( dom(ib)%w(i,j,k) - dom(ib)%w(i,j,k-1) )/dom(ib)%dz
        dwdx = ( vr_a - vr_b )/dom(ib)%dx
        dwdy = ( vr_c - vr_d )/dom(ib)%dy

!==========================================================================
! ..... WALL BOUNDARIES
!==========================================================================
        if (i.eq.dom(ib)%isp) then
           if (dom(ib)%iprev.lt.0) then
		if (dom(ib)%bc_west.ge.61 .or. dom(ib)%bc_west.eq.4) then

              h1=dom(ib)%dx; h2=2.0*dom(ib)%dx; h3=dom(ib)%dx
              rh123=1.0/(h1*h2*h3)

              ufv_c =0.5*( dom(ib)%u(i,j,k)  +dom(ib)%u(i-1,j,k  ) )
              ufv_n1=0.5*( dom(ib)%u(i+1,j,k)+dom(ib)%u(i,j,k) )
              ufv_n2=0.5*( dom(ib)%u(i+2,j,k)+dom(ib)%u(i+1,j,k) )

              vfv_c =0.5*( dom(ib)%v(i,j,k)  +dom(ib)%v(i,j-1,k) )
              vfv_n1=0.5*( dom(ib)%v(i+1,j,k)+dom(ib)%v(i+1,j-1,k) )
              vfv_n2=0.5*( dom(ib)%v(i+2,j,k)+dom(ib)%v(i+2,j-1,k) )

              wfv_c =0.5*( dom(ib)%w(i,j,k)  +dom(ib)%w(i,j,k-1) )
              wfv_n1=0.5*( dom(ib)%w(i+1,j,k)+dom(ib)%w(i+1,j,k-1) )
              wfv_n2=0.5*( dom(ib)%w(i+2,j,k)+dom(ib)%w(i+2,j,k-1) )

              dudx=(h2*h2*(ufv_n1-ufv_c)+h1*h1*(ufv_c-ufv_n2))*rh123
              dvdx=(h2*h2*(vfv_n1-vfv_c)+h1*h1*(vfv_c-vfv_n2))*rh123
              dwdx=(h2*h2*(wfv_n1-wfv_c)+h1*h1*(wfv_c-wfv_n2))*rh123
		endif
           end if
        end if

        if (i.eq.dom(ib)%iep) then
           if (dom(ib)%inext.lt.0) then
		if (dom(ib)%bc_east.ge.61 .or. dom(ib)%bc_east.eq.4) then

              h1=dom(ib)%dx; h2=2.0*dom(ib)%dx; h3=dom(ib)%dx
              rh123=-1.0/(h1*h2*h3)

              ufv_c =0.5*( dom(ib)%u(i,j,k)  +dom(ib)%u(i-1,j,k  ) )
              ufv_n1=0.5*( dom(ib)%u(i-1,j,k)+dom(ib)%u(i-2,j,k) )
              ufv_n2=0.5*( dom(ib)%u(i-2,j,k)+dom(ib)%u(i-3,j,k) )

              vfv_c =0.5*( dom(ib)%v(i,j,k)  +dom(ib)%v(i,j-1,k) )
              vfv_n1=0.5*( dom(ib)%v(i-1,j,k)+dom(ib)%v(i-1,j-1,k) )
              vfv_n2=0.5*( dom(ib)%v(i-2,j,k)+dom(ib)%v(i-2,j-1,k) )

              wfv_c =0.5*( dom(ib)%w(i,j,k)  +dom(ib)%w(i,j,k-1) )
              wfv_n1=0.5*( dom(ib)%w(i-1,j,k)+dom(ib)%w(i-1,j,k-1) )
              wfv_n2=0.5*( dom(ib)%w(i-2,j,k)+dom(ib)%w(i-2,j,k-1) )

              dudx=(h2*h2*(ufv_n1-ufv_c)+h1*h1*(ufv_c-ufv_n2))*rh123
              dvdx=(h2*h2*(vfv_n1-vfv_c)+h1*h1*(vfv_c-vfv_n2))*rh123
              dwdx=(h2*h2*(wfv_n1-wfv_c)+h1*h1*(wfv_c-wfv_n2))*rh123
		endif
           end if
        end if

        if (j.eq.dom(ib)%jsp) then
           if (dom(ib)%jprev.lt.0) then
		if (dom(ib)%bc_south.ge.61 .or. dom(ib)%bc_south.eq.4) then

              h1=dom(ib)%dy; h2=2.0*dom(ib)%dy; h3=dom(ib)%dy
              rh123=1.0/(h1*h2*h3)

              ufv_c =0.5*( dom(ib)%u(i,j,k)  +dom(ib)%u(i-1,j,k  ) )
              ufv_n1=0.5*( dom(ib)%u(i,j+1,k)+dom(ib)%u(i-1,j+1,k) )
              ufv_n2=0.5*( dom(ib)%u(i,j+2,k)+dom(ib)%u(i-1,j+2,k) )

              vfv_c =0.5*( dom(ib)%v(i,j,k)  +dom(ib)%v(i,j-1,k  ) )
              vfv_n1=0.5*( dom(ib)%v(i,j+1,k)+dom(ib)%v(i,j,k) )
              vfv_n2=0.5*( dom(ib)%v(i,j+2,k)+dom(ib)%v(i,j+1,k) )

              wfv_c =0.5*( dom(ib)%w(i,j,k)  +dom(ib)%w(i,j,k-1) )
              wfv_n1=0.5*( dom(ib)%w(i,j+1,k)+dom(ib)%w(i,j+1,k-1) )
              wfv_n2=0.5*( dom(ib)%w(i,j+2,k)+dom(ib)%w(i,j+2,k-1) )

              dudy=(h2*h2*(ufv_n1-ufv_c)+h1*h1*(ufv_c-ufv_n2))*rh123
              dvdy=(h2*h2*(vfv_n1-vfv_c)+h1*h1*(vfv_c-vfv_n2))*rh123
              dwdy=(h2*h2*(wfv_n1-wfv_c)+h1*h1*(wfv_c-wfv_n2))*rh123
		endif
           end if
        end if

        if (j.eq.dom(ib)%jep) then
           if (dom(ib)%jnext.lt.0) then
		if (dom(ib)%bc_north.ge.61 .or. dom(ib)%bc_north.eq.4) then

              h1=dom(ib)%dy; h2=2.0*dom(ib)%dy; h3=dom(ib)%dy
              rh123=-1.0/(h1*h2*h3)

              ufv_c =0.5*( dom(ib)%u(i,j,k)  +dom(ib)%u(i-1,j,k  ) )
              ufv_n1=0.5*( dom(ib)%u(i,j-1,k)+dom(ib)%u(i-1,j-1,k) )
              ufv_n2=0.5*( dom(ib)%u(i,j-2,k)+dom(ib)%u(i-1,j-2,k) )

              vfv_c =0.5*( dom(ib)%v(i,j,k)  +dom(ib)%v(i,j-1,k  ) )
              vfv_n1=0.5*( dom(ib)%v(i,j-1,k)+dom(ib)%v(i,j-2,k) )
              vfv_n2=0.5*( dom(ib)%v(i,j-2,k)+dom(ib)%v(i,j-3,k) )

              wfv_c =0.5*( dom(ib)%w(i,j,k)  +dom(ib)%w(i,j,k-1) )
              wfv_n1=0.5*( dom(ib)%w(i,j-1,k)+dom(ib)%w(i,j-1,k-1) )
              wfv_n2=0.5*( dom(ib)%w(i,j-2,k)+dom(ib)%w(i,j-2,k-1) )

              dudy=(h2*h2*(ufv_n1-ufv_c)+h1*h1*(ufv_c-ufv_n2))*rh123
              dvdy=(h2*h2*(vfv_n1-vfv_c)+h1*h1*(vfv_c-vfv_n2))*rh123
              dwdy=(h2*h2*(wfv_n1-wfv_c)+h1*h1*(wfv_c-wfv_n2))*rh123
		endif
           end if
        end if

        if (k.eq.dom(ib)%ksp) then
           if (dom(ib)%kprev.lt.0) then
		if (dom(ib)%bc_bottom.ge.61 .or. dom(ib)%bc_bottom.eq.4) then

              h1=dom(ib)%dz; h2=2.0*dom(ib)%dz; h3=dom(ib)%dz
              rh123=1.0/(h1*h2*h3)

              ufv_c =0.5*( dom(ib)%u(i,j,k)  +dom(ib)%u(i-1,j,k) )
              ufv_n1=0.5*( dom(ib)%u(i,j,k+1)+dom(ib)%u(i-1,j,k+1) )
              ufv_n2=0.5*( dom(ib)%u(i,j,k+2)+dom(ib)%u(i-1,j,k+2) )

              vfv_c =0.5*( dom(ib)%v(i,j,k)  +dom(ib)%v(i,j-1,k) )
              vfv_n1=0.5*( dom(ib)%v(i,j,k+1)+dom(ib)%v(i,j-1,k+1) )
              vfv_n2=0.5*( dom(ib)%v(i,j,k+2)+dom(ib)%v(i,j-1,k+2) )

              wfv_c =0.5*( dom(ib)%w(i,j,k)  +dom(ib)%w(i,j,k-1) )
              wfv_n1=0.5*( dom(ib)%w(i,j,k+1)+dom(ib)%w(i,j,k) )
              wfv_n2=0.5*( dom(ib)%w(i,j,k+2)+dom(ib)%w(i,j,k+1) )

              dudz=(h2*h2*(ufv_n1-ufv_c)+h1*h1*(ufv_c-ufv_n2))*rh123
              dvdz=(h2*h2*(vfv_n1-vfv_c)+h1*h1*(vfv_c-vfv_n2))*rh123
              dwdz=(h2*h2*(wfv_n1-wfv_c)+h1*h1*(wfv_c-wfv_n2))*rh123
		endif
           end if
        end if

        if (k.eq.dom(ib)%kep) then
           if (dom(ib)%knext.lt.0) then
		if (dom(ib)%bc_top.ge.61 .or. dom(ib)%bc_top.eq.4) then

              h1=dom(ib)%dz; h2=2.0*dom(ib)%dz; h3=dom(ib)%dz
              rh123=-1.0/(h1*h2*h3)

              ufv_c =0.5*( dom(ib)%u(i,j,k)  +dom(ib)%u(i-1,j,k) )
              ufv_n1=0.5*( dom(ib)%u(i,j,k-1)+dom(ib)%u(i-1,j,k-1) )
              ufv_n2=0.5*( dom(ib)%u(i,j,k-2)+dom(ib)%u(i-1,j,k-2) )

              vfv_c =0.5*( dom(ib)%v(i,j,k)  +dom(ib)%v(i,j-1,k) )
              vfv_n1=0.5*( dom(ib)%v(i,j,k-1)+dom(ib)%v(i,j-1,k-1) )
              vfv_n2=0.5*( dom(ib)%v(i,j,k-2)+dom(ib)%v(i,j-1,k-2) )

              wfv_c =0.5*( dom(ib)%w(i,j,k)  +dom(ib)%w(i,j,k-1) )
              wfv_n1=0.5*( dom(ib)%w(i,j,k-1)+dom(ib)%w(i,j,k-2) )
              wfv_n2=0.5*( dom(ib)%w(i,j,k-2)+dom(ib)%w(i,j,k-3) )

              dudz=(h2*h2*(ufv_n1-ufv_c)+h1*h1*(ufv_c-ufv_n2))*rh123
              dvdz=(h2*h2*(vfv_n1-vfv_c)+h1*h1*(vfv_c-vfv_n2))*rh123
              dwdz=(h2*h2*(wfv_n1-wfv_c)+h1*h1*(wfv_c-wfv_n2))*rh123
		endif
           end if
        end if

!==========================================================================
! ..... EDDY VISCOSITY CALCULATION
!==========================================================================
        l_s  = (cw * delta_grid)**2.0

        s12 = 0.5 * (dudy + dvdx)

        s13 = 0.5 * (dudz + dwdx)

        s23 = 0.5 * (dvdz + dwdy)

        ss  = ( dudx*dudx + dvdy*dvdy   + dwdz*dwdz  +
     &      2.0*s12*s12   + 2.0*s13*s13 + 2.0*s23*s23 )

        eqnA=dudx*dudx+dvdy*dvdy+dwdz*dwdz+
     & 2.0*dudy*dvdx+2.0*dudz*dwdx+2.0*dvdz*dwdy

        s11d = dudx*dudx+dudy*dvdx+dudz*dwdx-eqnA/3.0

        s22d = dvdx*dudy+dvdy*dvdy+dvdz*dwdy-eqnA/3.0

        s33d = dwdx*dudz+dwdy*dvdz+dwdz*dwdz-eqnA/3.0

        s12d =0.5*( dudx*dudy+dudy*dvdy+dudz*dwdy+
     &              dvdx*dudx+dvdy*dvdx+dvdz*dwdx)

        s13d =0.5*( dudx*dudz+dudy*dvdz+dudz*dwdz+
     &              dwdx*dudx+dwdy*dvdx+dwdz*dwdx)

        s23d =0.5*( dvdx*dudz+dvdy*dvdz+dvdz*dwdz+
     &              dwdx*dudy+dwdy*dvdy+dwdz*dwdy)

        sdsd = ( s11d*s11d +     s22d*s22d +     s33d*s33d  +
     &       2.0*s12d*s12d + 2.0*s13d*s13d + 2.0*s23d*s23d  )

        if (L_LSM) rrey=dom(ib)%mu(i,j,k)/dom(ib)%dens(i,j,k)

        if(sdsd.ne.0.0) then
           denom=(ss**2.5+sdsd**1.25)
           if (denom.eq.0.0) then
			!print*,'error, denominator is zero!'
           		dom(ib)%vis(i,j,k) = rrey
	     endif
           dom(ib)%vis(i,j,k) = rrey + l_s * sdsd**1.5 / denom
        else
           dom(ib)%vis(i,j,k) = rrey
        end if

              end do
           end do
        end do

        end do

!        call exchange(7)

        do ib=1,nbp

        is=dom(ib)%isp; ie=dom(ib)%iep
        js=dom(ib)%jsp; je=dom(ib)%jep
        ks=dom(ib)%ksp; ke=dom(ib)%kep

           dx=dom(ib)%dx
           dy=dom(ib)%dy
           dz=dom(ib)%dz

!..........................................................................
!=== West ===> ..  4=wall  ..   1=Inlet
!..........................................................................
        if (dom(ib)%iprev.lt.0) then
           if (dom(ib)%bc_west.eq.4) then
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    dom(ib)%vis(is,j,k)= rrey
                    dom(ib)%vis(is-1,j,k)= dom(ib)%vis(is,j,k)
                 end do
              end do
           else if (dom(ib)%bc_west.eq.1) then
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    dom(ib)%vis(is-1,j,k)= dom(ib)%vis(is,j,k)
                 end do
              end do
           else if (dom(ib)%bc_west.ge.63) then
	     call wall_function(1,dom(ib)%bc_west)
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    !dom(ib)%vis(is,j,k)= dom(ib)%tauww2(j,k)*dx		!m2/s
                    dom(ib)%vis(is-1,j,k)= dom(ib)%vis(is,j,k)
                 end do
              end do
           else if (dom(ib)%bc_west.eq.61.or.dom(ib)%bc_west.eq.62) then
	     call log_law(1,dom(ib)%bc_west)
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    !dom(ib)%vis(is,j,k)= dom(ib)%tauww2(j,k)*dx		!m2/s
                    dom(ib)%vis(is-1,j,k)= dom(ib)%vis(is,j,k)
                 end do
              end do
           else
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    dom(ib)%vis(is-1,j,k)= dom(ib)%vis(is,j,k)
                 end do
              end do
           end if
        else
           do k=ks-1,ke+1
              do j=js-1,je+1
                 dom(ib)%vis(is-1,j,k)= dom(ib)%vis(is,j,k)
              end do
           end do
        end if
!..........................................................................
!=== East ===> ..  4=wall  ..   2=Outflow
!..........................................................................
        if (dom(ib)%inext.lt.0) then
           if (dom(ib)%bc_east.eq.4) then
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    dom(ib)%vis(ie,j,k)= rrey
                    dom(ib)%vis(ie+1,j,k)= dom(ib)%vis(ie,j,k)
                 end do
              end do
           else if (dom(ib)%bc_east.eq.2) then
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    dom(ib)%vis(ie+1,j,k)= dom(ib)%vis(ie,j,k)
                 end do
              end do
           else if (dom(ib)%bc_east.ge.63) then
	     call wall_function(2,dom(ib)%bc_east)
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    !dom(ib)%vis(ie,j,k)= dom(ib)%tauwe2(j,k)*dx		!m2/s
                    dom(ib)%vis(ie+1,j,k)= dom(ib)%vis(ie,j,k)
                 end do
              end do
           else if (dom(ib)%bc_east.eq.61.or.dom(ib)%bc_east.eq.62) then
	     call log_law(2,dom(ib)%bc_east)
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    !dom(ib)%vis(ie,j,k)= dom(ib)%tauwe2(j,k)*dx		!m2/s
                    dom(ib)%vis(ie+1,j,k)= dom(ib)%vis(ie,j,k)
                 end do
              end do
           else
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    dom(ib)%vis(ie+1,j,k)= dom(ib)%vis(ie,j,k)
                 end do
              end do
           end if
        else
           do k=ks-1,ke+1
              do j=js-1,je+1
                 dom(ib)%vis(ie+1,j,k)= dom(ib)%vis(ie,j,k)
              end do
           end do
        end if
!..........................................................................
!=== South ===> ..   4=wall ..   3=Symmetry
!..........................................................................
        if (dom(ib)%jprev.lt.0) then
           if (dom(ib)%bc_south.eq.4) then
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,js,k)= rrey
                    dom(ib)%vis(i,js-1,k)= dom(ib)%vis(i,js,k)
                 end do
              end do
           else if (dom(ib)%bc_south.ge.63) then
	     call wall_function(3,dom(ib)%bc_south)
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                   ! dom(ib)%vis(i,js,k)= dom(ib)%tauws2(i,k)*dy		!m2/s
                    dom(ib)%vis(i,js-1,k)= dom(ib)%vis(i,js,k)
                 end do
              end do
           else if(dom(ib)%bc_south.eq.61.or.dom(ib)%bc_south.eq.62)then
	     call log_law(3,dom(ib)%bc_south)
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                    !dom(ib)%vis(i,js,k)= dom(ib)%tauws2(i,k)*dy		!m2/s
                    dom(ib)%vis(i,js-1,k)= dom(ib)%vis(i,js,k)
                 end do
              end do
           else
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,js-1,k)= dom(ib)%vis(i,js,k)
                 end do
              end do
           end if
        else
           do k=ks-1,ke+1
              do i=is-1,ie+1
                 dom(ib)%vis(i,js-1,k)= dom(ib)%vis(i,js,k)
              end do
           end do
        end if
!..........................................................................
!=== North ===>  ..   4=wall ..   44=moving wall ..  3=Symmetry
!..........................................................................
        if (dom(ib)%jnext.lt.0) then
           if (dom(ib)%bc_north.eq.4) then
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,je,k) = rrey
                    dom(ib)%vis(i,je+1,k) =  dom(ib)%vis(i,je,k)
                 end do
              end do
           else if (dom(ib)%bc_north.eq.3) then
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,je+1,k) =  dom(ib)%vis(i,je,k)
                 end do
              end do
           else if (dom(ib)%bc_north.ge.63) then
	     call wall_function(4,dom(ib)%bc_north)
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                   ! dom(ib)%vis(i,je,k)= dom(ib)%tauwn2(i,k)*dy		!m2/s
                    dom(ib)%vis(i,je+1,k) =  dom(ib)%vis(i,je,k)
                 end do
              end do
           else if(dom(ib)%bc_north.eq.61.or.dom(ib)%bc_north.eq.62)then
	     call log_law(4,dom(ib)%bc_north)
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                  !  dom(ib)%vis(i,je,k)= dom(ib)%tauwn2(i,k)*dy		!m2/s
                    dom(ib)%vis(i,je+1,k) =  dom(ib)%vis(i,je,k)
                 end do
              end do
           else
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,je+1,k) =  dom(ib)%vis(i,je,k)
                 end do
              end do
           end if
        else
           do k=ks-1,ke+1
              do i=is-1,ie+1
                 dom(ib)%vis(i,je+1,k) =  dom(ib)%vis(i,je,k)
              end do
           end do
        end if
!..........................................................................
!=== Bottom ===> ..   4=wall ..   3=Symmetry
!..........................................................................
        if (dom(ib)%kprev.lt.0) then
           if (dom(ib)%bc_bottom.eq.4) then
              do j=js-1,je+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,j,ks)= rrey
                    dom(ib)%vis(i,j,ks-1)= dom(ib)%vis(i,j,ks)
                 end do
              end do
           else if (dom(ib)%bc_bottom.eq.3) then
              do j=js-1,je+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,j,ks-1)= dom(ib)%vis(i,j,ks)
                 end do
              end do
           else if (dom(ib)%bc_bottom.ge.63) then
	     call wall_function(5,dom(ib)%bc_bottom)
              do j=js-1,je+1
                 do i=is-1,ie+1
                   ! dom(ib)%vis(i,j,ks)= dom(ib)%tauwb2(i,j)*dz
                    dom(ib)%vis(i,j,ks-1)= dom(ib)%vis(i,j,ks)
                 end do
              end do
           else if(dom(ib)%bc_bottom.eq.61.or.
     &					dom(ib)%bc_bottom.eq.62)then
	     call log_law(5,dom(ib)%bc_bottom)
              do j=js-1,je+1
                 do i=is-1,ie+1
                  !  dom(ib)%vis(i,j,ks)= dom(ib)%tauwb2(i,j)*dz
                    dom(ib)%vis(i,j,ks-1)= dom(ib)%vis(i,j,ks)
                 end do
              end do
           else
              do j=js-1,je+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,j,ks-1)= dom(ib)%vis(i,j,ks)
                 end do
              end do
           end if
        else
           do j=js-1,je+1
              do i=is-1,ie+1
                 dom(ib)%vis(i,j,ks-1)= dom(ib)%vis(i,j,ks)
              end do
           end do
        end if
!..........................................................................
!=== Top ===>  ..   4=wall ..     3=Symmetry
!..........................................................................
        if (dom(ib)%knext.lt.0) then
           if (dom(ib)%bc_top.eq.4) then
              do j=js-1,je+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,j,ke)   = rrey
                    dom(ib)%vis(i,j,ke+1)   = dom(ib)%vis(i,j,ke)
                 end do
              end do
           else if (dom(ib)%bc_top.eq.3) then
              do j=js-1,je+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,j,ke+1)   = dom(ib)%vis(i,j,ke)
                 end do
              end do
           else if (dom(ib)%bc_top.ge.63) then
	     call wall_function(6,dom(ib)%bc_top)
              do j=js-1,je+1
                 do i=is-1,ie+1
                   ! dom(ib)%vis(i,j,ke)= dom(ib)%tauwt2(i,j)*dz
                    dom(ib)%vis(i,j,ke+1)   = dom(ib)%vis(i,j,ke)
                 end do
              end do
           else if(dom(ib)%bc_top.eq.61.or.
     &					dom(ib)%bc_top.eq.62)then
	     call log_law(6,dom(ib)%bc_top)
              do j=js-1,je+1
                 do i=is-1,ie+1
                   ! dom(ib)%vis(i,j,ke)   = dom(ib)%tauwt2(i,j)*dz
                    dom(ib)%vis(i,j,ke+1)   = dom(ib)%vis(i,j,ke)
                 end do
              end do
           else
              do j=js-1,je+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,j,ke+1)   = dom(ib)%vis(i,j,ke)
                 end do
              end do
           end if
        else
           do j=js-1,je+1
              do i=is-1,ie+1
                 dom(ib)%vis(i,j,ke+1)   = dom(ib)%vis(i,j,ke)
              end do
           end do
        end if

        end do

        return
        end subroutine eddyv_wale
!##########################################################################


module spectral

use parameters
use constants
use generic
use sta2dfft

 !Declarations:
implicit double precision(a-h,o-z)
implicit integer(i-n)

 !Maximum x wavenumber:
integer,parameter:: nwx=nx/2,nwxm1=nwx-1,nwxp1=nwx+1

 !Common arrays, constants:
double precision:: yg(0:ny),pbar(0:ny),bety(0:ny)
double precision:: decy1(nym1,0:nxm1),decy2(nym1,0:nxm1)
double precision:: yh0(0:ny),yh1(0:ny)
double precision:: pftop1(0:ny),pfbot1(0:ny),uftop1(0:ny),ufbot1(0:ny)
double precision:: pftop2(0:ny),pfbot2(0:ny),uftop2(0:ny),ufbot2(0:ny)
double precision:: qgop1(0:nxm1,0:ny),qgop2(0:nxm1,0:ny)
double precision:: rkx(0:nxm1),hrkx(nx),rky(ny)
double precision:: facp1,facu1

double precision:: xtrig(2*nx),ytrig(2*ny)
integer:: xfactors(5),yfactors(5)

double precision:: frkx(0:nxm1),frky(ny)
double precision:: spmf(0:max(nx,ny)),alk(max(nx,ny))
integer:: kmag(0:nxm1,0:ny),kmax,kmaxred

!========================================================================!
! From main code: call init_invert                   to initialise       !
! then            call main_invert(qq,fhb,uu,vv,pp)  to perform inversion!
!========================================================================!

contains

!===========================
subroutine init_spectral

 !Declarations:
implicit double precision(a-h,o-z)
implicit integer(i-n)

double precision:: ld

!---------------------------------------------------------------------
 !Set up FFTs:
call init2dfft(nx,ny,ellx,elly,xfactors,yfactors,xtrig,ytrig,hrkx,rky)

 !Fractional y grid values:
fac=one/dble(ny)
do iy=0,ny
  yh1(iy)=fac*dble(iy)
  yh0(iy)=one-yh1(iy)
enddo

 !Define part of streamfunction proportional to the mean vorticity
 !as well as beta*y:
do iy=0,ny
  yg(iy)=ymin+gly*dble(iy)
  pbar(iy)=f12*(yg(iy)-ymin)*(yg(iy)-ymax)
  bety(iy)=beta*yg(iy)
enddo

 !Define x wavenumbers:
rkx(0)=zero
do kx=1,nwxm1
  kxc=nx-kx
  rkx(kx )=hrkx(2*kx)
  rkx(kxc)=hrkx(2*kx)
enddo
rkx(nwx)=hrkx(nx)

scx=twopi/ellx
rkxmax=scx*dble(nwx)
frkx(0)=zero
do kx=1,nxm1
  wratx=rkx(kx)/rkxmax
  frkx(kx)=rkx(kx)*exp(-36.d0*wratx**36.d0)
enddo

 !Define y wavenumbers:
scy=pi/elly
rkymax=scy*dble(ny)
do ky=1,ny
  wraty=rky(ky)/rkymax
  frky(ky)=rky(ky)*exp(-36.d0*wraty**36.d0)
enddo

 !Initialise arrays for computing the spectrum of any field:
delk=sqrt(scx**2+scy**2)
delki=one/delk
kmax=nint(sqrt(rkxmax**2+rkymax**2)*delki)
do k=0,kmax
  spmf(k)=zero
enddo
do kx=0,nxm1
  k=nint(rkx(kx)*delki)
  kmag(kx,0)=k
  spmf(k)=spmf(k)+one
enddo
do ky=1,ny
  do kx=0,nxm1
    k=nint(sqrt(rkx(kx)**2+rky(ky)**2)*delki)
    kmag(kx,ky)=k
    spmf(k)=spmf(k)+one
  enddo
enddo
 !Compute spectrum multiplication factor (spmf) to account for unevenly
 !sampled shells and normalise spectra by 8/(nx*ny) so that the sum
 !of the spectrum is equal to the L2 norm of the original field:
snorm=four*pi/dble(nx*ny)
spmf(0)=zero
do k=1,kmax
  spmf(k)=snorm*dble(k)/spmf(k)
  alk(k)=log10(delk*dble(k))
enddo
 !Only output shells which are fully occupied (k <= kmaxred):
kmaxred=nint(sqrt((rkxmax**2+rkymax**2)/two)*delki)

 !Define inverse spectral inversion operators:
if (barot) then
   !The first mode is barotropic (kd1 = 0):
  qgop1(0,0)=zero
else
  qgop1(0,0)=-one/(kd1sq+small)
endif
qgop2(0,0)=-one/kd2sq
do kx=1,nxm1
  rksq=rkx(kx)**2
  qgop1(kx,0)=-one/(rksq+kd1sq)
  qgop2(kx,0)=-one/(rksq+kd2sq)
enddo
do ky=1,ny
  rksq=rky(ky)**2
  qgop1(0,ky)=-one/(rksq+kd1sq)
  qgop2(0,ky)=-one/(rksq+kd2sq)
enddo
do ky=1,ny
  do kx=1,nxm1
    rksq=rkx(kx)**2+rky(ky)**2
    qgop1(kx,ky)=-one/(rksq+kd1sq)
    qgop2(kx,ky)=-one/(rksq+kd2sq)
  enddo
enddo

 !Hyperbolic functions used to correct boundary conditions in inversion:
if (barot) then
   !The first mode is barotropic (kd1 = 0):
  do iy=1,nym1
    decy1(iy,0)=yh1(iy)
  enddo
  do kx=1,nxm1
    fac=rkx(kx)*elly
    div=one/(one-exp(-two*fac))
    do iy=1,nym1
      argm=fac*(one-yh1(iy))
      argp=fac*(one+yh1(iy))
      decy1(iy,kx)=(exp(-argm)-exp(-argp))*div
    enddo
  enddo
else
  do kx=0,nxm1
    fac=sqrt(rkx(kx)**2+kd1sq)*elly
    div=one/(one-exp(-two*fac))
    do iy=1,nym1
      argm=fac*(one-yh1(iy))
      argp=fac*(one+yh1(iy))
      decy1(iy,kx)=(exp(-argm)-exp(-argp))*div
    enddo
  enddo
endif

do kx=0,nxm1
  fac=sqrt(rkx(kx)**2+kd2sq)*elly
  div=one/(one-exp(-two*fac))
  do iy=1,nym1
    argm=fac*(one-yh1(iy))
    argp=fac*(one+yh1(iy))
    decy2(iy,kx)=(exp(-argm)-exp(-argp))*div
  enddo
enddo

if (.not. barot) then
   !The first mode is *not* barotropic (kd1 .ne. 0):
  div=one/sinh(kd1*elly+small)
  ld=one/(kd1+small)
  do iy=0,ny
    pftop1(iy)= ld*cosh(kd1*(yg(iy)-ymax))*div
    pfbot1(iy)=-ld*cosh(kd1*(yg(iy)-ymin))*div
    uftop1(iy)=   -sinh(kd1*(yg(iy)-ymax))*div
    ufbot1(iy)=    sinh(kd1*(yg(iy)-ymin))*div
  enddo
  facp1=kd1sq*elly
  facu1=-kd1*elly*sinh(kd1*elly)/(cosh(kd1*elly)+small-one)
endif

div=one/sinh(kd2*elly)
ld=one/kd2
do iy=0,ny
  pftop2(iy)= ld*cosh(kd2*(yg(iy)-ymax))*div
  pfbot2(iy)=-ld*cosh(kd2*(yg(iy)-ymin))*div
  uftop2(iy)=   -sinh(kd2*(yg(iy)-ymax))*div
  ufbot2(iy)=    sinh(kd2*(yg(iy)-ymin))*div
enddo

return
end subroutine

!======================================
subroutine main_invert(qq,fhb,uu,vv,pp)

!f2py intent(in)  :: qq, fhb
!f2py intent(out) :: uu, vv, pp

 !Input:  PV field (qq) and scaled bottom topography f_0*H_b/H_1 (fhb)
 !Output: Velocity field (uu) and streamfunction field (pp)

 !Declarations:
implicit double precision(a-h,o-z)
implicit integer(i-n)

 !Passed arrays:
double precision:: qq(0:ny,0:nxm1,2),pp(0:ny,0:nxm1,2)
double precision:: uu(0:ny,0:nxm1,2),vv(0:ny,0:nxm1,2)
double precision:: fhb(0:ny,0:nxm1)
 !Local arrays:
double precision:: p1(0:ny,0:nxm1),p2(0:ny,0:nxm1),ss(0:nxm1,0:ny)
double precision:: pbot(0:nxm1),ptop(0:nxm1),cppy(nym1,0:nxm1)
double precision:: q1lin(0:ny),p1add(0:ny),u1add(0:ny)
double precision:: q2lin(0:ny),p2add(0:ny),u2add(0:ny)
double precision:: ldsq

!---------------------------------------------------------------------
! f2py hack
call init_spectral

!---------------------------------------------------------------------
 !Divide PV anomaly (q - beta*y) into modes:
do ix=0,nxm1
  do iy=0,ny
     !Add topography (f_0*H_b/H_1) to PV in lower layer:
    qq1=qq(iy,ix,1)-bety(iy)+fhb(iy,ix)
    qq2=qq(iy,ix,2)-bety(iy)
    p1(iy,ix)=vec11*qq1+vec12*qq2
    p2(iy,ix)=vec21*qq1+vec22*qq2
  enddo
enddo

 !Note: vec11 + vec12 = 1 while vec2sum = vec21 + vec22
 !Here, p1 and p2 are used temporarily

!-----------------------------------------
 !Solve for the mode 1 streamfunction, p1:

if (barot) then
   !Here, the first mode is truly barotropic (kd1 = 0); invert Laplace's
   !operator:

   !(1) compute mean vorticity (zbar) by averaging barotropic PV anomaly:
  zbar=zero
  do ix=0,nxm1
    zbar=zbar+p1(0,ix)+p1(ny,ix)
  enddo
  zbar=f12*zbar
  do ix=0,nxm1
    do iy=1,nym1
      zbar=zbar+p1(iy,ix)
    enddo
  enddo
  zbar=zbar*dsumi

   !(2) Remove mean vorticity from p1:
  do ix=0,nxm1
    do iy=0,ny
      p1(iy,ix)=p1(iy,ix)-zbar
    enddo
  enddo

   !(3) FFT p1 and invert to get uncorrected streamfunction p1:
  call ptospc_fc(nx,ny,p1,ss,xfactors,yfactors,xtrig,ytrig)
  do ky=0,ny
    do kx=0,nxm1
      ss(kx,ky)=qgop1(kx,ky)*ss(kx,ky)
    enddo
  enddo
  call spctop_fc(nx,ny,ss,p1,xfactors,yfactors,xtrig,ytrig)

   !(4) Add part of p1 due to mean vorticity found above:
  do ix=0,nxm1
    do iy=0,ny
      p1(iy,ix)=p1(iy,ix)+zbar*pbar(iy)
    enddo
  enddo

   !(5) Do a sine transform of p1 at y = ymin and ymax and obtain the
   !    interior field (cppy) that must be subtracted to give p1 = 0
   !    at y = ymin and ymax:
  do ix=0,nxm1
    pbot(ix)=p1(0,ix)
    ptop(ix)=p1(ny,ix)
  enddo
  call forfft(1,nx,pbot,xtrig,xfactors)
  call forfft(1,nx,ptop,xtrig,xfactors)

   !Define the interior semi-spectral field:
  do kx=0,nxm1
    do iy=1,nym1
      cppy(iy,kx)=pbot(kx)*decy1(ny-iy,kx)+ptop(kx)*decy1(iy,kx)
    enddo
  enddo
   !Invert using a full transform in x:
  call revfft(nym1,nx,cppy,xtrig,xfactors)

   !(6) Remove cppy to obtain the final barotropic streamfunction p1:
  do ix=0,nxm1
    p1(0, ix)=zero
    p1(ny,ix)=zero
  enddo

  do ix=0,nxm1
    do iy=1,nym1
      p1(iy,ix)=p1(iy,ix)-cppy(iy,ix)
    enddo
  enddo

   !Ensure u1bar = 0 to enforce zero global momentum:
  u1bar=zero

else
   !Here, kd1 > 0; invert the mode 1 Helmholtz operator:

   !(1) compute average mode 1 PV at each edge of the channel:
  q1bot=zero
  q1top=zero
  do ix=0,nxm1
    q1bot=q1bot+p1(0 ,ix)
    q1top=q1top+p1(ny,ix)
  enddo
  q1bot=q1bot/dble(nx)
  q1top=q1top/dble(nx)

   !(2) Subtract a linear profile from p1 before inversion:
  dq1dy=(q1top-q1bot)/elly
  fac=dq1dy*gly
  do iy=0,ny
    q1lin(iy)=q1bot+fac*dble(iy)
  enddo
  u1bar=dq1dy/(kd1sq+small)
   !u1bar: mean zonal velocity associated with this linear profile
  do ix=0,nxm1
    do iy=0,ny
      p1(iy,ix)=p1(iy,ix)-q1lin(iy)
    enddo
  enddo

   !(3) FFT p1 and invert to get uncorrected streamfunction p1:
  call ptospc_fc(nx,ny,p1,ss,xfactors,yfactors,xtrig,ytrig)
  do ky=0,ny
    do kx=0,nxm1
      ss(kx,ky)=qgop1(kx,ky)*ss(kx,ky)
    enddo
  enddo
  call spctop_fc(nx,ny,ss,p1,xfactors,yfactors,xtrig,ytrig)

   !(4) Do a sine transform of p1 at y = ymin and ymax and obtain the
   !    interior field (cppy) that must be subtracted to give p1 = 0
   !    at y = ymin and ymax:
  do ix=0,nxm1
    pbot(ix)=p1(0,ix)
    ptop(ix)=p1(ny,ix)
  enddo
  call forfft(1,nx,pbot,xtrig,xfactors)
  call forfft(1,nx,ptop,xtrig,xfactors)

   !Define the interior semi-spectral field:
  do kx=0,nxm1
    do iy=1,nym1
      cppy(iy,kx)=pbot(kx)*decy1(ny-iy,kx)+ptop(kx)*decy1(iy,kx)
    enddo
  enddo
   !Invert using a full transform in x:
  call revfft(nym1,nx,cppy,xtrig,xfactors)

   !(5) Remove cppy to obtain the final mode 1 streamfunction p1:
  do ix=0,nxm1
    p1(0, ix)=zero
    p1(ny,ix)=zero
  enddo

  do ix=0,nxm1
    do iy=1,nym1
      p1(iy,ix)=p1(iy,ix)-cppy(iy,ix)
    enddo
  enddo
endif

!-----------------------------------------
 !Solve for the mode 2 streamfunction, p2:

 !(1) compute average mode 2 PV at each edge of the channel:
q2bot=zero
q2top=zero
do ix=0,nxm1
  q2bot=q2bot+p2(0 ,ix)
  q2top=q2top+p2(ny,ix)
enddo
q2bot=q2bot/dble(nx)
q2top=q2top/dble(nx)

 !(2) Subtract a linear profile from p2 before inversion:
dq2dy=(q2top-q2bot)/elly
fac=dq2dy*gly
do iy=0,ny
  q2lin(iy)=q2bot+fac*dble(iy)
enddo
u2bar=dq2dy/kd2sq
 !u2bar: mean zonal velocity associated with this linear profile
do ix=0,nxm1
  do iy=0,ny
    p2(iy,ix)=p2(iy,ix)-q2lin(iy)
  enddo
enddo

 !(3) FFT p2 and invert to get uncorrected streamfunction p2:
call ptospc_fc(nx,ny,p2,ss,xfactors,yfactors,xtrig,ytrig)
do ky=0,ny
  do kx=0,nxm1
    ss(kx,ky)=qgop2(kx,ky)*ss(kx,ky)
  enddo
enddo
call spctop_fc(nx,ny,ss,p2,xfactors,yfactors,xtrig,ytrig)

 !(4) Do a sine transform of p2 at y = ymin and ymax and obtain the
 !    interior field (cppy) that must be subtracted to give p2 = 0
 !    at y = ymin and ymax:
do ix=0,nxm1
  pbot(ix)=p2(0,ix)
  ptop(ix)=p2(ny,ix)
enddo
call forfft(1,nx,pbot,xtrig,xfactors)
call forfft(1,nx,ptop,xtrig,xfactors)

 !Define the interior semi-spectral field:
do kx=0,nxm1
  do iy=1,nym1
    cppy(iy,kx)=pbot(kx)*decy2(ny-iy,kx)+ptop(kx)*decy2(iy,kx)
  enddo
enddo
 !Invert using a full transform in x:
call revfft(nym1,nx,cppy,xtrig,xfactors)

 !(5) Remove cppy to obtain the final mode 2 streamfunction p2:
do ix=0,nxm1
  p2(0, ix)=zero
  p2(ny,ix)=zero
enddo

do ix=0,nxm1
  do iy=1,nym1
    p2(iy,ix)=p2(iy,ix)-cppy(iy,ix)
  enddo
enddo

!-------------------------------------------------------------------------
!-------------------------------------------------------------------------
 !Re-construct layer streamfunctions by projecting modes:
do ix=0,nxm1
  do iy=0,ny
    pp(iy,ix,1)=vect11*p1(iy,ix)+vect12*p2(iy,ix)
    pp(iy,ix,2)=vect21*p1(iy,ix)+vect22*p2(iy,ix)
  enddo
enddo

 !Note: these do not include the parts associated with the
 !      linear PV profiles above; they are added back below and
 !      a further correction is made to satisfy imposed boundary
 !      conditions.

!!--------------------------------------------------------------
 !Compute velocity in each layer:
call getvel(pp,uu,vv,u1bar,u2bar)
 !Note: uu & vv are not yet corrected, though they include the
 !      contributions from the linear PV profiles above.

!!---------------------------------------------------------------
! !Correct streamfunction and velocity fields

if (.not. barot) then
   !Mode 1 is not barotropic (kd1 > 0); correct streamfunction and velocity
   !of this mode depending on choice made for mod1bc in parameters.f90:
  if (mod1bc .eq. 1) then
     !The mode 1 zonal velocity takes prescribed values of
     !u1bot at y = ymin, and u1top at y = ymax:

     !Project zonally-averaged edge values of u onto mode 1:
    cbot=zero
    ctop=zero
    do ix=0,nxm1
      cbot=cbot+vec11*uu(0 ,ix,1)+vec12*uu(0 ,ix,2)
      ctop=ctop+vec11*uu(ny,ix,1)+vec12*uu(ny,ix,2)
    enddo
    cbot=u1bot-cbot/dble(nx)
    ctop=u1top-ctop/dble(nx)

    ldsq=one/(kd1sq+small)
    do iy=0,ny
      p1add(iy)=ctop*pfbot1(iy)+cbot*pftop1(iy)-ldsq*q1lin(iy)
      u1add(iy)=ctop*ufbot1(iy)+cbot*uftop1(iy)
    enddo
     !Above we also add back the linear part of the mode 1 streamfunction

     !Correct fields:
    do ix=0,nxm1
      do iy=0,ny
        pp(iy,ix,1)=pp(iy,ix,1)+vect11*p1add(iy)
        pp(iy,ix,2)=pp(iy,ix,2)+vect21*p1add(iy)
        uu(iy,ix,1)=uu(iy,ix,1)+vect11*u1add(iy)
        uu(iy,ix,2)=uu(iy,ix,2)+vect21*u1add(iy)
      enddo
    enddo

  else
     !Set the mean displacement of the upper free surface to zero and
     !the associated mean velocity (of mode 1) to zero:

     !Get average uncorrected streamfunction for this mode:
    call average(p1,p1avg)
     !Include contribution from linear part taken away above:
    ldsq=one/(kd1sq+small)
    p1avg=p1avg-f12*ldsq*(q1lin(0)+q1lin(ny))
     !Get average uncorrected zonal velocity for this mode (overwrite p1):
    do ix=0,nxm1
      do iy=0,ny
        p1(iy,ix)=vec11*uu(iy,ix,1)+vec12*uu(iy,ix,2)
      enddo
    enddo
    call average(p1,u1avg)

     !Enforce zero global average (mode 1) streamfunction and zonal velocity:
    aaa=facp1*p1avg
    bbb=facu1*u1avg

    cbot=f12*(bbb-aaa)
    ctop=f12*(aaa+bbb)

    do iy=0,ny
      p1add(iy)=ctop*pfbot1(iy)+cbot*pftop1(iy)-ldsq*q1lin(iy)
      u1add(iy)=ctop*ufbot1(iy)+cbot*uftop1(iy)
    enddo
     !Above we also add back the linear part of the mode 1 streamfunction

     !Correct fields:
    do ix=0,nxm1
      do iy=0,ny
        pp(iy,ix,1)=pp(iy,ix,1)+vect11*p1add(iy)
        pp(iy,ix,2)=pp(iy,ix,2)+vect21*p1add(iy)
        uu(iy,ix,1)=uu(iy,ix,1)+vect11*u1add(iy)
        uu(iy,ix,2)=uu(iy,ix,2)+vect21*u1add(iy)
      enddo
    enddo

  endif

endif

 !---------------------------------------------------
 !Next deal with mode 2 (we assume kd2 > kd1 always):

 !Project zonally-averaged edge values of u onto mode 2:
cbot=zero
ctop=zero
do ix=0,nxm1
  cbot=cbot+vec21*uu(0 ,ix,1)+vec22*uu(0 ,ix,2)
  ctop=ctop+vec21*uu(ny,ix,1)+vec22*uu(ny,ix,2)
enddo
cbot=u2bot-cbot/dble(nx)
ctop=u2top-ctop/dble(nx)

ldsq=one/kd2sq
do iy=0,ny
  p2add(iy)=ctop*pfbot2(iy)+cbot*pftop2(iy)-ldsq*q2lin(iy)
  u2add(iy)=ctop*ufbot2(iy)+cbot*uftop2(iy)
enddo
 !Above we also add back the linear part of the mode 2 streamfunction

 !Correct fields:
do ix=0,nxm1
  do iy=0,ny
    pp(iy,ix,1)=pp(iy,ix,1)+vect12*p2add(iy)
    pp(iy,ix,2)=pp(iy,ix,2)+vect22*p2add(iy)
    uu(iy,ix,1)=uu(iy,ix,1)+vect12*u2add(iy)
    uu(iy,ix,2)=uu(iy,ix,2)+vect22*u2add(iy)
  enddo
enddo

 !--------------------------------------------------------------------
 !Correct zonal velocity so that x momentum h1*<u1>+h2*alpha*<u2> = 0:
call average(uu(0,0,1),u1avg)
call average(uu(0,0,2),u2avg)
umean=(h1*u1avg+alpha*h2*u2avg)*massfac
 !massfac = 1/(h1+h2*alpha) is inversely proportional to total mass

 !Subtract umean from zonal velocity component in each layer:
do lay=1,2
  do ix=0,nxm1
    do iy=0,ny
      uu(iy,ix,lay)=uu(iy,ix,lay)-umean
    enddo
  enddo
enddo

return
end subroutine

!===================================================================

subroutine getvel(pp,uu,vv,u1bar,u2bar)
! Computes the velocity components uu & vv from the streamfunction
! pp via uu = -d(pp)/dy and vv = d(pp)/dx.  The mean modal velocities
! u1bar & u2bar contribute a mean flow in each layer.
! *** pp, uu & vv are all in physical space
! *** and include the domain edges.

implicit double precision (a-h,o-z)
implicit integer(i-n)

 !Passed arrays:
double precision:: pp(0:ny,0:nxm1,2),uu(0:ny,0:nxm1,2),vv(0:ny,0:nxm1,2)

 !Local arrays:
double precision:: ppi(ny  ,0:nxm1),pps(0:nxm1  ,ny)
double precision:: ppx(0:nxm1,  ny),vvi(  ny,0:nxm1)
double precision:: ppy(0:nxm1,0:ny),uui(0:ny,0:nxm1)
double precision:: ubar(2)

 !Define mean velocity in each layer associated with linear (in y)
 !part of the zonal-average PV in each mode:
ubar(1)=vect11*u1bar+vect12*u2bar
ubar(2)=vect21*u1bar+vect22*u2bar

 !Loop over layers and compute velocity field:
do lay=1,2

   !Copy non-zero interior values of pp to ppi:
  do ix=0,nxm1
    do iy=1,nym1
      ppi(iy,ix)=pp(iy,ix,lay)
    enddo
  enddo

   !Transform ppi to spectral space:
  call ptospc_fs(nx,ny,ppi,pps,xfactors,yfactors,xtrig,ytrig)

   !Compute d(ppi)/dx = ppx spectrally:
  call xderiv_fs(nx,ny,hrkx,pps,ppx)

   !Transform ppx back to physical space as vvi:
  call spctop_fs(nx,ny,ppx,vvi,xfactors,yfactors,xtrig,ytrig)

   !Copy vvi into vv and add on zero edge values at iy = 0 & ny:
  do ix=0,nxm1
    vv(0,ix,lay)=zero
    do iy=1,nym1
      vv(iy,ix,lay)=vvi(iy,ix)
    enddo
    vv(ny,ix,lay)=zero
  enddo

   !Compute d(ppi)/dy = ppy spectrally:
  call yderiv_fs(nx,ny,rky,pps,ppy)

   !Transform ppy back to physical space as uui:
  call spctop_fc(nx,ny,ppy,uui,xfactors,yfactors,xtrig,ytrig)

   !Copy -uui into uu and add mean layer velocity:
  do ix=0,nxm1
    do iy=0,ny
      uu(iy,ix,lay)=ubar(lay)-uui(iy,ix)
    enddo
  enddo

enddo
 !ends loop over layers

return
end subroutine

!===================================================================

subroutine spec1d_fc(rvar,spec)
! Computes the 1d spectrum of a field rvar which is
! periodic in x and represented by a cosine series in y
! and returns the result in spec.
!   *** Warning: rvar is modified by this routine.***

implicit double precision (a-h,o-z)
implicit integer(i-n)

 !Passed arrays:
double precision:: rvar(0:ny,0:nxm1),spec(0:max(nx,ny))
 !Local array:
double precision:: wks(0:nxm1,0:ny)

 !Transform rvar to spectral space:
call ptospc_fc(nx,ny,rvar,wks,xfactors,yfactors,xtrig,ytrig)

do k=0,kmax
  spec(k)=zero
enddo

 !x and y-independent mode:
k=kmag(0,0)
spec(k)=spec(k)+f14*wks(0,0)**2

 !y-independent mode:
do kx=1,nxm1
  k=kmag(kx,0)
  spec(k)=spec(k)+f12*wks(kx,0)**2
enddo

 !x-independent mode:
do ky=1,ny
  k=kmag(0,ky)
  spec(k)=spec(k)+f12*wks(0,ky)**2
enddo

 !All other modes:
do ky=1,ny
  do kx=1,nxm1
    k=kmag(kx,ky)
    spec(k)=spec(k)+wks(kx,ky)**2
  enddo
enddo

return
end subroutine

!==================================================

end module


program monte_carlo
    use types
    use mcrt_functions

    implicit none
    ! allocate variables and declare things
    real(dp), allocatable :: tau_list(:), total_scatter(:, :), mean_arr(:), length_travelled(:, :), image_grid(:,:,:), flux_grid(:,:,:)
    real(dp) :: pos(3), nhat(3), old_pos(3), nhat_view(3)
    real(dp) :: r_max = 200.0*AU, min_wt = 1e-3, albedo = 1.0_dp, luminosity = 0.1*lsolar, p = 0.1, etheta = 0.0, ephi = 0.0, distance = 140.0*pc ! CORRECT THESE
    real(dp) :: xim, yim, pw_wt, leng, r, tau, ran,  wt, flux_wt, flux_multiplier, intensity_multiplier, area_pp
    integer :: num_packets, len_tau, j, i, u, k, xbins = 500, ybins = 500

    ! Parameters for the MC run
    num_packets = 10000000

    ! define the flux multiplier
    flux_multiplier = luminosity/( num_packets * distance**2 )

    ! define the intensity multiplier
    area_pp = (r_max/xbins)**2
    intensity_multiplier = luminosity/( distance**2 * num_packets * ( area_pp/(distance**2) ) )

    ! configure the tau that we want to see

    tau_list = [0.1, 5.0, 10.0, 50.0]
    len_tau = size(tau_list)

    ! allocating the memory for things
    allocate( total_scatter( len_tau, num_packets ) )
    allocate( mean_arr( len_tau ) )
    allocate( length_travelled( len_tau, num_packets ) )
    allocate( image_grid( len_tau, xbins, ybins ) )
    allocate( flux_grid( len_tau, xbins, ybins ) )

    ! creating an image plane and an image nhat vector that can be used later
    call initialise_image_plane(nhat_view, etheta, ephi)

    write(*,*) 'Program running!'

    do j = 1, size(tau_list)
        ! loop over tau

        do i = 1, num_packets
            ! loop over packets

            ! set location to zero again
            r = 0.0_dp
            ! define tau to make it easier when referencing
            tau = tau_list(j)
            ! make sure everything is zero
            call zeros(pos)
            call zeros(old_pos)
            call mc_emit(nhat)
            ! give the packet an initial weight
            wt = (1-exp(-tau))
            ! set the length travelled to zero
            length_travelled(j, i) = 0.0

            do while ((r < r_max) .and. (r .ge. 0.0_dp))
                ! provided we are within the sphere
                old_pos = pos
                ! store the old position

                ! if it is the first scatter than you force it to scatter
                if (total_scatter(j,i) .eq. 0) then
                    leng = mc_gen_first_L(tau,r_max)
                else
                    leng = mc_gen_L(tau,r_max)
                end if

                ! NEE image binning
                ! generate the peeling off weight and the flux weight as described in the lectures
                pw_wt = gen_pw_wt(wt, pos, nhat_view, r_max, tau)
                flux_wt = gen_flux_wt(wt, pos, nhat_view, r_max, tau)

                ! calculate the image locations for the packets
                call image_calculate(pos, etheta, ephi, xim, yim)
                ! bin them in their respective arrays according to their weight
                call image_bin(xim, yim, xbins, ybins, image_grid, pw_wt, r_max, j)
                call image_bin(xim, yim, xbins, ybins, flux_grid, flux_wt, r_max, j)

                ! normal MC stuff

                ! create an nhat vector
                call mc_emit(nhat)
                ! make it walk along the nhat vector a certain length leng
                call mc_update(pos, nhat, leng)

                ! check if it will remain in the sphere
                r = norm(pos)

                if (r < r_max) then
                    ! update the length travelled if we remain in the sphere
                    length_travelled(j, i) = length_travelled(j, i) + leng

                    ! could include the russian roulette here if Kenny wanted
                else if (r .ge. r_max) then
                    ! if it's outside the sphere then use the geometry to allow us to calculate the "true" length that it's travelled
                    leng = edge_length(old_pos, nhat, r_max)
                    length_travelled(j, i) = length_travelled(j, i) + leng
                end if
            end do
        end do
        write(*,*) j
    end do

    open(newunit = u, file = "Q2/Data_nb2_b/image_data.txt", status = "replace")
    do k = 1, len_tau
        do j = 1, xbins
            do i = 1, ybins
                write(u,*) tau_list(k), ',', j, ',' ,i, ',', image_grid(k,j,i)
            end do
        end do
    end do

    open(newunit = u, file = "Q2/Data_nb2_b/flux_data.txt", status = "replace")
    do k = 1, len_tau
        do j = 1, xbins
            do i = 1, ybins
                write(u,*) tau_list(k), ',', j, ',' ,i, ',', flux_grid(k, j, i)*flux_multiplier
            end do
        end do
    end do

    open(newunit = u, file = "Q2/Data_nb2_b/intensity_data.txt", status = "replace")
    do k = 1, len_tau
        do j = 1, xbins
            do i = 1, ybins
                write(u,*) tau_list(k), ',', j, ',' ,i, ',', flux_grid(k, j, i)*intensity_multiplier
            end do
        end do
    end do

end program