module <module_name>

  use ad
  use fitfunction
  use gadf_constants

  implicit none

  type, extends(fitfunc) :: <function_name>
   contains
     procedure :: init => init_<function_name>
     procedure :: eval => eval_<function_name>
  end type <function_name>

contains
  subroutine init_<function_name>(this)
    class(<function_name>), intent(out) :: this
    allocate(this%pars(<number_of_fitting_parameters>))
  end subroutine init_<function_name>

  type(advar) function eval_<function_name>(this, x) result(y)
    class(<function_name>), intent(in) :: this
    real(kp), intent(in) :: x
    <function_body>
  end function eval_<function_name>
end module <module_name>


use FEMDomainClass

type(FEMDomain_) :: domain
real(real64) :: x=100.0d0,y=100.0d0,z=100.0d0

call domain%create(meshtype="Cube3D",x_num=2,y_num=2,z_num=2)
call domain%resize(x=1.0d0,y=1.0d0,z=1.0d0)
call domain%msh("domain")
call domain%move(x=x,y=y,z=z)

! Get the nearest Element to (x,y,z) = (0,0,1)
print *, domain%mesh%nearestElementID(x=0.0d0,y=0.0d0,z=1.0d0)

! P(51,51,100) is in the 5th element?
print *, domain%mesh%InsideOfElement(ElementID=5,x=0.0d0,y=0.0d0,z=1.0d0)

! get local coordinates
print *, domain%getLocalCoordinate(ElementID=1,x=0.20d0+x,y=0.20d0+y,z=0.000d0+z)
print *, domain%getLocalCoordinate(ElementID=1,x=0.00d0+x,y=0.00d0+y,z=0.000d0+z)
print *, domain%getLocalCoordinate(ElementID=1,x=0.300d0+x,y=0.300d0+y,z=0.5000d0+z)

end


program P18221
    implicit none
    integer :: size, i, j, sungyu_x, sungyu_y, gyosu_x, gyosu_y, top, left, bottom, right, barrier
    integer, dimension(1000, 1000) :: room
    read *, size
    do i = 1, size
        read *, (room(i, j), j = 1, size)
    end do
    do i = 1, size
        do j = 1, size
            if (room(i, j) == 2) then
                sungyu_x = i
                sungyu_y = j
            else if (room(i, j) == 5) then
                gyosu_x = i
                gyosu_y = j
            end if
        end do
    end do
    left = min(sungyu_x, gyosu_x)
    right = max(sungyu_x, gyosu_x)
    top = min(sungyu_y, gyosu_y)
    bottom = max(sungyu_y, gyosu_y)
    barrier = 0
    do i = left, right
        do j = top, bottom
            if (room(i, j) == 1) then
                barrier = barrier + 1
            end if
        end do
    end do
    if (((sungyu_x - gyosu_x) ** 2 + (sungyu_y - gyosu_y) ** 2) >= 25 .and. barrier >= 3) then
        write (*, '(I0)') 1
    else
        write (*, '(I0)') 0
    end if
end program P18221


!>
!> @file
!>
!>  PLASMA is a software package provided by:
!>  University of Tennessee, US,
!>  University of Manchester, UK.
!>
!> @precisions normal z -> s d c
!>
!>    @brief Tests PLASMA linear system (Ax=b) solution based on
!>           Cholesky factorization

      PROGRAM TEST_ZPOTRS

      USE, INTRINSIC :: ISO_FORTRAN_ENV
      USE OMP_LIB
      USE PLASMA

      IMPLICIT NONE

      integer, parameter :: sp = REAL32
      integer, parameter :: dp = REAL64

      ! set working precision, this value is rewritten for different precisions
      integer, parameter :: wp = dp

      integer,     parameter   :: n = 2000, nrhs = 1000
      complex(wp), parameter   :: zone = 1.0, zmone = -1.0
      complex(wp), allocatable :: A(:,:), Aref(:,:), B(:,:), Bref(:,:)
      real(wp),    allocatable :: work(:)
      integer                  :: seed(4) = [0, 0, 0, 1]
      real(wp)                 :: Anorm, Xnorm, Rnorm, error, tol
      character                :: uploLapack ='L'
      integer                  :: uploPlasma = PlasmaLower
      !character(len=32)        :: frmt ="(10(3X,F7.3,SP,F6.3,'i'))"
      integer                  :: lda, ldb, infoPlasma, infoLapack, i
      logical                  :: success = .false.

      ! Performance variables
      real(dp) :: tstart, tstop, telapsed

      ! External functions
      real(wp), external :: dlamch, zlanhe, zlange

      tol = 50.0 * dlamch('E')
      print *, "tol:", tol

      lda = max(1,n);  ldb = max(1,n)

      ! Allocate matrices A, B, Re, Im
      allocate(A(lda,n), B(ldb,nrhs), stat=infoPlasma)

      ! Generate random Hermitian positive definite matrix A
      call zlarnv(1, seed, lda*n, A)
      A = A * conjg(transpose(A))
      do i = 1, n
        A(i,i) = A(i,i) + n
      end do

      !print *, "Random Hermitian positive definite matrix A:"
      !do i = 1, n
      !  print frmt, A(i,:)
      !end do
      !print *, ""

      ! Generate random matrix B
      call zlarnv(1, seed, ldb*nrhs, B)
      !print *, "Random matrix B:"
      !do i = 1, n
      !  print frmt, B(i,:)
      !end do
      !print *, ""

      allocate(Aref(lda,n), Bref(ldb,nrhs), work(n), stat=infoPlasma)
      Aref = A;  Bref = B;  work = 0.0

      ! Factorize matrix A with Cholesky
      call zpotrf(uploLapack, n, A, lda, infoLapack)

      !print *, "Factor " // uploLapack // " of Chol(A):"
      !do i = 1, n
      !  print frmt, A(i,:)
      !end do
      !print *, ""

      !===================
      ! Initialize PLASMA.
      !===================
      call plasma_init(infoPlasma)

      !============================================================
      ! Solve linear system (Ax=b) using factor L or U from Chol(A)
      !============================================================
      tstart = omp_get_wtime()
      call plasma_zpotrs(uploPlasma, n, nrhs, A, lda, B, ldb, infoPlasma)
      tstop  = omp_get_wtime()
      telapsed  = tstop-tstart

      !=================
      ! Finalise PLASMA.
      !=================
      call plasma_finalize(infoPlasma)

      !print *, "Solution matrix X:"
      !do i = 1, n
      !  print frmt, B(i,:)
      !end do
      !print *, ""

      print *, "Time:", telapsed
      print *, ""

      ! Check linear system (Ax=b) solution is correct

      ! Calculate residual (R=b-Ax), Bref := -Aref*B + Bref
      call zgemm('N', 'N', n, nrhs, n, zmone, Aref, lda, B, ldb, &
                  zone, Bref, ldb)

      !print *, "Residual R=b-Ax:"
      !do i = 1, n
      !  print frmt, Bref(i,:)
      !end do
      !print *, ""

      ! Calculate norms |Aref|_I, |X|_I, |R|_I
      Anorm = zlanhe('I', uploLapack, n, Aref, lda, work)

      Xnorm = zlange('I', n, nrhs, B,    ldb, work)
      Rnorm = zlange('I', n, nrhs, Bref, ldb, work)

      print *, "|Aref|_I:", Anorm
      print *, "|X|_I:   ", Xnorm
      print *, "|R|_I:   ", Rnorm
      print *, ""

      if (Anorm > 0.0 .and. Xnorm > 0.0) then

        ! Calculate error |b-Ax|_I / (|A|_I * |x|_I * n)
        error = Rnorm/Anorm/Xnorm/n

        if (error < tol)  success = .true.

      else
          error = -1.0
      end if

      print *, "|b-Ax|_I / (|A|_I * |x|_I * n):", error
      print *, "success:                       ", success

      if (success) then
          write(*,'(a)') "  The result is CORRECT."
      else
          write(*,'(a)') "  The result is WRONG!"
      end if
      write(*,'(a)') ""

      ! Deallocate matrices Aref, Bref
      deallocate(Aref, Bref, work, stat=infoPlasma)

      ! Deallocate matrices A, B
      deallocate(A, B, stat=infoPlasma)

      END PROGRAM TEST_ZPOTRS


!  CFD_Prova1_Questao1_MarinaMazuroski.f90
!
!  FUNCTIONS:
!  CFD_Prova1_Questao1_MarinaMazuroski - Entry point of console application.
!

!****************************************************************************
!
!  PROGRAM: CFD_Prova1_Questao1_MarinaMazuroski
!
!  PURPOSE:  Entry point for the console application.
!
!****************************************************************************

    program CFD_Prova1_Questao1_MarinaMazuroski

    implicit none

    integer,parameter:: nv=5 !Volumes de controle
    integer:: i
    real:: L, dx, dt, f, tempo, tempof, pi
    real, dimension(nv):: Ap, Apo, Aw, Ae, Su, Sp
    real, dimension(nv):: T, x, Tpo, a, b, V
    real:: ro, rL, T0, h, Tinf, Cp, k, rho

    f=1
    dt=1
    pi=3.1415

    L=0.1
    ro=0.011
    rL=0.001
    T0=100
    h=2500
    Tinf=20
    Cp=466.2
    k=57.7
    rho=7840

    dx=L/nv
    write(*,*) 'Tempo final'
    read(*,*) tempof

    !Malha
    x(1)=0.5D0*dx
    do i=2,nv
        x(i)=x(i-1)+dx
    end do

    !Campo inicial de T
    do i=1,nv
        T(i)=T0
        Tpo(i)=T0
    end do

    tempo=0
    do while (tempo<tempof)

    !Parametros
    do i=1,nv
        a(i)=x(i)-dx/2.0D0
        A(i)=((rL-ro)*a(i)/L+ro)
        b(i)=x(i)+dx/2.0D0
        B(i)=((rL-ro)*b(i)/L+ro)
        V(i)=pi*dx/3*(A(i)*A(i)+A(i)*B(i)+B(i)*B(i))
        if(i==1) then
            Aw(i)=0
            Ae(i)=k*pi*B(i)**2.0D0/dx
            Apo(i)=rho*Cp*V(i)/dt
            Su(i)=(2*k*pi*A(i)**2.0D0/dx)*T0+Apo(i)*Tpo(i)
            Sp(i)=-(2*k*pi*A(i)**2.0D0/dx)
            Ap(i)=Apo(i)+f*(Aw(i)+Ae(i))-Sp(i)
        else if((i>1).and.(i<nv)) then
            Aw(i)=k*pi*A(i)**2.0D0/dx
            Ae(i)=k*pi*B(i)**2.0D0/dx
            Apo(i)=rho*Cp*V(i)/dt
            Su(i)=Apo(i)*T(i)
            Sp(i)=0
            Ap(i)=Apo(i)+f*(Aw(i)+Ae(i))-Sp(i)
        else
            Aw(i)=k*pi*A(i)**2.0D0/dx
            Ae(i)=0
            Apo(i)=rho*Cp*V(i)/dt
            Su(i)=pi*B(i)**2.0D0*Tinf/(1.0D0/h+dx/(2.0D0*k))+Apo(i)*Tpo(i)
            Sp(i)=-pi*B(i)**2.0D0/(1.0D0/h+dx/(2.0D0*k))
            Ap(i)=Apo(i)+f*(Aw(i)+Ae(i))-Sp(i)
        end if
    end do

        call tdma1D(Aw, Ae, Su, Sp, Ap, nv, T)
        tempo=tempo+dt
        write(*,*) 'Tempo', tempo, 'segundos'
        write(*,*) 'Temperatura'
        write(*,*) T
        do i=1,nv
            Tpo(i)=T(i)
        end do
    end do

    pause
    !Tecplot
    150 format (2x,30(F20.12,1X))
    open(15,file="Transiente.plt")
    write(15,*) 'Title="Transiente"'
    write(15,*) "Variables='x','T'"
    write(15,*) 'ZONE T="Transiente" i=',nv

    do i=1,nv
        write(15,150) x(i), T(i)
    end do
    close(15)

    Contains
    SUBROUTINE tdma1D(Aw, Ae, Su, Sp, Ap, nv, T)

    integer:: i, k, it_final
    integer:: nv
    real, dimension(nv):: Ap, Aw, Ae, Su, Sp
    real, dimension(nv):: Am, Bm, Cm, Dm, P, Q
    real, dimension(nv):: T
    real, dimension(1:nv,1:2):: M

    do i=1,nv
        if (i==1) then
            Am(i)=Ap(i)
            Bm(i)=-Ae(i)
            Cm(i)=0
            Dm(i)=Su(i)
            P(i)=-Bm(i)/Am(i)
            Q(i)=Dm(i)/Am(i)
        else
            Am(i)=Ap(i)
            Bm(i)=-Ae(i)
            Cm(i)=-Aw(i)
            Dm(i)=Su(i)
            P(i)=-Bm(i)/(Am(i)+Cm(i)*P(i-1))
            Q(i)=(Dm(i)-Cm(i)*Q(i-1))/(Am(i)+Cm(i)*P(i-1))
        end if
    end do
    T(nv)=Q(nv)
    do i=nv,2,-1
        T(i-1)=P(i-1)*T(i)+Q(i-1)
    end do

    end subroutine tdma1D

    end program CFD_Prova1_Questao1_MarinaMazuroski


