#include <default_macro.h>

 module fluids_equilibrium_mod

!***********************************************************************
!
!     LBsoft module containing the equilibrium functions of the LB model
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification June 2020
!
!***********************************************************************

 use fluids_lattices_mod

 implicit none

 private

 public :: equil_pop00
 public :: equil_pop01
 public :: equil_pop02
 public :: equil_pop03
 public :: equil_pop04
 public :: equil_pop05
 public :: equil_pop06
 public :: equil_pop07
 public :: equil_pop08
 public :: equil_pop09
 public :: equil_pop10
 public :: equil_pop11
 public :: equil_pop12
 public :: equil_pop13
 public :: equil_pop14
 public :: equil_pop15
 public :: equil_pop16
 public :: equil_pop17
 public :: equil_pop18
 public :: equil_popCG
 public :: equil_popCG_corr

 contains

 pure function equil_pop00(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population zero
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop00

  real(kind=PRC) :: uv

  integer, parameter :: myl = 0

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

  equil_pop00=myrho*myp*(ONE-(HALF/mycssq)*(myu**TWO+myv**TWO+myw**TWO))

  return

 end function equil_pop00

 pure function equil_pop01(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population one
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop01

  real(kind=PRC) :: uv

  integer, parameter :: myl = 1

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myu*mydex)
  equil_pop01=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop01=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop01

 pure function equil_pop02(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population two
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop02

  real(kind=PRC) :: uv

  integer, parameter :: myl = 2

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myu*mydex)
  equil_pop02=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop02=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop02

 pure function equil_pop03(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population three
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop03

  real(kind=PRC) :: uv

  integer, parameter :: myl = 3

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myv*mydey)
  equil_pop03=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop03=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop03

 pure function equil_pop04(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population four
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop04

  real(kind=PRC) :: uv

  integer, parameter :: myl = 4

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myv*mydey)
  equil_pop04=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop04=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop04

 pure function equil_pop05(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population five
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop05

  real(kind=PRC) :: uv

  integer, parameter :: myl = 5

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myw*mydez)
  equil_pop05=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop05=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop05

 pure function equil_pop06(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population six
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop06

  real(kind=PRC) :: uv

  integer, parameter :: myl = 6

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myw*mydez)
  equil_pop06=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop06=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop06

 pure function equil_pop07(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population seven
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop07

  real(kind=PRC) :: uv

  integer, parameter :: myl = 7

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey)
  equil_pop07=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop07=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop07

 pure function equil_pop08(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population eight
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop08

  real(kind=PRC) :: uv

  integer, parameter :: myl = 8

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey)
  equil_pop08=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop08=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop08

 pure function equil_pop09(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population nine
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop09

  real(kind=PRC) :: uv

  integer, parameter :: myl = 9

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey)
  equil_pop09=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop09=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop09

 pure function equil_pop10(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population ten
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop10

  real(kind=PRC) :: uv

  integer, parameter :: myl = 10

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey)
  equil_pop10=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop10=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop10

 pure function equil_pop11(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population eleven
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop11

  real(kind=PRC) :: uv

  integer, parameter :: myl = 11

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myu*mydex + myw*mydez)
  equil_pop11=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop11=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop11

 pure function equil_pop12(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population twelve
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop12

  real(kind=PRC) :: uv

  integer, parameter :: myl = 12

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myu*mydex  + myw*mydez)
  equil_pop12=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop12=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop12

 pure function equil_pop13(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population thirteen
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop13

  real(kind=PRC) :: uv

  integer, parameter :: myl = 13

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myu*mydex + myw*mydez)
  equil_pop13=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop13=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop13

 pure function equil_pop14(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population fourteen
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop14

  real(kind=PRC) :: uv

  integer, parameter :: myl = 14

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myu*mydex + myw*mydez)
  equil_pop14=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop14=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop14

 pure function equil_pop15(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population fiveteen
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop15

  real(kind=PRC) :: uv

  integer, parameter :: myl = 15

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myv*mydey + myw*mydez)
  equil_pop15=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop15=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop15

 pure function equil_pop16(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population sixteen
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop16

  real(kind=PRC) :: uv

  integer, parameter :: myl = 16

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myv*mydey + myw*mydez)
  equil_pop16=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop16=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop16

 pure function equil_pop17(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population seventeen
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop17

  real(kind=PRC) :: uv

  integer, parameter :: myl = 17

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myv*mydey + myw*mydez)
  equil_pop17=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop17=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop17

 pure function equil_pop18(myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the population eighteen
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification July 2018
!
!***********************************************************************

  implicit none

  real(kind=PRC), intent(in) :: myrho,myu,myv,myw

  real(kind=PRC) :: equil_pop18

  real(kind=PRC) :: uv

  integer, parameter :: myl = 18

  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter :: myp = p(myl)

  real(kind=PRC), parameter :: mydex = dex(myl)
  real(kind=PRC), parameter :: mydey = dey(myl)
  real(kind=PRC), parameter :: mydez = dez(myl)

#if LATTICE==319
  uv=(ONE/mycssq)*(myv*mydey + myw*mydez)
  equil_pop18=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#else
  uv=(ONE/mycssq)*(myu*mydex + myv*mydey + myw*mydez)
  equil_pop18=myrho*myp*(ONE+uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))
#endif

  return

 end function equil_pop18

 pure function equil_popCG(myl,myomega,myalpha, &
  myrho,myu,myv,myw)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the populations in the Colour Gradient model
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification November 2019
!
!***********************************************************************

  implicit none

  integer, parameter :: mylinks=links
  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter, dimension(0:mylinks) :: myp=p
  real(kind=PRC), parameter, dimension(0:mylinks) :: mydex=dex
  real(kind=PRC), parameter, dimension(0:mylinks) :: mydey=dey
  real(kind=PRC), parameter, dimension(0:mylinks) :: mydez=dez
  real(kind=PRC), parameter, dimension(0:mylinks) :: myphi=phi_CG
  real(kind=PRC), parameter, dimension(0:mylinks) :: myvarphi=varphi_CG

  integer, intent(in) :: myl

  real(kind=PRC), intent(in) :: myalpha,myrho,myu,myv,myw,myomega

  real(kind=PRC) :: equil_popCG

  real(kind=PRC) :: uv

  integer :: i,j

  uv=(ONE/mycssq)*(myu*mydex(myl) + myv*mydey(myl) + myw*mydez(myl))
  equil_popCG=myrho*(myphi(myl)+myalpha*myvarphi(myl) + myp(myl)* &
                   (uv + HALF*(uv*uv) - (HALF/mycssq)*(myu**TWO + &
                   myv**TWO + myw**TWO)))

  return

 end function equil_popCG

 pure function equil_popCG_corr(myl,myomega,myalpha, &
  myrho,myu,myv,myw,gradx,grady,gradz)

!***********************************************************************
!
!     LBsoft function for Boltzmann equilibrium distribution
!     for the populations in the Colour Gradient model
!
!     licensed under the 3-Clause BSD License (BSD-3-Clause)
!     author: M. Lauricella
!     last modification November 2019
!
!***********************************************************************

  implicit none

  integer, parameter :: mylinks=links
  real(kind=PRC), parameter :: mycssq = cssq
  real(kind=PRC), parameter, dimension(0:mylinks) :: myp=p
  real(kind=PRC), parameter, dimension(0:mylinks) :: mydex=dex
  real(kind=PRC), parameter, dimension(0:mylinks) :: mydey=dey
  real(kind=PRC), parameter, dimension(0:mylinks) :: mydez=dez
  real(kind=PRC), parameter, dimension(0:mylinks) :: mypsi=psi_CG
  real(kind=PRC), parameter, dimension(0:mylinks) :: myxi=xi_CG
  real(kind=PRC), parameter, dimension(0:mylinks) :: myphi=phi_CG
  real(kind=PRC), parameter, dimension(0:mylinks) :: myvarphi=varphi_CG

  integer, intent(in) :: myl

  real(kind=PRC), intent(in) :: myalpha,myrho,myu,myv,myw, &
   gradx,grady,gradz,myomega

  real(kind=PRC) :: equil_popCG_corr

  real(kind=PRC) :: uv,mycontraction,dotugrad,myviscos
  real(kind=PRC), dimension(3) :: myvel,mygrad
  real(kind=PRC), dimension(3,3) :: tens_temp,tens_velgrad,tens_de

  integer :: i,j

  myvel(1)=myu
  myvel(2)=myv
  myvel(3)=myw
  mygrad(1)=gradx
  mygrad(2)=grady
  mygrad(3)=gradz

  tens_temp(1,1)=myvel(1)*mygrad(1)
  tens_temp(2,1)=myvel(2)*mygrad(1)
  tens_temp(3,1)=myvel(3)*mygrad(1)
  tens_temp(1,2)=myvel(1)*mygrad(2)
  tens_temp(2,2)=myvel(2)*mygrad(2)
  tens_temp(3,2)=myvel(3)*mygrad(2)
  tens_temp(1,3)=myvel(1)*mygrad(3)
  tens_temp(2,3)=myvel(2)*mygrad(3)
  tens_temp(3,3)=myvel(3)*mygrad(3)

  tens_velgrad(1,1)=(TWO*tens_temp(1,1))
  tens_velgrad(2,1)=(tens_temp(2,1)+tens_temp(1,2))
  tens_velgrad(3,1)=(tens_temp(3,1)+tens_temp(1,3))
  tens_velgrad(1,2)=(tens_temp(1,2)+tens_temp(2,1))
  tens_velgrad(2,2)=(TWO*tens_temp(2,2))
  tens_velgrad(3,2)=(tens_temp(3,2)+tens_temp(2,3))
  tens_velgrad(1,3)=(tens_temp(1,3)+tens_temp(3,1))
  tens_velgrad(2,3)=(tens_temp(2,3)+tens_temp(3,2))
  tens_velgrad(3,3)=(TWO*tens_temp(3,3))

  tens_de(1,1)=mydex(myl)*mydex(myl)
  tens_de(2,1)=mydey(myl)*mydex(myl)
  tens_de(3,1)=mydez(myl)*mydex(myl)
  tens_de(1,2)=mydex(myl)*mydey(myl)
  tens_de(2,2)=mydey(myl)*mydey(myl)
  tens_de(3,2)=mydez(myl)*mydey(myl)
  tens_de(1,3)=mydex(myl)*mydez(myl)
  tens_de(2,3)=mydey(myl)*mydez(myl)
  tens_de(3,3)=mydez(myl)*mydez(myl)

  mycontraction = tens_velgrad(1,1)*tens_de(1,1)+ &
                  tens_velgrad(2,1)*tens_de(2,1)+ &
                  tens_velgrad(3,1)*tens_de(3,1)+ &
                  tens_velgrad(1,2)*tens_de(1,2)+ &
                  tens_velgrad(2,2)*tens_de(2,2)+ &
                  tens_velgrad(3,2)*tens_de(3,2)+ &
                  tens_velgrad(1,3)*tens_de(1,3)+ &
                  tens_velgrad(2,3)*tens_de(2,3)+ &
                  tens_velgrad(3,3)*tens_de(3,3)

  dotugrad=dot_product(myvel,mygrad)
  myviscos=mycssq*(ONE / myomega - HALF)
  uv=(ONE/mycssq)*(myu*mydex(myl) + myv*mydey(myl) + myw*mydez(myl))
  equil_popCG_corr=myrho*(myphi(myl)+ &
   myvarphi(myl)*myalpha+myp(myl)*(uv+HALF*(uv*uv)-(HALF/mycssq)* &
   (myu**TWO+myv**TWO+myw**TWO))) + &
   myviscos*(mypsi(myl)*dotugrad + myxi(myl)*mycontraction)

  return

 end function equil_popCG_corr

 end module fluids_equilibrium_mod


! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!X
!X Functions Module
!X
!% The Functions Module contains useful subroutines and functions
!% to compute the Fermi occupation $n(E)$ of given energy levels,
!% and error functions.
!X
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
module functions_module

use System_module

implicit none
private

public erf, erfc
public :: f_Fermi, f_Fermi_deriv, smooth_cutoff

contains

!% Calculate the Fermi occupation for en energy level ('E'),
!% at a given temperature ('T'),
!% and chemical potential ('mu').
elemental function f_Fermi(mu, T, E)
  real(dp), intent(in) :: mu, T, E
  real(dp) :: f_Fermi

  if (abs(T) < 1.0e-10_dp) then
    if (E-mu < 0.0_dp) then
      f_Fermi = 1.0_dp
    else if (E-mu > 0.0_dp) then
      f_Fermi = 0.0_dp
    else
      f_Fermi = 0.5_dp
    endif
  else
    f_Fermi = 1.0_dp/(1.0_dp+exp((E-mu)/T))
  endif
end function f_Fermi

elemental function f_Fermi_deriv(mu, T, E)
  real(dp), intent(in) :: mu, T, E
  real(dp) :: f_Fermi_deriv

  real(dp) :: arg

  if (abs(T) < 1.0e-10_dp) then
    f_Fermi_deriv = 0.0_dp
  else
    arg = abs((E-mu)/T)
    f_Fermi_deriv = -1.0_dp/((1.0_dp+exp(-arg))**2 * exp(arg) * T)
  endif
end function f_Fermi_deriv

!| double precision function erf
!| calculate error function of argument
!| returns error function of argument
!|
!|I double precision x: argument
!|
!| Noam Bernstein 9/12/2001

double precision function erf(x)
implicit none
    double precision x

    if (x .lt. 0.0D0) then
	erf = -gammp_half(x*x)
    else
	erf = gammp_half(x*x)
    end if

end function

!| double precision function erfc
!| calculate error function complement of argument
!| returns error function complement of argument
!|
!|I double precision x: argument
!|
!| Noam Bernstein 9/12/2001

double precision function erfc(x)
implicit none
    double precision x

    if (x .lt. 0.0D0) then
	erfc = 1.0D0 + gammp_half(x*x)
    else
	erfc = gammq_half(x*x)
    end if
end function

!| double precision function gammp_half
!| calculate incomplete gamma p function of (0.5,x)
!| returns incomplete gamma p function of (0.5,x)
!|
!|I double precision x: argument
!|
!| Noam Bernstein 9/12/2001

double precision function gammp_half(x)
implicit none
    double precision x

    double precision Gamma_half ! = sqrt(pi)
    parameter ( Gamma_half = 1.77245385090552D0 )

    gammp_half = 2.0D0/Gamma_half * sqrt(x) * p_F0(x)

end function

!| double precision function gammq_half
!| calculate incomplete gamma q function (complement of gamma p) of (0.5,x)
!| returns incomplete gamma q function (complement of gamma p) of (0.5,x)
!|
!|I double precision x: argument
!|
!| Noam Bernstein 9/12/2001

double precision function gammq_half(x)
implicit none
    double precision x

    double precision Gamma_half ! = sqrt(pi)
    parameter ( Gamma_half = 1.77245385090552D0 )

    if (x .ne. 0) then
	gammq_half = 2.0D0/Gamma_half * sqrt(x) * p_F0C(x)
    else
	gammq_half = 1.0D0
    end if

end function

!| double precision function p_F0(x)
!| calculate F_m(x) for m=0 using FFFMT3
!| returns value of F_0(x)
!|
!|I double precision x: argument
!|
!| Noam Bernstein 9/13/2001

double precision function p_F0(x)
implicit none
    double precision x

    double precision xx(1)
    double precision s1(1,5)

    xx(1) = x
    call FFFMT3_F90(1, 1, xx, s1)

    p_F0 = s1(1,1)

end function

!| double precision function p_F0C(x)
!| calculate sqrt(pi/x)/2-F_m(x) for m=0 using FFFMT3C
!| returns value of sqrt(pi/x)/2-F_0(x)
!|
!|I double precision x: argument
!|
!| Noam Bernstein 9/13/2001

double precision function p_F0C(x)
implicit none
    double precision x

    double precision xx(1)
    double precision s1(1,5)

    xx(1) = x
    call FFFMT3C_F90(1, 1, xx, s1)

    p_F0C = s1(1,1)

end function

!| subroutine FFFMT3_F90(x)
!% Calculate $F_m(x)$ for $m=0$ using 'FFFMT3C'
!|
!|I integer MX, NPTS: maximum, actual number of pts to be evaluated
!|I double precision xx(NPTS): arguments
!|O double precision s1(NPTS,5): returned values
!|
!| Noam Bernstein 9/13/2001
!| From Mark Pederson's code

subroutine FFFMT3_F90(MX,NPTS,XX,S1)
! MODIFIED BY MARK R PEDERSON (1990)
! To FORTRAN 90 by Noam Bernstein
implicit none
    integer MX, NPTS
    double precision XX(MX),S1(MX,5)

    logical, save:: FIRST = .true.
    double precision, save:: F(10,1601)

    double precision ONEOVRI(5)
    double precision G(20)

    double precision:: ROOTPI = 1.77245385090551602728D0
    double precision:: ONEOVER3 = 1.0D0/3.0D0

    integer I, L, K, KK, IT, IPTS
    double precision T, X, DEN, TERM, SUM, FACT, Q, EPS, EX
    double precision RT, POL1, RECT1, DT

    IF (NPTS.GT.MX) THEN
	PRINT *,'FFFMT3: MX MUST BE AT LEAST: ',NPTS
	stop
    END IF
    IF (FIRST) THEN
	! ONEOVER3 = 1.0D0/3.0D0
	FACT = 1.0D0
	DO I = 1,5
	    ONEOVRI(I) = 1.0D0/I
	    FACT = FACT*ONEOVRI(I)
	END DO
	FIRST = .FALSE.
	EPS = 1.0D-12
	DO I = 1,10
	    F(I,1) = 1.0D0/(2*I-1)
	END DO
	T = 0.0D0
	DO L = 2,1601
	    T = (1.0D-2)*(L-1)
	    X = 2*T
	    DEN = 39.0D0
	    TERM = 1.0D0/DEN
	    SUM = TERM
	    !DO 130 I = 2,100
	    DO I = 2,100
		DEN = DEN+2.0D0
		TERM = TERM*X/DEN
		SUM = SUM+TERM
		Q = TERM/SUM
		! IF (Q-EPS)  140,140,130
		if (Q .le. EPS) exit
	    END DO
	    ! 130   CONTINUE
	    ! 140   EX = EXP(-T)
	    EX = EXP(-T)
	    G(20) = EX*SUM
	    !
	    !  USE DOWNWARD RECURSION
	    !
	    DO I = 1,19
		K = 21-I
		KK = K-1
		G(KK) = (X*G(K)+EX)/(2*KK-1)
	    END DO
	    DO I = 1,10
		F(I,L) = G(I)
	    END DO
	END DO
	DO L = 1,1601
	    F(5,L) = F(5,L)/2.0D0
	    F(6,L) = F(6,L)/6.0D0
	END DO
    END IF
    !
    DO IPTS = 1,NPTS
	IF (XX(IPTS) .GT. 16.0D0) THEN
	    POL1 =  -EXP(-XX(IPTS))
	    RT = SQRT(XX(IPTS))*ROOTPI
	    RECT1 = 0.5D0/XX(IPTS)
	    S1(IPTS,1) = RECT1*(RT+POL1)
	    S1(IPTS,2) = RECT1*(S1(IPTS,1)+POL1)
	    S1(IPTS,3) = RECT1*(3*S1(IPTS,2)+POL1)
	ELSE
	    IT = INT(100*XX(IPTS)+1.5D0)
	    POL1 = EXP(-XX(IPTS))
	    RECT1 = 2*XX(IPTS)
	    DT = (1.0D-2)*(IT-1)-XX(IPTS)
	    S1(IPTS,3) = F(3,IT)+DT*(F(4,IT)+DT*(F(5,IT)+DT*F(6,IT)))
	    S1(IPTS,2) = (S1(IPTS,3)*RECT1+POL1)*ONEOVER3
	    S1(IPTS,1) = (S1(IPTS,2)*RECT1+POL1)
	END IF
    END DO
    RETURN
end subroutine

!| subroutine FFFMT3C_F90(x)
!% Calculate $\frac{1}{2}\sqrt{\frac{\pi}{x}}-F_m(x)$ for $m=0$ using FFFMT3C
!|
!|I integer MX, NPTS: maximum, actual number of pts to be evaluated
!|I double precision xx(NPTS): arguments
!|O double precision s1(NPTS,5): returned values
!|
!| Noam Bernstein 9/13/2001
!| Modified for F_0(x) complement from Mark Pederson's code

subroutine FFFMT3C_F90(MX,NPTS,XX,S1)
! MODIFIED BY MARK R PEDERSON (1990)
! To FORTRAN 90 by Noam Bernstein
implicit none
    integer MX, NPTS
    double precision XX(MX),S1(MX,5)

    logical, save:: FIRST = .true.
    double precision, save:: F(10,1601)

    double precision ONEOVRI(5)
    double precision G(20)

    double precision:: ROOTPI = 1.77245385090551602728D0
    double precision:: ONEOVER3 = 1.0D0/3.0D0

    integer I, L, K, KK, IT, IPTS
    double precision T, X, DEN, TERM, SUM, FACT, Q, EPS, EX
    double precision RT, POL1, RECT1, DT

    IF (NPTS.GT.MX) THEN
	PRINT *,'FFFMT3: MX MUST BE AT LEAST: ',NPTS
	stop
    END IF
    IF (FIRST) THEN
	! ONEOVER3 = 1.0D0/3.0D0
	FACT = 1.0D0
	DO I = 1,5
	    ONEOVRI(I) = 1.0D0/I
	    FACT = FACT*ONEOVRI(I)
	END DO
	FIRST = .FALSE.
	EPS = 1.0D-12
	DO I = 1,10
	    F(I,1) = 1.0D0/(2*I-1)
	END DO
	T = 0.0D0
	DO L = 2,1601
	    T = (1.0D-2)*(L-1)
	    X = 2*T
	    DEN = 39.0D0
	    TERM = 1.0D0/DEN
	    SUM = TERM
	    !DO 130 I = 2,100
	    DO I = 2,100
		DEN = DEN+2.0D0
		TERM = TERM*X/DEN
		SUM = SUM+TERM
		Q = TERM/SUM
		! IF (Q-EPS)  140,140,130
		if (Q .le. EPS) exit
	    END DO
	    ! 130   CONTINUE
	    ! 140   EX = EXP(-T)
	    EX = EXP(-T)
	    G(20) = EX*SUM
	    !
	    !  USE DOWNWARD RECURSION
	    !
	    DO I = 1,19
		K = 21-I
		KK = K-1
		G(KK) = (X*G(K)+EX)/(2*KK-1)
	    END DO
	    DO I = 1,10
		F(I,L) = G(I)
	    END DO
	END DO
	DO L = 1,1601
	    F(5,L) = F(5,L)/2.0D0
	    F(6,L) = F(6,L)/6.0D0
	END DO
    END IF
    !
    DO IPTS = 1,NPTS
	IF (XX(IPTS) .GT. 16.0D0) THEN
	    POL1 =  -EXP(-XX(IPTS))
	    RT = SQRT(XX(IPTS))*ROOTPI
	    RECT1 = 0.5D0/XX(IPTS)
	    !! S1(IPTS,1) = RECT1*(RT+POL1)
	    ! for computing the complement of F0
	    S1(IPTS,1) = -RECT1*POL1
	    ! S1(IPTS,2) = RECT1*(S1(IPTS,1)+POL1)
	    ! S1(IPTS,3) = RECT1*(3*S1(IPTS,2)+POL1)
	ELSE
	    IT = INT(100*XX(IPTS)+1.5D0)
	    POL1 = EXP(-XX(IPTS))
	    RECT1 = 2*XX(IPTS)
	    DT = (1.0D-2)*(IT-1)-XX(IPTS)
	    S1(IPTS,3) = F(3,IT)+DT*(F(4,IT)+DT*(F(5,IT)+DT*F(6,IT)))
	    S1(IPTS,2) = (S1(IPTS,3)*RECT1+POL1)*ONEOVER3
	    S1(IPTS,1) = (S1(IPTS,2)*RECT1+POL1)
	    ! for computing the complement of F0
	    S1(IPTS,1) = ROOTPI/(2.0D0*sqrt(XX(IPTS))) - S1(IPTS,1)
	END IF
    END DO
    RETURN
end subroutine

!% Smooth cutoff function from D.J. Cole \emph{et al.}, J. Chem. Phys. {\bf 127}, 204704 (2007).
subroutine smooth_cutoff(x,R,D,fc,dfc_dx)

  real(dp), intent(in) :: x,R,D
  real(dp), intent(out) :: fc,dfc_dx
  real(dp), parameter :: pi = dacos(-1.0d0)

  if (x .lt. (R-D)) then
     fc = 1.0d0
     dfc_dx = 0.0d0
     return
  else if (x .gt. (R+D)) then
     fc = 0.0d0
     dfc_dx = 0.0d0
     return
  else
     fc = 1.0d0 - (x-R+D)/(2.0d0*D) + 1.0d0/(2.0d0*pi)*dsin((pi/D)*(x-R+D))
     dfc_dx = 1.0d0/(2.0d0*D)* (dcos((pi/D)*(x-R+D)) - 1.0d0)
     return
  end if
end subroutine smooth_cutoff

end module functions_module


    subroutine compflux
    use setup2d
    implicit none
    include 'mpif.h'

    eigvmax = 0.d0

    call comp_inviscid_flux

    call nablaAsp

    if (vismode==1) then

        call nablaQsp(1,9)
        call nablaQ_interior_FP
        call interfaceVISflux
        call PROCINTVISFLUX
        call CYCREMVISFLUX
        call BCVISFLUX
        call CYCLOCVISFLUX

        if (ARTIV==1) then
            call comp_artificial_viscosity
            call compAVflux
        end if

        call comp_viscous_flux

    end if

    end subroutine compflux

    subroutine comp_inviscid_flux
    use setup2d
    implicit none

    call inviscid_flux_interior

    call interfaceflux

    call PROCINTFLUX

    call CYCREMFLUX

    call CYCLOCFLUX

    call BCFLUX

    end subroutine comp_inviscid_flux

    subroutine inviscid_flux_interior
    use setup2d
    implicit none

    integer :: ic,ifp,jfp,sp
    double precision,dimension(9) :: Qf,Qs
    double precision,dimension(8) :: F,G

    do ic=1,NCELL
        ! firstly the i-dir flux points (only interior)
        ! FOR INTERIOR QF is the one which will be used by
        ! Qvfi and Qvfj store them temporarily
        do jfp=1,N
        do ifp=2,N
            ! we need to find the Q at the flux points
            Qf(1:9) = 0.d0
            do sp=1,N
                Qs(1:9) = Q(1:9,sp,jfp,ic)
                Qf(1:9) = Qf(1:9) + Qs(1:9)*Lmat(ifp,sp)
            end do

            if (vismode==1) then
                Qvfi(1:9,ifp,jfp,ic) = Qf(1:9)
                Azfi(ifp,jfp,ic) = Qf(9)
            end if

            CALL getIfluxvectors(Qf(1:8),F(1:8),G(1:8))
            F1(1:8,ifp,jfp,ic) = F(1:8)*S1(1,1,ifp,jfp,ic) + G(1:8)*S1(1,2,ifp,jfp,ic)
        end do
        end do

        ! secondly the j-dir flux points (only interior)
        do jfp=2,N
        do ifp=1,N
            ! we need to find the Q at the flux points
            Qf(1:9) = 0.d0
            do sp=1,N
                Qs(1:9) = Q(1:9,ifp,sp,ic)
                Qf(1:9) = Qf(1:9) + Qs(1:9)*Lmat(jfp,sp)
            end do
            if (vismode==1) then
                Qvfj(1:9,ifp,jfp,ic) = Qf(1:9)
                Azfj(ifp,jfp,ic) = Qf(9)
            end if

            call getIfluxvectors(Qf(1:8),F(1:8),G(1:8))
            G2(1:8,ifp,jfp,ic) = F(1:8)*S2(2,1,ifp,jfp,ic) + G(1:8)*S2(2,2,ifp,jfp,ic)

        end do
        end do

    end do ! end of loop over cells

    end subroutine inviscid_flux_interior

    Subroutine nablaQsp(v_sta,v_end)
    !*********************************************************************************************
    !get nablaQ at the solution points
    ! using the formula (2.15) in Sun et al. (2007) Communications in Comput. Physics
    !**********************************************************************************************
    use setup2d
    IMPLICIT NONE

    integer,intent(in) :: v_sta,v_end
    integer :: is,js,ic,rfp
    double precision,allocatable,dimension(:) :: dQSpsi,dQSeta

    allocate(dQSpsi(numv),dQSeta(numv))

    do ic=1,NCELL
        do js=1,N
        do is=1,N
            dQSpsi(v_sta:v_end) = 0.d0
            do rfp=1,N+1
                dQSpsi(v_sta:v_end) = dQSpsi(v_sta:v_end) + &
                Qvfi(v_sta:v_end,rfp,js,ic) * Mmat(rfp,is) * S1(1,1,rfp,js,ic)
                ! ksi_x
            end do
            dQSeta(v_sta:v_end) = 0.d0
            do rfp=1,N+1
                dQSeta(v_sta:v_end) = dQSeta(v_sta:v_end) + &
                Qvfj(v_sta:v_end,is,rfp,ic) * Mmat(rfp,js) * S2(2,1,is,rfp,ic)
                ! eta_x
            end do
            nablaQs(v_sta:v_end,1,is,js,ic) = &
            ( dQSpsi(v_sta:v_end) + dQSeta(v_sta:v_end) ) / Jac(is,js,ic)
    !**********************************************************************************************
            dQSpsi(v_sta:v_end) = 0.d0
            do rfp=1,N+1
                dQSpsi(v_sta:v_end)= dQSpsi(v_sta:v_end) + &
                Qvfi(v_sta:v_end,rfp,js,ic) * Mmat(rfp,is) * S1(1,2,rfp,js,ic)
            end do

            dQSeta(v_sta:v_end) = 0.d0
            do rfp=1,N+1
                dQSeta(v_sta:v_end) = dQSeta(v_sta:v_end) + &
                Qvfj(v_sta:v_end,is,rfp,ic) * Mmat(rfp,js) * S2(2,2,is,rfp,ic)
            end do
            nablaQs(v_sta:v_end,2,is,js,ic) = &
            ( dQSpsi(v_sta:v_end) + dQSeta(v_sta:v_end) ) / Jac(is,js,ic)
    !**********************************************************************************************
        end do
        end do
    end do

    end Subroutine nablaQsp

    subroutine nablaQ_interior_FP
    use setup2d
    implicit none

    integer :: ic,ifp,jfp,sp
    double precision :: Qf(9),Qf2(9)

    do ic=1,NCELL
        do jfp=1,N
            do ifp=2,N ! for interior flux points only
                Qf(1:9) = 0.d0
                Qf2(1:9) = 0.d0
                do sp=1,N
                Qf(1:9) = Qf(1:9) + nablaQs(1:9,1,sp,jfp,ic)*Lmat(ifp,sp)
                Qf2(1:9) = Qf2(1:9) + nablaQs(1:9,2,sp,jfp,ic)*Lmat(ifp,sp)
                end do
                nablaQvfi(1:9,1,ifp,jfp,ic) = Qf(1:9)
                nablaQvfi(1:9,2,ifp,jfp,ic) = Qf2(1:9)
            end do
        end do

        ! secondly the j-dir flux points (only interior)

        do jfp=2,N
            do ifp=1,N
                Qf(1:9) = 0.d0
                Qf2(1:9) = 0.d0
                do sp=1,N
                Qf(1:9) = Qf(1:9) + nablaQs(1:9,1,ifp,sp,ic)*Lmat(jfp,sp)
                Qf2(1:9) = Qf2(1:9) + nablaQs(1:9,2,ifp,sp,ic)*Lmat(jfp,sp)
                end do
                nablaQvfj(1:9,1,ifp,jfp,ic) = Qf(1:9)
                nablaQvfj(1:9,2,ifp,jfp,ic) = Qf2(1:9)
            end do
        end do
    end do		! end of loop over cells for nablaQf

    end subroutine nablaQ_interior_FP

    subroutine comp_viscous_flux
    use setup2d
    implicit none

    integer :: ic,ifp,jfp
    double precision :: Qs(9),nablaQ(9,2),Fv(9),Gv(9),Fv_art(9),Gv_art(9)

    do ic = 1,NCELL

        do jfp = 1,N
        do ifp = 1,N+1

            Qs(1:9) = Qvfi(1:9,ifp,jfp,ic)
            nablaQ(1:9,1) = nablaQvfi(1:9,1,ifp,jfp,ic)
            nablaQ(1:9,2) = nablaQvfi(1:9,2,ifp,jfp,ic)

            call getVfluxvectors(Qs,nablaQ,Fv,Gv)

            Fv1(1:9,ifp,jfp,ic) = Fv(1:9)*S1(1,1,ifp,jfp,ic) &
            + Gv(1:9)*S1(1,2,ifp,jfp,ic)

            if (ARTIV==1) then

                call getVfluxvectors_AV(Qs,nablaQ,Fv_art,Gv_art,1,ifp,jfp,ic)

                Fv1(1:9,ifp,jfp,ic) = Fv1(1:9,ifp,jfp,ic) + &
                Fv_art(1:9)*S1(1,1,ifp,jfp,ic) &
                + Gv_art(1:9)*S1(1,2,ifp,jfp,ic)

            end if

        end do
        end do

        do jfp = 1,N+1
        do ifp = 1,N

            Qs(1:9) = Qvfj(1:9,ifp,jfp,ic)
            nablaQ(1:9,1) = nablaQvfj(1:9,1,ifp,jfp,ic)
            nablaQ(1:9,2) = nablaQvfj(1:9,2,ifp,jfp,ic)

            call getVfluxvectors(Qs,nablaQ,Fv,Gv)

            Gv2(1:9,ifp,jfp,ic) = Fv(1:9)*S2(2,1,ifp,jfp,ic) &
            + Gv(1:9)*S2(2,2,ifp,jfp,ic)

            if (ARTIV==1) then

                call getVfluxvectors_AV(Qs,nablaQ,Fv_art,Gv_art,2,ifp,jfp,ic)

                Gv2(1:9,ifp,jfp,ic) = Gv2(1:9,ifp,jfp,ic) + &
                Fv_art(1:9)*S2(2,1,ifp,jfp,ic) &
                + Gv_art(1:9)*S2(2,2,ifp,jfp,ic)

            end if

        end do
        end do
    end do

    end subroutine comp_viscous_flux


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C======================================================================
      SUBROUTINE BS(N,S,F,L,X)

C**********************************************************************

C Subroutine BS does the back substitution for the soultion of the
C local least squares extrapolation technique for element variables
C from their element centroid location to a nodal location.
C The least squares solution is started by a Gauss elimination in
C subroutine FRGE. The process is started in subroutines EXTQ for
C 4-node quads or EXTH for 8-node hexes.

C Called by EXTH, EXTQ

C**********************************************************************

C N    INT   number of equations - 1 + the number of dimensions
C S    REAL  the coefficient matrix - after forward gauss elimination
C F    REAL  the load vector
C L    INT   dummy array - placeholder for subscripts
C X    REAL  the solution vector - coefficients of the equation
C SUM  REAL  dummy variable - used in the solution scheme

C**********************************************************************

C subroutine written in double precision

      DOUBLE PRECISION S(N,N),F(N),X(N),SUM
      INTEGER L(N)

      DO 3 K = 1,N-1
        DO 2 I = K+1,N
          F(L(I)) = F(L(I)) - S(L(I),K) * F(L(K))
    2   CONTINUE
    3 CONTINUE
      X(N) = F(L(N)) / S(L(N),N)
      DO 5 I = N-1,1,-1
        SUM = F(L(I))
        DO 4 J = I+1,N
          SUM = SUM - S(L(I),J) * X(J)
    4   CONTINUE
        X(I) = SUM / S(L(I),I)
    5 CONTINUE
      RETURN
      END


module REFERENCE_TRAJECTORY_MOD
! Description:
!    Contains the REFERENCE_TRAJECTORY subroutine.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    d.amato@upm.es
!
! ==============================================================================

use KINDS, only: ik,dk,qk
implicit none

contains

subroutine REFERENCE_TRAJECTORY_COWELL(R_i,V_i,JD_i,JD_f,tol,Yt,JD_sw,ind_sw,istate)
! Description:
!    Computes the reference trajectory in quadruple precision, using trajectory
!    splitting with Cowell equations integrated by DLSODAR.
!    Provides the reference trajectory and times of switch IN and OUT.
!
! ==============================================================================

! MODULES
use AUXILIARIES,     only: inSoI
use CONSTANTS,       only: muSun,muEarth,smaEarth,secsPerDay,pi
use CONSTANTS,       only: SET_UNITS
use SETTINGS,        only: dt_H,dt_CE
use PROP_COWELL_MOD, only: QLEG_COW_LSODAR

! VARIABLES
implicit none
! Arguments IN
real(qk),intent(in)    ::  R_i(1:3),V_i(1:3)    ! Initial position and velocity [km,km/s]
real(qk),intent(in)    ::  JD_i,JD_f            ! Initial and final times [days]
real(qk),intent(in)    ::  tol                  ! Integration tolerance
! Arguments OUT
real(qk),allocatable,intent(out)   ::  Yt(:,:)    ! Trajectory array [km,s]
real(qk),intent(out)     ::  JD_sw                      ! Switch time [days]
integer(ik),intent(out)  ::  ind_sw                     ! Index of switch time
integer(ik),intent(out)  ::  istate                     ! Integration diagnostics
! States and trajectories
real(qk)              ::  R_helio(1:3),V_helio(1:3)
real(qk)              ::  R_geo(1:3),V_geo(1:3)
real(qk),allocatable  ::  traj_H(:,:),traj_CE(:,:)
integer               ::  length_CE,length_H,length
! Integration
real(qk)            ::  dir
integer(ik)         ::  jroot(1)
! Misc
integer :: temp

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

! ==============================================================================
! 01. INITIALIZATIONS
! ==============================================================================

! In this subroutine, we start propagating from t_CA = 0, i.e. at the time of
! minimum geocentric distance.

! Reference quantities for non-dimensionalization
call SET_UNITS(R_i,muEarth)

dir = sign(1._qk,JD_f - JD_i)

! Initialize geocentric state
R_geo = R_i
V_geo = V_i

! Initialize istate, jroot, switch time index
istate = 1
jroot  = 0
ind_sw = -1

! ===============================================================================
! 02. PROPAGATION WITH ONLINE TRAJECTORY MATCHING (needed to get the switch time)
! ===============================================================================

inSoI = .true.

! Propagate IN
call QLEG_COW_LSODAR(R_geo,V_geo,JD_i,JD_f,dir*dt_CE,tol,traj_CE,istate,jroot,ind_sw)
if (istate < 0) return

! Switch IN-> OUT:
inSoI = .false.
length_CE = size(traj_CE,1)
JD_sw = traj_CE(length_CE,1)/secsPerDay
R_helio = traj_CE(length_CE,2:4)
V_helio = traj_CE(length_CE,5:7)

call SET_UNITS(R_helio,muSun)

! Propagate OUT:
call QLEG_COW_LSODAR(R_helio,V_helio,JD_sw,JD_f,dir*dt_H,tol,traj_H,istate,jroot,temp)
if (istate < 0) return

length_H = size(traj_H,1)

! ==============================================================================
! 03. MERGE TRAJECTORIES AND QUIT
! ==============================================================================

length = length_CE + length_H - 1

if(allocated(Yt)) deallocate(Yt)
allocate(Yt(1:length,1:7))
Yt(1:length_CE-1,:) = traj_CE(1:length_CE-1,:)
Yt(length_CE:length,:) = traj_H(1:length_H,:)

deallocate(traj_CE)
deallocate(traj_H)

end subroutine REFERENCE_TRAJECTORY_COWELL

end module REFERENCE_TRAJECTORY_MOD


module real_to_unum_mod
  use unum_to_float_mod, only : Boole,&
                                Signmask,&
                                U2f
  use ISO_FORTRAN_ENV,   only : INT64, REAL64
  use unum_env_mod,      only : Get_qNaNu,&
                                Get_posinfu,&
                                Get_neginfu,&
                                Get_maxreal,&
                                Get_maxrealu,&
                                Get_utagmask,&
                                Get_utagsize,&
                                Get_ubitmask,&
                                Get_signbigu,&
                                Get_smallsubnormal,&
                                Get_smallnormalu,&
                                Get_efsizemask,&
                                Get_fsizemax,&
                                Get_fsizesize,&
                                Get_fsizemask,&
                                Get_ulpu
  use IEEE_ARITHMETIC           !Entire package for '==' overload
  use unum_t_mod

  implicit none
  private
  public :: X2u

contains
  function Scale_to_norm (x)
    implicit none
    real (REAL64), intent (in)  :: x
    integer (INT64)             :: Scale_to_norm
    if (x == 0.0) then
      Scale_to_norm = 0
    else
      Scale_to_norm = floor (log (abs (x)) / log (2.0_REAL64))
    end if
  end function Scale_to_norm

  function Min_exp_bits (x)
    implicit none
    real (REAL64), intent (in)  :: x
    integer (INT64)             :: Min_exp_bits
    if (x == 0.0 .or. Scale_to_norm (x) == 1) then
      Min_exp_bits = 1
    else
      Min_exp_bits = ceiling (&
                     log (1.0 + abs (Scale_to_norm (x) - 1)) / &
                     log (2.0), INT64) + 1
    end if
  end function Min_exp_bits

  function Subnormal2u (x)
    implicit none
    real (REAL64), intent (in)    :: x
    type (unum_t)                 :: Subnormal2u
    real (REAL64)                 :: y
    type (unum_t)                 :: sub_temp
    type (unum_t)                 :: sign_adder
    type (unum_t)                 :: ubitmask_adder
    type (unum_t)                 :: efsizemask_local

    sign_adder%u = 0
    ubitmask_adder%u = 0
    efsizemask_local = Get_efsizemask ()

    y = abs (x) / Get_smallsubnormal ()

    if (x < 0) sign_adder = Get_signbigu ()
    if (y /= floor (y)) ubitmask_adder = Get_ubitmask ()

    sub_temp%u = sign_adder%u + efsizemask_local%u + ubitmask_adder%u + &
               ishft (floor (y, INT64), Get_utagsize ())
    do while (iand (ishft (3, Get_utagsize () - 1), sub_temp%u) == 0)
      sub_temp%u = (sub_temp%u - &
                 iand (efsizemask_local%u, sub_temp%u)) / 2_INT64 + &
                 iand (efsizemask_local%u, sub_temp%u) - 1
    end do

    Subnormal2u = sub_temp
  end function Subnormal2u

  function Norm2u (x)
    implicit none
    real   (REAL64), intent (in)  :: x
    type (unum_t)                 :: Norm2u
    real (REAL64)                 :: y
    real (REAL64)                 :: z_real
    integer (INT64)               :: z_int
    type (unum_t)                 :: z_unum
    type (unum_t)                 :: temp_norm
    type (unum_t)                 :: ulpu_local, signmask_temp
    type (unum_t)                 :: fsizemask_local, ubitmask_local
    integer (INT64)               :: n

    n = 0
    ulpu_local = Get_ulpu ()

    y = abs (x) / 2.0_REAL64**(Scale_to_norm (x))

    do while (floor (y) /= y .and. n < Get_fsizemax ())
      y = y * 2.0_REAL64
      n = n + 1_INT64
    end do
    if (y == floor (y)) then
      temp_norm%u = n - Boole (n > 0) + &
                  ishft (Min_exp_bits (x) - 1, Get_fsizesize ())
      if (n /= 0) then
        temp_norm%u = temp_norm%u + &
                    ishft (floor (y, INT64) - &
                    2_INT64**(Scale_to_norm (y)), Get_utagsize ())
      end if
      temp_norm%u = temp_norm%u + &
                  ishft (Scale_to_norm (x) + &
                  2_INT64**(Min_exp_bits (x) - 1_INT64) - 1_INT64, &
                  Get_utagsize () + n + Boole (n == 0))
      if (x < 0) then
        temp_norm%u = temp_norm%u + &
                    ishft (1_INT64, Get_utagsize () + n + Boole (n == 0) + &
                    Min_exp_bits (x))
      end if
      z_real = log (1.0_REAL64 - log (abs (x)) / log (2.0_REAL64)) / &
               log (2.0_REAL64)
      z_int = int (z_real)
      if (z_real == z_int .and. z_int >= 0) then
        z_unum%u = ishft (z_int, Get_fsizesize ())
        signmask_temp = Signmask (z_unum)
        temp_norm%u = ishft (z_int, Get_fsizesize ()) + ulpu_local%u + &
                    Boole (x < 0) * signmask_temp%u
      end if
    else
      z_real = ceiling (abs (x) / &
              2.0_REAL64**(Scale_to_norm (x) - Get_fsizemax ())) * &
              2.0_REAL64**(Scale_to_norm (x) - Get_fsizemax ())
      !z_int = int (z_real)
      n = max (Min_exp_bits (x), Min_exp_bits (z_real))
      fsizemask_local = Get_fsizemask ()
      ubitmask_local = Get_ubitmask ()
      temp_norm%u = fsizemask_local%u + &
                    ishft (n - 1_INT64, Get_fsizesize ()) + &
                    ubitmask_local%u - ulpu_local%u + &
                    ishft (floor ((z_real/2.0_REAL64**Scale_to_norm (z_real) - &
                    1.0_REAL64) * 2.0_REAL64**Get_fsizemax ()), &
                    Get_utagsize ())+&
                    ishft (Scale_to_norm (z_real) + &
                    2_INT64**(n - 1_INT64) - 1_INT64, &
                    Get_utagsize () + Get_fsizemax ())
      signmask_temp = Signmask (temp_norm)
      if (x < 0) temp_norm%u = temp_norm%u + signmask_temp%u
    end if
    Norm2u = temp_norm
  end function Norm2u

  function X2u (x)
    implicit none
    real (REAL64),   intent (in)  :: x
    type (unum_t)                 :: X2u
    type (unum_t)                 :: maxrealu_local, ubitmask_local
    type (unum_t)                 :: signbigu_local, utagmask_local
    if (ieee_is_nan (x)) then
      X2u = Get_qNaNu ()
    else if (ieee_class (x) == IEEE_POSITIVE_INF) then
      X2u = Get_posinfu ()
    else if (ieee_class (x) == IEEE_NEGATIVE_INF) then
      X2u = Get_neginfu ()
    else if (abs (x) > Get_maxreal ()) then
      maxrealu_local = Get_maxrealu ()
      ubitmask_local = Get_ubitmask ()
      if (x < 0) then
        signbigu_local = Get_signbigu ()
        X2u%u = maxrealu_local%u + ubitmask_local%u + signbigu_local%u
      else
        X2u%u = maxrealu_local%u + ubitmask_local%u
      end if
    else if (x == 0.0) then
      X2u%u = 0
    else if (abs (x) < Get_smallsubnormal ()) then
      utagmask_local = Get_utagmask ()
      if (x < 0) then
        signbigu_local = Get_signbigu ()
        X2u%u = utagmask_local%u + signbigu_local%u
      else
        X2u = utagmask_local
      end if
    else if (abs (x) < U2f (Get_smallnormalu ())) then
      X2u = Subnormal2u (x)
    else
      X2u = Norm2u (x)
    end if
  end function X2u

end module real_to_unum_mod


      SUBROUTINE CONST(X,XD,M,NB,ENERGY,G,ALAG)
*
*
*       Constants of motion.
*       --------------------
*
      IMPLICIT REAL*8 (A-H,M,O-Z)
*     COMMON/SOFT/  EPS2
      REAL*8 X(3*NB),XD(3*NB),G(3),M(NB)
*
      EPS2 = 0.0
*
      U=0.0
      T=0.0
      UG=0.0
      G(1)=0.
      G(2)=0.
      G(3)=0.
      DO 10 I=1,NB
      K1=(I-1)*3+1
      K2=K1+1
      K3=K2+1
      T=T+.5D0*M(I)*(XD(K1)**2+XD(K2)**2+XD(K3)**2)
      G(1)=G(1)+M(I)*(X(K2)*XD(K3)-X(K3)*XD(K2))
      G(2)=G(2)-M(I)*(X(K1)*XD(K3)-X(K3)*XD(K1))
      G(3)=G(3)+M(I)*(X(K1)*XD(K2)-X(K2)*XD(K1))
      J1=I+1
      DO 9 J=J1,NB
      KI=(I-1)*3
      KJ=(J-1)*3
      R2=0.
      DO 8 K=1,3
      KI=KI+1
      KJ=KJ+1
      R2=R2+(X(KI)-X(KJ))**2
8     CONTINUE
*       Include possible softening for singular interaction.
      IF(J.LT.NB)R2=R2+EPS2
      U=U+M(I)*M(J)/SQRT(R2)
9     CONTINUE
10    CONTINUE
*
*       Form the total energy and Lagrangean energy.
      ENERGY=T-U
      ALAG=T+U
*     G(1) = U
*
      RETURN
      END


c
      function plnkut(u1,u2)
c***********************************************************************
c     function plnkut - evaluates the fraction of energy emitted in     *
c     region ir and group ig based on the plankian    *
c     integral.                                       *
c***********************************************************************
c     ******************************************************************
c     * plnkut(u1,u2) =                                                *
c     *    15.*pi**(-4)*integral(u**3/(exp(u)-1.),  u1 .lt. u .lt. u2) *
c     *                                                                *
c     *   plnkut(0,z) = sum (ck*z**k  ,  k=3,4,5,...)  near z = 0      *
c     *                                                                *
c     *   f(i) = plnkut(0,xm + h*i)                                    *
c     ******************************************************************

      implicit double precision (a-h,o-z)

      dimension f(59)
      data f  /.144005d0,.177286d0,.212769d0,.249946d0,.288322d0,
     x .327420d0,.366798d0,
     1     .406054d0,.444830d0,.482815d0,.519747d0,.555410d0,.589629d0,
     x     .622277d0,.653255d0,
     2     .682506d0,.709999d0,.735729d0,.759714d0,.781988d0,.802601d0,
     x     .821615d0,.839099d0,
     3     .855130d0,.869788d0,.883155d0,.895317d0,.906355d0,.916351d0,
     x     .925385d0,.933533d0,
     4     .940868d0,.947460d0,.953372d0,.958668d0,.963403d0,.967630d0,
     x     .971399d0,.974754d0,
     5     .977738d0,.980387d0,.982737d0,.984818d0,.986660d0,.988288d0,
     x     .989726d0,.990994d0,
     6     .992111d0,.993095d0,.993961d0,.994721d0,.995389d0,.995975d0,
     x     .996489d0,.996939d0,
     7     .997333d0,.997677d0,.997978d0,.998242d0/

      data c3,c4,c5,c7,c9/
     1     .51329911d-1,.19248717d-1,.25664956d-2, .30553519d-4,
     x     .5658059d-6/
      data xmin,xmax,q,xm,h/1.9d0,12.0d0,.15398973d0,1.62d0,.18d0/

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

      if (u1 .le. xmax) then
c     *****************************************
c     * two passes will be made through loop. *
c     * first pass (iq=1) will set up for the *
c     * upper limit. the second pass (iq=2)   *
c     * will set up for the lower limit.      *
c     *****************************************
         iq = 1
         z  = u2

 87      if ( iq .ge. 3 ) go to 88

         if (z .gt. xmax) then
c     *****************************************
c     * use asymptotic formula for z.ge.xmax  *
c     *****************************************
            plkint = 1.-q*exp(-z)*((z+3.)*z+6.)*z

         else if (z .gt. xmin) then
c     *****************************************
c     * quadratic interpolation for           *
c     *         xmin .lt. z .lt. xmax         *
c     *****************************************
            d      = (z-xm)/h
            i      = d
            d      = d-dble(i)
            dm     = d -1.d0
            dn     = dm-1.d0
            plkint = (f(i)*dm*dn+f(i+2)*d*dm)*.5d0-f(i+1)*dn*d

         else
c     *****************************************
c     * use power series for  z .le. xmin     *
c     *****************************************

            plkint = ((((c9*(z*z)-c7)*(z*z)+c5)*z-c4)*z+c3)*z*(z*z)
         endif

         if (iq .eq. 1) then
            z      = u1
            plnkut = plkint
         endif

         iq = iq+1
         go to 87

 88      continue
         plnkut = plnkut - plkint

      else
         zu = u2
         zl = u1
         fstlog = log(zl*(6.+zl*(3.+zl)))
         sndlog = log(zu*(6.+zu*(3.+zu)))
         plnkut = q * (exp(fstlog-zl) - exp(sndlog-zu))
      endif

      return
      end


      subroutine fpgrpa(ifsu,ifsv,ifbu,ifbv,idim,ipar,u,mu,v,mv,z,mz,
     * tu,nu,tv,nv,p,c,nc,fp,fpu,fpv,mm,mvnu,spu,spv,right,q,au,au1,
     * av,av1,bu,bv,nru,nrv)
c  ..
c  ..scalar arguments..
      real*8 p,fp
      integer ifsu,ifsv,ifbu,ifbv,idim,mu,mv,mz,nu,nv,nc,mm,mvnu
c  ..array arguments..
      real*8 u(mu),v(mv),z(mz*idim),tu(nu),tv(nv),c(nc*idim),fpu(nu),
     * fpv(nv),spu(mu,4),spv(mv,4),right(mm*idim),q(mvnu),au(nu,5),
     * au1(nu,4),av(nv,5),av1(nv,4),bu(nu,5),bv(nv,5)
      integer ipar(2),nru(mu),nrv(mv)
c  ..local scalars..
      real*8 arg,fac,term,one,half,value
      integer i,id,ii,it,iz,i1,i2,j,jz,k,k1,k2,l,l1,l2,mvv,k0,muu,
     * ncof,nroldu,nroldv,number,nmd,numu,numu1,numv,numv1,nuu,nvv,
     * nu4,nu7,nu8,nv4,nv7,nv8
c  ..local arrays..
      real*8 h(5)
c  ..subroutine references..
c    fpback,fpbspl,fpdisc,fpbacp,fptrnp,fptrpe
c  ..
c  let
c               |   (spu)    |            |   (spv)    |
c        (au) = | ---------- |     (av) = | ---------- |
c               | (1/p) (bu) |            | (1/p) (bv) |
c
c                                | z  ' 0 |
c                            q = | ------ |
c                                | 0  ' 0 |
c
c  with c      : the (nu-4) x (nv-4) matrix which contains the b-spline
c                coefficients.
c       z      : the mu x mv matrix which contains the function values.
c       spu,spv: the mu x (nu-4), resp. mv x (nv-4) observation matrices
c                according to the least-squares problems in the u-,resp.
c                v-direction.
c       bu,bv  : the (nu-7) x (nu-4),resp. (nv-7) x (nv-4) matrices
c                containing the discontinuity jumps of the derivatives
c                of the b-splines in the u-,resp.v-variable at the knots
c  the b-spline coefficients of the smoothing spline are then calculated
c  as the least-squares solution of the following over-determined linear
c  system of equations
c
c    (1)  (av) c (au)' = q
c
c  subject to the constraints
c
c    (2)  c(nu-3+i,j) = c(i,j), i=1,2,3 ; j=1,2,...,nv-4
c            if(ipar(1).ne.0)
c
c    (3)  c(i,nv-3+j) = c(i,j), j=1,2,3 ; i=1,2,...,nu-4
c            if(ipar(2).ne.0)
c
c  set constants
      one = 1
      half = 0.5
c  initialization
      nu4 = nu-4
      nu7 = nu-7
      nu8 = nu-8
      nv4 = nv-4
      nv7 = nv-7
      nv8 = nv-8
      muu = mu
      if(ipar(1).ne.0) muu = mu-1
      mvv = mv
      if(ipar(2).ne.0) mvv = mv-1
c  it depends on the value of the flags ifsu,ifsv,ifbu  and ibvand
c  on the value of p whether the matrices (spu), (spv), (bu) and (bv)
c  still must be determined.
      if(ifsu.ne.0) go to 50
c  calculate the non-zero elements of the matrix (spu) which is the ob-
c  servation matrix according to the least-squares spline approximation
c  problem in the u-direction.
      l = 4
      l1 = 5
      number = 0
      do 40 it=1,muu
        arg = u(it)
  10    if(arg.lt.tu(l1) .or. l.eq.nu4) go to 20
        l = l1
        l1 = l+1
        number = number+1
        go to 10
  20    call fpbspl(tu,nu,3,arg,l,h)
        do 30 i=1,4
          spu(it,i) = h(i)
  30    continue
        nru(it) = number
  40  continue
      ifsu = 1
c  calculate the non-zero elements of the matrix (spv) which is the ob-
c  servation matrix according to the least-squares spline approximation
c  problem in the v-direction.
  50  if(ifsv.ne.0) go to 100
      l = 4
      l1 = 5
      number = 0
      do 90 it=1,mvv
        arg = v(it)
  60    if(arg.lt.tv(l1) .or. l.eq.nv4) go to 70
        l = l1
        l1 = l+1
        number = number+1
        go to 60
  70    call fpbspl(tv,nv,3,arg,l,h)
        do 80 i=1,4
          spv(it,i) = h(i)
  80    continue
        nrv(it) = number
  90  continue
      ifsv = 1
 100  if(p.le.0.) go to  150
c  calculate the non-zero elements of the matrix (bu).
      if(ifbu.ne.0 .or. nu8.eq.0) go to 110
      call fpdisc(tu,nu,5,bu,nu)
      ifbu = 1
c  calculate the non-zero elements of the matrix (bv).
 110  if(ifbv.ne.0 .or. nv8.eq.0) go to 150
      call fpdisc(tv,nv,5,bv,nv)
      ifbv = 1
c  substituting (2)  and (3) into (1), we obtain the overdetermined
c  system
c         (4)  (avv) (cr) (auu)' = (qq)
c  from which the nuu*nvv remaining coefficients
c         c(i,j) , i=1,...,nu-4-3*ipar(1) ; j=1,...,nv-4-3*ipar(2) ,
c  the elements of (cr), are then determined in the least-squares sense.
c  we first determine the matrices (auu) and (qq). then we reduce the
c  matrix (auu) to upper triangular form (ru) using givens rotations.
c  we apply the same transformations to the rows of matrix qq to obtain
c  the (mv) x nuu matrix g.
c  we store matrix (ru) into au (and au1 if ipar(1)=1) and g into q.
 150  if(ipar(1).ne.0) go to 160
      nuu = nu4
      call fptrnp(mu,mv,idim,nu,nru,spu,p,bu,z,au,q,right)
      go to 180
 160  nuu = nu7
      call fptrpe(mu,mv,idim,nu,nru,spu,p,bu,z,au,au1,q,right)
c  we determine the matrix (avv) and then we reduce this matrix to
c  upper triangular form (rv) using givens rotations.
c  we apply the same transformations to the columns of matrix
c  g to obtain the (nvv) x (nuu) matrix h.
c  we store matrix (rv) into av (and av1 if ipar(2)=1) and h into c.
 180  if(ipar(2).ne.0) go to 190
      nvv = nv4
      call fptrnp(mv,nuu,idim,nv,nrv,spv,p,bv,q,av,c,right)
      go to 200
 190  nvv = nv7
      call fptrpe(mv,nuu,idim,nv,nrv,spv,p,bv,q,av,av1,c,right)
c  backward substitution to obtain the b-spline coefficients as the
c  solution of the linear system    (rv) (cr) (ru)' = h.
c  first step: solve the system  (rv) (c1) = h.
 200  ncof = nuu*nvv
      k = 1
      if(ipar(2).ne.0) go to 240
      do 220 ii=1,idim
      do 220 i=1,nuu
         call fpback(av,c(k),nvv,5,c(k),nv)
         k = k+nvv
 220  continue
      go to 300
 240  do 260 ii=1,idim
      do 260 i=1,nuu
         call fpbacp(av,av1,c(k),nvv,4,c(k),5,nv)
         k = k+nvv
 260  continue
c  second step: solve the system  (cr) (ru)' = (c1).
 300  if(ipar(1).ne.0) go to 400
      do 360 ii=1,idim
      k = (ii-1)*ncof
      do 360 j=1,nvv
        k = k+1
        l = k
        do 320 i=1,nuu
          right(i) = c(l)
          l = l+nvv
 320    continue
        call fpback(au,right,nuu,5,right,nu)
        l = k
        do 340 i=1,nuu
           c(l) = right(i)
           l = l+nvv
 340    continue
 360  continue
      go to 500
 400  do 460 ii=1,idim
      k = (ii-1)*ncof
      do 460 j=1,nvv
        k = k+1
        l = k
        do 420 i=1,nuu
          right(i) = c(l)
          l = l+nvv
 420    continue
        call fpbacp(au,au1,right,nuu,4,right,5,nu)
        l = k
        do 440 i=1,nuu
           c(l) = right(i)
           l = l+nvv
 440    continue
 460  continue
c  calculate from the conditions (2)-(3), the remaining b-spline
c  coefficients.
 500  if(ipar(2).eq.0) go to 600
      i = 0
      j = 0
      do 560 id=1,idim
      do 560 l=1,nuu
         ii = i
         do 520 k=1,nvv
            i = i+1
            j = j+1
            q(i) = c(j)
 520     continue
         do 540 k=1,3
            ii = ii+1
            i = i+1
            q(i) = q(ii)
 540     continue
 560  continue
      ncof = nv4*nuu
      nmd = ncof*idim
      do 580 i=1,nmd
         c(i) = q(i)
 580  continue
 600  if(ipar(1).eq.0) go to 700
      i = 0
      j = 0
      n33 = 3*nv4
      do 660 id=1,idim
         ii = i
         do 620 k=1,ncof
            i = i+1
            j = j+1
            q(i) = c(j)
 620     continue
         do 640 k=1,n33
            ii = ii+1
            i = i+1
            q(i) = q(ii)
 640     continue
 660  continue
      ncof = nv4*nu4
      nmd = ncof*idim
      do 680 i=1,nmd
         c(i) = q(i)
 680  continue
c  calculate the quantities
c    res(i,j) = (z(i,j) - s(u(i),v(j)))**2 , i=1,2,..,mu;j=1,2,..,mv
c    fp = sumi=1,mu(sumj=1,mv(res(i,j)))
c    fpu(r) = sum''i(sumj=1,mv(res(i,j))) , r=1,2,...,nu-7
c                  tu(r+3) <= u(i) <= tu(r+4)
c    fpv(r) = sumi=1,mu(sum''j(res(i,j))) , r=1,2,...,nv-7
c                  tv(r+3) <= v(j) <= tv(r+4)
 700  fp = 0.
      do 720 i=1,nu
        fpu(i) = 0.
 720  continue
      do 740 i=1,nv
        fpv(i) = 0.
 740  continue
      nroldu = 0
c  main loop for the different grid points.
      do 860 i1=1,muu
        numu = nru(i1)
        numu1 = numu+1
        nroldv = 0
        iz = (i1-1)*mv
        do 840 i2=1,mvv
          numv = nrv(i2)
          numv1 = numv+1
          iz = iz+1
c  evaluate s(u,v) at the current grid point by making the sum of the
c  cross products of the non-zero b-splines at (u,v), multiplied with
c  the appropiate b-spline coefficients.
          term = 0.
          k0 = numu*nv4+numv
          jz = iz
          do 800 id=1,idim
          k1 = k0
          value = 0.
          do 780 l1=1,4
            k2 = k1
            fac = spu(i1,l1)
            do 760 l2=1,4
              k2 = k2+1
              value = value+fac*spv(i2,l2)*c(k2)
 760        continue
            k1 = k1+nv4
 780      continue
c  calculate the squared residual at the current grid point.
          term = term+(z(jz)-value)**2
          jz = jz+mz
          k0 = k0+ncof
 800      continue
c  adjust the different parameters.
          fp = fp+term
          fpu(numu1) = fpu(numu1)+term
          fpv(numv1) = fpv(numv1)+term
          fac = term*half
          if(numv.eq.nroldv) go to 820
          fpv(numv1) = fpv(numv1)-fac
          fpv(numv) = fpv(numv)+fac
 820      nroldv = numv
          if(numu.eq.nroldu) go to 840
          fpu(numu1) = fpu(numu1)-fac
          fpu(numu) = fpu(numu)+fac
 840    continue
        nroldu = numu
 860  continue
      return
      end