!*==dgtts2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DGTTS2 solves a system of linear equations with a tridiagonal matrix using the LU factorization computed by sgttrf.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DGTTS2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
!
!       .. Scalar Arguments ..
!       INTEGER            ITRANS, LDB, N, NRHS
!       ..
!       .. Array Arguments ..
!       INTEGER            IPIV( * )
!       DOUBLE PRECISION   B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DGTTS2 solves one of the systems of equations
!>    A*X = B  or  A**T*X = B,
!> with a tridiagonal matrix A using the LU factorization computed
!> by DGTTRF.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] ITRANS
!> \verbatim
!>          ITRANS is INTEGER
!>          Specifies the form of the system of equations.
!>          = 0:  A * X = B  (No transpose)
!>          = 1:  A**T* X = B  (Transpose)
!>          = 2:  A**T* X = B  (Conjugate transpose = Transpose)
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!> \endverbatim
!>
!> \param[in] DL
!> \verbatim
!>          DL is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) multipliers that define the matrix L from the
!>          LU factorization of A.
!> \endverbatim
!>
!> \param[in] D
!> \verbatim
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The n diagonal elements of the upper triangular matrix U from
!>          the LU factorization of A.
!> \endverbatim
!>
!> \param[in] DU
!> \verbatim
!>          DU is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) elements of the first super-diagonal of U.
!> \endverbatim
!>
!> \param[in] DU2
!> \verbatim
!>          DU2 is DOUBLE PRECISION array, dimension (N-2)
!>          The (n-2) elements of the second super-diagonal of U.
!> \endverbatim
!>
!> \param[in] IPIV
!> \verbatim
!>          IPIV is 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.
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          On entry, the matrix of right hand side vectors B.
!>          On exit, B is overwritten by the solution vectors X.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup doubleGTcomputational
!
!  =====================================================================
      SUBROUTINE DGTTS2(Itrans,N,Nrhs,Dl,D,Du,Du2,Ipiv,B,Ldb)
      IMPLICIT NONE