module PSEDirectSumModule
!> @file PSEDirectSum.f90
!> Data structure and methods for approximations of scattered data and derivatives using Particle Strength Exchange (PSE).
!> @author Peter Bosler, Sandia National Laboratories Center for Computing Research
!>
!>
!> @defgroup PSEDirectSum PSEDirectSum
!> @brief  Data structure and methods for approximations of scattered data and derivatives using Particle Strength Exchange (PSE).
!>
!>	PSE provides a method for approximating derivatives on scattered data by replacing a differential operator with
!>  an integral convolution that approximates the action of the differential operator in the sense of distributions. @n
!>  PSE approximations converge as a small parameter @f$ \epsilon @f$ approaches zero in a limit that also depends on the
!>  distance between particles, @f$ \Delta x @f$,
!> @f[
!> 		\epsilon = \Delta x^{1/p},\quad p>1.
!> @f]
!>
!>  A differential operator @f$ D^\beta @f$, where @f$ \beta @f$ is a multi-index, is approximated by a linear integral operator @f$ L^\beta @f$,
!> @f[
!> 		D^\beta f(\vec{x}) \approx L^\beta f(\vec{x}) = \frac{1}{\epsilon^{|\beta|}}\int_{\mathbb{R}^d} \left( f(\vec{y}) \mp f(\vec{x})\right)\eta_\epsilon^\beta(\vec{x}-\vec{y})\,dV(\vec{y}),
!> @f]
!> 	where d the dimension of the space, @f$ \eta_{\epsilon}^\beta = \eta^\beta(|\vec{x}|/\epsilon) @f$, where @f$\eta^\beta @f$
!> is defined to satisfy a set of moment conditions related to @f$D^\beta@f$ that define its order of accuracy as @f$ \epsilon\to 0@f$.
!>
!>  Using PSE for derivatives transforms spatial derivatives on moving sets of LPM particles into integrals of the same form
!>  we already use to compute the velocity. @n
!>  Like stream functions and the Biot-Savart integral, PSE integrals are currently computed using a parallel direct summation algorithm.
!>
!>	For a detailed description of how to construct PSE kernels for Euclidean spaces with free boundaries, see @n
!>    [J. Eldredge, A. Leonard, and T. Colonius, A general deterministic treatment of derivatives in particle methods,
!>    <i>J. Comput. Phys.,</i> 180 (2002).](http://kefalari.seas.ucla.edu/~jeff/getpaper.php?id=14)
!>
!> @{
use NumberKindsModule
use LoggerModule
use ParticlesModule
use EdgesModule, only : MaxEdgeLength
use PolyMesh2dModule
use FieldModule
use MPISetupModule
use SphereGeomModule, only : ChordDistance, SphereDistance, SphereProjection

implicit none

include 'mpif.h'

private
public PSE, New, Delete
public PSEPlaneInterpolateScalar
public PSEPlaneGradientAtParticles, PSEPlaneSecondPartialsAtParticles, PSEPlaneLaplacianAtParticles
public PSESphereInterpolateScalar, PSESphereGradientAtParticles, PSESphereDivergenceAtParticles, PSESphereLaplacianAtParticles
public bivariateFirstDerivativeKernel8, bivariateLaplacianKernel8
public PSEPlaneDoubleDotProductAtParticles

!> @brief Data type for implementing Particle Strength Exchange (PSE) methods on LPM particle sets
type PSE
	real(kreal) :: eps !< PSE radius of influence, depends on mesh size
	contains
		final :: deletePrivate
end type

interface New
	module procedure newPrivate
end interface

interface Delete
	module procedure deletePrivate
end interface

!
!----------------
! Logging
!----------------
!
logical(klog), save :: logInit = .FALSE.
type(Logger) :: log
character(len=28), save :: logKey = 'PSE'
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL

contains
!----------------
!
! Public functions
!
!----------------

!> @brief Initializes a new PSE object and computes the PSE parameter epsilon.
!>
!> Epsilon is defined to be a fractional power of the mesh size,
!> @f[
!> 	\epsilon = \Delta x^{1/p},\quad p > 1
!> @f]
subroutine newPrivate( self, aMesh, radiusMultiplier )
	type(PSE), intent(out) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	real(kreal), intent(in), optional :: radiusMultiplier
	!
	real(kreal) :: h, pow
	integer(kint) :: nP

	if ( .NOT. logInit ) call InitLogger(log, procRank)

	h = MaxEdgeLength( aMesh%edges, aMesh%particles)

	if ( present(radiusMultiplier) ) then
		pow = radiusMultiplier
	else
		pow = 0.75_kreal
	endif

	self%eps = h ** pow
	call LogMessage(log, TRACE_LOGGING_LEVEL, "PSE Initialized. eps = ", self%eps )
end subroutine

!> @brief Deletes and frees memory associated with a PSE object.
!> @param[inout] self PSE object
subroutine deletePrivate(self)
	type(PSE), intent(inout) :: self
end subroutine

!> @brief Interpolates a scalar field in the plane using convolution with a kernel that approximates a delta function.
!>
!> @param[in] self PSE object
!> @param[in] aMesh @ref PolyMesh2d
!> @param[in] scalarField scalar @ref Field
!> @param[in] interpLoc position vector of desired interpolation location
!> @return Interpolated scalar value
pure function PSEPlaneInterpolateScalar(self, aMesh, scalarField, interpLoc )
	real(kreal) :: PSEPlaneInterpolateScalar
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: scalarField
	real(kreal), intent(in) :: interpLoc(3)
	!
	integer(kint) :: j
	real(kreal) :: kIn, xj(3)

	PSEPlaneInterpolateScalar = 0.0_kreal
	do j = 1, aMesh%particles%N
		if ( aMesh%particles%isActive(j) ) then
			xj = PhysCoord(aMesh%particles,j)
			kIn = ChordDistance(interpLoc,xj)/self%eps
			PSEPlaneInterpolateScalar = PSEPlaneInterpolateScalar + scalarField%scalar(j) * aMesh%particles%area(j) * &
			 	bivariateDeltaKernel8( kIn ) / (self%eps**2)
		endif
	enddo
end function

pure function PSESphereInterpolateScalar( self, aMesh, scalarField, interpLoc)
	real(kreal) :: PSESphereInterpolateScalar
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: scalarField
	real(kreal), intent(in) :: interpLoc(3)
	!
	integer(kint) :: j
	real(kreal) :: kIn, xj(3)

	PSESphereInterpolateScalar = 0.0_kreal
	do j = 1, aMesh%particles%N
		if ( aMesh%particles%isActive(j) ) then
			xj = PhysCoord(aMesh%particles, j)
			kIn = SphereDistance(xj, interpLoc)/self%eps
			PSESphereInterpolateScalar = PSESphereInterpolateScalar + scalarField%scalar(j) * aMesh%particles%area(j) * &
				bivariateDeltaKernel8( kIn ) / (self%eps**2)
		endif
	enddo
end function

!> @brief Constructs a @ref Field that approximates that gradient of a scalar in the plane using PSE.
!>
!> Integration is carried out in parallel using direct summation.
!>
!> @param[in] self PSE object
!> @param[in] aMesh @ref PolyMesh2d
!> @param[in] scalarField scalar @ref Field containing source data
!> @param[inout] scalarGrad vector @ref Field (preallocated) that, on output, stores the approximate scalar gradient at each particles
!> @param[in] particlesMPI @ref MPISetup object to distribute particles across processes
subroutine PSEPlaneGradientAtParticles( self, aMesh, scalarField, scalarGrad, particlesMPI )
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: scalarField
	type(Field), intent(inout) :: scalarGrad
	type(MPISetup), intent(in) :: particlesMPI
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, xi(3), xj(3), kOut

	call SetFieldToZero(scalarGrad)
	scalarGrad%N = aMesh%particles%N

	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey), " entering PSEGradientAtParticles...")

	do i = particlesMPI%indexStart(procRank), particlesMPI%indexEnd(procRank)
		xi = PhysCoord(aMesh%particles, i)
		do j = 1, aMesh%particles%N
			if ( aMesh%particles%isActive(j) ) then
				xj = PhysCoord(aMesh%particles, j)
				kIn = ChordDistance(xi,xj)/self%eps
				scalarGrad%xComp(i) = scalarGrad%xComp(i) + ( scalarField%scalar(j) + scalarField%scalar(i)) *&
					(xi(1)-xj(1)) * bivariateFirstDerivativeKernel8(kIn) / (self%eps**3) * aMesh%particles%area(j)
				scalarGrad%yComp(i) = scalarGrad%yComp(i) + ( scalarField%scalar(j) + scalarField%scalar(i)) *&
					(xi(2)-xj(2)) * bivariateFirstDerivativeKernel8(kIn) / (self%eps**3) * aMesh%particles%area(j)
			endif
		enddo
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST(scalarGrad%xComp(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
					   particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
		call MPI_BCAST(scalarGrad%yComp(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
					   particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	enddo

	call MultiplyFieldByScalar(scalarGrad, 1.0_kreal/self%eps)
end subroutine

subroutine PSESphereGradientAtParticles( self, amesh, scalarField, scalarGrad, particlesMPI )
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: scalarField
	type(Field), intent(inout) :: scalarGrad
	type(MPISetup), intent(in) :: particlesMPI
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, xi(3), xj(3), grad(3), proj(3,3), kOut

	call SetFieldToZero(scalarGrad)
	scalarGrad%N = aMesh%particles%N

	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logkey), " entering PSESphereGradientAtParticles.")

	do i = particlesMPI%indexStart(procRank), particlesMPI%indexEnd(procRank)
		xi = PhysCoord(aMesh%particles, i)
		proj = SphereProjection(xi)
		grad = 0.0_kreal
		do j = 1, aMesh%particles%N
			if ( aMesh%particles%isActive(j) ) then
				xj = PhysCoord( aMesh%particles, j)
				kIn = SphereDistance(xj, xi) / self%eps
				kOut = bivariateFirstDerivativeKernel8( kIn ) / self%eps**2
				grad(1) = grad(1) + ( scalarField%scalar(j) + scalarField%scalar(i)) * ( xi(1) - xj(1) ) * &
						  kOut * aMesh%particles%area(j)
				grad(2) = grad(2) + ( scalarField%scalar(j) + scalarField%scalar(i)) * ( xi(2) - xj(2) ) * &
						  kOut * aMesh%particles%area(j)
			    grad(3) = grad(3) + ( scalarField%scalar(j) + scalarField%scalar(i)) * ( xi(3) - xj(3) ) * &
			    		  kOut * aMesh%particles%area(j)
			endif
		enddo
		grad = MATMUL( proj, grad)
		scalarGrad%xComp(i) = grad(1)
		scalarGrad%yComp(i) = grad(2)
		scalarGrad%zComp(i) = grad(3)
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST( scalarGrad%xComp(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
			particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
		call MPI_BCAST( scalarGrad%yComp(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
			particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
		call MPI_BCAST( scalarGrad%zComp(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
			particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	enddo
	call MultiplyFieldByScalar(scalarGrad, 1.0_kreal/(self%eps**2))
end subroutine

subroutine PSEPlaneSecondPartialsAtParticles( self, aMesh, scalarGrad, secondPartials, particlesMPI )
	type(PSE), intent(in) :: self
	class(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: scalarGrad
	type(Field), intent(inout) :: secondPartials
	type(MPISetup), intent(in) :: particlesMPI
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, xi(3), xj(3), dxx, dxy, dyx, dyy, kOut

	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey), " entering PSESecondPartialsAtParticles...")

	call SetFieldToZero(secondPartials)
	secondPartials%N = aMesh%particles%N

	do i = particlesMPI%indexStart(procRank), particlesMPI%indexEnd(procRank)
		xi = PhysCoord( aMesh%particles, i)
		dxx = 0.0_kreal
		dxy = 0.0_kreal
		dyx = 0.0_kreal
		dyy = 0.0_kreal
		do j = 1, aMesh%particles%N
			if ( aMesh%particles%isActive(j) ) then
				xj = PhysCoord(aMesh%particles, j)
				kIn = ChordDistance(xi,xj)/self%eps
				kOUt = bivariateFirstDerivativeKernel8(kIn) / self%eps**2
				dxx = dxx + (scalarGrad%xComp(j) + scalarGrad%xComp(i)) * ( xi(1) - xj(1) )/self%eps * &
					kOut * aMesh%particles%area(j)
				dxy = dxy + (scalarGrad%xComp(j) + scalarGrad%xComp(i)) * ( xi(2) - xj(2) )/self%eps * &
					kOut * aMesh%particles%area(j)
				dyx = dyx + (scalarGrad%yComp(j) + scalarGrad%yComp(i)) * ( xi(1) - xj(1)) /self%eps * &
					kOut * aMesh%particles%area(j)
				dyy = dyy + (scalarGrad%yComp(j) + scalarGrad%yComp(i)) * ( xi(2) - xj(2)) /self%eps * &
					kOut * aMesh%particles%area(j)
			endif
		enddo
		secondPartials%xComp(i) = dxx
		secondPartials%yComp(i) = 0.5_kreal * ( dxy + dyx )
		secondPartials%zComp(i) = dyy
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST(secondPartials%xComp(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
				   particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCOde)
		call MPI_BCAST(secondPartials%yComp(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
				   particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCOde)
		call MPI_BCAST(secondPartials%zComp(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
				   particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCOde)
	enddo

	call MultiplyFieldByScalar( secondPartials, 1.0_kreal / self%eps )
end subroutine

subroutine PSEPlaneDoubleDotProductAtParticles( self, aMesh, vectorField, doubleDot, particlesMPI)
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: vectorField
	type(Field), intent(inout) :: doubleDot
	type(MPISetup), intent(in) :: particlesMPI
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, xi(3), xj(3), ux, uy, vx, vy, kOut

	call SetFieldToZero(doubleDot)
	doubleDot%N = aMesh%particles%N

	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey), " entering PSEDoubleDotProduct ...")

	do i = particlesMPI%indexStart(procRank), particlesMPI%indexEnd(procRank)
		xi = PhysCoord(aMesh%particles, i)
		ux = 0.0_kreal
		uy = 0.0_kreal
		vx = 0.0_kreal
		vy = 0.0_kreal
		do j = 1, aMesh%particles%N
			if ( aMesh%particles%isActive(j) ) then
				xj = PhysCoord(aMesh%particles, j)
				kIn = ChordDistance(xi,xj)/self%eps
				kOut = bivariateFirstDerivativeKernel8( kIn ) / self%eps**2
				ux = ux + (vectorField%xComp(j) + vectorField%xComp(i)) * ( xi(1) - xj(1) )/self%eps * &
					kOut * aMesh%particles%area(j)
				uy = uy + (vectorField%xComp(j) + vectorField%xComp(i)) * ( xi(2) - xj(2) )/self%eps * &
					kOut * aMesh%particles%area(j)
				vx = vx + (vectorField%yComp(j) + vectorField%yComp(i)) * ( xi(1) - xj(1) )/self%eps * &
					kOut * aMesh%particles%area(j)
				vy = vy + (vectorField%yComp(j) + vectorField%yComp(i)) * ( xi(2) - xj(2) )/self%eps * &
					kOut * aMesh%particles%area(j)
			endif
		enddo
		doubleDot%scalar(i) = (ux * ux + 2.0_kreal * uy * vx + vy * vy)/self%eps**2
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST( doubleDot%scalar(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
				particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode )
	enddo
end subroutine

subroutine PSESphereDoubleDotProductAtParticles( self, aMesh, vectorField, doubleDot, particlesMPI)
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: vectorField
	type(Field), intent(inout) :: doubleDot
	type(MPISetup), intent(in) :: particlesMPI
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, xi(3), xj(3), ux, uy, uz, vx, vy, vz, wx, wy, wz, kOut

	call SetFieldToZero(doubleDot)
	doubleDot%N = aMesh%particles%N

	do i = particlesMPI%indexStart(procRank), particlesMPI%indexEnd(procRank)
		xi = PhysCoord(aMesh%particles, i)
		ux = 0.0_kreal
		uy = 0.0_kreal
		uz = 0.0_kreal
		vx = 0.0_kreal
		vy = 0.0_kreal
		vz = 0.0_kreal
		wx = 0.0_kreal
		wy = 0.0_kreal
		wz = 0.0_kreal
		do j = 1, aMesh%particles%N
			if ( aMesh%particles%isActive(j) ) then
				xj = PhysCoord(aMesh%particles, j)
				kIn = SphereDistance(xi,xj) / self%eps
				kOut = bivariateFirstDerivativeKernel8( kIn ) / self%eps**2
				ux = ux + (vectorField%xComp(j) + vectorField%xComp(i)) * ( xi(1) - xj(1) )/self%eps * &
					kOut * aMesh%particles%area(j)
				uy = uy + (vectorField%xComp(j) + vectorField%xComp(i)) * ( xi(2) - xj(2) )/self%eps * &
					kOut * aMesh%particles%area(j)
				uz = uz + (vectorField%xComp(j) + vectorField%xComp(i)) * ( xi(3) - xj(3) )/self%eps * &
					kOut * aMesh%particles%area(j)
				vx = vx + (vectorField%yComp(j) + vectorField%yComp(i)) * ( xi(1) - xj(1) )/self%eps * &
					kOut * aMesh%particles%area(j)
				vy = vy + (vectorField%yComp(j) + vectorField%yComp(i)) * ( xi(2) - xj(2) )/self%eps * &
					kOut * aMesh%particles%area(j)
				vz = vz + (vectorField%yComp(j) + vectorField%yComp(i)) * ( xi(3) - xj(3) )/self%eps * &
					kOut * aMesh%particles%area(j)
				wx = wx + (vectorField%zComp(j) + vectorField%yComp(i)) * ( xi(1) - xj(1) )/self%eps * &
					kOut * aMesh%particles%area(j)
				wy = wy + (vectorField%zComp(j) + vectorField%yComp(i)) * ( xi(2) - xj(2) )/self%eps * &
					kOut * aMesh%particles%area(j)
				wz = wz + (vectorField%zComp(j) + vectorField%yComp(i)) * ( xi(3) - xj(3) )/self%eps * &
					kOut * aMesh%particles%area(j)
			endif
		enddo
		doubleDot%scalar(i) = (ux*ux + vy*vy + wz*wz + 2.0_kreal*( uy*vx + uz*wx + vz*wy))/self%eps**2
	enddo
end subroutine

subroutine PSEDoubleDotProductArrays( self, doubleDot, xIn, yIn, uIn, vIn, areaIn, activeMask, mpiParticles )
	type(PSE), intent(in) :: self
	real(kreal), intent(out) :: doubleDot(:)
	real(kreal), intent(in) :: xIn(:)
	real(kreal), intent(in) :: yIn(:)
	real(kreal), intent(in) :: uIn(:)
	real(kreal), intent(in) :: vIn(:)
	real(kreal), intent(in) :: areaIn(:)
	logical(klog), intent(in) :: activeMask(:)
	type(MPISetup), intent(in) :: mpiParticles
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, ux, uy, vx, vy, kernel

	doubleDot(mpiParticles%indexStart(procRank):mpiParticles%indexEnd(procRank)) = 0.0_kreal

	do i = mpiParticles%indexStart(procRank), mpiParticles%indexEnd(procRank)
		ux = 0.0_kreal
		uy = 0.0_kreal
		vx = 0.0_kreal
		vy = 0.0_kreal
		if ( activeMask(j) ) then
			kIn  = sqrt( (xIn(i) - xIn(j))**2 + (yIn(i) - yIn(j))**2 ) / self%eps
			kernel = bivariateFirstDerivativeKernel8( kIn ) / self%eps**2
			ux = ux + ( uIn(j) + uIn(i) ) * ( xIn(i) - xIn(j) ) / self%eps * kernel * areaIn(j)
			uy = uy + ( uIn(j) + uIn(i) ) * ( yIn(i) - yIn(j) ) / self%eps * kernel * areaIn(j)
			vx = vx + ( vIn(j) + vIn(i) ) * ( xIn(i) - xIn(j) ) / self%eps * kernel * areaIn(j)
			vy = vy + ( vIn(j) + vIn(i) ) * ( yIn(i) - yIn(j) ) / self%eps * kernel * areaIn(j)
		endif
		doubleDot(i) = ( ux * ux + 2.0_kreal * uy * vx + vy * vy ) / self%eps**2
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST( doubleDot(mpiParticles%indexStart(i):mpiParticles%indexEnd(i)), mpiParticles%messageLength(i), &
			MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	enddo
end subroutine

!> @brief Constructs a @ref Field that approximates that Laplacian of a scalar in the plane using PSE.
!>
!> Integration is carried out in parallel using direct summation.
!>
!> @param[in] self PSE object
!> @param[in] aMesh @ref PolyMesh2d
!> @param[in] scalarField scalar @ref Field containing source data
!> @param[inout] scalarLap scalar @ref Field (preallocated) that, on output, stores the approximate Laplacian at each particle
!> @param[in] particlesMPI @ref MPISetup object to distribute particles across processes
subroutine PSEPlaneLaplacianAtParticles(self, aMesh, scalarField, scalarLap, particlesMPI )
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: scalarField
	type(Field), intent(inout) :: scalarLap
	type(MPISetup), intent(in) :: particlesMPI
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, xi(3), xj(3)

	call SetFieldToZero(scalarLap)
	scalarLap%N = aMesh%particles%N

	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey), " entering PSELaplacianAtParticles...")

	do i = particlesMPI%indexStart(procRank), particlesMPI%indexEnd(procRank)
		xi = PhysCoord(aMesh%particles, i)
		do j = 1, aMesh%particles%N
			if ( aMesh%particles%isActive(j) ) then
				xj = PhysCoord(aMesh%particles, j)
				kIn = ChordDistance(xi,xj)/self%eps
				scalarLap%scalar(i) = scalarLap%scalar(i) + (scalarField%scalar(j) - scalarField%scalar(i)) * &
					bivariateLaplacianKernel8(kIN)/(self%eps**2) * aMesh%particles%area(j)
			endif
		enddo
	enddo

	do i = 0, numProcs-1
		call MPI_BCAST(scalarLap%scalar(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
					   particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	enddo

	call MultiplyFieldByScalar(scalarLap, 1.0_kreal/(self%eps**2))
end subroutine

subroutine PSESphereLaplacianAtParticles( self, aMesh, scalarField, scalarLap, particlesMPI )
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: scalarField
	type(Field), intent(inout) :: scalarLap
	type(MPISetup), intent(in) :: particlesMPI
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, xi(3), xj(3)

	call SetFieldToZero(scalarLap)
	scalarLap%N = aMesh%particles%N

	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey), " entering PSELaplacianAtParticles...")

	do i = particlesMPI%indexStart(procRank), particlesMPI%indexEnd(procRank)
		xi = PhysCoord(aMesh%particles, i)
		do j = 1, aMesh%particles%N
			if ( aMesh%particles%isActive(j) ) then
				xj = PhysCoord(aMesh%particles, j)
				kIn = SphereDistance(xi,xj)/self%eps
				scalarLap%scalar(i) = scalarLap%scalar(i) + (scalarField%scalar(j) - scalarField%scalar(i)) * &
					bivariateLaplacianKernel8(kIN)/(self%eps**2) * aMesh%particles%area(j)
			endif
		enddo
	enddo

	do i = 0, numProcs-1
		call MPI_BCAST(scalarLap%scalar(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
					   particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	enddo

	call MultiplyFieldByScalar(scalarLap, 1.0_kreal/(self%eps**2))
end subroutine

subroutine PSESphereDivergenceAtParticles( self, aMesh, vectorField, divergence, particlesMPI )
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: vectorField
	type(Field), intent(inout) :: divergence
	type(MPISetup), intent(in) :: particlesMPI
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, xi(3), xj(3), grad(3), proj(3,3), denom

	call SetFieldToZero(divergence)
	divergence%N = aMesh%particles%N

	denom = self%eps**3

	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logkey), " entering PSESphereDivergenceAtParticles.")

	do i = particlesMPI%indexStart(procRank), particlesMPI%indexEnd(procRank)
		xi = PhysCoord(aMesh%particles, i)
		proj = SphereProjection(xi)
		grad = 0.0_kreal
		do j = 1, aMesh%particles%N
			if ( aMesh%particles%isActive(j) ) then
				xj = PhysCoord(aMesh%particles, j)
				kIn = SphereDistance(xj, xi)/self%eps
				grad(1) = (xi(1) - xj(1)) * bivariateFirstDerivativeKernel8( kIn ) / denom
				grad(2) = (xi(2) - xj(2)) * bivariateFirstDerivativeKernel8( kIn ) / denom
				grad(3) = (xi(3) - xj(3)) * bivariateFirstDerivativeKernel8( kIn ) / denom
				grad = MATMUL( proj, grad )
				divergence%scalar(i) = divergence%scalar(i) + ( grad(1) * (vectorField%xComp(j) + vectorField%xComp(i)) + &
						grad(2) * (vectorField%yComp(j) + vectorField%yComp(i) ) +&
						grad(3) * (vectorField%zComp(j) + vectorField%zComp(i) )) * aMesh%particles%area(j)
			endif
		enddo
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST( divergence%scalar(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
			particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode )
	enddo

	call MultiplyFieldByScalar(divergence, 1.0_kreal/self%eps)
end subroutine

!----------------
!
! Private functions
!
!----------------

!> @brief Computes the scaled input to a PSE kernel.
!>
!> @param[in] xi position vector of particle i
!> @param[in] xj position vector of particle j
!> @param[in] eps PSE parameter
!> @param[in] geomKind geometry kind (e.g., planar or spherical) as defined in @ref NumberKinds
!> @return Scaled kernel input @f$ \frac{|\vec{x}_i - \vec{x}_j|}{\epsilon}  @f$
pure function integralKernelInput( xi, xj, eps, geomKind )
	real(kreal) :: integralKernelInput
	real(kreal), intent(in) :: xi(3), xj(3), eps
	integer(kint), intent(in) :: geomKind
	if ( geomKind == PLANAR_GEOM ) then
		integralKernelInput = ChordDistance(xi,xj)/eps
	elseif ( geomKind == SPHERE_GEOM ) then
		integralKernelInput = SphereDistance(xi,xj)/eps
	else
		integralKernelInput = 0.0_kreal
	endif
end function

!> @brief Computes the value of a kernel that approximates a delta function on @f$ \mathbb{R}^2 @f$ to 8th order accuracy.
!>
!> @param[in] radialDist Kernel input, typically from psedirectsummodule::integralkernelinput
!> @return kernel value
pure function bivariateDeltaKernel8( radialDist )
	real(kreal) :: bivariateDeltaKernel8
	real(kreal), intent(in) :: radialDist
	bivariateDeltaKernel8 = (4.0_kreal - 6.0_kreal * radialDist**2 + 2.0_kreal * radialDist**4 - &
			 radialDist**6 / 6.0_kreal) * exp(-radialDist * radialDist) / PI
end function

!> @brief Computes the value of a kernel that approximates the Laplacian on @f$ \mathbb{R}^2 @f$ to 8th order accuracy.
!>
!> @param[in] radialDist Kernel input, typically from psedirectsummodule::integralkernelinput
!> @return kernel value
pure function bivariateLaplacianKernel8( radialDist )
	real(kreal) :: bivariateLaplacianKernel8
	real(kreal), intent(in) :: radialDist
	bivariateLaplacianKernel8 = (40.0_kreal - 40.0_kreal * radialDist**2 + 10.0_kreal * radialDist**4 - &
								 2.0_kreal * radialDist**6/3.0_kreal) * exp( -radialDist*radialDist) / PI
end function

pure function bivariateFirstDerivativeKernel8( radialDist)
	real(kreal) :: bivariateFirstDerivativeKernel8
	real(kreal), intent(in) :: radialDist
	bivariateFirstDerivativeKernel8 = (-20.0_kreal + 20.0_kreal * radialDist**2 - 5.0_kreal * radialDist**4 + &
									   radialDist**6/3.0_kreal) * exp( - radialDist*radialDist ) / PI
end function

pure function bivariateSecondDerivativeKernel8( radialDist )
	real(kreal) :: bivariateSecondDerivativeKernel8
	real(kreal), intent(in) :: radialDist
	bivariateSecondDerivativeKernel8 = (24.0_kreal -16.0_kreal * radialDist**2 + 2.0_kreal * radialDist**4) * &
				exp(- radialDist**2) / PI
end function

pure function bivariateMixedSecondDerivativeKernel8( radialDist, x, y )
	real(kreal) :: bivariateMixedSecondDerivativeKernel8
	real(kreal), intent(in) :: radialDist, x, y
	bivariateMixedSecondDerivativeKernel8 = x * y * (160.0_kreal - 120.0_kreal * radialDist**2  + &
		24.0_kreal * radialDist**4 - 4.0_kreal * radialDist**6/3.0_kreal )* exp(-radialDist**2)/PI
end function

pure function trivariateDeltaKernel8( radialDist )
	real(kreal) :: trivariateDeltaKernel8
	real(kreal), intent(in) :: radialDist
	trivariateDeltaKernel8 = (6.5625_kreal - 7.875 * radialDist**2 + 2.25_kreal * radialDist**4 - &
		radialDist**6/6.0_kreal) * exp( - radialDist**2 ) / 5.568327996831708_kreal
end function

pure function trivariateFirstDerivativeKernel8( radialDist, eps )
	real(kreal) :: trivariateFirstDerivativeKernel8
	real(kreal), intent(in) :: radialDist
	real(kreal), intent(in) :: eps
	trivariateFirstDerivativeKernel8 = (-7.875_kreal/eps**2 + 9.0_kreal * radialDist**2/eps**4 - radialDist**4/eps**4 - &
										13.125_kreal - 15.75_kreal * radialDist**2 + 4.5_kreal * radialDist**4 - &
										radialDist**6/3.0_kreal ) * exp(-radialDist**2)
end function

!> @brief Initializes a logger for the PSEDirectSum module
!>
!> Output is controlled both by message priority and by MPI Rank
!> @param aLog Target Logger object
!> @param rank Rank of this processor
subroutine InitLogger(aLog,rank)
! Initialize a logger for this module and processor
	type(Logger), intent(out) :: aLog
	integer(kint), intent(in) :: rank
	write(logKey,'(A,A,I0.2,A)') trim(logKey),'_',rank,' : '
	if ( rank == 0 ) then
		call New(aLog,logLevel)
	else
		call New(aLog,ERROR_LOGGING_LEVEL)
	endif
	logInit = .TRUE.
end subroutine

!> @}
end module


c
c
c     =====================================================
      subroutine clawpack46_rpn2(ixy,maxm,meqn,mwaves,mbc,mx,
     &      ql,qr,auxl,auxr,wave,s,amdq,apdq)
c     =====================================================
c
c     # Riemann solver for the acoustics equations in 2d,
c
c     # Note that although there are 3 eigenvectors, the second eigenvalue
c     # is always zero and so we only need to compute 2 waves.
c     #
c     # solve Riemann problems along one slice of data.
c
c     # On input, ql contains the state vector at the left edge of each cell
c     #           qr contains the state vector at the right edge of each cell
c
c     # This data is along a slice in the x-direction if ixy=1
c     #                            or the y-direction if ixy=2.
c     # On output, wave contains the waves,
c     #            s the speeds,
c     #            amdq the  left-going flux difference  A^- \Delta q
c     #            apdq the right-going flux difference  A^+ \Delta q
c
c
c     # Note that the i'th Riemann problem has left state qr(i-1,:)
c     #                                    and right state ql(i,:)
c     # From the basic clawpack routines, this routine is called with ql = qr
c
c     # aux arrays not used in this solver.
c
      implicit none

      integer ixy,maxm,meqn,mwaves,mbc,mx
      double precision wave(1-mbc:maxm+mbc, meqn, mwaves)
      double precision    s(1-mbc:maxm+mbc, mwaves)
      double precision   ql(1-mbc:maxm+mbc, meqn)
      double precision   qr(1-mbc:maxm+mbc, meqn)
      double precision apdq(1-mbc:maxm+mbc, meqn)
      double precision amdq(1-mbc:maxm+mbc, meqn)
      double precision auxl(1-mbc:maxm+mbc, *)
      double precision auxr(1-mbc:maxm+mbc, *)
c
c     local arrays
c     ------------
      double precision delta(3)
c
c     # density, bulk modulus, and sound speed, and impedence of medium:
c     # (should be set in setprob.f)
      double precision rho, bulk, cc, zz
      common /cparam/ rho,bulk,cc,zz

      integer mu, mv, i, m
      double precision a1, a2

c     # set mu to point to  the component of the system that corresponds
c     # to velocity in the direction of this slice, mv to the orthogonal
c     # velocity:
c
      if (ixy.eq.1) then
          mu = 2
          mv = 3
      else
          mu = 3
          mv = 2
      endif
c
c     # note that notation for u and v reflects assumption that the
c     # Riemann problems are in the x-direction with u in the normal
c     # direciton and v in the orthogonal direcion, but with the above
c     # definitions of mu and mv the routine also works with ixy=2
c     # in which case waves come from the
c     # Riemann problems u_t + g(u)_y = 0 in the y-direction.
c
c
c     # split the jump in q at each interface into waves
c
c     # find a1 and a2, the coefficients of the 2 eigenvectors:
      do i = 2-mbc, mx+mbc
         delta(1) = ql(i,1) - qr(i-1,1)
         delta(2) = ql(i,mu) - qr(i-1,mu)
         a1 = (-delta(1) + zz*delta(2)) / (2.d0*zz)
         a2 = (delta(1) + zz*delta(2)) / (2.d0*zz)
c
c        # Compute the waves.
c
         wave(i,1,1) = -a1*zz
         wave(i,mu,1) = a1
         wave(i,mv,1) = 0.d0
         s(i,1) = -cc
c
         wave(i,1,2) = a2*zz
         wave(i,mu,2) = a2
         wave(i,mv,2) = 0.d0
         s(i,2) = cc
      end do
c
c
c     # compute the leftgoing and rightgoing flux differences:
c     # Note s(i,1) < 0   and   s(i,2) > 0.
c
      do m=1,meqn
         do i = 2-mbc, mx+mbc
            amdq(i,m) = s(i,1)*wave(i,m,1)
            apdq(i,m) = s(i,2)*wave(i,m,2)
         end do
      end do
c
      return
      end


C NCLFORTSTART
      SUBROUTINE DPOTMP(PRESS,TEMP,S,RP,POTEMP)
      IMPLICIT NONE
C
C     TITLE:
C     *****
C
C       POTMP  -- CALCULATE POTENTIAL TEMPERATURE FOR AN ARBITRARY
C                 REFERENCE PRESSURE
C
C     PURPOSE:
C     *******
C
C       TO CALCULATE POTENTIAL TEMPERATURE
C
C       REF: N.P. FOFONOFF
C            DEEP SEA RESEARCH
C            IN PRESS NOV 1976
C
C     PARAMETERS:
C     **********
C
C       PRESS  -> PRESSURE IN DECIBARS
C       TEMP   -> TEMPERATURE IN CELSIUS DEGREES
C       S      -> SALINITY PSS 78
C       RP     -> REFERENCE PRESSURE IN DECIBARS
C                 (0.0 FOR THE QUANTITY THETA)
C       POTEMP <- POTENTIAL TEMPERATURE (DEG C)
C
      DOUBLE PRECISION PRESS,TEMP,S,RP,POTEMP
C NCLEND
C
C     VARIABLES:
C     *********
C
         INTEGER I,J,N
         DOUBLE PRECISION DP,P,Q,R1,R2,R3,R4,R5,S1,T,X
C
C     CODE:
C     ****
C
      S1 = S-35.0D0
      P  = PRESS
      T  = TEMP
C
      DP = RP - P
C C C N  = IFIX(ABS(DP)/1000.0D0) + 1     ! original; IFIX does not allow dble
      N  = IDINT (ABS(DP)/1000.0D0) + 1
      DP = DP/N
C
      DO 10 I=1,N
         DO 20 J=1,4
C
            R1 = ((-2.1687D-16*T+1.8676D-14)*T-4.6206D-13)*P
            R2 = (2.7759D-12*T-1.1351D-10)*S1
            R3 = ((-5.4481D-14*T+8.733D-12)*T-6.7795D-10)*T
            R4 = (R1+(R2+R3+1.8741D-8))*P+(-4.2393D-8*T+1.8932D-6)*S1
            R5 = R4+((6.6228D-10*T-6.836D-8)*T+8.5258D-6)*T+3.5803D-5
C
            X  = DP*R5
C
            GO TO (100,200,300,400),J
C
  100       CONTINUE
            T = T+0.5D0*X
            Q = X
            P = P + 0.5D0*DP
            GO TO 20
C
  200       CONTINUE
            T = T + .29298322D0*(X-Q)
            Q = 0.58578644D0*X + 0.121320344D0*Q
            GO TO 20
C
  300       CONTINUE
            T = T + 1.707106781D0*(X-Q)
            Q = 3.414213562D0*X - 4.121320344D0*Q
            P = P + 0.5D0*DP
            GO TO 20
C
  400       CONTINUE
            T = T + (X-2.0D0*Q)/6.0D0
  20      CONTINUE
  10    CONTINUE
C
        POTEMP = T
        RETURN
C
C       END POTMP
C
        END
c ------------
C NCLFORTSTART
        subroutine dpth2pres(nd, depth, has_msg_depth, depth_msg,
     +             pressure)
        implicit none
c  DESCRIPTION:
c  This function computes pressure in bars from depth in meters
c  using a mean density derived from depth-dependent global
c  average temperatures and salinities from Levitus 1994, and
c  integrating using hydrostatic balance.
c
c  References:
c
c  Levitus, S., R. Burgett, and T.P. Boyer, World Ocean Atlas
c  Volume 3: Salinity, NOAA Atlas NESDIS 3, US Dept. of ! Commerce, 1994.
c
c  Levitus, S. and T.P. Boyer, World Ocean Atlas 1994, ! Volume 4:
c  Temperature, NOAA Atlas NESDIS 4, US Dept. of ! Commerce, 1994.
c
c  Dukowicz, J. K., 2000: Reduction of Pressure and Pressure
c  Gradient Errors in Ocean Simulations, J. Phys. Oceanogr.,
c  submitted.

c  INPUT PARAMETERS:
c  nd     - size of
c  depth  - depth in meters. No units check is made

      integer  nd, has_msg_depth
      double precision depth(nd), depth_msg

c  OUTPUT PARAMETERS:
c  pressure - pressure in bars

      double precision pressure(nd)
C NCLEND

c  LOCAL PARAMETERS:
      integer n
      double precision c1
      data c1 /1.0d0/
c -----------------------------------------------------------------------
c  convert depth in meters to pressure in bars
c -----------------------------------------------------------------------

      if (has_msg_depth.eq.1) then
         do n=1,nd
            if(depth(n).eq.depth_msg) then
               pressure(n) = depth_msg
            else
               pressure(n) = 0.059808d0*(exp(-0.025d0*depth(n)) - c1) +
     &                       0.100766d0*depth(n)+2.28405d-7*depth(n)**2
            end if
         end do
      else
         do n=1,nd
            pressure(n) = 0.059808d0*(exp(-0.025d0*depth(n)) - c1) +
     &                    0.100766d0*depth(n)+2.28405d-7*depth(n)**2
         end do
      end if

      return
      end


	SUBROUTINE RU_WHGT  ( field, nwnd, hght, iret )
C************************************************************************
C* RU_WHGT								*
C*									*
C* This subroutine decodes the height from a significant wind field.	*
C* The field is of the form  atuuu  where a is 1 if the height is 	*
C* above 100000 feet and 9 or 8 otherwise.  t  is the ten-thousands	*
C* digit of the height and the u's are up to three thousands-of-feet	*
C* fields.  The heights are converted from feet to meters.		*
C*									*
C* RU_WHGT  ( FIELD, NWND, HGHT, IRET )					*
C*									*
C* Input parameters:							*
C*	FIELD		CHAR*		Height field			*
C*									*
C* Output parameters:							*
C*	NWND		INTEGER		Number of height fields		*
C*	HGHT (NWND)	REAL		Height in meters		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 8/86						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	field
	REAL		hght (*)
C------------------------------------------------------------------------
	iret = 0
	nwnd = 0
C
C*	Check that the first character of the field is '9' or '1'.
C
	IF (( field (1:1) .eq. '9' ) .or. ( field (1:1) .eq. '8')) THEN
	    iadd = 0
	  ELSE IF  ( field (1:1) .eq. '1' ) THEN
	    iadd = 100000
	  ELSE
	    RETURN
	END IF
C
C*	Convert the tens digit to an integer.
C
	CALL ST_INTG ( field (2:2), iten, ier )
	IF  ( ier .eq. 0 ) THEN
	    iten = iten * 10
	  ELSE
	    RETURN
	END IF
C
C*	Convert the unit digits to integers and compute height.
C
	DO WHILE ( ( ier .eq. 0 ) .and. ( nwnd .lt. 3 ) )
	    i = nwnd + 3
	    CALL ST_INTG ( field (i:i), iunit, ier )
	    IF  ( ier .eq. 0 ) THEN
		nwnd = nwnd + 1
		z    = ( (iten + iunit) * 1000 + iadd )
		hght ( nwnd ) = PR_HGFM  ( z )
	    END IF
	END DO
C*
	RETURN
	END


! RUN: %python %S/test_folding.py %s %flang_fc1
! Ensure that lower bounds are accounted for in intrinsic folding;
! this is a regression test for a bug in which they were not
module m
  real, parameter :: a(-1:-1) = 1.
  real, parameter :: b(-1:-1) = log(a)
  integer, parameter :: c(-1:1) = [33, 22, 11]
  integer, parameter :: d(1:3) = [33, 22, 11]
  integer, parameter :: e(-2:0) = ([33, 22, 11])
  logical, parameter :: test_1 = lbound((a),1)==-1 .and. lbound(b,1)==-1 .and. &
                               lbound(log(a),1)==1 .and. all(b==0)
  logical, parameter :: test_2 = all(c .eq. d)
  logical, parameter :: test_3 = all(c .eq. e)
  logical, parameter :: test_4 = all(d .eq. e)
end


!! main subroutines for ma_sub measurement

!------------------------------------------------------------------
subroutine fft(n,xi,zzign,dt)
    ! Fourier transform
    ! This inputs AND outputs a complex function.
    ! The convention is FFT --> e^(-iwt)
    ! numerical factor for Plancherel theorem: planch_fac = dble(NPT * dt * dt)
    !------------------------------------------------------------------
    use constants

    implicit none

    complex*16, dimension(*) :: xi
    integer :: n
    double precision :: dt

    complex*16 :: wk, hold, q
    double precision :: m(25)
    double precision :: zzign,zign,flx,v
    integer :: lblock,k,fk,jh,ii,istart
    integer :: l,iblock,nblock,i,lbhalf,j,lx

    ! sign must be +1. or -1.
    if(zzign >= 0.) then
        zign = 1.
    else
        zign = -1.
    endif

    lx = 2**n

    ! checks bounds
    if( lx > NPT ) stop 'error fft increase NPT, or decrease n'

    do 1 i=1,n
    1 m(i) = 2**(n-i)
    do 4 l=1,n
    nblock = 2**(l-1)
    lblock = lx/nblock
    lbhalf = lblock/2
    k = 0
    do 4 iblock=1,nblock
    fk = k
    flx = lx

    v = zign*2.*PI*fk/flx         ! Fourier convention

    wk = cmplx(cos(v),-sin(v))   ! sign change to -sin(v) 17-Nov-2006
    istart = lblock*(iblock-1)

    do 2 i=1,lbhalf
    j  = istart+i
    jh = j+lbhalf
    ! checks bounds
    if( jh < 1 .or. jh > NPT ) stop 'error fft bounds'

    q = xi(jh)*wk
    xi(jh) = xi(j)-q
    xi(j)  = xi(j)+q
    2 continue

    do 3 i=2,n
    ii = i
    if(k < m(i)) go to 4
    3 k = k-m(i)
    4 k = k+m(ii)
    k = 0
    do 7 j=1,lx
    if(k < j) go to 5
    hold = xi(j)
    ! checks bounds
    if( k+1 < 1 .or. k+1 > NPT ) stop 'error fft k bounds'
    xi(j) = xi(k+1)
    xi(k+1) = hold
    5 do 6 i=1,n
    ii = i
    if(k < m(i)) go to 7
    6 k = k-m(i)
    7 k = k+m(ii)

    ! final steps deal with dt factors
    if(zign > 0.) then       ! FORWARD FFT
        do i = 1,lx
        xi(i) = xi(i)*dt   ! multiplication by dt
        enddo

    else                     ! REVERSE FFT
        flx = flx*dt
        do i = 1,lx
        xi(i) = xi(i)/flx  ! division by dt
        enddo
    endif

end subroutine fft
!------------------------------------------------------------------
subroutine fftinv(npow,s,zzign,dt,r)
    ! inverse Fourier transform -- calls fft
    !------------------------------------------------------------------
    !  use constants

    implicit none

    !implicit real*8(a-h,o-z)
    !dimension r(4096*4)
    !complex s(4096*4)

    complex*16, intent(in) :: s(*)
    double precision, intent(out) :: r(*)   ! note this is REAL

    double precision :: dt,zzign,zign
    integer :: npow, nsmp, nhalf, i

    nsmp = 2**npow
    nhalf = nsmp/2
    call rspec(s,nhalf)   ! re-structuring

    zign=zzign
    call fft(npow,s,zign,dt)    ! Fourier transform

    do i = 1,nsmp
    r(i) = real(s(i))     ! REAL part
    enddo

end subroutine fftinv

!------------------------------------------------------------------
subroutine rspec(s,np2)
    !------------------------------------------------------------------
    !  use constants

    implicit none

    !implicit real*8(a-h,o-z)
    !complex s(4096*4)

    complex*16 :: s(*)
    integer :: np2,n,n1,i

    n = 2*np2
    n1 = np2+1

    s(n1) = 0.
    !     s(1)  = 0.
    s(1)  = cmplx( real(s(1)),0.)

    do i = 1,np2
    s(np2+i) = conjg(s(np2+2-i))
    enddo

end subroutine rspec

!------------------------------------------------------------------
subroutine staper(nt, fw, nev, v, ndim, a, w)
    !------------------------------------------------------------------
    !$$$$ calls tsturm, root
    !  Slepian - Thomson multi-taper procedure
    !  Slepian, D.     1978  Bell Sys Tech J v57 n5 1371-1430
    !  Thomson, D. J.  1982  Proc IEEE v70 n9 1055-1096
    !    nt    the number of points in the series
    !    fw    the time-bandwidth product (number of Rayleigh bins)
    !    nev   the desired number of tapers
    !    v     the eigenvectors (tapers) are returned in v(.,nev)
    !    a, w  work arrays dimensioned at least nt long (nt+1, nt odd)
    !    a(1..nev) contains bandwidth retention factors on output.
    !  The tapers are the eigenvectors of the tridiagonal matrix sigma(i,j)
    !  [see Slepian(1978) eq 14 and 25.] They are also the eigenvectors of
    !  the Toeplitz matrix eq. 18. We solve the tridiagonal system in
    !  tsturm for the tapers and use them in Slepians eq 18 to get the
    !  bandwidth retention factors (i.e. the eigenvalues) Thomson's
    !  normalisation is used with no attention to sign.
    !implicit real*8(a-h,o-z)
    !dimension a(*),w(*),v(ndim,*)
    !parameter (pi=3.14159265358979d0,r2=1.414213562373095d0)
    !  use constants

    implicit none

    integer :: nt, nev, ndim
    double precision :: fw
    double precision :: v(ndim,*), a(*), w(*)

    double precision, parameter :: PI = 3.141592653589793d+00
    integer :: i,j,k,m
    integer :: nxi, lh, lp1, neven, nodd, ntot, kk, kmax, nlow, nup
    double precision :: r2,om,com,hn,asav,rbd,dc,sm,s,sn,vmax

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

    r2 = sqrt(2.)

    if(nt < 2) return
    nxi=mod(nt,2)
    lh=(nt/2)+nxi
    lp1=nt+1
    om=2.*PI*fw/nt
    com=cos(om)
    hn=0.5*dble(lp1)
    do 10 i=1,lh
    a(i)=com*(i-hn)**2
    10   w(i)=0.5*dble(i*(nt-i))
    if(nxi == 0) then
        asav=a(lh)-w(lh)
        a(lh)=a(lh)+w(lh)
        rbd=1./(a(lh)+w(lh-1))
    else
        asav=w(lh-1)
        rbd=1./(w(lh)+w(lh-1))
        w(lh-1)=r2*w(lh-1)
    endif
    do 15 i=1,lh
    a(i+lh)=w(i)*rbd
    w(i)=a(i+lh)**2
    15   a(i)=a(i)*rbd
    neven=max0((nev+1)/2,1)
    nodd=nev-neven
    !  Do the even tapers
    call tsturm(nt,lh,a,a(lh+1),w,neven,v,ndim,w(lh+1),0)
    do 20 i=1,neven
    k=2*i-1
    if(nxi == 1) v(lh,k)=r2*v(lh,k)
    do 20 j=1,lh
    20     v(lp1-j,k)=v(j,k)
    if(nodd <= 0) goto 34
    !  Do the odd tapers
    if(nxi == 0) then
        a(lh)=asav*rbd
    else
        a(nt)=asav*rbd
        w(lh-1)=asav*asav
    endif
    call tsturm(nt,lh-nxi,a,a(lh+1),w,nodd,v,ndim,w(lh+1),1)
    do 30 i=1,nodd
    k=2*i
    if(nxi == 1) v(lh,k)=0.
    do 30 j=1,lh
    30     v(lp1-j,k)=-v(j,k)
    34 ntot=neven+nodd
    !  Calculate bandwidth retention parameters
    dc=2.*com
    sm=0.
    s=sin(om)
    w(1)=om/PI
    w(2)=s/PI
    do 35 j=3,nt
    sn=dc*s-sm
    sm=s
    s=sn
    35   w(j)=s/(PI*(j-1))
    do 55 m=1,ntot
    vmax=abs(v(1,m))
    kmax=1
    do 40 kk=2,lh
    if(abs(v(kk,m)) <= vmax) goto 40
    kmax=kk
    vmax=abs(v(kk,m))
    40     continue
    a(m)=0.
    nlow=kmax-1
    do 45 j=1,nlow
    45     a(m)=a(m)+w(j+1)*v(nlow+1-j,m)
    nup=nt-nlow
    do 50 j=1,nup
    50     a(m)=a(m)+w(j)*v(nlow+j,m)
    55 a(m)=a(m)/v(kmax,m)
    return

end subroutine staper

!------------------------------------------------------------------
subroutine tsturm(nt,n,a,b,w,nev,r,ndim,ev,ipar)
    !------------------------------------------------------------------
    !$$$$ calls root
    !  Uses bisection and Sturm counting to isolate the eigenvalues of the
    !  symmetric tridiagonal matrix with main diagonal a(.) and sub/super
    !  diagonal b(.).  Newton's method is used to refine the eigenvalue in
    !  subroutine root then direct recursion is used to get the eigenvector
    !  as this is always stable.  Note  ipar=0 for even tapers   =1 for odd
    !  tapers
    !implicit real*8(a-h,o-z)
    !parameter (epsi=1.d-15,epsi1=5.d-15)
    !dimension a(*),b(*),ev(*),w(*),r(ndim,*)
    !  use constants

    implicit none

    double precision, parameter :: epsi = 1.d-15, epsi1 = 5.d-15

    double precision, dimension(ndim) :: a, b, w, ev
    double precision, dimension(ndim,*) :: r
    integer :: nt,n,ndim,nev,ipar

    !double precision, dimension(ndim) :: bb
    double precision :: q,el,elam,u,umeps,x,ddot,rnorm
    integer :: i,j,ik,iag,m,jk,jm1

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

    if(n <= 0.or.nev <= 0) return
    umeps=1.-epsi
    do 5 i=1,nev
    5 ev(i)=-1.
    u=1.
    do 1000 ik=1,nev
    if(ik > 1) u=ev(ik-1)*umeps
    el=min(ev(ik),u)
    10 elam=0.5*(u+el)
    if(abs(u-el) <= epsi1) goto 35
    iag=0
    q=a(1)-elam
    if(q >= 0.) iag=iag+1
    do 15 i=2,n
    if(q == 0.) x=abs(b(i-1))/epsi
    if(q /= 0.) x=w(i-1)/q
    q=a(i)-elam-x
    if(q >= 0.) iag=iag+1
    if(iag > nev) goto 20
    15 continue
    if(iag >= ik) go to 20
    u=elam
    go to 10
    20 if(iag == ik) go to 30
    m=ik+1
    do 25 i=m,iag
    25 ev(i)=elam
    el=elam
    go to 10
    30 el=elam
    call root(u,el,elam,a,b,w,n,ik)
    35 ev(ik)=elam
    jk=2*ik+ipar-1
    r(1,jk)=1.
    r(2,jk)=-(a(1)-ev(ik))/b(1)
    ddot=1.+r(2,jk)*r(2,jk)
    jm1=2
    do 45 j=3,n
    r(j,jk)=-((a(jm1)-ev(ik))*r(jm1,jk)+b(j-2)*r(j-2,jk))/b(jm1)
    ddot=ddot+r(j,jk)*r(j,jk)
    45 jm1=j
    rnorm=sqrt(nt/(2.*ddot))
    do 50 j=1,n
    50 r(j,jk)=r(j,jk)*rnorm
    1000 continue
    return

end subroutine tsturm
!------------------------------------------------------------------
subroutine root(u,el,elam,a,bb,w,n,ik)
    !------------------------------------------------------------------
    !  use constants

    implicit none

    !implicit real*8(a-h,o-z)
    !parameter (epsi = 1.d-15, epsi1 = 5.d-15)
    !dimension a(*),bb(*),w(*)

    double precision, parameter :: epsi = 1.d-15, epsi1 = 5.d-15
    double precision :: u,el,elam
    double precision, dimension(*) :: a,bb,w
    integer :: n,ik

    double precision :: an,b,bm,bn,del,x
    integer :: i,iag

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

    5 elam=0.5*(u+el)
    10 if(abs(u-el) <= 1.5*epsi1) return
    an=a(1)-elam
    b=0.
    bn=-1./an
    iag=0
    if(an >= 0.) iag=iag+1
    do 20 i=2,n
    if(an == 0.) x=abs(bb(i-1))/epsi
    if(an /= 0.) x=w(i-1)/an
    an=a(i)-elam-x
    if(an == 0.) an=epsi
    bm=b
    b=bn
    bn=((a(i)-elam)*b-bm*x-1.)/an
    if(an >= 0.) iag=iag+1
    20 continue
    if(iag == ik) goto 25
    u=elam
    goto 30
    25 el=elam
    30 del=1./bn
    if(abs(del) <= epsi1) del=sign(epsi1,del)
    elam=elam-del
    if(elam >= u.or.elam <= el) goto 5
    goto 10

end subroutine root


C-----------------------------------------------------------------------
      SUBROUTINE SPLAT(IDRT,JMAX,SLAT,WLAT)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  SPLAT      COMPUTE LATITUDE FUNCTIONS
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-02-20
C
C ABSTRACT: COMPUTES COSINES OF COLATITUDE AND GAUSSIAN WEIGHTS
C           FOR ONE OF THE FOLLOWING SPECIFIC GLOBAL SETS OF LATITUDES.
C             GAUSSIAN LATITUDES (IDRT=4)
C             EQUALLY-SPACED LATITUDES INCLUDING POLES (IDRT=0)
C             EQUALLY-SPACED LATITUDES EXCLUDING POLES (IDRT=256)
C           THE GAUSSIAN LATITUDES ARE LOCATED AT THE ZEROES OF THE
C           LEGENDRE POLYNOMIAL OF THE GIVEN ORDER.  THESE LATITUDES
C           ARE EFFICIENT FOR REVERSIBLE TRANSFORMS FROM SPECTRAL SPACE.
C           (ABOUT TWICE AS MANY EQUALLY-SPACED LATITUDES ARE NEEDED.)
C           THE WEIGHTS FOR THE EQUALLY-SPACED LATITUDES ARE BASED ON
C           ELLSAESSER (JAM,1966).  (NO WEIGHT IS GIVEN THE POLE POINT.)
C           NOTE THAT WHEN ANALYZING GRID TO SPECTRAL IN LATITUDE PAIRS,
C           IF AN EQUATOR POINT EXISTS, ITS WEIGHT SHOULD BE HALVED.
C
C PROGRAM HISTORY LOG:
C   96-02-20  IREDELL
C
C USAGE:    CALL SPLAT(IDRT,JMAX,SLAT,WLAT)
C
C   INPUT ARGUMENT LIST:
C     IDRT     - INTEGER GRID IDENTIFIER
C                (IDRT=4 FOR GAUSSIAN GRID,
C                 IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
C                 IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
C     JMAX     - INTEGER NUMBER OF LATITUDES.
C
C   OUTPUT ARGUMENT LIST:
C     SLAT     - REAL (JMAX) SINES OF LATITUDE.
C     WLAT     - REAL (JMAX) GAUSSIAN WEIGHTS.
C
C SUBPROGRAMS CALLED:
C   MINV         SOLVES FULL MATRIX PROBLEM
C
C REMARKS: FORTRAN 90 EXTENSIONS ARE USED.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C
C$$$
      REAL SLAT(JMAX),WLAT(JMAX)
      REAL PK(JMAX/2),PKM1(JMAX/2),PKM2(JMAX/2)
      PARAMETER(JZ=50)
      REAL BZ(JZ)
      DATA BZ        / 2.4048255577,  5.5200781103,
     $  8.6537279129, 11.7915344391, 14.9309177086, 18.0710639679,
     $ 21.2116366299, 24.3524715308, 27.4934791320, 30.6346064684,
     $ 33.7758202136, 36.9170983537, 40.0584257646, 43.1997917132,
     $ 46.3411883717, 49.4826098974, 52.6240518411, 55.7655107550,
     $ 58.9069839261, 62.0484691902, 65.1899648002, 68.3314693299,
     $ 71.4729816036, 74.6145006437, 77.7560256304, 80.8975558711,
     $ 84.0390907769, 87.1806298436, 90.3221726372, 93.4637187819,
     $ 96.6052679510, 99.7468198587, 102.888374254, 106.029930916,
     $ 109.171489649, 112.313050280, 115.454612653, 118.596176630,
     $ 121.737742088, 124.879308913, 128.020877005, 131.162446275,
     $ 134.304016638, 137.445588020, 140.587160352, 143.728733573,
     $ 146.870307625, 150.011882457, 153.153458019, 156.295034268 /
      REAL AWORK((JMAX+1)/2,((JMAX+1)/2+1)),BWORK(((JMAX+1)/2)*2)
      PARAMETER(PI=3.14159265358979,C=(1.-(2./PI)**2)*0.25)
      PARAMETER(EPS=1.E-6)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  GAUSSIAN LATITUDES
      IF(IDRT.EQ.4) THEN
        JH=JMAX/2
        JHE=(JMAX+1)/2
        R=1./SQRT((JMAX+0.5)**2+C)
        DO J=1,MIN(JH,JZ)
          SLAT(J)=COS(BZ(J)*R)
        ENDDO
        DO J=JZ+1,JH
          SLAT(J)=COS((BZ(JZ)+(J-JZ)*PI)*R)
        ENDDO
        SPMAX=1.
        DO WHILE(SPMAX.GT.EPS)
          SPMAX=0.
          DO J=1,JH
            PKM1(J)=1.
            PK(J)=SLAT(J)
          ENDDO
          DO N=2,JMAX
            DO J=1,JH
              PKM2(J)=PKM1(J)
              PKM1(J)=PK(J)
              PK(J)=((2*N-1)*SLAT(J)*PKM1(J)-(N-1)*PKM2(J))/N
            ENDDO
          ENDDO
          DO J=1,JH
            SP=PK(J)*(1.-SLAT(J)**2)/(JMAX*(PKM1(J)-SLAT(J)*PK(J)))
            SLAT(J)=SLAT(J)-SP
            SPMAX=MAX(SPMAX,ABS(SP))
          ENDDO
        ENDDO
        DO J=1,JH
          WLAT(J)=(2.*(1.-SLAT(J)**2))/(JMAX*PKM1(J))**2
          SLAT(JMAX+1-J)=-SLAT(J)
          WLAT(JMAX+1-J)=WLAT(J)
        ENDDO
        IF(JHE.GT.JH) THEN
          SLAT(JHE)=0.
          WLAT(JHE)=2./JMAX**2
          DO N=2,JMAX,2
            WLAT(JHE)=WLAT(JHE)*N**2/(N-1)**2
          ENDDO
        ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  EQUALLY-SPACED LATITUDES INCLUDING POLES
      ELSE
          WRITE(*,*) "SPLAT SHOULD BE CALLED WITH IDRT=4 not ", IDRT
	  STOP 10
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      RETURN
      END


***
      real*8 FUNCTION fallback(sne,mproto,mc,mt)
*
*     Author : N. Giacobbo
*     Date :   25th March 2017
*
*     Fallback of matter after the SNe.
*     Ref: Fryer et al. 2012 and Spera et al. 2015
*     --------------------------------------------------
*
*
      implicit none
      real*8 mt,mc
      real*8 mproto,alpha_R,beta_R,alpha_D,beta_D
      integer sne

      if(sne.eq.1)then
* StarTrack
         if(mc.lt.5.d0)then
            fallback = 0.d0
         elseif(5.d0.le.mc .and. mc.lt.7.6d0)then
            fallback = 0.378d0*mc - 1.889d0
         elseif(7.6d0.le.mc)then
            fallback = 1.d0
         endif
*
      elseif(sne.eq.2)then
* Rapid
         alpha_R = 0.25d0 - 1.275d0/(mt - mproto)
         beta_R = 1.d0 - 11.d0*alpha_R
*
         if(mc.lt.2.5d0)then
            fallback = 0.2d0/(mt - mproto)
         elseif(2.5d0.le.mc .and. mc.lt.6.d0)then
            fallback = (0.286d0*mc - 0.514d0)/(mt - mproto)
         elseif(6.d0.le.mc .and. mc.lt.7.d0)then
            fallback = 1.d0
         elseif(7.d0.le.mc .and. mc.lt.11.d0)then
            fallback = alpha_R*mc + beta_R
         elseif(11.d0.le.mc)then
            fallback = 1.d0
         endif
*
      elseif(sne.eq.3)then
* Delayed
         alpha_D = 0.133d0 - 0.084d0/(mt - mproto)
         beta_D = 1.d0 - 11.d0*alpha_D
*
         if(mc.lt.2.5d0)then
            fallback = 0.2d0/(mt - mproto)
         elseif(2.5d0.le.mc .and. mc.lt.3.5d0)then
            fallback = (0.5d0*mc - 1.05d0)/(mt - mproto)
         elseif(3.5d0.le.mc .and. mc.lt.11.d0)then
            fallback = alpha_D*mc + beta_D
         elseif(11.d0.le.mc)then
            fallback = 1.d0
         endif
*
      elseif(sne.eq.4)then
* Belczynski 2002
         fallback = 0.d0
      elseif(sne.eq.5)then
* Only remnants
         fallback = 0.d0
      else
         write(*,*) "Invalid SNe mechanism"
      endif
*
      return
**
      end


Real Function pionpp(srt)
  Save
  pmass = 0.14
  pmass1 = 0.938
  pionpp = 0.00001
  If (srt<=1.22) Return
  plab = sqrt(((srt**2-pmass**2-pmass1**2)/(2.*pmass1))**2-pmass**2)
  pmin = 0.3
  pmax = 25.0
  If (plab>pmax) Then
    pionpp = 20./10.
    Return
  End If
  If (plab<pmin) Then
    pionpp = 0.
    Return
  End If
  a = 24.3
  b = -12.3
  c = 0.324
  an = -1.91
  d = -2.44
  pionpp = a + b*(plab**an) + c*(alog(plab))**2 + d*alog(plab)
  If (pionpp<=0) pionpp = 0
  pionpp = pionpp/10.
  Return
End Function pionpp


      recursive subroutine polar(iopt,m,x,y,z,w,rad,s,nuest,nvest,
     *  eps,nu,tu,nv,tv,u,v,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier)
      implicit none
c  subroutine polar fits a smooth function f(x,y) to a set of data
c  points (x(i),y(i),z(i)) scattered arbitrarily over an approximation
c  domain  x**2+y**2 <= rad(atan(y/x))**2. through the transformation
c    x = u*rad(v)*cos(v) , y = u*rad(v)*sin(v)
c  the approximation problem is reduced to the determination of a bi-
c  cubic spline s(u,v) fitting a corresponding set of data points
c  (u(i),v(i),z(i)) on the rectangle 0<=u<=1,-pi<=v<=pi.
c  in order to have continuous partial derivatives
c              i+j
c             d   f(0,0)
c    g(i,j) = ----------
c                i   j
c              dx  dy
c
c  s(u,v)=f(x,y) must satisfy the following conditions
c
c    (1) s(0,v) = g(0,0)   -pi <=v<= pi.
c
c        d s(0,v)
c    (2) -------- = rad(v)*(cos(v)*g(1,0)+sin(v)*g(0,1))
c        d u
c                                                    -pi <=v<= pi
c         2
c        d s(0,v)         2       2             2
c    (3) -------- = rad(v)*(cos(v)*g(2,0)+sin(v)*g(0,2)+sin(2*v)*g(1,1))
c           2
c        d u                                         -pi <=v<= pi
c
c  moreover, s(u,v) must be periodic in the variable v, i.e.
c
c         j            j
c        d s(u,-pi)   d s(u,pi)
c    (4) ---------- = ---------   0 <=u<= 1, j=0,1,2
c           j           j
c        d v         d v
c
c  if iopt(1) < 0 circle calculates a weighted least-squares spline
c  according to a given set of knots in u- and v- direction.
c  if iopt(1) >=0, the number of knots in each direction and their pos-
c  ition tu(j),j=1,2,...,nu ; tv(j),j=1,2,...,nv are chosen automatical-
c  ly by the routine. the smoothness of s(u,v) is then achieved by mini-
c  malizing the discontinuity jumps of the derivatives of the spline
c  at the knots. the amount of smoothness of s(u,v) is determined  by
c  the condition that fp = sum((w(i)*(z(i)-s(u(i),v(i))))**2) be <= s,
c  with s a given non-negative constant.
c  the bicubic spline is given in its standard b-spline representation
c  and the corresponding function f(x,y) can be evaluated by means of
c  function program evapol.
c
c calling sequence:
c     call polar(iopt,m,x,y,z,w,rad,s,nuest,nvest,eps,nu,tu,
c    *  nv,tv,u,v,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier)
c
c parameters:
c  iopt  : integer array of dimension 3, specifying different options.
c          unchanged on exit.
c  iopt(1):on entry iopt(1) must specify whether a weighted
c          least-squares polar spline (iopt(1)=-1) or a smoothing
c          polar spline (iopt(1)=0 or 1) must be determined.
c          if iopt(1)=0 the routine will start with an initial set of
c          knots tu(i)=0,tu(i+4)=1,i=1,...,4;tv(i)=(2*i-9)*pi,i=1,...,8.
c          if iopt(1)=1 the routine will continue with the set of knots
c          found at the last call of the routine.
c          attention: a call with iopt(1)=1 must always be immediately
c          preceded by another call with iopt(1) = 1 or iopt(1) = 0.
c  iopt(2):on entry iopt(2) must specify the requested order of conti-
c          nuity for f(x,y) at the origin.
c          if iopt(2)=0 only condition (1) must be fulfilled,
c          if iopt(2)=1 conditions (1)+(2) must be fulfilled and
c          if iopt(2)=2 conditions (1)+(2)+(3) must be fulfilled.
c  iopt(3):on entry iopt(3) must specify whether (iopt(3)=1) or not
c          (iopt(3)=0) the approximation f(x,y) must vanish at the
c          boundary of the approximation domain.
c  m     : integer. on entry m must specify the number of data points.
c          m >= 4-iopt(2)-iopt(3) unchanged on exit.
c  x     : real array of dimension at least (m).
c  y     : real array of dimension at least (m).
c  z     : real array of dimension at least (m).
c          before entry, x(i),y(i),z(i) must be set to the co-ordinates
c          of the i-th data point, for i=1,...,m. the order of the data
c          points is immaterial. unchanged on exit.
c  w     : real array of dimension at least (m). before entry, w(i) must
c          be set to the i-th value in the set of weights. the w(i) must
c          be strictly positive. unchanged on exit.
c  rad   : real function subprogram defining the boundary of the approx-
c          imation domain, i.e   x = rad(v)*cos(v) , y = rad(v)*sin(v),
c          -pi <= v <= pi.
c          must be declared external in the calling (sub)program.
c  s     : real. on entry (in case iopt(1) >=0) s must specify the
c          smoothing factor. s >=0. unchanged on exit.
c          for advice on the choice of s see further comments
c  nuest : integer. unchanged on exit.
c  nvest : integer. unchanged on exit.
c          on entry, nuest and nvest must specify an upper bound for the
c          number of knots required in the u- and v-directions resp.
c          these numbers will also determine the storage space needed by
c          the routine. nuest >= 8, nvest >= 8.
c          in most practical situation nuest = nvest = 8+sqrt(m/2) will
c          be sufficient. see also further comments.
c  eps   : real.
c          on entry, eps must specify a threshold for determining the
c          effective rank of an over-determined linear system of equat-
c          ions. 0 < eps < 1.  if the number of decimal digits in the
c          computer representation of a real number is q, then 10**(-q)
c          is a suitable value for eps in most practical applications.
c          unchanged on exit.
c  nu    : integer.
c          unless ier=10 (in case iopt(1) >=0),nu will contain the total
c          number of knots with respect to the u-variable, of the spline
c          approximation returned. if the computation mode iopt(1)=1
c          is used, the value of nu should be left unchanged between
c          subsequent calls.
c          in case iopt(1)=-1,the value of nu must be specified on entry
c  tu    : real array of dimension at least nuest.
c          on successful exit, this array will contain the knots of the
c          spline with respect to the u-variable, i.e. the position
c          of the interior knots tu(5),...,tu(nu-4) as well as the
c          position of the additional knots tu(1)=...=tu(4)=0 and
c          tu(nu-3)=...=tu(nu)=1 needed for the b-spline representation
c          if the computation mode iopt(1)=1 is used,the values of
c          tu(1),...,tu(nu) should be left unchanged between subsequent
c          calls. if the computation mode iopt(1)=-1 is used,the values
c          tu(5),...tu(nu-4) must be supplied by the user, before entry.
c          see also the restrictions (ier=10).
c  nv    : integer.
c          unless ier=10 (in case iopt(1)>=0), nv will contain the total
c          number of knots with respect to the v-variable, of the spline
c          approximation returned. if the computation mode iopt(1)=1
c          is used, the value of nv should be left unchanged between
c          subsequent calls. in case iopt(1)=-1, the value of nv should
c          be specified on entry.
c  tv    : real array of dimension at least nvest.
c          on successful exit, this array will contain the knots of the
c          spline with respect to the v-variable, i.e. the position of
c          the interior knots tv(5),...,tv(nv-4) as well as the position
c          of the additional knots tv(1),...,tv(4) and tv(nv-3),...,
c          tv(nv) needed for the b-spline representation.
c          if the computation mode iopt(1)=1 is used, the values of
c          tv(1),...,tv(nv) should be left unchanged between subsequent
c          calls. if the computation mode iopt(1)=-1 is used,the values
c          tv(5),...tv(nv-4) must be supplied by the user, before entry.
c          see also the restrictions (ier=10).
c  u     : real array of dimension at least (m).
c  v     : real array of dimension at least (m).
c          on successful exit, u(i),v(i) contains the co-ordinates of
c          the i-th data point with respect to the transformed rectan-
c          gular approximation domain, for i=1,2,...,m.
c          if the computation mode iopt(1)=1 is used the values of
c          u(i),v(i) should be left unchanged between subsequent calls.
c  c     : real array of dimension at least (nuest-4)*(nvest-4).
c          on successful exit, c contains the coefficients of the spline
c          approximation s(u,v).
c  fp    : real. unless ier=10, fp contains the weighted sum of
c          squared residuals of the spline approximation returned.
c  wrk1  : real array of dimension (lwrk1). used as workspace.
c          if the computation mode iopt(1)=1 is used the value of
c          wrk1(1) should be left unchanged between subsequent calls.
c          on exit wrk1(2),wrk1(3),...,wrk1(1+ncof) will contain the
c          values d(i)/max(d(i)),i=1,...,ncof=1+iopt(2)*(iopt(2)+3)/2+
c          (nv-7)*(nu-5-iopt(2)-iopt(3)) with d(i) the i-th diagonal el-
c          ement of the triangular matrix for calculating the b-spline
c          coefficients.it includes those elements whose square is < eps
c          which are treated as 0 in the case of rank deficiency(ier=-2)
c  lwrk1 : integer. on entry lwrk1 must specify the actual dimension of
c          the array wrk1 as declared in the calling (sub)program.
c          lwrk1 must not be too small. let
c            k = nuest-7, l = nvest-7, p = 1+iopt(2)*(iopt(2)+3)/2,
c            q = k+2-iopt(2)-iopt(3) then
c          lwrk1 >= 129+10*k+21*l+k*l+(p+l*q)*(1+8*l+p)+8*m
c  wrk2  : real array of dimension (lwrk2). used as workspace, but
c          only in the case a rank deficient system is encountered.
c  lwrk2 : integer. on entry lwrk2 must specify the actual dimension of
c          the array wrk2 as declared in the calling (sub)program.
c          lwrk2 > 0 . a save upper bound  for lwrk2 = (p+l*q+1)*(4*l+p)
c          +p+l*q where p,l,q are as above. if there are enough data
c          points, scattered uniformly over the approximation domain
c          and if the smoothing factor s is not too small, there is a
c          good chance that this extra workspace is not needed. a lot
c          of memory might therefore be saved by setting lwrk2=1.
c          (see also ier > 10)
c  iwrk  : integer array of dimension (kwrk). used as workspace.
c  kwrk  : integer. on entry kwrk must specify the actual dimension of
c          the array iwrk as declared in the calling (sub)program.
c          kwrk >= m+(nuest-7)*(nvest-7).
c  ier   : integer. unless the routine detects an error, ier contains a
c          non-positive value on exit, i.e.
c   ier=0  : normal return. the spline returned has a residual sum of
c            squares fp such that abs(fp-s)/s <= tol with tol a relat-
c            ive tolerance set to 0.001 by the program.
c   ier=-1 : normal return. the spline returned is an interpolating
c            spline (fp=0).
c   ier=-2 : normal return. the spline returned is the weighted least-
c            squares constrained polynomial . in this extreme case
c            fp gives the upper bound for the smoothing factor s.
c   ier<-2 : warning. the coefficients of the spline returned have been
c            computed as the minimal norm least-squares solution of a
c            (numerically) rank deficient system. (-ier) gives the rank.
c            especially if the rank deficiency which can be computed as
c            1+iopt(2)*(iopt(2)+3)/2+(nv-7)*(nu-5-iopt(2)-iopt(3))+ier
c            is large the results may be inaccurate.
c            they could also seriously depend on the value of eps.
c   ier=1  : error. the required storage space exceeds the available
c            storage space, as specified by the parameters nuest and
c            nvest.
c            probably causes : nuest or nvest too small. if these param-
c            eters are already large, it may also indicate that s is
c            too small
c            the approximation returned is the weighted least-squares
c            polar spline according to the current set of knots.
c            the parameter fp gives the corresponding weighted sum of
c            squared residuals (fp>s).
c   ier=2  : error. a theoretically impossible result was found during
c            the iteration process for finding a smoothing spline with
c            fp = s. probably causes : s too small or badly chosen eps.
c            there is an approximation returned but the corresponding
c            weighted sum of squared residuals does not satisfy the
c            condition abs(fp-s)/s < tol.
c   ier=3  : error. the maximal number of iterations maxit (set to 20
c            by the program) allowed for finding a smoothing spline
c            with fp=s has been reached. probably causes : s too small
c            there is an approximation returned but the corresponding
c            weighted sum of squared residuals does not satisfy the
c            condition abs(fp-s)/s < tol.
c   ier=4  : error. no more knots can be added because the dimension
c            of the spline 1+iopt(2)*(iopt(2)+3)/2+(nv-7)*(nu-5-iopt(2)
c            -iopt(3)) already exceeds the number of data points m.
c            probably causes : either s or m too small.
c            the approximation returned is the weighted least-squares
c            polar spline according to the current set of knots.
c            the parameter fp gives the corresponding weighted sum of
c            squared residuals (fp>s).
c   ier=5  : error. no more knots can be added because the additional
c            knot would (quasi) coincide with an old one.
c            probably causes : s too small or too large a weight to an
c            inaccurate data point.
c            the approximation returned is the weighted least-squares
c            polar spline according to the current set of knots.
c            the parameter fp gives the corresponding weighted sum of
c            squared residuals (fp>s).
c   ier=10 : error. on entry, the input data are controlled on validity
c            the following restrictions must be satisfied.
c            -1<=iopt(1)<=1 , 0<=iopt(2)<=2 , 0<=iopt(3)<=1 ,
c            m>=4-iopt(2)-iopt(3) , nuest>=8 ,nvest >=8, 0<eps<1,
c            0<=teta(i)<=pi, 0<=phi(i)<=2*pi, w(i)>0, i=1,...,m
c            lwrk1 >= 129+10*k+21*l+k*l+(p+l*q)*(1+8*l+p)+8*m
c            kwrk >= m+(nuest-7)*(nvest-7)
c            if iopt(1)=-1:9<=nu<=nuest,9+iopt(2)*(iopt(2)+1)<=nv<=nvest
c                          0<tu(5)<tu(6)<...<tu(nu-4)<1
c                          -pi<tv(5)<tv(6)<...<tv(nv-4)<pi
c            if iopt(1)>=0: s>=0
c            if one of these conditions is found to be violated,control
c            is immediately repassed to the calling program. in that
c            case there is no approximation returned.
c   ier>10 : error. lwrk2 is too small, i.e. there is not enough work-
c            space for computing the minimal least-squares solution of
c            a rank deficient system of linear equations. ier gives the
c            requested value for lwrk2. there is no approximation re-
c            turned but, having saved the information contained in nu,
c            nv,tu,tv,wrk1,u,v and having adjusted the value of lwrk2
c            and the dimension of the array wrk2 accordingly, the user
c            can continue at the point the program was left, by calling
c            polar with iopt(1)=1.
c
c further comments:
c  by means of the parameter s, the user can control the tradeoff
c   between closeness of fit and smoothness of fit of the approximation.
c   if s is too large, the spline will be too smooth and signal will be
c   lost ; if s is too small the spline will pick up too much noise. in
c   the extreme cases the program will return an interpolating spline if
c   s=0 and the constrained weighted least-squares polynomial if s is
c   very large. between these extremes, a properly chosen s will result
c   in a good compromise between closeness of fit and smoothness of fit.
c   to decide whether an approximation, corresponding to a certain s is
c   satisfactory the user is highly recommended to inspect the fits
c   graphically.
c   recommended values for s depend on the weights w(i). if these are
c   taken as 1/d(i) with d(i) an estimate of the standard deviation of
c   z(i), a good s-value should be found in the range (m-sqrt(2*m),m+
c   sqrt(2*m)). if nothing is known about the statistical error in z(i)
c   each w(i) can be set equal to one and s determined by trial and
c   error, taking account of the comments above. the best is then to
c   start with a very large value of s ( to determine the least-squares
c   polynomial and the corresponding upper bound fp0 for s) and then to
c   progressively decrease the value of s ( say by a factor 10 in the
c   beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the
c   approximation shows more detail) to obtain closer fits.
c   to choose s very small is strongly discouraged. this considerably
c   increases computation time and memory requirements. it may also
c   cause rank-deficiency (ier<-2) and endager numerical stability.
c   to economize the search for a good s-value the program provides with
c   different modes of computation. at the first call of the routine, or
c   whenever he wants to restart with the initial set of knots the user
c   must set iopt(1)=0.
c   if iopt(1)=1 the program will continue with the set of knots found
c   at the last call of the routine. this will save a lot of computation
c   time if polar is called repeatedly for different values of s.
c   the number of knots of the spline returned and their location will
c   depend on the value of s and on the complexity of the shape of the
c   function underlying the data. if the computation mode iopt(1)=1
c   is used, the knots returned may also depend on the s-values at
c   previous calls (if these were smaller). therefore, if after a number
c   of trials with different s-values and iopt(1)=1,the user can finally
c   accept a fit as satisfactory, it may be worthwhile for him to call
c   polar once more with the selected value for s but now with iopt(1)=0
c   indeed, polar may then return an approximation of the same quality
c   of fit but with fewer knots and therefore better if data reduction
c   is also an important objective for the user.
c   the number of knots may also depend on the upper bounds nuest and
c   nvest. indeed, if at a certain stage in polar the number of knots
c   in one direction (say nu) has reached the value of its upper bound
c   (nuest), then from that moment on all subsequent knots are added
c   in the other (v) direction. this may indicate that the value of
c   nuest is too small. on the other hand, it gives the user the option
c   of limiting the number of knots the routine locates in any direction
c
c  other subroutines required:
c    fpback,fpbspl,fppola,fpdisc,fpgivs,fprank,fprati,fprota,fporde,
c    fprppo
c
c  references:
c   dierckx p.: an algorithm for fitting data over a circle using tensor
c               product splines,j.comp.appl.maths 15 (1986) 161-173.
c   dierckx p.: an algorithm for fitting data on a circle using tensor
c               product splines, report tw68, dept. computer science,
c               k.u.leuven, 1984.
c   dierckx p.: curve and surface fitting with splines, monographs on
c               numerical analysis, oxford university press, 1993.
c
c  author:
c    p.dierckx
c    dept. computer science, k.u. leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  creation date : june 1984
c  latest update : march 1989
c
c  ..
c  ..scalar arguments..
      real*8 s,eps,fp
      integer m,nuest,nvest,nu,nv,lwrk1,lwrk2,kwrk,ier
c  ..array arguments..
      real*8 x(m),y(m),z(m),w(m),tu(nuest),tv(nvest),u(m),v(m),
     * c((nuest-4)*(nvest-4)),wrk1(lwrk1),wrk2(lwrk2)
      integer iopt(3),iwrk(kwrk)
c  ..user specified function
      real*8 rad
c  ..local scalars..
      real*8 tol,pi,dist,r,one
      integer i,ib1,ib3,ki,kn,kwest,la,lbu,lcc,lcs,lro,j,
     * lbv,lco,lf,lff,lfp,lh,lq,lsu,lsv,lwest,maxit,ncest,ncc,nuu,
     * nvv,nreg,nrint,nu4,nv4,iopt1,iopt2,iopt3,ipar,nvmin
c  ..function references..
      real*8 datan2,sqrt
      external rad
c  ..subroutine references..
c    fppola
c  ..
c  set up constants
      one = 1d0
c  we set up the parameters tol and maxit.
      maxit = 20
      tol = 0.1e-02
c  before starting computations a data check is made. if the input data
c  are invalid,control is immediately repassed to the calling program.
      ier = 10
      if(eps.le.0. .or. eps.ge.1.) go to 60
      iopt1 = iopt(1)
      if(iopt1.lt.(-1) .or. iopt1.gt.1) go to 60
      iopt2 = iopt(2)
      if(iopt2.lt.0 .or. iopt2.gt.2) go to 60
      iopt3 = iopt(3)
      if(iopt3.lt.0 .or. iopt3.gt.1) go to 60
      if(m.lt.(4-iopt2-iopt3)) go to 60
      if(nuest.lt.8 .or. nvest.lt.8) go to 60
      nu4 = nuest-4
      nv4 = nvest-4
      ncest = nu4*nv4
      nuu = nuest-7
      nvv = nvest-7
      ipar = 1+iopt2*(iopt2+3)/2
      ncc = ipar+nvv*(nuest-5-iopt2-iopt3)
      nrint = nuu+nvv
      nreg = nuu*nvv
      ib1 = 4*nvv
      ib3 = ib1+ipar
      lwest = ncc*(1+ib1+ib3)+2*nrint+ncest+m*8+ib3+5*nuest+12*nvest
      kwest = m+nreg
      if(lwrk1.lt.lwest .or. kwrk.lt.kwest) go to 60
      if(iopt1.gt.0) go to 40
      do 10 i=1,m
        if(w(i).le.0.) go to 60
        dist = x(i)**2+y(i)**2
        u(i) = 0.
        v(i) = 0.
        if(dist.le.0.) go to 10
        v(i) = datan2(y(i),x(i))
        r = rad(v(i))
        if(r.le.0.) go to 60
        u(i) = sqrt(dist)/r
        if(u(i).gt.one) go to 60
  10  continue
      if(iopt1.eq.0) go to 40
      nuu = nu-8
      if(nuu.lt.1 .or. nu.gt.nuest) go to 60
      tu(4) = 0.
      do 20 i=1,nuu
         j = i+4
         if(tu(j).le.tu(j-1) .or. tu(j).ge.one) go to 60
  20  continue
      nvv = nv-8
      nvmin = 9+iopt2*(iopt2+1)
      if(nv.lt.nvmin .or. nv.gt.nvest) go to 60
      pi = datan2(0d0,-one)
      tv(4) = -pi
      do 30 i=1,nvv
         j = i+4
         if(tv(j).le.tv(j-1) .or. tv(j).ge.pi) go to 60
  30  continue
      go to 50
  40  if(s.lt.0.) go to 60
  50  ier = 0
c  we partition the working space and determine the spline approximation
      kn = 1
      ki = kn+m
      lq = 2
      la = lq+ncc*ib3
      lf = la+ncc*ib1
      lff = lf+ncc
      lfp = lff+ncest
      lco = lfp+nrint
      lh = lco+nrint
      lbu = lh+ib3
      lbv = lbu+5*nuest
      lro = lbv+5*nvest
      lcc = lro+nvest
      lcs = lcc+nvest
      lsu = lcs+nvest*5
      lsv = lsu+m*4
      call fppola(iopt1,iopt2,iopt3,m,u,v,z,w,rad,s,nuest,nvest,eps,tol,
     *
     * maxit,ib1,ib3,ncest,ncc,nrint,nreg,nu,tu,nv,tv,c,fp,wrk1(1),
     * wrk1(lfp),wrk1(lco),wrk1(lf),wrk1(lff),wrk1(lro),wrk1(lcc),
     * wrk1(lcs),wrk1(la),wrk1(lq),wrk1(lbu),wrk1(lbv),wrk1(lsu),
     * wrk1(lsv),wrk1(lh),iwrk(ki),iwrk(kn),wrk2,lwrk2,ier)
  60  return
      end