!*--DGTTS2132
!
!  -- LAPACK computational 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 Itrans , Ldb , N , Nrhs
!     ..
!     .. Array Arguments ..
      INTEGER Ipiv(*)
      DOUBLE PRECISION B(Ldb,*) , D(*) , Dl(*) , Du(*) , Du2(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER i , ip , j
      DOUBLE PRECISION temp
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF ( N==0 .OR. Nrhs==0 ) RETURN
!
      IF ( Itrans==0 ) THEN
!
!        Solve A*X = B using the LU factorization of A,
!        overwriting each right hand side vector with its solution.
!
         IF ( Nrhs<=1 ) THEN
            j = 1
            DO
!
!           Solve L*x = b.
!
               DO i = 1 , N - 1
                  ip = Ipiv(i)
                  temp = B(i+1-ip+i,j) - Dl(i)*B(ip,j)
                  B(i,j) = B(ip,j)
                  B(i+1,j) = temp
               ENDDO
!
!           Solve U*x = b.
!
               B(N,j) = B(N,j)/D(N)
               IF ( N>1 ) B(N-1,j) = (B(N-1,j)-Du(N-1)*B(N,j))/D(N-1)
               DO i = N - 2 , 1 , -1
                  B(i,j) = (B(i,j)-Du(i)*B(i+1,j)-Du2(i)*B(i+2,j))/D(i)
               ENDDO
               IF ( j<Nrhs ) THEN
                  j = j + 1
                  CYCLE
               ENDIF
               EXIT
            ENDDO
         ELSE
            DO j = 1 , Nrhs
!
!              Solve L*x = b.
!
               DO i = 1 , N - 1
                  IF ( Ipiv(i)==i ) THEN
                     B(i+1,j) = B(i+1,j) - Dl(i)*B(i,j)
                  ELSE
                     temp = B(i,j)
                     B(i,j) = B(i+1,j)
                     B(i+1,j) = temp - Dl(i)*B(i,j)
                  ENDIF
               ENDDO
!
!              Solve U*x = b.
!
               B(N,j) = B(N,j)/D(N)
               IF ( N>1 ) B(N-1,j) = (B(N-1,j)-Du(N-1)*B(N,j))/D(N-1)
               DO i = N - 2 , 1 , -1
                  B(i,j) = (B(i,j)-Du(i)*B(i+1,j)-Du2(i)*B(i+2,j))/D(i)
               ENDDO
            ENDDO
         ENDIF
!
!        Solve A**T * X = B.
!
      ELSEIF ( Nrhs<=1 ) THEN
!
!           Solve U**T*x = b.
!
         j = 1
         DO
            B(1,j) = B(1,j)/D(1)
            IF ( N>1 ) B(2,j) = (B(2,j)-Du(1)*B(1,j))/D(2)
            DO i = 3 , N
               B(i,j) = (B(i,j)-Du(i-1)*B(i-1,j)-Du2(i-2)*B(i-2,j))/D(i)
            ENDDO
!
!           Solve L**T*x = b.
!
            DO i = N - 1 , 1 , -1
               ip = Ipiv(i)
               temp = B(i,j) - Dl(i)*B(i+1,j)
               B(i,j) = B(ip,j)
               B(ip,j) = temp
            ENDDO
            IF ( j<Nrhs ) THEN
               j = j + 1
               CYCLE
            ENDIF
            EXIT
         ENDDO
!
      ELSE
         DO j = 1 , Nrhs
!
!              Solve U**T*x = b.
!
            B(1,j) = B(1,j)/D(1)
            IF ( N>1 ) B(2,j) = (B(2,j)-Du(1)*B(1,j))/D(2)
            DO i = 3 , N
               B(i,j) = (B(i,j)-Du(i-1)*B(i-1,j)-Du2(i-2)*B(i-2,j))/D(i)
            ENDDO
            DO i = N - 1 , 1 , -1
               IF ( Ipiv(i)==i ) THEN
                  B(i,j) = B(i,j) - Dl(i)*B(i+1,j)
               ELSE
                  temp = B(i+1,j)
                  B(i+1,j) = B(i,j) - Dl(i)*temp
                  B(i,j) = temp
               ENDIF
            ENDDO
         ENDDO
      ENDIF
!
!     End of DGTTS2
!
      END SUBROUTINE DGTTS2


! { dg-do compile }

  integer, parameter :: q = 2
  integer, parameter :: nx=3, ny=2*q, nz=5
  integer, parameter, dimension(nx,ny,nz) :: p  = &
        & reshape ((/ (i**2, i=1,size(p)) /), shape(p))
  integer, parameter, dimension(   ny,nz) :: px = &
        & reshape ((/ (( &
        &       +      nx*(nx-1)*(2*nx-1)/6, &
        &       j=0,ny-1), k=0,nz-1) /), shape(px))
  integer, parameter, dimension(nx,   nz) :: py = &
        & reshape ((/ (( &
        &       +(nx   )**2*ny*(ny-1)*(2*ny-1)/6, &
        &       i=0,nx-1), k=0,nz-1) /), shape(py))
  integer, parameter, dimension(nx,ny   ) :: pz = &
        & reshape ((/ (( &
        &       +(nx*ny)**2*nz*(nz-1)*(2*nz-1)/6, &
        &       i=0,nx-1), j=0,ny-1) /), shape(pz))
  integer, dimension(nx,ny,nz) :: a
  integer, dimension(nx,ny   ) :: az
  if (sum(sum(sum(a,1),2),1) /= sum(a)) call abort
  if (sum(sum(sum(a,3),1),1) /= sum(a)) call abort
  if (any(1+sum(eid(a),1)+ax+sum( &
        neid3(a), &
        1)+1  /= 3*ax+2))        call abort
  if (any(1+eid(sum(a,2))+ay+ &
        neid2( &
        sum(a,2) &
        )+1  /= 3*ay+2))        call abort
  if (any(sum(eid(sum(a,3))+az+2* &
        neid2(az) &
        ,1)+1 /= 4*sum(az,1)+1)) call abort
contains
  elemental function eid (x)
    integer, intent(in) :: x
  end function eid
  function neid2 (x)
    integer, intent(in) :: x(:,:)
    integer             :: neid2(size(x,1),size(x,2))
    neid2 = x
  end function neid2
  function neid3 (x)
    integer, intent(in) :: x(:,:,:)
    integer             :: neid3(size(x,1),size(x,2),size(x,3))
  end function neid3
  elemental subroutine set (o, i)
    integer, intent(in)  :: i
    integer, intent(out) :: o
  end subroutine set
  elemental subroutine tes (i, o)
    integer, intent(in)  :: i
    integer, intent(out) :: o
  end subroutine tes
end


subroutine grmap(f1        ,n1        ,f2        ,n2        ,iref      , &
               & w         ,np        ,iprint    )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: grmap.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/tools_gpl/kubint/packages/kubint_f/src/grmap.f90 $
!!--description-----------------------------------------------------------------
! NONE
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    implicit none
!
! Global variables
!
    integer, intent(in)            :: iprint
    integer, intent(in)            :: n1
    integer, intent(in)            :: n2
    integer, intent(in)            :: np
    integer, dimension(np, n2), intent(in) :: iref
    real(hp), dimension(n1), intent(in) :: f1
    real(hp), dimension(n2) :: f2
    real(hp), dimension(np, n2), intent(in) :: w
!
!
! Local variables
!
    integer                        :: i
    integer                        :: i1
    integer                        :: i2
    integer                        :: ifac
    integer                        :: ip
!
!
!! executable statements -------------------------------------------------------
!
    !
    !     compute interpolated values for all points on grid 2
    !
    if (iprint==1) write (*, *) 'in grmap n1 n2', n1, n2
    do i2 = 1, n2
       !
       ! Function values at grid 2 are expressed as weighted average
       ! of function values in Np surrounding points of grid 1
       !
       if (iprint==1 .and. i2<=n2) &
        & write (*, '(1X,A,I6,4(1X,E11.4))') ' i2 w ', i2, (w(ip, i2) , ip = 1,  &
        & np)
       !
       f2(i2) = 0.0
       !
       do ip = 1, np
          i = iref(ip, i2)
          i1 = max(i, 1)
          if (iprint==1 .and. i2<=n2) write (*, *) ' i1,f1(i1) ', i1, f1(i1)
          f2(i2) = f2(i2) + w(ip, i2)*f1(i1)
       enddo
    enddo
end subroutine grmap


c
c
c
c
      double precision function fbody(x,y)

      implicit double precision (a-h,o-z)
      common /userdt/ cfl,gamma,gamma1,xprob,yprob,alpha,Re,iprob,
     .                ismp,gradThreshold
c
c  supersonic vortex problem
c  negative inside the body (exterior to the domain), positive otherwise.
c
      r1 = 1.d0
      r2 = 1.3840
      fbody = -1.d0

      rsq = (x**2 + y**2)
      if (rsq .ge. r1*r1 .and. rsq .le. r2*r2) fbody = 1.d0

      return
      end
c


      module channel_velocity_module

      implicit none

      type channel_velocity_parameters
          real :: area = 0.              !m^2           |cross sectional area of flow at bankfull depth
          real :: vel_bf = 0.            !m^3/s         |flow rate when reach is at bankful depth
          real :: wid_btm = 0.           !m             |bottom width of main channel
          real :: dep_bf = 0.            !m             |depth of water when reach is at bankfull depth
          real :: velav_bf = 0.          !m/s           |average velocity when reach is at bankfull depth
          real :: celerity_bf = 0.        !m/s          |wave celerity when reach is at bankfull depth
          real :: st_dis = 0.             !hr           |storage time constant for reach at bankfull depth
          real :: vel_1bf = 0.            !m/s          |average velocity when reach is at 0.1 bankfull depth (low flow)
          real :: celerity_1bf = 0.       !m/s          |wave celerity when reach is at 0.1 bankfull depth (low flow)
          real :: stor_dis_1bf = 0.       !hr           |storage time constant for reach at 0.1 bankfull depth (low flow)
      end type channel_velocity_parameters
      type (channel_velocity_parameters), dimension(:), allocatable :: ch_vel
      type (channel_velocity_parameters), dimension(:), allocatable :: sd_ch_vel
      type (channel_velocity_parameters), dimension(:), allocatable :: grwway_vel

      end module channel_velocity_module


c
c ---------------------------------------------------------
c
      subroutine projec2(level,numpro,rectflags,ilo,ihi,jlo,jhi,mbuff)
c
      use amr_module
      implicit double precision (a-h,o-z)
      dimension rectflags(ilo-mbuff:ihi+mbuff,jlo-mbuff:jhi+mbuff)
c
c  ::::::::::::::::::::::: PROJEC2 ::::::::::::::::::::::::::::::
c  for all newly created fine grids, project area onto a coarser
c  grid 2 levels down. Used to recreate grids 1 level down, and
c  insure proper level nesting.
c
c  on entry, all coarse grids have already had error estimated, so
c  add bad flags.   count number of 'added' flags only.
c
c input parameters:
c    level = project all fine subgrids onto grids at this level.
c output parameters:
c  numpro = number of additional flagged pts. at 'level'.
c           (initialized to 0 in flglvl)
c local variables:
c     iflags  = holds coarser domain flagged points - receives projection
c     mkid    = grid doing the projecting
c  :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c
      levpro  =  level + 2
      lrat2x  = intratx(level)*intratx(level+1)
      lrat2y  = intraty(level)*intraty(level+1)
c
      mkid = newstl(levpro)
 10   if (mkid .eq. 0) go to 90
       ikidlo = node(ndilo,mkid)
       jkidlo = node(ndjlo,mkid)
       ikidhi = node(ndihi,mkid)
       jkidhi = node(ndjhi,mkid)
c
c  project entire region of fine grids onto rectflag array if intersects
c  possibly take care of buffering.
c  adjust since grid descriptor (integer indices)  is 0 based,
c  iflags indexing is 1 based.
c  do not projec the buffer region, only interior needs it
c  since buffering will take care of rest (unless ibuff=0-see below)
c
      ist  = floor(ikidlo/real(lrat2x))
      jst  = floor(jkidlo/real(lrat2y))
!--      iend = ikidhi/lrat2x
!--      jend = jkidhi/lrat2y
      iend = ceiling((ikidhi+1.d0)/lrat2x) -1
      jend = ceiling((jkidhi+1.d0)/lrat2y) -1

      if (ibuff .eq. 0) then
c     ## ensure proper nesting here, since buffering step won't follow when ibuff 0
        if (ist*lrat2x .eq. ikidlo) ist = ist-1
        if (jst*lrat2y .eq. jkidlo) jst = jst-1
        if ((iend+1)*lrat2x .eq. ikidhi+1) iend = iend+1
        if ((jend+1)*lrat2y .eq. jkidhi+1) jend = jend+1
      endif

      ixlo = max(ist, ilo-mbuff)
      ixhi = min(iend,ihi+mbuff)
      jxlo = max(jst, jlo-mbuff)
      jxhi = min(jend,jhi+mbuff)
      if (.not.((ixlo .le. ixhi) .and. (jxlo .le. jxhi))) go to 80 ! grid mkid doesnt intersect with rectflags
c
c       do 60 j = jst+1, jend+1   !old code, shift indices by 1
c       do 60 i = ist+1, iend+1   ! since iflags used 1-based indexing
c       do 60 j = jst, jend        ! new code into rectflags is 0 based
c       do 60 i = ist, iend
        do 60 j = jxlo, jxhi
        do 60 i = ixlo, ixhi
           if (rectflags(i,j) .eq. goodpt) then
               rectflags(i,j) = badpro
               numpro      = numpro + 1
               if (pprint) write(outunit,101) i,j,mkid
101            format(' pt.',2i5,' of grid ',i5,' projected' )
           endif
 60    continue
c
c IS THERE SOMETHING TO DO ABOUT PERIODICITY
c
c repeat above procedure for wrapped area if nec. if ibuff > 0
c this will be caught in shiftset flagging
       if (spheredom .and. ibuff .eq. 0) then
          jst  = jkidlo/lrat2y
          jend = jkidhi/lrat2y
          if (jst .eq. 0) then
             iwrap1 = iregsz(level) - iend - 1
             iwrap2 = iregsz(level) - ist - 1
c             do 61 i = iwrap1+1, iwrap2+1
             do 61 i = iwrap1, iwrap2  !changing this WITHOUT CHECKING, AS ABOVE. STILL NEED TO CHECK***
                if (rectflags(i,1) .eq. goodpt) then
                  rectflags(i,1) = badpro  ! only need to flag 1 wrapped buffer cell
                  numpro      = numpro + 1
                  if (pprint) write(outunit,101) i,1,mkid
                endif
 61          continue

          endif
          if (jend .eq. jsize-1) then
             iwrap1 = iregsz(level) - iend - 1
             iwrap2 = iregsz(level) - ist - 1
c             do 62 i = iwrap1+1, iwrap2+1
             do 62 i = iwrap1, iwrap2 !CHANGING W/O CHECKING
                if (rectflags(i,jsize-1) .eq. goodpt) then
                  rectflags(i,jsize-1) = badpro  ! only need to flag 1 wrapped buffer cell
                  numpro            = numpro + 1
                  if (pprint) write(outunit,101) i,j,mkid
                endif
 62          continue
          endif
       endif
c
c  done with gridpt. loop for grid mkid.
c
 80     mkid = node(levelptr, mkid)
        go to 10
c
 90   if (pprint) then
         write(outunit,102) numpro,level
 102     format(i9,' more pts. projected to level ',i5)

         write(outunit,103) level
 103     format(/,'  from projec: flagged pts. (incl. buffer zone)',
     &           ' at level ',i4,':')

         do 110 j = jhi+mbuff, jlo-mbuff, -1
           write(outunit,104)(int(rectflags(i,j)),i=ilo-mbuff,ihi+mbuff)
104        format(80i1)
 110     continue
      endif
c
 99   return
      end


module Mod_nsm_ViscosityBouope
   use Mod_PointerSetter
   use Mod_nsm_BaseBouope
   use Mod_nsm_Viscosity
   implicit none
   private
   public SetPointersViscosity

   type, extends(PointerSetter) :: SPViscosity
contains
      procedure :: SpecificSet => SpecificSetViscosity
   end type
   type(SPViscosity) :: SetPointersViscosity

contains

   subroutine SpecificSetViscosity(d)
      implicit none
      class(SPViscosity) :: d

      !Smagorinsky
      if (a%kfl_cotur< 0.or.a%MatProp(imat)%lawvi/=0.or.a%kfl_ExchangeLocationWallLaw==1) then
         call ConcatenateProcedures(ProcHook_Gathers,GatherSmagorinsky)
      endif
      if (a%kfl_cotur<0) call ConcatenateProcedures(ProcHook_InGauss,InGaussSmagorinsky)
      !Non-newtonian viscosity
      if(a%MatProp(imat)%lawvi /= 0) call ConcatenateProcedures(ProcHook_InGauss,InGaussNonNewtonianViscosity)
   end subroutine

   !*************!
   ! Smagorinsky !
   !*************!
   subroutine GatherSmagorinsky
      implicit none
      call e%gather(e%ndime,elvel,a%veloc(:,:,1))
   end subroutine

   subroutine InGaussSmagorinsky
      implicit none
      call e%elmlen
      if (a%kfl_cotur == -1) then
         call nsm_smago(e,grbve,acden,a%turbu(1),vista)
      elseif (a%kfl_cotur == -2) then
         call nsm_wale(e,grbve,acden,a%turbu(1),vista)
      endif
      acvis = acvis + vista
   end subroutine

   !*************************!
   ! Non-Newtonian Viscosity !
   !*************************!
   subroutine InGaussNonNewtonianViscosity
      implicit none
      call nsi_vislaw(e,grbve,a%MatProp(imat)%lawvi,a%MatProp(imat)%LawViParam,acvis)
   end subroutine

end module


program test_ffte_par
use types, only: dp
use constants, only: pi
use fourier, only: dft, idft, fft, fft_vectorized, fft_pass, fft_pass_inplace, &
        fft_vectorized_inplace, calculate_factors, ifft_pass, fft2_inplace, &
        fft3_inplace, ifft3_inplace
use utils, only: assert, init_random, stop_error, get_int_arg, get_float_arg
use ffte, only: factor
use pofdft_fft, only: pfft3_init, preal2fourier, pfourier2real, &
    real_space_vectors, reciprocal_space_vectors, calculate_myxyz, &
    pintegral, pintegralG
use openmp, only: omp_get_wtime
use mpi2, only: mpi_finalize, MPI_COMM_WORLD, mpi_comm_rank, &
    mpi_comm_size, mpi_init, mpi_comm_split, MPI_INTEGER, &
    mpi_barrier, MPI_DOUBLE_PRECISION, mpi_bcast
implicit none

complex(dp), dimension(:,:,:), allocatable :: ne, neG, ne2
real(dp), allocatable :: G(:,:,:,:), G2(:,:,:), X(:,:,:,:)
real(dp) :: L(3), r2, alpha, Z, Eee, Eee_conv
integer :: i, j, k
integer :: Ng(3)
real(dp) :: t1, t2, t3
integer :: LNPU(3)

!  parallel variables
integer :: comm_all, commy, commz, nproc, ierr, nsub(3), Ng_local(3)
integer :: myid ! my ID (MPI rank), starts from 0
integer :: myxyz(3) ! myid, converted to the (x, y, z) box, starts from 0

call mpi_init(ierr)
comm_all  = MPI_COMM_WORLD
call mpi_comm_rank(comm_all, myid, ierr)
call mpi_comm_size(comm_all, nproc, ierr)
if (myid == 0) then
    if (command_argument_count() == 0) then
        call factor(nproc, LNPU)
        nsub(3) = (2**(LNPU(1)/2))*(3**(LNPU(2)/2))*(5**(LNPU(3)/2))
        nsub(2) = nproc / nsub(3)
        nsub(1) = 1
        Ng = 32
        L = 2
    else
        if (command_argument_count() /= 9) then
            print *, "Usage:"
            print *
            print *, "test_ffte_par L(3) Ng(3) nsub(3)"
            call stop_error("Incorrect number of arguments.")
        end if
        L(1) = get_float_arg(1)
        L(2) = get_float_arg(2)
        L(3) = get_float_arg(3)
        Ng(1) = get_int_arg(4)
        Ng(2) = get_int_arg(5)
        Ng(3) = get_int_arg(6)
        nsub(1) = get_int_arg(7)
        nsub(2) = get_int_arg(8)
        nsub(3) = get_int_arg(9)
    end if
    Ng_local = Ng / nsub

    print *, "L:       ", L
    print *, "nproc:   ", nproc
    print *, "nsub:    ", nsub
    print *, "Ng:      ", Ng
    print *, "Ng_local:", Ng_local

    if (product(nsub) /= nproc) then
        call stop_error("nproc must be equal to the number of subdomains")
    end if
end if
call mpi_bcast(L, size(L), MPI_DOUBLE_PRECISION, 0, comm_all, ierr)
call mpi_bcast(nsub, size(nsub), MPI_INTEGER, 0, comm_all, ierr)
call mpi_bcast(Ng, size(Ng), MPI_INTEGER, 0, comm_all, ierr)
call mpi_bcast(Ng_local, size(Ng_local), MPI_INTEGER, 0, comm_all, ierr)
call pfft3_init(myid, comm_all, Ng, nsub)

myxyz = calculate_myxyz(myid, nsub)

! Note that myxyz(3) corresponds to commy, and myxyz(2) to commz
call mpi_comm_split(comm_all, myxyz(3), 0, commy, ierr)
call mpi_comm_split(comm_all, myxyz(2), 0, commz, ierr)

allocate(ne(Ng_local(1), Ng_local(2), Ng_local(3)))
allocate(neG(Ng_local(1), Ng_local(2), Ng_local(3)))
allocate(ne2(Ng_local(1), Ng_local(2), Ng_local(3)))
allocate(X(Ng_local(1), Ng_local(2), Ng_local(3), 3))
allocate(G(Ng_local(1), Ng_local(2), Ng_local(3), 3))
allocate(G2(Ng_local(1), Ng_local(2), Ng_local(3)))
call real_space_vectors(L, X, Ng, myxyz)
call reciprocal_space_vectors(L, G, G2, Ng, myxyz)

! Setup two Gaussians with opposite charges, thus overall the density is net
! neutral:
alpha = 5
Z = 3
do k = 1, size(ne, 3)
do j = 1, size(ne, 2)
do i = 1, size(ne, 1)
    r2 =sum((X(i,j,k,:)-L/2)**2)
    ne(i, j, k) = Z*alpha**3/pi**(3._dp/2)*exp(-alpha**2*r2) &
        - Z*(alpha+1)**3/pi**(3._dp/2)*exp(-(alpha+1)**2*r2)
end do
end do
end do

Eee = pintegral(comm_all, L, real(ne, dp), Ng)
if (myid == 0) then
    print *, "integral:", myid, Eee
    call assert(abs(Eee) < 1e-10_dp)
end if
ne2 = 0
call mpi_barrier(comm_all, ierr)
call cpu_time(t1)
call preal2fourier(ne, neG, commy, commz, Ng, nsub)
call mpi_barrier(comm_all, ierr)
call cpu_time(t2)
call pfourier2real(neG, ne2, commy, commz, Ng, nsub)
call mpi_barrier(comm_all, ierr)
call cpu_time(t3)
if (myid == 0) then
    print *, "Timings (t, t*nproc):"
    print *, t2-t1, (t2-t1)*nproc
    print *, t3-t2, (t3-t2)*nproc
    print *, "Error:", maxval(abs(ne-ne2))
    call assert(all(abs(ne - ne2) < 1e-12_dp))
end if
call mpi_barrier(comm_all, ierr)

if (myid == 0) then
    neG(1,1,1) = 0
    G(1, 1, 1, :) = 1 ! To avoid division by 0
    G2(1, 1, 1) = 1 ! To avoid division by 0
end if
Eee = pintegralG(comm_all, L, 2*pi*abs(neG)**2/G2) - Z**2*alpha/sqrt(2*pi)
if (myid == 0) then
    print *, "integralG:", myid, Eee
    Eee_conv = -17.465136801093962_dp
    print *, "error:", abs(Eee-Eee_conv)
    call assert(abs(Eee - Eee_conv) < 1e-12_dp)
end if

call mpi_finalize(ierr)
end program


PROGRAM CEI_EXAMPLE
! Gael de Oliveira, Ricardo Pereira, Feb. 2015
! We follow implicit type rules REAL(A-H,O-Z), INTEGER(I-N)

! Start by including the data (file generated from matlab
! with custom script)
     INCLUDE 'CEI_DATA.f90'
! Typical variable declarations found in the include (together with data)
!    INTEGER N_HK, N_RT, N_TPPT
!    REAL, DIMENSION(1,11) :: HK_RANGE
!    REAL, DIMENSION(1,11) :: RT_RANGE
!    REAL, DIMENSION(1,11) :: TPPT_RANGE
!    REAL, DIMENSION(11,11,11) :: CEI_TABLE

! Define CEI evaluation point
     HK   = 2.0
     RT   = 1000.0
     TPPT = 0.5

      DO 100 I_HK=1,N_HK
        DO 200 I_RT=1,N_RT
          DO 300 I_TPPT=1,N_TPPT
              ! Write some output
              WRITE(*,1000) I_HK, I_RT, I_TPPT
              WRITE(*,1100) HK_RANGE(1,I_HK) , RT_RANGE(1,I_RT), TPPT_RANGE(1,I_TPPT)
 300      CONTINUE
 200    CONTINUE
 100  CONTINUE

 1000 FORMAT('I_HK=', I12  , '   I_RT=', I12  , '   I_TPPT=', I12)
 1100 FORMAT('  HK=', F12.4, '     RT=', F12.1, '     TPPT=', F12.4)

END PROGRAM


*DECK CDIV
      SUBROUTINE CDIV (AR, AI, BR, BI, CR, CI)
C***BEGIN PROLOGUE  CDIV
C***SUBSIDIARY
C***PURPOSE  Compute the complex quotient of two complex numbers.
C***LIBRARY   SLATEC
C***TYPE      COMPLEX (CDIV-C)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     Complex division, (CR,CI) = (AR,AI)/(BR,BI)
C
C***SEE ALSO  EISDOC
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   811101  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  CDIV
      REAL AR,AI,BR,BI,CR,CI
C
      REAL S,ARS,AIS,BRS,BIS
C***FIRST EXECUTABLE STATEMENT  CDIV
      S = ABS(BR) + ABS(BI)
      ARS = AR/S
      AIS = AI/S
      BRS = BR/S
      BIS = BI/S
      S = BRS**2 + BIS**2
      CR = (ARS*BRS + AIS*BIS)/S
      CI = (AIS*BRS - ARS*BIS)/S
      RETURN
      END


      subroutine tcalc (x,y,t,n)
C...subroutine     tcalc     01/09/73
C...subroutine     tcalc     01/09/78
      dimension x(n),y(n),t(n)
      t(1)=1.
      t(2)=2.
      dx=x(2)-x(1)
      dy=y(2)-y(1)
      dz=dx*dx+dy*dy
      if (dz.eq.0.) goto 3
      do 2 i=3,n
      dx=x(i)-x(i-1)
      dy=y(i)-y(i-1)
   2  t(i)=t(i-1)+sqrt((dx*dx+dy*dy)/dz)
   3  return
      end


c***************************************************************
c  F-K: @(#) haskell.f			1.0 4/29/2000
c
c  Copyright (c) 2000 by L. Zhu
c  See README file for copying and redistribution conditions.
c
c  this file contains subroutines for computing Haskell propagator
c  matrix and other related subroutines
c	haskell()	compute the Haskell matrix
c	propagateZ()	apply the Haskell matrix to the Z matrix
c	layerParameter() compute some parameters for this layer
c       sh_ch()		compute Cosh(x), Sinh(x)/x, and x*Sinh(x)
c***************************************************************

      subroutine haskellMatrix(a)
c***************************************************************
c compute 4x4 Haskell a for the layer, the layer parameter
c is passed in by common /layer/.
c a(5,5) is for SH because the SH compound matrix is scaled by exb
c***************************************************************
      complex*16 a(5,5)
      include 'layer.h'
c due to the scaling in compound matrix, we have to scale a with exa*exb
      Ca = Ca*exb
      Xa = Xa*exb
      Ya = Ya*exb
      Cb = Cb*exa
      Yb = Yb*exa
      Xb = Xb*exa
c for p-sv, form the 4x4 haskell matrix (p381, Haskell, 1964)
      a(1,1) = r*(Ca-r1*Cb)
      a(1,2) = r*(r1*Ya-Xb)
      a(1,3) = (Cb-Ca)*r/mu2
      a(1,4) = (Xb-Ya)*r/mu2
      a(2,1) = r*(r1*Yb-Xa)
      a(2,2) = r*(Cb-r1*Ca)
      a(2,3) = (Xa-Yb)*r/mu2
      a(2,4) =-a(1,3)
      a(3,1) = mu2*r*r1*(Ca-Cb)
      a(3,2) = mu2*r*(r1*r1*Ya-Xb)
      a(3,3) = a(2,2)
      a(3,4) =-a(1,2)
      a(4,1) = mu2*r*(r1*r1*Yb-Xa)
      a(4,2) =-a(3,1)
      a(4,3) =-a(2,1)
      a(4,4) = a(1,1)
c for sh, the a is scaled by exb (in compound.f too)
      a(5,5) = exb
      return
      end

      subroutine propagateZ(z)
c***************************************************************
c  apply the Haskell matrix to Z matrix
c	Z = Z*a
c***************************************************************
      include 'constants.h'
      integer i, j, l
      complex*16 z(3,6), a(5,5), temp(4)

      call haskellMatrix(a)

      do i = 1, 3
c p-sv
         do j = 1, 4
            temp(j) = zero
            do l = 1, 4
               temp(j) = temp(j) + z(i,l)*a(l,j)
            enddo
         enddo
         do j = 1, 4
            z(i,j) = temp(j)
         enddo
c sh, could be used only once (for S*X) if not for the exb factor
         z(i,5) = z(i,5)*a(5,5)
      enddo
      return
      end

      subroutine layerParameter(k, lay)
c***************************************************************
c compute some parameters for this layer
c	IN:
c		k   --- wave-number square
c		lay --- layer number
c		volocity model passed in common/model/
c	Out:
c		common/layer/
c called by: kernel()		in kernel.f
c***************************************************************
      integer	lay
      real	k
      real*8	k2
      complex*16	kka, kkb
      include 'layer.h'
      include 'model.h'
      k2 = k*k
      kka = ka(lay)/k2
      kkb = kb(lay)/k2
      r = two/kkb
      kd = k*d(lay)
      mu2 = rho(lay)*r
c in above, because we don't have w, we use mu*(w/k)^2 instead of mu,
c the (w/k)^2 was corrected later in kernel.f and fk.f
      ra = zsqrt(one - kka)
      rb = zsqrt(one - kkb)
      r1 = one - one/r
      return
      end

      subroutine sh_ch(c,y,x,ex,a,kd)
c***************************************************************
c compute c=cosh(a*kd); y=sinh(a*kd)/a; x=sinh(a*kd)*a
c and multiply them by ex=exp(-Real(a*kd)) to supress overflow
c
c called by: compoundMatrix()		in compound.f
c***************************************************************
      complex*16 c,y,x,a
      real*8 kd,r,i,ex
      y = kd*a
      r = dreal(y)
      i = dimag(y)
      ex = dexp(-r)
      y = 0.5d0*dcmplx(dcos(i),dsin(i))
      x = ex*ex*dconjg(y)
      c = y + x
      x = y - x
      y = x/a
      x = x*a
      return
      end


      subroutine init_rpi(n_a1,n_alpha,n_beta,n_rPHI,n_rpsidot,Nx,res)
      implicit none
      integer i
      integer Nx
      real*8 n_a1(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_rPHI(Nx)
      real*8 n_rpsidot(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=1, Nx, 1
      qb = n_a1(i) / n_alpha(i) * (n_rpsidot(i) - 0.1D1 * n_beta(i) * n_
     #rPHI(i))
      res(i)=qb
      end do
      END


! ****************************************************
!    setsvalslice.f90 for smadrzmet
!  13  Aug. 2017    written by D.KAWATA
! ****************************************************

subroutine setsvalslice(np,nx,ny,xl,xh,yl,yh,nsmapval,flag3d,zsl,fval)
      use gcdp_const
      use gcdp_system
      use gcdp_kernel
      use smap_particle

      implicit none
      include 'mpif.h'

      integer,intent(in) :: np,nx,ny,nsmapval,flag3d
      double precision,intent(in) :: xl,xh,yl,yh,zsl
      double precision,intent(inout) :: fval(0:nx-1,0:ny-1,0:nsmapval-1)

      integer ierr
! parallerise along x-axis
      integer ixs,ixe
      double precision dx,dy,xmesh,ymesh
! for work
      integer i,j,k,pn
      integer is
      double precision xij,yij,zij,rij,hsi,ihsi,s,wij,sdencgs
! mesh data point
      integer ixm0,ixm1,iym0,iym1
      double precision xsm,xem,ysm,yem
      double precision xpm,ypm,zpm
! for MPI work
      integer ntm,nc,nct
      double precision,allocatable :: tdvs(:),tdvr(:)

!     write(6,*) ' xl,xh,yl,yh=',xl,xh,yl,yh

! assign x,y position
      dx=(xh-xl)/dble(nx)
      dy=(yh-yl)/dble(ny)

! at the start and end point of mesh for x and y
      xsm=xl+0.5d0*dx
      xem=xh-0.5d0*dx
      ysm=yl+0.5d0*dy
      yem=yh-0.5d0*dy

      nc=0
      if(myrank.eq.0) then
        write(6,*) ' np in setsval=',np
      endif
!        write(6,*) myrank,hm,xl,xh,yl,yh
      do pn=0,np-1
! output contributing particles
!            write(60,'(2(1pE13.5))') xp(pn),yp(pn)
! x
!        write(6,*) ' pn, x, h, xsm=',pn,xsp(pn),hsp(pn),xsm,dx

        ixm0=(xsp(pn)-hsp(pn)-xsm)/dx
        if(ixm0.lt.0) then
          ixm0=0
        else if(ixm0.gt.nx-1) then
          ixm0=nx-1
        endif
        ixm1=(xsp(pn)+hsp(pn)-xsm)/dx
        if(ixm1.lt.0) then
          ixm1=0
        else if(ixm1.gt.nx-1) then
          ixm1=nx-1
        endif
! y
        iym0=(ysp(pn)-hsp(pn)-ysm)/dy
        if(iym0.lt.0) then
          iym0=0
        else if(iym1.gt.ny-1) then
          iym0=ny-1
        endif
        iym1=(ysp(pn)+hsp(pn)-ysm)/dy
        if(iym1.lt.0) then
          iym1=0
        else if(iym1.gt.ny-1) then
          iym1=ny-1
        endif
        do j=iym0,iym1
          ypm=yl+0.5d0*dy+dble(j)*dy
          do i=ixm0,ixm1
            xpm=xl+0.5d0*dx+dble(i)*dx
! *** smooth the values ***
            xij = xsp(pn)-xpm
            yij = ysp(pn)-ypm
            zij = zsp(pn)-zsl
            rij=dsqrt(xij**2+yij**2+zij**2)
            hsi=hsp(pn)
            if(rij.lt.hsi) then
              ihsi=1.0d0/hsi
              s=rij*ihsi
              is=int(s*dnktab)
              if(is.lt.0) then
                is=0
              else if(is.ge.NKTAB) then
                is=NKTAB-1
              endif
              wij=w_tb(is)+(w_tb(is+1)-w_tb(is))*(s-s_tb(is))*dnktab
              if(flag3d.le.0) then
                wij=wij*(ihsi**3)
              else
! 2D
                wij=wij*(ihsi**2)
              endif
! ***  0:m, 1:vx, 2:vy, 3:vz, 4:p, 5:T, 6:mH, 7:Z
              fval(i,j,0)=fval(i,j,0)+wij*masssp(pn)
              fval(i,j,1)=fval(i,j,1)+wij*vxsp(pn)
              fval(i,j,2)=fval(i,j,2)+wij*vysp(pn)
              fval(i,j,3)=fval(i,j,3)+wij*vzsp(pn)
              fval(i,j,4)=fval(i,j,4)+wij*psp(pn)
              fval(i,j,5)=fval(i,j,5)+wij*tempsp(pn)
              fval(i,j,6)=fval(i,j,6)+wij*mhsp(pn)
              fval(i,j,7)=fval(i,j,7)+wij*metsp(pn)
              nct=nct+1
            endif
          enddo
        enddo
      enddo
      nct=0
      call MPI_ALLREDUCE(nc,nct,1,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,ierr)
      if(myrank.eq.0) then
        write(6,*) ' # of contributing particles=',nct
      endif
!      close(60)

! sum up
      if(nprocs.gt.1) then
        ntm=nx*ny
        allocate(tdvs(0:ntm-1))
        allocate(tdvr(0:ntm-1))

        do k=0,nsmapval-1
          nc=0
          do j=0,ny-1
            do i=0,nx-1
              tdvs(nc)=fval(i,j,k)
              tdvr(nc)=0.0d0
              nc=nc+1
            enddo
          enddo
          call MPI_ALLREDUCE(tdvs,tdvr,ntm,MPI_DOUBLE_PRECISION &
           ,MPI_SUM,MPI_COMM_WORLD,ierr)
          nc=0
          do j=0,ny-1
            do i=0,nx-1
              fval(i,j,k)=tdvr(nc)
              nc=nc+1
            enddo
          enddo
        enddo

        deallocate(tdvr)
        deallocate(tdvs)

      endif

end subroutine


module conversion_mod

  use real_type_mod
  use variables_mod
  use parameters_mod
  use master_function_mod

  implicit none

contains

  subroutine compute_scalars_pt(n_up, n_down, n_sqd)

    real(kind=wp), dimension(NF, NV), intent(in) :: n_up, n_down
    real(kind=wp), dimension(NFF), intent(out) :: n_sqd

    integer :: f1, f2, f, k

!!$    The scalars are -n^2. The first NF are the n_x^2; the rest are in
!!$    standard lexicographic order

    do f = 1, NF
      n_sqd(f) = -n_up(f, 1) * n_down(f, 1)
      do k = 2, NV
        n_sqd(f) = n_sqd(f) - n_up(f, k) * n_down(f, k)
      end do
    end do
    f = NF
    do f1 = 1, NF
      do f2 = f1 + 1, NF
        f = f + 1
        n_sqd(f) = -n_up(f1, 1) * n_down(f2, 1)
        do k = 2, NV
          n_sqd(f) = n_sqd(f) - n_up(f1, k) * n_down(f2, k)
        end do
      end do
    end do

  end subroutine compute_scalars_pt

  subroutine compute_scalars(n_up, n_down, n_sqd)

    real(kind=wp), dimension(NF, NV, 1-gz:np+gz), intent(in) :: n_up, n_down
    real(kind=wp), dimension(NFF, 1-gz:np+gz), intent(out) :: n_sqd

    integer :: i

!!$    Use local routine
    do i = 1-gz, np+gz
      call compute_scalars_pt(n_up(:, :, i), n_down(:, :, i), n_sqd(:, i))
    end do

  end subroutine compute_scalars

  subroutine compute_mu_down_pt(n_down, n_sqd, mu_down)

    real(kind=wp), dimension(NF, NV), intent(in) :: n_down
    real(kind=wp), dimension(NFF), intent(in) :: n_sqd
    real(kind=wp), dimension(NF, NV), intent(out) :: mu_down

    real(kind=wp), dimension(NFF) :: dLdn

    integer :: f, f1, f2

!!$    Compute the derivatives of the master function
    call MasterFunction_Derivs(n_sqd, dLdn)

!!$    Compute conjugate momenta
    mu_down = 0_wp
!!$    Bulk terms (B^x)
    do f = 1, NF
      mu_down(f, :) = -2.0_wp * dLdn(f) * n_down(f, :)
    end do
!!$    Other terms (A^{xy})
    f = NF
    do f1 = 1, NF
      do f2 = f1 + 1, NF
        f = f + 1
        mu_down(f1, :) = mu_down(f1, :) - dLdn(f) * n_down(f2, :)
        mu_down(f2, :) = mu_down(f2, :) - dLdn(f) * n_down(f1, :)
      end do
    end do

  end subroutine compute_mu_down_pt

  subroutine all_from_n_up_pt(n_up, n_down, mu_up, mu_down, n_sqd)

    real(kind=wp), dimension(NF, NV), intent(in) :: n_up
    real(kind=wp), dimension(NF, NV), intent(out) :: &
         n_down, mu_up, mu_down
    real(kind=wp), dimension(NFF), intent(out) :: n_sqd

    integer :: i, f, f1, f2

!!$    Use the metric to compute n_down
    n_down(:, 1)    = -n_up(:, 1)
    n_down(:, 2:NV) =  n_up(:, 2:NV)

!!$    Compute the scalars (-n^2)
    call compute_scalars_pt(n_up, n_down, n_sqd)

!!$    Compute the conjugate momenta.
    call compute_mu_down_pt(n_down, n_sqd, mu_down)

!!$    Compute mu_up for completeness
    mu_up(:, 1)    = -mu_down(:, 1)
    mu_up(:, 2:NV) =  mu_down(:, 2:NV)

  end subroutine all_from_n_up_pt

  subroutine all_from_n_up(n_up, n_down, mu_up, mu_down, n_sqd)

    real(kind=wp), dimension(NF, NV, 1-gz:np+gz), intent(in) :: n_up
    real(kind=wp), dimension(NF, NV, 1-gz:np+gz), intent(out) :: &
         n_down, mu_up, mu_down
    real(kind=wp), dimension(NFF, 1-gz:np+gz), intent(out) :: n_sqd

    integer :: i

!!$    Use the local routine
    do i = 1-gz, np+gz
      call all_from_n_up_pt(n_up(:, :, i), n_down(:, :, i), &
           mu_up(:, :, i), mu_down(:, :, i), n_sqd(:, i))
    end do

  end subroutine all_from_n_up

  subroutine all_from_evolved_pt(q, n_up, n_down, mu_up, mu_down, n_sqd)

    use local_cons_mod

    real(kind=wp), dimension(NEVOLVE), intent(in) :: q
    real(kind=wp), dimension(NF, NV), intent(out) :: n_up, n_down, &
         mu_up, mu_down
    real(kind=wp), dimension(NFF), intent(inout) :: n_sqd

    integer :: f, f1, f2, k

    real(kind=wp) :: tol = 1.d-10
    integer :: info
    real(kind=wp), dimension(LWA) :: wa

    integer, dimension(NF) :: ipiv
    real(kind=wp), dimension(NFF) :: dLdn
    real(kind=wp), dimension(NF, NF) :: A
    real(kind=wp), dimension(NF) :: b
    real(kind=wp), dimension(NFF) :: f_err
    real(kind=wp), dimension(NFF, NFF) :: f_jac

!!$    Set the local_cons variable for the external routines
    do f = 1, NF
      local_cons(f, 1) = q(f)
      local_cons(f, 2) = q(NF + f)
    end do

!!$    The first NF evolved variables are timelike components of n_up
    n_up(:, 1) = q(1:NF)

!!$    Initial guesses for the scalars; that they are the squares of
!!$    the timelike components of n
    do f = 1, NF
!!$      Do not let the guess jump too much
      if (n_up(f, 1)**2 < 2.0_wp * n_sqd(f)) then
        n_sqd(f) = n_up(f, 1)**2 - mu_down(f, 2)**2
      end if
    end do
    f = NF
    do f1 = 1, NF
      do f2 = f1 + 1, NF
        f = f + 1
        if (n_up(f1, 1) * n_up(f2, 1) < 2.0_wp * n_sqd(f)) then
          n_sqd(f) = n_up(f1, 1) * n_up(f2, 1) - mu_down(f1, 2) * mu_down(f2, 2)
        end if
      end do
    end do

!!$  We have to try and find the correct values of the scalars.
!!$  This requires a multi-dimensional root find.
    call hybrd1(Cons2PrimFn, NFF, n_sqd, f_err, tol, info, wa, LWA)
!!$    The minpack procedure complains if the tolerance requested is
!!$    too tight (info=3), and says if it thinks the solution is fine
!!$    and within the tolerance (info=1); all others should be errors
    if ((info .ne. 1).and.(info .ne. 3)) then
      write(*,*) 'hybrd1 call failed'
      write(*,*) 'Error in ''all_from_evolved_pt'''
      write(*,*) 'Error is ', info
      write(*,*) n_sqd
      write(*,*) n_up
      write(*,*) mu_down
      write(*,*) local_cons
      stop
    end if

!!$  We now know the values of the scalars -
!!$  find the terms depending on the master function
    call MasterFunction_Derivs(n_sqd, dLdn)

!!$  Now define the matrix equation A x = b and invert;
!!$  solution is in b
    do f = 1, NF
      A(f, f) = -2.0_wp * dLdn(f)
      b(f) = local_cons(f, 2)
    end do
    f = NF
    do f1 = 1, NF
      do f2 = f1 + 1, NF
        f = f + 1
        A(f1, f2) = - dLdn(f)
        A(f2, f1) = - dLdn(f)
      end do
    end do
    call dgesv(NF, 1, A, NF, ipiv, b, NF, info)
    if (info .ne. 0) then
      write(*,*) 'dgesv call failed'
      write(*,*) 'Error in ''all_from_n_up'''
      write(*,*) 'Error is ', info
      stop
    end if
    n_up(:, 2) = b

!!$    We now have the complete n_up vector; find all the rest

    call all_from_n_up_pt(n_up, n_down, mu_up, mu_down, n_sqd)

  end subroutine all_from_evolved_pt

  subroutine Cons2PrimFn(NF_NF, n_sqd, f_err, iflag)

    use local_cons_mod

!!$  This argument is required by the minpack routines. However, as we
!!$  already have this through the module, we never use it
    integer, intent(in) :: NF_NF

    integer :: iflag
    real(kind=wp), dimension(NFF) :: n_sqd, new_n_sqd, f_err

    real(kind=wp), dimension(NFF) :: dLdn
    real(kind=wp), dimension(NF, NF) :: A
    real(kind=wp), dimension(NF) :: b

    integer :: info
    integer, dimension(NF) :: ipiv

    integer :: f, f1, f2

!!$  Given the scalars (and through the external module the conserved
!!$  variables; in particular, the spatial components of the conserved
!!$  variables, which are the spatial components of the conjugate
!!$  momenta) we can compute the master function, and in particular its
!!$  derivatives (dLdn). From that we can write the conjugate momenta
!!$  as a matrix (A) times the spatial components of n. Solving this linear
!!$  system gives n. From n we compute the scalars, and hence an error in
!!$  the initial guess for the scalars

!!$    Check if any guess for n_sqd is unphysical (negative); if so, exit
    if (any(n_sqd < 0.0_wp)) then

      f_err = 1.d10

    else

      call MasterFunction_Derivs(n_sqd, dLdn)

!!$  Now define the matrix equation A x = b and invert;
!!$  solution is in b
      do f = 1, NF
        A(f, f) = -2.0_wp * dLdn(f)
        b(f) = local_cons(f, 2)
      end do
      f = NF
      do f1 = 1, NF
        do f2 = f1 + 1, NF
          f = f + 1
          A(f1, f2) = - dLdn(f)
          A(f2, f1) = - dLdn(f)
        end do
      end do
      call dgesv(NF, 1, A, NF, ipiv, b, NF, info)
      if (info .ne. 0) then
        write(*,*) 'dgesv call failed'
        write(*,*) 'Error in ''Con2PrimFn'''
        write(*,*) 'Error is ', info
        write(*,*) 'A', A
        write(*,*) 'b', b
        write(*,*) 'local_cons', local_cons
        write(*,*) 'n_sqd', n_sqd
        stop
      end if

!!$  The newly computed n is placed in b; find the new scalars
!!$  Note that the timelike component of n is given by the timelike
!!$  component of the conserved variables

!!$    Should write this out generally

      new_n_sqd(1) = local_cons(1, 1) * local_cons(1, 1) - b(1) * b(1)
      new_n_sqd(2) = local_cons(2, 1) * local_cons(2, 1) - b(2) * b(2)
      new_n_sqd(3) = local_cons(1, 1) * local_cons(2, 1) - b(1) * b(2)

      f_err = n_sqd - new_n_sqd

    end if

  end subroutine Cons2PrimFn

  subroutine Cons2PrimFnJac(NF_NF, n_sqd, f_err, f_jac, NF_NF_NF, iflag)

    use local_cons_mod

!!$  This argument is required by the minpack routines. However, as we
!!$  already have this through the module, we never use it
    integer, intent(in) :: NF_NF, NF_NF_NF

    integer :: iflag
    real(kind=wp), dimension(NFF) :: n_sqd, new_n_sqd, f_err
    real(kind=wp), dimension(NFF, NFF) :: f_jac

    real(kind=wp), dimension(NFF) :: dLdn
    real(kind=wp), dimension(NF, NF) :: A
    real(kind=wp), dimension(NF) :: b

    integer :: info
    integer, dimension(NF) :: ipiv

    integer :: f, f1, f2

!!$  Given the scalars (and through the external module the conserved
!!$  variables; in particular, the spatial components of the conserved
!!$  variables, which are the spatial components of the conjugate
!!$  momenta) we can compute the master function, and in particular its
!!$  derivatives (dLdn). From that we can write the conjugate momenta
!!$  as a matrix (A) times the spatial components of n. Solving this linear
!!$  system gives n. From n we compute the scalars, and hence an error in
!!$  the initial guess for the scalars

    if (iflag .eq. 1) then ! Compute the function, not the Jacobian

!!$    Check if any guess for n_sqd is unphysical (negative); if so, exit
      if (any(n_sqd < 0.0_wp)) then

        f_err = 1.d10

      else

        call MasterFunction_Derivs(n_sqd, dLdn)

!!$  Now define the matrix equation A x = b and invert;
!!$  solution is in b
        do f = 1, NF
          A(f, f) = -2.0_wp * dLdn(f)
          b(f) = local_cons(f, 2)
        end do
        f = NF
        do f1 = 1, NF
          do f2 = f1 + 1, NF
            f = f + 1
            A(f1, f2) = - dLdn(f)
            A(f2, f1) = - dLdn(f)
          end do
        end do
        call dgesv(NF, 1, A, NF, ipiv, b, NF, info)
        if (info .ne. 0) then
          write(*,*) 'dgesv call failed'
          write(*,*) 'Error in ''Con2PrimFn'''
          write(*,*) 'Error is ', info
          write(*,*) 'A', A
          write(*,*) 'b', b
          write(*,*) 'local_cons', local_cons
          write(*,*) 'n_sqd', n_sqd
          stop
        end if

!!$  The newly computed n is placed in b; find the new scalars
!!$  Note that the timelike component of n is given by the timelike
!!$  component of the conserved variables

!!$    Should write this out generally

        new_n_sqd(1) = local_cons(1, 1) * local_cons(1, 1) - b(1) * b(1)
        new_n_sqd(2) = local_cons(2, 1) * local_cons(2, 1) - b(2) * b(2)
        new_n_sqd(3) = local_cons(1, 1) * local_cons(2, 1) - b(1) * b(2)

        f_err = n_sqd - new_n_sqd

      end if

    else if (iflag .eq. 2) then ! Compute Jacobian

      f_jac = 0_wp
      write(*, *) 'Do not know how to compute Jacobian yet'
      stop

    else

      write(*,*) 'Do not understand iflag value in Cons2PrimFnJac', iflag

    end if

  end subroutine Cons2PrimFnJac

end module conversion_mod


      SUBROUTINE SPLINE_CENTER(IBUF,LONG,NN,INCR,CEN,EXTR,NUM,*)
      INTEGER*2 IBUF(1),IMAX,IA,IB,IC,ID,IS
C
C-----LOCAL EXTREMUM OF IBUF COMPUTED FROM CUBIC SPLINES:
C-----ON ENTRY N DEFINES AN INITIAL GUESS OF POSITION,
C-----ON EXIT N CONTAINS THE NEXT LOWER PIXEL POSITION.
C-----FOR MULTIDIMENSIONAL CENTERING, INCR DEFINES THE
C-----DIRECTION OF THE SEARCH.
C-----CEN OBTAINS THE FRACTIONAL DISTANCE FROM N, AND
C-----EXTR IS THE INTERPOLATED MAXIMUM (NUM>0) OR MINIMUM
C-----(NUM<0). ABS(NUM) DETERMINES THE INCREMENTAL EXTENSION
C-----OF THE SEARCH.
      IS=ISIGN(1,NUM)
      IMAX=-30000
      NDIF=IABS(NUM)*INCR
      N=NN
C
   10 I1=N-NDIF
      I2=N+NDIF
      IF (I1.LT.1 .OR. I2.GT.LONG) RETURN 1
      DO 20 I=I1,I2,INCR
      IB=IS*IBUF(I)
      IF (IB.GT.IMAX) THEN
      N=I
      IMAX=IB
      END IF
   20 CONTINUE
      IF (N.EQ.I1 .OR. N.EQ.I2) RETURN 1
C
      IF (ISIGN(1,IBUF(N-INCR)-IBUF(N+INCR)).EQ.IS) N=N-INCR
      IA=IBUF(N-INCR)
      IB=IBUF(N)
      IC=IBUF(N+INCR)
      ID=IBUF(N+INCR+INCR)
      A=IS*(12.*IC-2.*ID-3.*IB-7.*IA)/15.
      B=IS*(6.*IC-ID-9.*IB+4.*IA)/5.
      C=IS*(IB-IC+(ID-IA)/3.)
      IF (C.EQ..0) THEN
      CEN=-.5*A/B
      ELSE IF (B.EQ..0) THEN
      CEN=SQRT(-A/C/3.)
      ELSE
      D=-B/C/3.
      E=SQRT(D*D-A/C/3.)
      CEN=D+E
      IF (CEN.GT.1.) CEN=D-E
      END IF
      EXTR=IB+IS*CEN*(A+CEN*(B+CEN*C))
      NN=N
C
      RETURN
      END


    SUBROUTINE CYCREMFLUX
    use setup2d
    IMPLICIT NONE
    include 'mpif.h'

    integer :: icright,faml
    integer :: ifacelc
    integer :: ifpl,jfpl,ifpr,jfpr,ic,sp,ifinter,sign_l,sign_r
    integer :: nfp,mfp,count
    integer :: k,MLENGTH,mfprm,nfprm,M,IB
    INTEGER :: TAG,DEST,SOURCE,IC2,ivar
    INTEGER :: REQHANDLE(NCYCREM),ISTAT(MPI_STATUS_SIZE,NCYCREM)

    double precision,dimension(9)  :: Qs,Qfl,Qfr
    double precision,dimension(8) :: Fnl,Fnr
    double precision, dimension(2) :: normf
    double precision                :: eigv,Az
    double precision, dimension(:,:),allocatable :: RBUFC, SBUFC

    MLENGTH = N*numv

    allocate(RBUFC(MLENGTH,NCYCREM))
    allocate(SBUFC(MLENGTH,NCYCREM))

    ! FIRST POST NON-BLOCKING RECEIVES

    do IB=1,NCYCREM
        K = IBFCYCREM(IB)
        TAG = K
        SOURCE=CYCREM2PROC(IB)
        CALL MPI_IRECV(RBUFC(1,IB),MLENGTH,MPI_DOUBLE_PRECISION,SOURCE,TAG,&
        MPI_COMM_WORLD,REQHANDLE(IB),IERROR)
    end do

    ! Then loop over faces and send Qfl

    do IB=1,NCYCREM
        K= IBFCYCREM(IB)
        ic = IF2C(K,1)
        ifacelc = IF2C(K,3)
        faml = mod(ifacelc,2) + 1

        TAG = CYCREM2F_PROC(IB)
        DEST = CYCREM2PROC(IB)
        M = 1

        do nfp=1,N
            ifpl = iface2fp(nfp,ifacelc)
            jfpl = jface2fp(nfp,ifacelc)

            Qfl_c(1:9,nfp,IB) = 0.d0

            if(faml==1) then
                do sp=1,N
                Qs(1:9) = Q(1:9,sp,jfpl,ic)
                Qfl_c(1:9,nfp,IB) = Qfl_c(1:9,nfp,IB) + Qs(1:9)*Lmat(ifpl,sp)
                end do
            else
                do sp=1,N
                Qs(1:9) = Q(1:9,ifpl,sp,ic)
                Qfl_c(1:9,nfp,IB) = Qfl_c(1:9,nfp,IB) + Qs(1:9)*Lmat(jfpl,sp)
                end do
            end if

            do ivar = 1,9
                SBUFC(M+ivar-1,IB) = Qfl_c(ivar,nfp,IB)
            end do

            M=M+9
        end do  ! do loop over points on interface

        ! Now send the buffer
        CALL MPI_SEND(SBUFC(1,IB),MLENGTH,MPI_DOUBLE_PRECISION,DEST,TAG,&
        MPI_COMM_WORLD,IERROR)

    end do  ! do loop over processor interface faces

    ! ----------------------------------------------------------
    CALL MPI_WAITALL(NCYCREM,REQHANDLE,ISTAT,IERROR)
    ! ------------------------------------------------------------

    ! Now receive the information and store in appropriate Qfr

    do IB=1,NCYCREM
        M = 1
        ! Loop over remote values of and nfp
        do nfprm=1,N

            nfp = N+1-nfprm
            ! Now we have all the left information
            ! Need to receive Qfr
            do ivar = 1,9
                Qfr_c(ivar,nfp,IB) = RBUFC(M+ivar-1,IB)
            end do

            M=M+9
        end do
    end do
    ! -----------------------------------------------------
    ! Now that we have Qfl and Qfr, we can call getrusanov
    ! -----------------------------------------------------

    do IB=1,NCYCREM
        K= IBFCYCREM(IB)
        ic  = IF2C(K,1)

        ifacelc = IF2C(K,3)
        faml = mod(ifacelc,2) + 1

        do nfp=1,N

            ifpl = iface2fp(nfp, ifacelc)
            jfpl = jface2fp(nfp, ifacelc)
            sign_l =1

            if(faml==1) then
                normf(1:2) = S1(1,1:2,ifpl,jfpl,ic)
                if(ifpl==1) sign_l=-1
            else
                normf(1:2) = S2(2,1:2,ifpl,jfpl,ic)
                if(jfpl==1) sign_l=-1
            end if

            ! Now we have all the left information

            sign_r = 1 ! don't care the right side

            Qfl(1:9) = Qfl_c(1:9,nfp,IB)
            Qfr(1:9) = Qfr_c(1:9,nfp,IB)

            CALL getrusanovflux(Qfl,Qfr,Fnl,Fnr,Az,&
            normf,sign_l,sign_r,eigv)

            if(faml==1) then
                F1(1:8,ifpl,jfpl,ic)  = Fnl(1:8)
                Azfi(ifpl,jfpl,ic) = Az
            else
                G2(1:8,ifpl,jfpl,ic)  = Fnl(1:8)
                Azfj(ifpl,jfpl,ic) = Az
            end if

            IF (vismode==1) Then
                if(faml==1) then
                    Qvfi(1:9,ifpl,jfpl,ic) = 0.5d0*Qfl(1:9) +0.5d0*Qfr(1:9)
                else
                    Qvfj(1:9,ifpl,jfpl,ic) = 0.5d0*Qfl(1:9) +0.5d0*Qfr(1:9)
                end if
            END IF
        end do  ! do loop over points on interface

    end do  ! do loop over processor interface faces

    deallocate(RBUFC)
    deallocate(SBUFC)

    END SUBROUTINE CYCREMFLUX

    SUBROUTINE CYCREMVISFLUX

    use setup2d

    IMPLICIT NONE
    include 'mpif.h'

    integer :: ifacelc,faml
    integer :: ifpl,jfpl,ic,iface,sp
    integer :: nfp,mfp
    integer :: k,MLENGTH,mfprm,nfprm,M,ivar
    INTEGER :: TAG,DEST,SOURCE,IC2
    INTEGER :: REQHANDLE(NCYCREM),ISTAT(MPI_STATUS_SIZE,NCYCREM)

    double precision, dimension(9)  :: Qs,Qfl,Qfr,Qfl2,Qfr2
    double precision, dimension(:,:),allocatable :: RBUF2C, SBUF2C

    MLENGTH = N*18

    allocate(RBUF2C(MLENGTH,NCYCREM))
    allocate(SBUF2C(MLENGTH,NCYCREM))

    do k=1,NCYCREM
        iface = IBFCYCREM(k)
        TAG = iface
        SOURCE=CYCREM2PROC(k)
        CALL MPI_IRECV(RBUF2C(1,K),MLENGTH,MPI_DOUBLE_PRECISION,SOURCE,TAG,&
        MPI_COMM_WORLD,REQHANDLE(k),IERROR)
    end do

    ! Then loop over faces and send Qfl,Qfl2

    do k=1,NCYCREM
        iface = IBFCYCREM(k)
        ic    = IF2C(iface,1)

        TAG = CYCREM2F_PROC(k)
        DEST = CYCREM2PROC(k)
        M = 1

        ifacelc = IF2C(iface,3)

        faml = mod(ifacelc,2) + 1

        do nfp=1,N

            ifpl = iface2fp(nfp,ifacelc)
            jfpl = jface2fp(nfp,ifacelc)

            Qfl_c(1:9,nfp,K) = 0.d0
            Qfl_c2(1:9,nfp,K) = 0.d0

            if(faml==1) then

                do sp=1,N
                    Qfl_c(1:9,nfp,K) = Qfl_c(1:9,nfp,K) &
                    + nablaQs(1:9,1,sp,jfpl,ic)*Lmat(ifpl,sp)
                    Qfl_c2(1:9,nfp,K) = Qfl_c2(1:9,nfp,K) &
                    + nablaQs(1:9,2,sp,jfpl,ic)*Lmat(ifpl,sp)
                end do

            else

                do sp=1,N
                    Qfl_c(1:9,nfp,K) = Qfl_c(1:9,nfp,K) &
                    + nablaQs(1:9,1,ifpl,sp,ic)*Lmat(jfpl,sp)
                    Qfl_c2(1:9,nfp,K) = Qfl_c2(1:9,nfp,K) &
                    + nablaQs(1:9,2,ifpl,sp,ic)*Lmat(jfpl,sp)
                end do

            end if

            do ivar = 1,9
                SBUF2C(M+ivar-1,K) = Qfl_c(ivar,nfp,K)
            end do

            M = M+9

            do ivar = 1,9
                SBUF2C(M+ivar-1,K) = Qfl_c2(ivar,nfp,K)
            end do

            M = M+9

        end do  ! do loop over points on interface,nfp

        ! Now send the buffer
        CALL MPI_SEND(SBUF2C(1,K),MLENGTH,MPI_DOUBLE_PRECISION,DEST,TAG,&
        MPI_COMM_WORLD,IERROR)

    end do  ! do loop over processor interface faces

    ! ----------------------------------------------------------
    CALL MPI_WAITALL(NCYCREM,REQHANDLE,ISTAT,IERROR)
    ! ------------------------------------------------------------

    ! Now receive the information and store in appropriate Qfr

    do k=1,NCYCREM
         M = 1
        ! Loop over remote values of mfp and nfp
        do nfprm=1,N

            nfp = N+1-nfprm
            ! Now we have all the left information
            ! Need to receive Qfr

            do ivar = 1,9
                Qfr_c(ivar,nfp,K) = RBUF2C(M+ivar-1,K)
            end do
            M = M+9

            do ivar = 1,9
                Qfr_c2(ivar,nfp,K) = RBUF2C(M+ivar-1,K)
            end do
            M = M+9

        end do
    end do

    ! -----------------------------------------------------
    ! Now that we have Qfl,Qfl2 and Qfr,Qfr2 we can calculate nablaQvf
    ! -----------------------------------------------------

    do k=1,NCYCREM
        iface   = IBFCYCREM(k)
        ic  = IF2C(iface,1)

        ifacelc = IF2C(iface,3)

        faml = mod(ifacelc,2) + 1

        do nfp=1,N

            ifpl = iface2fp(nfp,ifacelc)
            jfpl = jface2fp(nfp,ifacelc)

            Qfl(1:9)  = Qfl_c(1:9,nfp,K)
            Qfl2(1:9) = Qfl_c2(1:9,nfp,K)

            Qfr(1:9)  = Qfr_c(1:9,nfp,K)
            Qfr2(1:9) = Qfr_c2(1:9,nfp,K)

            if(faml==1) then

                nablaQvfi(1:9,1,ifpl,jfpl,ic) = &
                0.5*Qfl(1:9)+0.5*Qfr(1:9)
                nablaQvfi(1:9,2,ifpl,jfpl,ic) = &
                0.5*Qfl2(1:9)+0.5*Qfr2(1:9)

            else

                nablaQvfj(1:9,1,ifpl,jfpl,ic) = &
                0.5*Qfl(1:9)+0.5*Qfr(1:9)
                nablaQvfj(1:9,2,ifpl,jfpl,ic) = &
                0.5*Qfl2(1:9)+0.5*Qfr2(1:9)

            end if

        end do  ! do loop over points on interface, nfp

    end do  ! do loop over processor interface faces

    deallocate(RBUF2C)
    deallocate(SBUF2C)

    END SUBROUTINE CYCREMVISFLUX