      subroutine runCY_0(i,j,f,Xtwiddle,Gtwiddle,Gtt,Shat1,Bzero0,N0)
      implicit none
C---  Expression for Eq. 5.55
C---  Calculates C0, requires C00
C---  Small terms of order Xtwiddle(0,j)*Ci
C---  Denominator Xtwiddle(i,j)
      include 'TRconstants.f'
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,i,j,n,m,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np),f(np),
     . Gtt(np,np,np,np)
      double complex Shat1(np,-2:0),Bzero0(-2:0),
     . bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gtt(i,n,j,m)*f(n)*Shat1(m,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=-4d0*Cv(cc00+N0,ep-1)
      Cv(cc0+N0,ep)=
     .  (Gtwiddle(i,j)*(4d0*Cv(cc00+N0,ep)+pole-Bzero0(ep))
     . +bit+Xtwiddle(0,j)*Cv(ci(i)+N0,ep))/Xtwiddle(i,j)
c      write(6,*) Gtwiddle(i,j)*(4d0*Cv(cc00+N0,ep))/Xtwiddle(i,j)
c      write(6,*) Gtwiddle(i,j)*(+pole)/Xtwiddle(i,j)
c      write(6,*) Gtwiddle(i,j)*(-Bzero0(ep))/Xtwiddle(i,j)
c      write(6,*) (bit)/Xtwiddle(i,j)
c      write(6,*) (Xtwiddle(0,j)*Cv(ci(i)+N0,ep))/Xtwiddle(i,j)
c      write(6,*)
      enddo

c      write(6,*) 'Cv(cc0)',Cv(cc0+N0,-2),Cv(cc0+N0,-1),Cv(cc0+N0,0)
c      write(6,*) 'bit',Cv(cc0+N0,-2),Cv(cc0+N0,-1),Cv(cc0+N0,0)

      return
      end


  SUBROUTINE saturate_lwc_points(sh,t,p,thresh,sh_m,rh_m)

  ! Subroutine to saturate points containing a certain threshold
  ! of cloud liquid

    IMPLICIT NONE

    ! Inputs:

    REAL, INTENT(IN)    :: sh     ! Specific humidity (kg/kg)
    REAL, INTENT(IN)    :: t      ! Temperature (K)
    REAL, INTENT(IN)    :: p      ! Pressure (Pa)
    REAL, INTENT(IN)    :: thresh ! Saturation factor
              ! Set thresh to 1.0 to convert cloud water up to
              ! vapor saturation.  1.1 will allow 110% RH, and so
              ! forth

    ! Outputs:

    REAL, INTENT(OUT)   :: sh_m   ! Adjusted specific humidity
    REAL, INTENT(OUT)   :: rh_m   ! Adjusted RH (%)

    ! Locals

    REAL :: shsat,mrmax,mr,mr_m,mrsat
    REAL, EXTERNAL :: ssh,make_rh

    ! Set saturation specific humidity for this point

    shsat = ssh(p,t-273.15)*0.001

    ! Convert specific humidity to mixing ratio
    mrsat = shsat/(1.-shsat)
    mr = sh/(1.-sh)

    mrmax = mrsat*thresh

    rh_m = thresh*100.

    ! Convert modified mixing ratio back to specific humidity
    sh_m = mrmax/(1.+mrmax)

    RETURN
  END SUBROUTINE saturate_lwc_points


!==============================================================================
! Module REGIONAL_MODULE                                          (28-Jun-2017)
!
! Written by:
! 	   Dr. Randal J. Barnes
!     Department of Civil, Environmental, and Geo- Engineering
!     University of Minnesota
!     <barne003@umn.edu>
!==============================================================================

!==============================================================================
MODULE REGIONAL_MODULE
!==============================================================================
   USE CONSTANTS_MODULE
   USE ERROR_MODULE
   USE NUMERIC_MODULE
   IMPLICIT NONE

   !===========================================================================
   ! Type T_REGIONAL
   !===========================================================================
   TYPE T_REGIONAL
   PRIVATE
      REAL(8) :: Xo = 0    ! local origin easting
      REAL(8) :: Yo = 0    ! local origin northing

      REAL(8) :: A  = 0    ! coefficient for (X - Xo)**2
      REAL(8) :: B  = 0    ! coefficient for (Y - Yo)**2
      REAL(8) :: C  = 0    ! coefficient for (X - Xo) (Y - Yo)
      REAL(8) :: D  = 0    ! coefficient for (X - Xo)
      REAL(8) :: E  = 0    ! coefficient for (Y - Yo)
      REAL(8) :: F  = 0    ! constant
   END TYPE T_REGIONAL

   !===========================================================================
   ! INTERFACES
   !===========================================================================
   INTERFACE Potential
      MODULE PROCEDURE Potential_Regional
   END INTERFACE

   INTERFACE Discharge
      MODULE PROCEDURE Discharge_Regional
   END INTERFACE

   INTERFACE GetOrigin
      MODULE PROCEDURE GetOrigin_Regional
   END INTERFACE

   INTERFACE GetParameters
      MODULE PROCEDURE GetParameters_Regional
   END INTERFACE

   INTERFACE Reset
      MODULE PROCEDURE Reset_Regional
   END INTERFACE

   INTERFACE SetOrigin
      MODULE PROCEDURE SetOrigin_Regional
   END INTERFACE

   INTERFACE SetParameters
      MODULE PROCEDURE SetParameters_Regional
   END INTERFACE

CONTAINS
   !---------------------------------------------------------------------------
   ! Potential_Regional
   !---------------------------------------------------------------------------
   FUNCTION Potential_Regional( Regional, X, Y ) RESULT( Phi )

   ! Declare the arguments.
   TYPE(T_REGIONAL), INTENT(IN)  :: Regional ! regional flow of interest
   REAL(8),          INTENT(IN)  :: X        ! X coordinate of interest
   REAL(8),          INTENT(IN)  :: Y        ! Y coordinate of interest

   REAL(8)                       :: Phi      ! resulting discharge potential

   ! Declare the local variables.
   REAL(8) :: DX, DY

   ! Compute the regional component.
   DX = X - Regional%Xo
   DY = Y - Regional%Yo

   Phi = Regional%A*DX*DX + Regional%B*DY*DY + Regional%C*DX*DY + &
      Regional%D*DX + Regional%E*DY + Regional%F

   END FUNCTION Potential_Regional

   !---------------------------------------------------------------------------
   ! Discharge_Regional
   !---------------------------------------------------------------------------
   FUNCTION Discharge_Regional( Regional, X, Y ) RESULT( Q )

   ! Declare the arguments.
   TYPE(T_REGIONAL), INTENT(IN)  :: Regional ! regional flow of interest
   REAL(8),          INTENT(IN)  :: X        ! X coordinate of interest
   REAL(8),          INTENT(IN)  :: Y        ! Y coordinate of interest

   REAL(8), DIMENSION(2)         :: Q        ! resulting discharge

   ! Declare the local variables.
   REAL(8) :: DX, DY

   ! Compute the regional component.
   DX = X - Regional%Xo
   DY = Y - Regional%Yo

   Q(1) = -( 2*Regional%A*DX + Regional%C*DY + Regional%D )
   Q(2) = -( 2*Regional%B*DY + Regional%C*DX + Regional%E )

   END FUNCTION Discharge_Regional

   !---------------------------------------------------------------------------
   ! GetOrigin
   !---------------------------------------------------------------------------
   SUBROUTINE GetOrigin_Regional( Regional, Xo, Yo )

   ! Declare the arguments.
   TYPE(T_REGIONAL), INTENT(INOUT) :: Regional
   REAL(8),          INTENT(OUT)   :: Xo
   REAL(8),          INTENT(OUT)   :: Yo

   ! Set the parameter vector.
   Xo = Regional%Xo
   Yo = Regional%Yo

   END SUBROUTINE GetOrigin_Regional

   !---------------------------------------------------------------------------
   ! GetParameters
   !---------------------------------------------------------------------------
   SUBROUTINE GetParameters_Regional( Regional, P )

   ! Declare the arguments.
   TYPE(T_REGIONAL),      INTENT(INOUT) :: Regional ! regional model to fit
   REAL(8), DIMENSION(6), INTENT(OUT)   :: P        ! parameter vector

   ! Set the parameter vector.
   P(1) = Regional%A
   P(2) = Regional%B
   P(3) = Regional%C
   P(4) = Regional%D
   P(5) = Regional%E
   P(6) = Regional%F

   END SUBROUTINE GetParameters_Regional

   !---------------------------------------------------------------------------
   ! Reset_Regional
   !---------------------------------------------------------------------------
   SUBROUTINE Reset_Regional( Regional )

   ! Declare the arguments.
   TYPE(T_REGIONAL), INTENT(INOUT) :: Regional

   ! Reset the parameters the defaults.
   Regional%Xo = 0
   Regional%Yo = 0

   Regional%A  = 0
   Regional%B  = 0
   Regional%C  = 0
   Regional%D  = 0
   Regional%E  = 0
   Regional%F  = 0

   END SUBROUTINE Reset_Regional

   !---------------------------------------------------------------------------
   ! SetOrigin
   !---------------------------------------------------------------------------
   SUBROUTINE SetOrigin_Regional( Regional, Xo, Yo )

   ! Declare the arguments.
   TYPE(T_REGIONAL), INTENT(INOUT) :: Regional
   REAL(8),          INTENT(IN)    :: Xo
   REAL(8),          INTENT(IN)    :: Yo

   ! Set the parameter vector.
   Regional%Xo = Xo
   Regional%Yo = Yo

   END SUBROUTINE SetOrigin_Regional

   !---------------------------------------------------------------------------
   ! SetParameters
   !---------------------------------------------------------------------------
   SUBROUTINE SetParameters_Regional( Regional, P )

   ! Declare the arguments.
   TYPE(T_REGIONAL),      INTENT(INOUT) :: Regional ! regional model to fit
   REAL(8), DIMENSION(6), INTENT(IN)    :: P        ! parameter vector

   ! Do a simple validation check.
   IF( ANY(ISNAN(P)) .OR. ANY(ISINF(P)) ) THEN
      CALL ExecutionError( INVALID_PARAM_ERROR, 'Regional.f95', 'SetParameters' )
   END IF

   ! Set the parameter vector.
   Regional%A  = P(1)
   Regional%B  = P(2)
   Regional%C  = P(3)
   Regional%D  = P(4)
   Regional%E  = P(5)
   Regional%F  = P(6)

   END SUBROUTINE SetParameters_Regional

!==============================================================================
END MODULE REGIONAL_MODULE
!==============================================================================


program quicksort
      implicit none
      integer, parameter :: n = 10
      real, dimension(:), allocatable :: values
      character(len=10) :: fmt_str

      write (fmt_str, '(A, I0, A)') '(', n, 'F8.5)'
      call init_values(values, n)
      print fmt_str, values
      call qsort(values)
      print fmt_str, values

contains

      subroutine init_values(values, n)
          implicit none
          real, dimension(:), allocatable, intent(inout) :: values
          integer, intent(in) :: n
          allocate(values(n))
          call random_number(values)
      end subroutine init_values

      recursive subroutine qsort(values)
          implicit none
          real, dimension(:), intent(inout) :: values
          call qsort_r(values, 1, size(values))
      end subroutine qsort

      recursive subroutine qsort_r(values, low, high)
          implicit none
          real, dimension(:), intent(inout) :: values
          integer, intent(in) :: low, high
          integer :: pivot
          if (low < high) then
              pivot = find_pivot(values, low, high)
              call qsort_r(values, low, pivot - 1)
              call qsort_r(values, pivot, high)
          end if
      end subroutine qsort_r

      subroutine swap_values(values, i, j)
          implicit none
          real, dimension(:), intent(inout) :: values
          integer, intent(in) :: i, j
          real :: tmp
          tmp = values(i)
          values(i) = values(j)
          values(j) = tmp
      end subroutine swap_values

      function find_pivot(values, low, high) result(pivot)
          implicit none
          real, dimension(:), intent(inout) :: values
          integer, intent(in) :: low, high
          integer :: pivot
          real :: pivot_value
          integer :: i
          pivot_value = values(high)
          pivot = low
          do i = low, high - 1
              if (values(i) < pivot_value) then
                  call swap_values(values, i, pivot)
                  pivot = pivot + 1
              end if
          end do
          call swap_values(values, pivot, high)
      end function find_pivot

end program quicksort


! Test reshape for character arrays.
! { dg-do run }
program main
  implicit none
  integer, parameter :: n = 20, slen = 9
  character (len = slen), dimension (n) :: a, pad
  integer, dimension (3) :: shape, order
  integer :: i

  do i = 1, n
    a (i) = 'abcdefghijklmnopqrstuvwxyz'(i:i+6)
    pad (i) = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'(i:i+6)
  end do

  shape = (/ 4, 6, 5 /)
  order = (/ 3, 1, 2 /)
  call test (reshape (a, shape, pad, order))
contains
  subroutine test (b)
    character (len = slen), dimension (:, :, :) :: b
    integer :: i1, i2, i3, ai, padi

    do i = 1, 3
      if (size (b, i) .ne. shape (i)) call abort
    end do
    ai = 0
    padi = 0
    do i2 = 1, shape (2)
      do i1 = 1, shape (1)
        do i3 = 1, shape (3)
          if (ai .lt. n) then
            ai = ai + 1
            if (b (i1, i2, i3) .ne. a (ai)) call abort
          else
            padi = padi + 1
            if (padi .gt. n) padi = 1
            if (b (i1, i2, i3) .ne. pad (padi)) call abort
          end if
        end do
      end do
    end do
  end subroutine test
end program main


!       Save alpha and cholnhess on unit specified by unitalpha
!       alpha is location of the maximum of the conditional probability
!	of a response given the latent vector.
!       cholnhess is the modified Cholesky decomposition of the
!       negative hessian of the log conditional probability with respect
!       to the latent vector at the maximum.
subroutine savealpha(unitalpha,alpha,cholnhess)
implicit none

integer,intent(in)::unitalpha
REAL(KIND=8),INTENT(in)::alpha(:,:),cholnhess(:,:,:)
!	buffers.
character(len=4)::buff
character(len=25)::buffer(size(alpha,1)*(size(alpha,1)+1))
!	writefmt is used for producing the output.
character(len=7)::writefmt
!	col is used to count columns.
!	counter is a counter.
!       io checks for output errors.
!       obs counts observations.
!       row is used to count rows.
integer::col,counter,io,obs,row

write(buff,'(i4)') 2*size(alpha,1)*(size(alpha,1)+1)-1
writefmt='('//trim(adjustl(buff))//'a)'
do obs=1,size(alpha,2)
	counter=size(alpha,1)+1
	do row=1,size(alpha,1)
		write(buffer(row),'(g25.15e3)') alpha(row,obs)
	end do
	do col=1,size(alpha,1)
		do row=1,size(alpha,1)
			write(buffer(counter),'(g25.16e3)') cholnhess(row,col,obs)
			counter=counter+1
		end do
	end do
	write(unitalpha,writefmt) (trim(adjustl(buffer(row))),',',row=1,size(buffer)-1),buffer(size(buffer))

end do
return

end subroutine savealpha


!*******************************************************************
!                                                                  *
      INTEGER FUNCTION JFAZE(I1,I2,I3,I4)
!                                                                  *
!     ------------  SECTION METWO    SUBPROGRAM 20  -------------  *
!                                                                  *
!     DETERMINATE THE PHASE FACTOR WHICH APPEAR FROM PERMUTATION   *
!     OF OPERATORS OF SECOND QUANTIZATION                          *
!                                                                  *
!     NO FUNCTION CALLED                                           *
!                                                                  *
!   Written by  G. Gaigalas                                        *
!   Transform to fortran 90/95 by G. Gaigalas       December 2012  *
!   The last modification made by G. Gaigalas       October  2017  *
!                                                                  *
!*******************************************************************
!
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN) :: I1, I2, I3, I4
!-----------------------------------------------
      JFAZE=1
      IF(I1 > I2)JFAZE=-JFAZE
      IF(I1 > I3)JFAZE=-JFAZE
      IF(I1 > I4)JFAZE=-JFAZE
      IF(I2 > I3)JFAZE=-JFAZE
      IF(I2 > I4)JFAZE=-JFAZE
      IF(I3 > I4)JFAZE=-JFAZE
      RETURN
      END FUNCTION JFAZE


program test_rngs
  use utils, only: fp,ip,dip
  use random
  implicit none
!#define SIMPLE_SPRNG
!#include "sprng_f.h"
  type(sprng_gen) :: sprng_obj
  integer(ip) :: n,ii
  real(fp),dimension(:),allocatable :: x
  !SPRNG_POINTER :: id
  integer(dip) :: id
  real(fp) :: w
  integer :: junk

  n = 500
  allocate(x(n))

  ! id = init_sprng(0,0,1,2,SPRNG_DEFAULT)
  ! print *, 'Print information about new stream:'
  ! junk = print_sprng(id)
  ! do ii=1,n
  !    w = sprng(id)
  !    write(*,*) w
  ! end do
  ! do ii=1,n
  !    w = sprng()
  !    write(*,*) w
  ! end do

  call sprng_obj%init(0,1,0)
  call sprng_obj%init(0,2,1)
  call sprng_obj%norm(x,n,0.0_fp,1.0_fp)
  write(*,*) xu
end program test_rngs


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   ezp :    Complex bifurcation in a boundary value problem
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      COMPLEX(KIND(1.0D0)), INTENT(IN) :: U(NDIM)
      DOUBLE PRECISION, INTENT(IN) :: PAR(*)
      COMPLEX(KIND(1.0D0)), INTENT(OUT) :: F(NDIM)
      COMPLEX(KIND(1.0D0)), INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      COMPLEX(KIND(1.0D0)) :: U1, U2, RL, E

       U1=U(1)
       U2=U(2)

       RL=PAR(1)

       E=CDEXP(U1)
       F(1)=U2
       F(2)=-RL*E

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      COMPLEX(KIND(1.0D0)), INTENT(INOUT) :: U(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

       U(1)=0
       U(2)=0

      END SUBROUTINE STPNT

      SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,F,IJAC,DBC)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*)
      COMPLEX(KIND(1.0D0)), INTENT(IN) :: U0(NDIM), U1(NDIM)
      COMPLEX(KIND(1.0D0)), INTENT(OUT) :: F(NBC)
      COMPLEX(KIND(1.0D0)), INTENT(INOUT) :: DBC(NBC,*)

       F(1)=U0(1)
       F(2)=U1(1)

      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


module chol_interface
  interface
    subroutine chol(a, deter)
      implicit none
      real(8), dimension(:,:), intent(inout) :: a
      real(8), intent(out) :: deter
    end subroutine
  end interface
end module


      double precision function dqwgts(x,a,b,alfa,beta,integr)
c***begin prologue  dqwgts
c***refer to dqk15w
c***routines called  (none)
c***revision date  810101   (yymmdd)
c***keywords  weight function, algebraico-logarithmic
c             end-point singularities
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  this function subprogram is used together with the
c            routine dqaws and defines the weight function.
c***end prologue  dqwgts
c
      double precision a,alfa,b,beta,bmx,dlog,x,xma
      integer integr
c***first executable statement  dqwgts
      xma = x-a
      bmx = b-x
      dqwgts = xma**alfa*bmx**beta
      go to (40,10,20,30),integr
   10 dqwgts = dqwgts*dlog(xma)
      go to 40
   20 dqwgts = dqwgts*dlog(bmx)
      go to 40
   30 dqwgts = dqwgts*dlog(xma)*dlog(bmx)
   40 return
      end


      subroutine calbx(n,index,indic,nt,np,y,s,ys,z,zs,x,diag,bx)
c
c     fonction : {bx}=[b]*{x}.
c                [b] est definie par les vecteurs
c                ({y}(i),{s}(i),{z}(i), i=1,np) et {diag}
c
      implicit double precision (a-h,o-z)
      dimension y(nt,n),s(nt,n),z(nt,n),ys(nt),zs(nt)
      dimension diag(n),bx(n),x(n)
      integer indic(n),index(nt)
c
      do 100 i=1,n
         if(indic(i).gt.0) go to 100
         bx(i)=diag(i)*x(i)
100   continue
c
      do 110 i=1,np
         ii=index(i)
c
         yx=0
         zx=0
         do 120 j=1,n
            if(indic(j).gt.0) go to 120
            yx=yx+y(ii,j)*x(j)
            zx=zx+z(ii,j)*x(j)
120      continue
c
         do 130 j=1,n
            if(indic(j).gt.0) go to 130
            bx(j)=bx(j)+yx*y(ii,j)/ys(ii)-zx*z(ii,j)/zs(ii)
130      continue
110   continue
c
      return
      end


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

MODULE m_tetrahedron_regular

   !--------------------------------------------------------------------
   !Decomposes an equidistant k-point grid into tetrahedra
   !This happens by looking at a cube of 8 neighbouring k-points
   !and dividing this cube into 6 tetrahedra along the shortest diagonal
   ! Largely equivalent to spex routine
   !--------------------------------------------------------------------

   USE m_types_kpts
   USE m_types_cell
   USE m_juDFT
   USE m_constants

   IMPLICIT NONE

   CONTAINS

   SUBROUTINE tetrahedron_regular(kpts,film,cell,grid,ntetra,voltet)

      TYPE(t_kpts),           INTENT(INOUT)  :: kpts
      LOGICAL,                INTENT(IN)     :: film
      TYPE(t_cell),           INTENT(IN)     :: cell
      INTEGER,                INTENT(IN)     :: grid(:)
      INTEGER, ALLOCATABLE,   INTENT(INOUT)  :: ntetra(:,:)
      REAL,    ALLOCATABLE,   INTENT(INOUT)  :: voltet(:)

      INTEGER :: ntetraCube,k1,k2,k3,ikpt,itetra
      REAL    :: vol,sumvol,volbz,diag(2)
      INTEGER :: iarr(3)
      INTEGER, ALLOCATABLE :: tetra(:,:)
      INTEGER, ALLOCATABLE :: kcorn(:)
      INTEGER, ALLOCATABLE :: p(:,:,:)

      !Determine the decomposition of each individual cube
      ! and the total volume of the brillouin zone
      IF(film) THEN
         volbz = cell%bmat(1,1)*cell%bmat(2,2)-cell%bmat(1,2)*cell%bmat(2,1)
         ALLOCATE(tetra(3,2),source=0)
         ALLOCATE(kcorn(4),source=0)
         ntetraCube = 2
         tetra = reshape ( [ 1,2,3, 2,3,4], [ 3,2 ] )
         diag = cell%bmat(:2,2)/grid(:2) - cell%bmat(:2,1) / grid(:2)
         vol =  sum(diag*diag)/4.0
      ELSE
         volbz = ABS(det(cell%bmat))
         ALLOCATE(tetra(4,24),source=0)
         ALLOCATE(kcorn(8),source=0)
         !Choose the tetrahedra decomposition along the shortest diagonal
         CALL get_tetra(kpts,cell,grid,ntetraCube,vol,tetra)
      ENDIF

      !Set up pointer array for the kpts
      ALLOCATE(p(0:grid(1),0:grid(2),0:grid(3)),source=0)
      p = 0
      DO ikpt = 1, kpts%nkptf
         iarr = nint(kpts%bkf(:,ikpt)*grid)
         p(iarr(1),iarr(2),iarr(3)) = ikpt
      ENDDO
      p(grid(1),:,:) = p(0,:,:)
      p(:,grid(2),:) = p(:,0,:)
      p(:,:,grid(3)) = p(:,:,0)

      !Check for invalid indices
      IF(ANY(p<=0).OR.ANY(p>kpts%nkptf)) THEN
         CALL juDFT_error("Invalid kpoint index in pointer array",calledby="tetrahedron_regular")
      ENDIF

      !Temporary Size
      IF(film) THEN
         ALLOCATE(ntetra(3,kpts%nkptf*2),source=0)
         ALLOCATE(voltet(kpts%nkptf*2),source=0.0)
      ELSE
         ALLOCATE(ntetra(4,kpts%nkptf*6),source=0)
         ALLOCATE(voltet(kpts%nkptf*6),source=0.0)
      ENDIF

      kpts%ntet = 0
      sumvol = 0.0
      !Set up the tetrahedrons
      DO k3 = 0, MERGE(grid(3)-1,0,grid(3).NE.0)
         DO k2 = 0, grid(2)-1
            DO k1 = 0, grid(1)-1
               !Corners of the current cube
               kcorn(1) = p(k1  ,k2  ,k3  )
               kcorn(2) = p(k1+1,k2  ,k3  )
               kcorn(3) = p(k1  ,k2+1,k3  )
               kcorn(4) = p(k1+1,k2+1,k3  )
               IF(.NOT.film) THEN
                  kcorn(5) = p(k1  ,k2  ,k3+1)
                  kcorn(6) = p(k1+1,k2  ,k3+1)
                  kcorn(7) = p(k1  ,k2+1,k3+1)
                  kcorn(8) = p(k1+1,k2+1,k3+1)
               ENDIF

               !Now divide the cube into tetrahedra
               DO itetra = 1, ntetraCube
                  !Drop all tetrahedra without kpoints inside the IBZ
                  sumvol = sumvol + vol
                  IF(ALL(kcorn(tetra(:,itetra)).GT.kpts%nkpt)) CYCLE
                  kpts%ntet = kpts%ntet+1
                  ntetra(:,kpts%ntet) = kcorn(tetra(:,itetra))
                  voltet(kpts%ntet) = vol
               ENDDO
            ENDDO
         ENDDO
      ENDDO

      !Has the whole brillouin zone been covered?
      IF(ABS(sumvol-volbz).GT.1E-10) THEN
            CALL juDFT_error("tetrahedron_regular failed", calledby="tetrahedron_regular")
      ENDIF

      !Normalize volumes
      voltet = voltet/volbz

      !Rescale volumes for IO to inp.xml
      !(so weights dont get to small for IO with dense meshes)
      voltet = voltet * kpts%ntet

   END SUBROUTINE tetrahedron_regular

   SUBROUTINE get_tetra(kpts,cell,grid,ntetra,vol,tetra)

      TYPE(t_kpts),  INTENT(IN)     :: kpts
      TYPE(t_cell),  INTENT(IN)     :: cell
      INTEGER,       INTENT(IN)     :: grid(:)
      INTEGER,       INTENT(INOUT)  :: ntetra
      REAL,          INTENT(INOUT)  :: vol
      INTEGER,       INTENT(INOUT)  :: tetra(:,:)

      REAL rlv(3,3),diag(4),d(3)
      INTEGER idmin

      !Calculate the lengths of the three diagonals
      rlv(:,1) = cell%bmat(:,1) / grid
      rlv(:,2) = cell%bmat(:,2) / grid
      rlv(:,3) = cell%bmat(:,3) / grid

      vol = 1/6.0*ABS(det(rlv))
      d = rlv(:,1) + rlv(:,3) - rlv(:,2)
      diag(1) = sum(d*d)
      d = rlv(:,2) + rlv(:,3) - rlv(:,1)
      diag(2) = sum(d*d)
      d = rlv(:,1) + rlv(:,2) + rlv(:,3)
      diag(3) = sum(d*d)
      d = rlv(:,1) + rlv(:,2) - rlv(:,3)
      diag(4) = sum(d*d)
      idmin = minloc(diag,1)

      ntetra = 0
      !From spex tetrahedron.f (For now we only choose one decomposition)
      if(idmin==1) then
        tetra(:,ntetra+1:ntetra+6) = reshape ( [ 1,2,3,6, 5,7,3,6, 1,5,3,6, 2,4,3,6, 4,8,3,6, 7,8,3,6 ], [ 4,6 ] )
        ntetra                     = ntetra + 6
      endif
      if(idmin==2) then
        tetra(:,ntetra+1:ntetra+6) = reshape ( [ 5,6,2,7, 1,5,2,7, 1,3,2,7, 8,6,2,7, 4,3,2,7, 8,4,2,7 ], [ 4,6 ] )
        ntetra                     = ntetra + 6
      endif
      if(idmin==3) then
        tetra(:,ntetra+1:ntetra+6) = reshape ( [ 2,6,1,8, 2,4,1,8, 3,4,1,8, 3,7,1,8, 5,7,1,8, 5,6,1,8 ], [ 4,6 ] )
        ntetra                     = ntetra + 6
      endif
      if(idmin==4) then
        tetra(:,ntetra+1:ntetra+6) = reshape ( [ 2,6,4,5, 1,2,4,5, 1,3,4,5, 3,7,4,5, 7,8,4,5, 6,8,4,5 ], [ 4,6 ] )
        ntetra                     = ntetra + 6
      endif

   END SUBROUTINE get_tetra

   REAL FUNCTION det(m)
      REAL m(:,:)
      det = m(1,1)*m(2,2)*m(3,3) + m(1,2)*m(2,3)*m(3,1) + &
            m(2,1)*m(3,2)*m(1,3) - m(1,3)*m(2,2)*m(3,1) - &
            m(2,3)*m(3,2)*m(1,1) - m(2,1)*m(1,2)*m(3,3)
   END FUNCTION det

END MODULE m_tetrahedron_regular


*
*
      subroutine denbin(nup,nb,denb)
*
*     calculate binary number density in the case of primordial binares
*     --------------------------------------------------------------------
*     density is calculated for binaries which position is inside r(lmax).
*     --------------------------------------------------------------------
*     lmax = nzon(nup)
*     ----------------
*
*
      include 'common.h'
*
cChanged following ftncheck
c      real*8 rb(nmax),denb(nmax),co
      real*8 rb(nmax),denb(nmax),co
*
      integer nup,lmax,i,im1,ib,nspan,nspan2,nmin1,nmax1,nb(nmax)
*
      nspan = 2
      nspan2 = 2*nspan
      co = 0.75d0*(nspan2 + 1)/pi
      lmax = nzst(nup)
      ib = 0
*
      do 10 i = 1,lmax
*
         nb(i) = 0
         im1 = iname(i)
         if(ikind(im1).eq.2) then
           ib = ib + 1
           rb(ib) = r(i)
           nb(i) = ib
           denb(ib) = 0.d0
         endif
*
 10   continue
*
      do 20 i = 1,ib
*
         if(i.le.nspan) then
           nmin1 = 1
           nmax1 = nspan2 + 1
           denb(i) = co/(rb(nmax1)**3 - rb(nmin1)**3)
*
         else
*
           if(i+nspan.gt.ib) then
c             nmin1 = 2*i - ib - nspan
c             denb(i) = co/(rb(ib)**3 - rb(nmin1)**3)
             nmin1 = ib - 2*nspan
             if(nmin1.le.0) then
               print*,' wrong-nmin0 i,ib,nmin,nspan =',i,ib,nmin,nspan
               call flush(6)
               nmin1 = 1
             endif
             nmax1 = ib
             denb(i) = co/(rb(nmax1)**3 - rb(nmin1)**3)
*
           else
*
             nmin1 = i - nspan
             if(nmin1.le.0) then
               print*,' wrong-nmin1 i,ib,nmin,nspan =',i,ib,nmin,nspan
               call flush(6)
               nmin1 = 1
             endif
             nmax1 = i + nspan
             denb(i) = co/(rb(nmax1)**3 - rb(nmin1)**3)
*
           endif
*
         endif
*
 20      continue
*
*       maybe is good to smooth the binary density
*
         return
*
         end
*
*


Subroutine Conc(Dens2)
  Use cte
  Implicit None

  Integer :: i, k
  Logical :: Ctrl1, Ctrl2
  Real :: Dens2

  !CHECAR CONCENTRACION FINAL EN LA CELDA ORIGINAL
  k=0                                                       !CONTADOR DE PARTICULAS DENTRO DE LA CELDA ORIGINAL
  Partic: Do i=1 , N
     Ctrl1 = X(i) .LT. Boxl/2.0 .AND. X(i) .GT. -Boxl/2.0
     Ctrl2 = Y(i) .LT. Boxl/2.0 .AND. Y(i) .GT. -Boxl/2.0
     DENS_VERIFY: If (Ctrl1 .AND. Ctrl2) Then
        k = k + 1
     End If DENS_VERIFY
  End Do Partic
  Dens2 = k / BoxL**Dim                  !CALCULAR NUEVA DENSIDAD
  Write(*,*) "DENSIDAD FINAL DE LA CELDA ",Boxl," ES: ", Dens2

End Subroutine Conc


!
! SPDX-License-Identifier: MIT
!
module mod_param
  !
  use mod_types
  !
  implicit none
  !
  public
  !
  ! parameters
  !
  real(rp), parameter :: pi = acos(-1._rp)
  real(rp), parameter :: small = epsilon(pi)*10**(precision(pi)/2._rp)
  logical , parameter, dimension(2,3) :: no_outflow = &
      reshape((/.false.,.false.,   & ! no outflow in x lower,upper bound
                .false.,.false.,   & ! no outflow in y lower,upper bound
                .false.,.false./), & ! no outflow in z lower,upper bound
                shape(no_outflow))
  real(rp), parameter, dimension(2,3) :: rkcoeff = reshape((/ 32._rp/60._rp,  0._rp        , &
                                                              25._rp/60._rp, -17._rp/60._rp, &
                                                              45._rp/60._rp, -25._rp/60._rp/), shape(rkcoeff))
  real(rp), parameter, dimension(3)   :: rkcoeff12 = rkcoeff(1,:)+rkcoeff(2,:)
  !
  ! variables to be determined from the input files '*.in'
  !
  integer                              :: itot,jtot,ktot
  real(rp)                             :: lx,ly,lz,dx,dy,dz,dxi,dyi,dzi,gr
  real(rp)                             :: cfl,dt_input
  logical                              :: constant_dt
  real(rp)                             :: visc
  character(len=100)                   :: inivel
  integer                              :: is_wallturb
  integer                              :: nstep
  real(rp)                             :: time_max,tw_max
  logical, dimension(3)                :: stop_type
  logical                              :: restart
  integer                              :: icheck,iout0d,iout1d,iout2d,iout3d,isave
  integer, dimension(2)                :: dims_in  ! input (user-choice for a 2D decomp.)
  integer                              :: nthreadsmax
  character(len=1), dimension(0:1,3,3) :: cbcvel
  real(rp)        , dimension(0:1,3,3) :: bcvel
  character(len=1), dimension(0:1,3)   :: cbcpre
  real(rp)        , dimension(0:1,3)   :: bcpre
  !
  real(rp), dimension(3) :: bforce
  real(rp) :: bulk_velx,bulk_vely,bulk_velz
  logical , dimension(3) :: is_forced
  logical , dimension(0:1,3) :: is_outflow
  !
  integer , dimension(3) :: ng
  integer , dimension(3) :: n
  real(rp), dimension(3) :: l
  real(rp), dimension(3) :: dl
  real(rp), dimension(3) :: dli
  !
#if defined(_DO_POSTPROC)
  logical  :: do_avg,do_favre,do_wall
  real(rp) :: deltaT
  integer  :: avg_dir,time_deltai,wall_deltai
#endif
  !
#if defined(_USE_VOF)
  real(rp),  dimension(3) :: gacc
  character(len=8) :: inivof
  character(len=1), dimension(0:1,3) ::  cbcvof
  real(rp),  allocatable, dimension(:) :: xc, yc, zc, r
  real(rp) :: rho1,rho2,mu1,mu2,sigma,rho0
  real(rp), dimension(0:1,3) ::   bcvof
  real(rp),  dimension(3) :: dpdl
  logical :: late_init
  integer :: nbub=0, i_b,i_late_init
#endif
  !
#if defined(_TURB_FORCING)
  character(len=3)       :: turbType
  real(rp)               :: u0_t, f0_t, k0_t
  real(rp), dimension(3) :: abc
  logical :: add_noise_abc
#endif
#if defined(_HEAT_TRANSFER)
  character(len=3)   :: initmp
  real(rp)           :: cp1,cv1,kappa1
  real(rp)           :: cp2,cv2,kappa2
  real(rp)           :: tl0,tg0,gam_g
#if defined(_BOUSSINESQ)
  real(rp)           :: tmp0,beta_th
#endif
  character(len=1), dimension(0:1,3) :: cbctmp
  real(rp)        , dimension(0:1,3) ::  bctmp
#endif
  !
  contains
  !
  subroutine read_input(myid)
    !
    use mpi
    !
    implicit none
    !
    integer, intent(in) :: myid
    integer :: iunit,ierr
    !
    ! load single-phase input files
    !
    open(newunit=iunit,file='dns.in',status='old',action='read',iostat=ierr)
    if( ierr.eq.0 ) then
      read(iunit,*) itot,jtot,ktot
      read(iunit,*) lx,ly,lz
      read(iunit,*) gr
      read(iunit,*) cfl,dt_input
      read(iunit,*) constant_dt
      read(iunit,*) visc
      read(iunit,*) inivel
      read(iunit,*) is_wallturb
      read(iunit,*) nstep, time_max,tw_max
      read(iunit,*) stop_type(1),stop_type(2),stop_type(3)
      read(iunit,*) restart
      read(iunit,*) icheck,iout0d,iout1d,iout2d,iout3d,isave
      read(iunit,*) cbcvel(0,1,1),cbcvel(1,1,1),cbcvel(0,2,1),cbcvel(1,2,1),cbcvel(0,3,1),cbcvel(1,3,1)
      read(iunit,*) cbcvel(0,1,2),cbcvel(1,1,2),cbcvel(0,2,2),cbcvel(1,2,2),cbcvel(0,3,2),cbcvel(1,3,2)
      read(iunit,*) cbcvel(0,1,3),cbcvel(1,1,3),cbcvel(0,2,3),cbcvel(1,2,3),cbcvel(0,3,3),cbcvel(1,3,3)
      read(iunit,*) cbcpre(0,1  ),cbcpre(1,1  ),cbcpre(0,2  ),cbcpre(1,2  ),cbcpre(0,3  ),cbcpre(1,3  )
      read(iunit,*)  bcvel(0,1,1), bcvel(1,1,1), bcvel(0,2,1), bcvel(1,2,1), bcvel(0,3,1), bcvel(1,3,1)
      read(iunit,*)  bcvel(0,1,2), bcvel(1,1,2), bcvel(0,2,2), bcvel(1,2,2), bcvel(0,3,2), bcvel(1,3,2)
      read(iunit,*)  bcvel(0,1,3), bcvel(1,1,3), bcvel(0,2,3), bcvel(1,2,3), bcvel(0,3,3), bcvel(1,3,3)
      read(iunit,*)  bcpre(0,1  ), bcpre(1,1  ), bcpre(0,2  ), bcpre(1,2  ), bcpre(0,3  ), bcpre(1,3  )
      read(iunit,*)  bforce(1),bforce(2),bforce(3)
      read(iunit,*)  is_forced(1),is_forced(2),is_forced(3)
      read(iunit,*)  bulk_velx,bulk_vely,bulk_velz
      read(iunit,*)  is_outflow(0,1),is_outflow(1,1),is_outflow(0,2),is_outflow(1,2),is_outflow(0,3),is_outflow(1,3)
      read(iunit,*) dims_in(1),dims_in(2)
      read(iunit,*) nthreadsmax
    else
      if(myid.eq.0) print*, 'Error reading the dns.in input file'
      if(myid.eq.0) print*, 'Aborting...'
      call MPI_FINALIZE(ierr)
      call exit
    endif
    close(iunit)
    !
    ! load two-phase input files
    !
#if defined(_USE_VOF)
    open(newunit=iunit,file='vof.in',status='old',action='read',iostat=ierr)
    if( ierr.eq.0 ) then
      read(iunit,*) rho1, rho2, mu1,mu2
      read(iunit,*) inivof
      read(iunit,*) nbub
      allocate(xc(nbub), yc(nbub), zc(nbub), r(nbub))
      if(nbub.eq.1) then
        read(iunit,*) xc, yc, zc, r
      else
        read(iunit,*) xc(1), yc(1), zc(1), r(1)
      endif
      read(iunit,*) cbcvof(0,1 ),cbcvof(1,1 ),cbcvof(0,2 ),cbcvof(1,2 ),cbcvof(0,3 ),cbcvof(1,3 )
      read(iunit,*) bcvof(0,1  ),bcvof(1,1  ),bcvof(0,2  ),bcvof(1,2  ),bcvof(0,3  ),bcvof(1,3  )
      read(iunit,*) gacc(1), gacc(2), gacc(3)
      read(iunit,*) sigma
      read(iunit,*) dpdl(1), dpdl(2), dpdl(3)
      read(iunit,*) late_init, i_late_init
    else
      if(myid.eq.0) print*, 'Error reading the vof.in input file'
      if(myid.eq.0) print*, 'Aborting...'
      call MPI_FINALIZE(ierr)
      call exit
    endif
    rho0 = min(rho1,rho2)
    close(iunit)
    !
    if(nbub.gt.1) then
      open(newunit=iunit,file='bub.in',status='old',action='read',iostat=ierr)
      if( ierr.eq.0 ) then
        do i_b=1,nbub
          read(iunit,*) xc(i_b), yc(i_b), zc(i_b), r(i_b)
        enddo
      else
        if(myid.eq.0) print*, 'Error reading the bub.in input file'
        if(myid.eq.0) print*, 'Aborting...'
        call MPI_FINALIZE(ierr)
        call exit
      endif
      close(iunit)
    endif
#endif
    !
    ! load post-processing input files
    !
#if defined(_DO_POSTPROC)
    open(newunit=iunit,file='post.in',status='old',action='read',iostat=ierr)
    if( ierr.eq.0 ) then
      read(iunit,*) do_avg
      read(iunit,*) avg_dir
      read(iunit,*) time_deltai
      read(iunit,*) do_favre
      read(iunit,*) do_wall
      read(iunit,*) wall_deltai
    else
      if(myid.eq.0) print*, 'Error reading the post.in input file'
      if(myid.eq.0) print*, 'Aborting...'
      call MPI_FINALIZE(ierr)
      call exit
    endif
    close(iunit)
#endif
    !
    ! load turbulent forcing input files
    !
#if defined(_TURB_FORCING)
    open(newunit=iunit,file='forcing.in',status='old',action='read',iostat=ierr)
    if( ierr.eq.0 ) then
      read(iunit,*) turbType
      read(iunit,*) u0_t
      read(iunit,*) f0_t
      read(iunit,*) k0_t
      read(iunit,*) abc(1), abc(2), abc(3)
      read(iunit,*) add_noise_abc
    else
      if(myid.eq.0) print*, 'Error reading the forcing.in input file'
      if(myid.eq.0) print*, 'Aborting...'
      call MPI_FINALIZE(ierr)
      call exit
    endif
    close(iunit)
#endif
    !
    ! load heat transfer input files
    !
#if defined(_HEAT_TRANSFER)
    open(newunit=iunit,file='heat_transfer.in',status='old',action='read',iostat=ierr)
    if( ierr.eq.0 ) then
      read(iunit,*) initmp
      read(iunit,*) tl0,tg0
      read(iunit,*) cp1,cp2
      read(iunit,*) cv1,cv2
      read(iunit,*) kappa1,kappa2
      read(iunit,*) cbctmp(0,1 ),cbctmp(1,1 ),cbctmp(0,2 ),cbctmp(1,2 ),cbctmp(0,3 ),cbctmp(1,3 )
      read(iunit,*) bctmp(0,1  ),bctmp(1,1  ),bctmp(0,2  ),bctmp(1,2  ),bctmp(0,3  ),bctmp(1,3  )
#if defined(_BOUSSINESQ)
      read(iunit,*) tmp0,beta_th
#endif
      gam_g = cp1/cv1
#if defined(_DO_POSTPROC)
      if(avg_dir.eq.1) then
        deltaT=abs(bctmp(0,1)-bctmp(1,1))
      elseif(avg_dir.eq.2) then
        deltaT=abs(bctmp(0,2)-bctmp(1,2))
      else
        deltaT=abs(bctmp(0,3)-bctmp(1,3))
      endif
#endif
      else
        if(myid.eq.0) print*, 'Error reading the heat_transfer.in input file'
        if(myid.eq.0) print*, 'Aborting...'
        call MPI_FINALIZE(ierr)
        call exit
      endif
    close(iunit)
#endif
    !
    ! compute the cartesian spacings
    !
    dx  = lx/(1._rp*itot)
    dy  = ly/(1._rp*jtot)
    dz  = lz/(1._rp*ktot)
    dxi = dx**(-1)
    dyi = dy**(-1)
    dzi = dz**(-1)
    !
    ng  = (/itot,jtot,ktot/)
    l   = (/lx  ,ly  ,lz  /)
    dl  = (/dx  ,dy  ,dz  /)
    dli = (/dxi ,dyi ,dzi /)
    !
    ! if _USE_VOF is active, we replace visc with the minimum viscosity between the two phases
    ! note: in this case, please fill dns.in and vof.in consistently
    !
#if defined(_USE_VOF)
    visc = min(mu1/rho1,rho2/mu2)
#endif
    !
    return
  end subroutine read_input
  !
end module mod_param


	SUBROUTINE GQGRAF ( ixtyp, iytyp, yszxsz, xlm, ybm, xrm, ytm,
     +	                    iret )
C************************************************************************
C* GQGRAF								*
C*									*
C* This subroutine returns the current coordinate system definition 	*
C* for the graph plotting mode of the map/graph coordinate system.	*
C*									*
C* GQGRAF  ( IXTYP, IYTYP, YSZXSZ, XLM, YBM, XRM, YTM, IRET )		*
C* 									*
C* Output parameters:							*
C* 	IXTYP		INTEGER		X coordinate type		*
C*					   1 = linear			*
C*					   2 = logarithmic		*
C*					   3 = ** kappa (2 / 7)		*
C*					   4 = skew			*
C*					   5 = polar (R)		*
C* 	IYTYP		INTEGER		Y coordinate type 		*
C*					   1 = linear			*
C*					   2 = logarithmic		*
C*					   3 = ** kappa (2 / 7)		*
C*					   5 = polar (THETA)		*
C* 	YSZXSZ		REAL		Height to width ratio of plot	*
C* 	XLM		REAL		Left limit of X axis 		*
C* 	YBM		REAL		Bottom limit of Y axis 		*
C* 	XRM		REAL		Right limit of X axis 		*
C* 	YTM		REAL		Top limit of Y axis 		*
C* 	IRET 		INTEGER		Return code			*
C**									*
C* Log:									*
C* M. Vilardo/RDS	 9/84	GEMPLT Version 3.0			*
C* I. Graffman/RDS	 5/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	10/86	Cleaned up				*
C* M. desJardins/GSFC	 9/88	GEMPAK4					*
C************************************************************************
	INCLUDE 	'ERROR.PRM'
	INCLUDE 	'XYDEF.CMN'
C------------------------------------------------------------------------
C*	Check for graph mode.
C
	IF  ( igmode .ne. 2 )  THEN
	    iret = NIMODE
C
C*	  Check for graph defined.
C
	  ELSE IF  ( .not. gset )  THEN
	    iret = NOGRAF
C
C*	   Return values from common.
C
	  ELSE
	    iret   = NORMAL
	    ixtyp  = jxtyp
	    iytyp  = jytyp
	    yszxsz = yxgraf
	    xlm    = xlmg
	    ybm    = ybmg
	    xrm    = xrmg
	    ytm    = ytmg
	END IF
C*
	RETURN
	END


function area(r, theta)
        real, intent(in) :: r, theta
        real :: area
        area = 0.5 * r**2 * theta
end function area

program filetest
        real :: pi = 3.14195, tau, unit_area
        tau = pi * 2
        unit_area = area(1.0, tau)

        open ( & ! '&' line-continuation
                unit=myfile, & ! file handler
                file="pi.txt", &
                action="write", &
                position="append")

        write(myfile,*) "pi ", "tau ", "unit_area"
        write(myfile,*) pi, tau, unit_area
        write(*,*) pi, tau, unit_area
end program filetest


!-----------------------------------------------------------------
! Programmer(s): Daniel R. Reynolds @ SMU
!-----------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2021, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
!-----------------------------------------------------------------
! Example problem:
!
! The following test simulates a simple anisotropic 2D heat
! equation,
!    u_t = kx*u_xx + ky*u_yy + h,
! for t in [0, 10], (x,y) in [0, 1]^2, with initial conditions
!    u(0,x,y) =  0,
! stationary boundary conditions, i.e.
!    u_t(t,0,y) = u_t(t,1,y) = u_t(t,x,0) = u_t(t,x,1) = 0,
! and a heat source of the form
!    h(x,y) = sin(pi*x)*sin(2*pi*y).
!
! Under this setup, the problem has an analytical solution:
!    u(t,x,y) = a(t)*sin(pi*x)*sin(2*pi*y), where
!    a(t) = (1 - exp(-(kx+4*ky)*pi^2*t)) / ((kx+4*ky)*pi^2).
!
! The spatial derivatives are computed using second-order
! centered differences, with the data distributed over nx*ny
! points on a uniform spatial grid.
!
! The spatial grid parameters nx and ny, the parameters kx and ky,
! as well as the desired relative and absolute solver tolerances,
! are provided in the input file input_heat2D.txt.
!
! This program solves the problem with a DIRK method.  This
! employs a Newton iteration with the PCG iterative linear solver,
! which itself uses a Jacobi preconditioner.  The example uses the
! built-in finite-difference Jacobian-vector product routine, but
! supplies both the RHS and preconditioner setup/solve functions.
!
! 20 outputs are printed at equal intervals, and run statistics
! are printed at the end.
!-----------------------------------------------------------------

!-----------------------------------------------------------------
! Main driver program
!-----------------------------------------------------------------
module UserData
  !---------------------------------------------------------------
  ! Description:
  !    Module containing problem-defining parameters, as well as
  !    data buffers for MPI exchanges with neighboring processes.
  !    Also contains routines to:
  !      (a) initialize the module
  !      (b) perform exchanges
  !      (c) free module data.
  !---------------------------------------------------------------
  implicit none
  include "sundials/sundials_fconfig.h"
  save

  integer*8 :: nx          ! global number of x grid points
  integer*8 :: ny          ! global number of y grid points
  integer*8 :: is          ! global x indices of this subdomain
  integer*8 :: ie
  integer*8 :: js          ! global y indices of this subdomain
  integer*8 :: je
  integer*8 :: nxl         ! local number of x grid points
  integer*8 :: nyl         ! local number of y grid points
  real*8    :: dx          ! x-directional mesh spacing
  real*8    :: dy          ! y-directional mesh spacing
  real*8    :: kx          ! x-directional diffusion coefficient
  real*8    :: ky          ! y-directional diffusion coefficient
  real(kind=REALTYPE), dimension(:,:), allocatable :: h    ! heat source vector
  real(kind=REALTYPE), dimension(:,:), allocatable :: d    ! inverse of Jacobian diagonal
  integer :: comm                             ! communicator object
  integer :: myid                             ! MPI process ID
  integer :: nprocs                           ! total number of MPI processes
  logical :: HaveNbor(2,2)                    ! flags denoting neighbor on boundary
  real(kind=REALTYPE), dimension(:), allocatable :: Erecv  ! receive buffers for neighbor exchange
  real(kind=REALTYPE), dimension(:), allocatable :: Wrecv
  real(kind=REALTYPE), dimension(:), allocatable :: Nrecv
  real(kind=REALTYPE), dimension(:), allocatable :: Srecv
  real(kind=REALTYPE), dimension(:), allocatable :: Esend  ! send buffers for neighbor exchange
  real(kind=REALTYPE), dimension(:), allocatable :: Wsend
  real(kind=REALTYPE), dimension(:), allocatable :: Nsend
  real(kind=REALTYPE), dimension(:), allocatable :: Ssend

contains

  !---------------------------------------------------------------
  ! Initialize memory allocated within Userdata (set to defaults)
  !---------------------------------------------------------------
  subroutine InitUserData()
    implicit none
    include "mpif.h"
    nx = 0
    ny = 0
    is = 0
    ie = 0
    js = 0
    je = 0
    nxl = 0
    nyl = 0
    dx = 0.d0
    dy = 0.d0
    kx = 0.d0
    ky = 0.d0
    if (allocated(h))  deallocate(h)
    if (allocated(d))  deallocate(d)
    comm = MPI_COMM_WORLD
    myid = 0
    nprocs = 0
    HaveNbor = .false.
    if (allocated(Erecv))  deallocate(Erecv)
    if (allocated(Wrecv))  deallocate(Wrecv)
    if (allocated(Nrecv))  deallocate(Nrecv)
    if (allocated(Srecv))  deallocate(Srecv)
    if (allocated(Esend))  deallocate(Esend)
    if (allocated(Wsend))  deallocate(Wsend)
    if (allocated(Nsend))  deallocate(Nsend)
    if (allocated(Ssend))  deallocate(Ssend)
  end subroutine InitUserData
  !---------------------------------------------------------------

  !---------------------------------------------------------------
  ! Set up parallel decomposition
  !---------------------------------------------------------------
  subroutine SetupDecomp(ierr)
    ! declarations
    implicit none
    include "mpif.h"
    integer, intent(out) :: ierr
    integer :: dims(2), periods(2), coords(2)

    ! internals

    ! check that this has not been called before
    if (allocated(h) .or. allocated(d)) then
       write(0,*) "SetupDecomp warning: parallel decomposition already set up"
       ierr = 1
       return
    end if

    ! get suggested parallel decomposition
    dims = (/0, 0/)
    call MPI_Comm_size(MPI_COMM_WORLD, nprocs, ierr)
    if (ierr /= MPI_SUCCESS) then
       write(0,*) "Error in MPI_Comm_size = " , ierr
       return
    end if
    call MPI_Dims_create(nprocs, 2, dims, ierr)
    if (ierr /= MPI_SUCCESS) then
       write(0,*) "Error in MPI_Dims_create = " , ierr
       return
    end if

    ! set up 2D Cartesian communicator
    periods = (/0, 0/)
    call MPI_Cart_create(MPI_COMM_WORLD, 2, dims, periods, 0, comm, ierr)
    if (ierr /= MPI_SUCCESS) then
       write(0,*) "Error in MPI_Cart_create = " , ierr
       return
    end if
    call MPI_Comm_rank(comm, myid, ierr)
    if (ierr /= MPI_SUCCESS) then
       write(0,*) "Error in MPI_Comm_rank = " , ierr
       return
    end if

    ! determine local extents
    call MPI_Cart_get(comm, 2, dims, periods, coords, ierr)
    if (ierr /= MPI_SUCCESS) then
       write(0,*) "Error in MPI_Cart_get = " , ierr
       return
    end if
    is = nx*coords(1)/dims(1) + 1
    ie = nx*(coords(1)+1)/dims(1)
    js = ny*coords(2)/dims(2) + 1
    je = ny*(coords(2)+1)/dims(2)
    nxl = ie-is+1
    nyl = je-js+1

    ! determine if I have neighbors, and allocate exchange buffers
    HaveNbor(1,1) = (is /= 1)
    HaveNbor(1,2) = (ie /= nx)
    HaveNbor(2,1) = (js /= 1)
    HaveNbor(2,2) = (je /= ny)
    if (HaveNbor(1,1)) then
       allocate(Wrecv(nyl))
       allocate(Wsend(nyl))
    endif
    if (HaveNbor(1,2)) then
       allocate(Erecv(nyl))
       allocate(Esend(nyl))
    endif
    if (HaveNbor(2,1)) then
       allocate(Srecv(nxl))
       allocate(Ssend(nxl))
    endif
    if (HaveNbor(2,2)) then
       allocate(Nrecv(nxl))
       allocate(Nsend(nxl))
    endif

    ! allocate temporary vectors
    allocate(h(nxl,nyl))    ! Create vector for heat source
    allocate(d(nxl,nyl))    ! Create vector for Jacobian diagonal

    ierr = 0     ! return with success flag
    return
  end subroutine SetupDecomp
  !---------------------------------------------------------------

  !---------------------------------------------------------------
  ! Perform neighbor exchange
  !---------------------------------------------------------------
  subroutine Exchange(y, ierr)
    ! declarations
    implicit none
    include "mpif.h"
    real(kind=REALTYPE),  intent(in)  :: y(nxl,nyl)
    integer, intent(out) :: ierr
    integer :: reqSW, reqSE, reqSS, reqSN, reqRW, reqRE, reqRS, reqRN;
    integer :: stat(MPI_STATUS_SIZE)
    integer*8 :: i
    integer :: ipW, ipE, ipS, ipN
    integer :: coords(2), dims(2), periods(2), nbcoords(2)

    ! internals

    ! MPI neighborhood information
    call MPI_Cart_get(comm, 2, dims, periods, coords, ierr)
    if (ierr /= MPI_SUCCESS) then
       write(0,*) "Error in MPI_Cart_get = ", ierr
       return
    endif
    if (HaveNbor(1,1)) then
       nbcoords = (/ coords(1)-1, coords(2) /)
       call MPI_Cart_rank(comm, nbcoords, ipW, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Cart_rank = ", ierr
          return
       endif
    endif
    if (HaveNbor(1,2)) then
       nbcoords = (/ coords(1)+1, coords(2) /)
       call MPI_Cart_rank(comm, nbcoords, ipE, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Cart_rank = ", ierr
          return
       endif
    endif
    if (HaveNbor(2,1)) then
       nbcoords = (/ coords(1), coords(2)-1 /)
       call MPI_Cart_rank(comm, nbcoords, ipS, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Cart_rank = ", ierr
          return
       endif
    endif
    if (HaveNbor(2,2)) then
       nbcoords = (/ coords(1), coords(2)+1 /)
       call MPI_Cart_rank(comm, nbcoords, ipN, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Cart_rank = ", ierr
          return
       endif
    endif

    ! open Irecv buffers
    if (HaveNbor(1,1)) then
       call MPI_Irecv(Wrecv, nyl, MPI_DOUBLE_PRECISION, ipW, &
                      MPI_ANY_TAG, comm, reqRW, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Irecv = ", ierr
          return
       endif
    endif
    if (HaveNbor(1,2)) then
       call MPI_Irecv(Erecv, nyl, MPI_DOUBLE_PRECISION, ipE, &
                      MPI_ANY_TAG, comm, reqRE, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Irecv = ", ierr
          return
       endif
    endif
    if (HaveNbor(2,1)) then
       call MPI_Irecv(Srecv, nxl, MPI_DOUBLE_PRECISION, ipS, &
                      MPI_ANY_TAG, comm, reqRS, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Irecv = ", ierr
          return
       endif
    endif
    if (HaveNbor(2,2)) then
       call MPI_Irecv(Nrecv, nxl, MPI_DOUBLE_PRECISION, ipN, &
                      MPI_ANY_TAG, comm, reqRN, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Irecv = ", ierr
          return
       endif
    endif

    ! send data
    if (HaveNbor(1,1)) then
       do i=1,nyl
          Wsend(i) = y(1,i)
       enddo
       call MPI_Isend(Wsend, nyl, MPI_DOUBLE_PRECISION, ipW, 0, &
                      comm, reqSW, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Isend = ", ierr
          return
       endif
    endif
    if (HaveNbor(1,2)) then
       do i=1,nyl
          Esend(i) = y(nxl,i)
       enddo
       call MPI_Isend(Esend, nyl, MPI_DOUBLE_PRECISION, ipE, 1, &
                      comm, reqSE, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Isend = ", ierr
          return
       endif
    endif
    if (HaveNbor(2,1)) then
       do i=1,nxl
          Ssend(i) = y(i,1)
       enddo
       call MPI_Isend(Ssend, nxl, MPI_DOUBLE_PRECISION, ipS, 2, &
                      comm, reqSS, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Isend = ", ierr
          return
       endif
    endif
    if (HaveNbor(2,2)) then
       do i=1,nxl
          Nsend(i) = y(i,nyl)
       enddo
       call MPI_Isend(Nsend, nxl, MPI_DOUBLE_PRECISION, ipN, 3, &
                      comm, reqSN, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Isend = ", ierr
          return
       endif
    endif

    ! wait for messages to finish
    if (HaveNbor(1,1)) then
       call MPI_Wait(reqRW, stat, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Wait = ", ierr
          return
       endif
       call MPI_Wait(reqSW, stat, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Wait = ", ierr
          return
       endif
    endif
    if (HaveNbor(1,2)) then
       call MPI_Wait(reqRE, stat, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Wait = ", ierr
          return
       endif
       call MPI_Wait(reqSE, stat, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Wait = ", ierr
          return
       endif
    endif
    if (HaveNbor(2,1)) then
       call MPI_Wait(reqRS, stat, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Wait = ", ierr
          return
       endif
       call MPI_Wait(reqSS, stat, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Wait = ", ierr
          return
       endif
    endif
    if (HaveNbor(2,2)) then
       call MPI_Wait(reqRN, stat, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Wait = ", ierr
          return
       endif
       call MPI_Wait(reqSN, stat, ierr)
       if (ierr /= MPI_SUCCESS) then
          write(0,*) "Error in MPI_Wait = ", ierr
          return
       endif
    endif

    ierr = 0     ! return with success flag
    return
  end subroutine Exchange
  !---------------------------------------------------------------

  !---------------------------------------------------------------
  ! Free memory allocated within Userdata
  !---------------------------------------------------------------
  subroutine FreeUserData(ierr)
    implicit none
    integer, intent(out) :: ierr
    if (allocated(h))      deallocate(h)
    if (allocated(d))      deallocate(d)
    if (allocated(Wrecv))  deallocate(Wrecv)
    if (allocated(Wsend))  deallocate(Wsend)
    if (allocated(Erecv))  deallocate(Erecv)
    if (allocated(Esend))  deallocate(Esend)
    if (allocated(Srecv))  deallocate(Srecv)
    if (allocated(Ssend))  deallocate(Ssend)
    if (allocated(Nrecv))  deallocate(Nrecv)
    if (allocated(Nsend))  deallocate(Nsend)
    ierr = 0     ! return with success flag
    return
  end subroutine FreeUserData
  !---------------------------------------------------------------

  !---------------------------------------------------------------
  ! RMS norm function for parallel array data
  !---------------------------------------------------------------
  subroutine PRMS(y,yrms,ierr)
    ! declarations
    implicit none
    include "mpif.h"
    integer, intent(out) :: ierr
    real(kind=REALTYPE),  intent(in)  :: y(nxl,nyl)
    real(kind=REALTYPE),  intent(out) :: yrms
    real(kind=REALTYPE) :: lsum, gsum

    ! internals
    lsum = sum(y**2)
    call MPI_Allreduce(lsum, gsum, 1, MPI_DOUBLE_PRECISION, &
                       MPI_SUM, comm, ierr)
    if (ierr /= MPI_SUCCESS) then
       write(0,*) "Error in MPI_Allreduce = ", ierr
       call MPI_Finalize(ierr)
    endif
    yrms = sqrt(gsum/nx/ny)

    ierr = 0     ! return with success flag
    return
  end subroutine PRMS
  !---------------------------------------------------------------

end module UserData
!-----------------------------------------------------------------

!-----------------------------------------------------------------
! Main driver program
!-----------------------------------------------------------------
program driver

  ! inclusions
  use UserData
  implicit none
  include "mpif.h"

  ! Declarations
  ! general problem parameters
  real*8,    parameter :: pi = 3.1415926535897932d0
  integer,   parameter :: Nt = 20           ! total number of output times
  integer*8, parameter :: nx_ = 60          ! spatial mesh size
  integer*8, parameter :: ny_ = 120
  integer,   parameter :: PCGpretype = 1    ! enable preconditioner
  integer,   parameter :: PCGmaxl = 20      ! max num. PCG iterations
  real(kind=REALTYPE), parameter :: T0 = 0.d0        ! initial time
  real(kind=REALTYPE), parameter :: Tf = 0.3d0       ! final time
  real(kind=REALTYPE), parameter :: rtol = 1.d-5     ! relative and absolute tolerances
  real(kind=REALTYPE), parameter :: atol = 1.d-10
  real(kind=REALTYPE), parameter :: kx_ = 0.5d0      ! heat conductivity coefficients
  real(kind=REALTYPE), parameter :: ky_ = 0.75d0
  real(kind=REALTYPE), parameter :: nlscoef = 1.d-7  ! nonlinear solver tolerance factor

  ! solution vector and other local variables
  real(kind=REALTYPE), allocatable :: y(:,:)
  real(kind=REALTYPE) :: rout(6), rpar, t, dTout, tout, urms
  integer*8 :: iout(35), ipar, N, Ntot, i, j
  integer   :: flag, ioutput
  logical   :: outproc
  character*100 :: outname

  ! initialize MPI
  call MPI_Init(flag)
  if (flag /= MPI_SUCCESS) then
     write(0,*) "Error in MPI_Init = ", flag
     stop
  end if
  call MPI_Comm_rank(MPI_COMM_WORLD, myid, flag)
  if (flag /= MPI_SUCCESS) then
     write(0,*) "Error in MPI_Comm_rank = ", flag
     call MPI_Finalize(flag)
  end if

  ! Initialize UserData module
  call InitUserData()
  nx = nx_
  ny = ny_
  kx = kx_
  ky = ky_
  dx = 1.d0/(nx-1)   ! x mesh spacing
  dy = 1.d0/(ny-1)   ! x mesh spacing

  ! Set up parallel decomposition (computes local mesh sizes)
  call SetupDecomp(flag)
  if (flag /= MPI_SUCCESS) then
     write(0,*) "Error in SetupDecomp = ", flag
     call MPI_Finalize(flag)
  end if

  ! Initial problem output
  outproc = (myid == 0)
  if (outproc) then
     write(6,*) "  "
     write(6,*) "2D Heat PDE test problem:";
     write(6,'(A,i4)') "   nprocs = " , nprocs
     write(6,'(A,i4)') "   nx = ", nx
     write(6,'(A,i4)') "   ny = ", ny
     write(6,'(A,f5.2)') "   kx = ", kx
     write(6,'(A,f5.2)') "   ky = ", ky
     write(6,'(A,es9.2)') "   rtol = ", rtol
     write(6,'(A,es9.2)') "   atol = ", atol
     write(6,'(A,i4)') "   nxl (proc 0) = ", nxl
     write(6,'(A,i4)') "   nyl (proc 0) = ", nyl
     write(6,*) "  "
  endif

  ! Initialize data structures
  N = nxl*nyl
  Ntot = nx*ny
  call FNVInitP(comm, 4, N, Ntot, flag)
  if (flag /= MPI_SUCCESS) then
     write(0,*) "Error in FNVInitP = ", flag
     call MPI_Finalize(flag)
  end if
  allocate(y(nxl,nyl))         ! Create parallel vector for solution
  y = 0.d0                     ! Set initial conditions

  ! initialize PCG linear solver module
  call FSunPCGInit(4, PCGpretype, PCGmaxl, flag)
  if (flag /= MPI_SUCCESS) then
     write(0,*) "Error in FSunPCGInit = ", flag
     call MPI_Finalize(flag)
  end if

  ! Create the solver memory to use DIRK integrator, scalar tolerances
  call FARKMalloc(T0, y, 0, 1, rtol, atol, iout, rout, ipar, rpar, flag)
  if (flag /= MPI_SUCCESS) then
     write(0,*) "Error in FARKMalloc = ", flag
     call MPI_Finalize(flag)
  end if

  ! fill in the heat source array
  do j=1,nyl
     do i=1,nxl
        h(i,j) = sin(pi*(is+i-2)*dx) * sin(2.d0*pi*(js+j-2)*dy)
     enddo
  enddo

  ! set integrator options
  call FARKSetRin("NLCONV_COEF", nlscoef, flag)
  if (flag < 0) then
     write(0,*) "Error in FARKSetRin = ", flag
     call MPI_Finalize(flag)
  end if
  call FARKSetIin("PREDICT_METHOD", 1_8, flag)
  if (flag < 0) then
     write(0,*) "Error in FARKSetIin = ", flag
     call MPI_Finalize(flag)
  end if

  ! attach linear solver module to ARKLs interface
  call FARKLsInit(flag)
  if (flag < 0) then
     write(0,*) "Error in FARKLsInit = ", flag
     call MPI_Finalize(flag)
  end if
  call FARKLsSetPrec(1, flag)     ! Signal user-supplied preconditioner
  if (flag < 0) then
     write(0,*) "Error in FARKLsSetPrec = ", flag
     call MPI_Finalize(flag)
  end if

  ! specify that the problem is linearly implicit, but that Jacobian does not depend on time
  call FARKSetIin("LINEAR", 0_8, flag)
  if (flag < 0) then
     write(0,*) "Error in FARKSetIin = ", flag
     call MPI_Finalize(flag)
  end if

  ! Each processor outputs subdomain information
  write(outname,'(16Hheat2d_subdomain,f4.3,4H.txt)') myid/1000.0
  open(100, file=outname)
  write(100,'(6(i9,1x))') nx, ny, is, ie, js, je
  close(100)

  ! Open output streams for results, access data array
  write(outname,'(6Hheat2d,f4.3,4H.txt)') myid/1000.0
  open(101, file=outname)

  ! Output initial condition to disk
  do j=1,nyl
     do i=1,nxl
        write(101,'(es25.16)',advance='no') y(i,j)
     enddo
  enddo
  write(101,*) "  "

  ! Main time-stepping loop: calls ARKode to perform the integration, then
  ! prints results.  Stops when the final time has been reached
  t = T0
  dTout = (Tf-T0)/Nt
  tout = T0+dTout
  call PRMS(y, urms, flag)
  if (outproc) then
    write(6,*) "        t      ||u||_rms"
    write(6,*) "   ----------------------"
    write(6,'(2(2x,f10.6))') t, urms
  endif
  do ioutput=1,Nt

     call FARKode(tout, t, y, 1, flag)         ! call integrator
     if (flag < 0) then
        write(0,*) "Error in FARKode = ", flag
        exit
     end if

     call PRMS(y, urms, flag)
     if (outproc) &
          write(6,'(2(2x,f10.6))') t, urms     ! print solution stats
     if (flag >= 0) then                       ! successful solve: update output time
        tout = min(tout + dTout, Tf)
     else                                      ! unsuccessful solve: break
        if (outproc) &
             write(0,*) "Solver failure, stopping integration"
        exit
     endif

     ! output results to disk
     do j=1,nyl
        do i=1,nxl
           write(101,'(es25.16)',advance='no') y(i,j)
        enddo
     enddo
     write(101,*) "  "

  enddo
  if (outproc) then
     write(6,*) "   ----------------------"
  endif
  close(101)

  ! Print some final statistics
  if (outproc) then
     write(6,*) "  "
     write(6,*) "Final Solver Statistics:"
     write(6,'(2(A,i6),A)') "   Internal solver steps = ", iout(3), &
          " (attempted = ", iout(6), ")"
     write(6,'(A,i6,A,i6)') "   Total RHS evals:  Fe = ", iout(7), ",  Fi = ", iout(8)
     write(6,'(A,i6)') "   Total linear solver setups = ", iout(9)
     write(6,'(A,i6)') "   Total linear iterations = ", iout(23)
     write(6,'(A,i6)') "   Total number of Jacobian-vector products = ", iout(20)
     write(6,'(A,i6)') "   Total number of Preconditioner setups = ", iout(21)
     write(6,'(A,i6)') "   Total number of Preconditioner solves = ", iout(22)
     write(6,'(A,i6)') "   Total number of linear solver convergence failures = ", &
          iout(24)
     write(6,'(A,i6)') "   Total number of Newton iterations = ", iout(11)
     write(6,'(A,i6)') "   Total number of nonlinear solver convergence failures = ", &
          iout(12)
     write(6,'(A,i6)') "   Total number of error test failures = ", iout(10)
 endif

 ! Clean up and return with successful completion
 if (allocated(y))  deallocate(y)    ! free solution
 call FreeUserData(flag)             ! free user data
 call FARKFree()                     ! free integrator memory
 call MPI_Barrier(comm, flag)
 call MPI_Finalize(flag)             ! Finalize MPI

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

!-----------------------------------------------------------------
! Functions called by the solver
!-----------------------------------------------------------------

subroutine farkifun(t, y, ydot, ipar, rpar, ierr)
!-----------------------------------------------------------------
! f routine to compute the ODE RHS function f(t,y).
!-----------------------------------------------------------------
  ! declarations
  use UserData
  implicit none
  include "mpif.h"
  real(kind=REALTYPE), intent(in)  :: t, rpar
  real(kind=REALTYPE), intent(in)  :: y(nxl,nyl)
  real(kind=REALTYPE), intent(out) :: ydot(nxl,nyl)
  integer*8, intent(in) :: ipar
  real(kind=REALTYPE) :: c1, c2, c3
  integer, intent(out) :: ierr
  integer*8 :: i, j

  ! internals

  ! Initialize ydot to zero
  ydot = 0.d0

  ! Exchange boundary data with neighbors
  call Exchange(y, ierr)
  if (ierr /= MPI_SUCCESS) then
     write(0,*) "Error in Exchange = " , ierr
     return
  end if

  ! iterate over subdomain interior, computing approximation to RHS
  c1 = kx/dx/dx
  c2 = ky/dy/dy
  c3 = -2.d0*(c1 + c2)
  do j=2,nyl-1
     do i=2,nxl-1
        ydot(i,j) = c1*(y(i-1,j)+y(i+1,j)) + c2*(y(i,j-1)+y(i,j+1)) + c3*y(i,j)
     enddo
  enddo

  ! iterate over subdomain boundaries (if not at overall domain boundary)
  if (HaveNbor(1,1)) then    ! West face
     i=1
     do j=2,nyl-1
        ydot(i,j) = c1*(Wrecv(j)+y(i+1,j)) + c2*(y(i,j-1)+y(i,j+1)) + c3*y(i,j)
     enddo
  endif
  if (HaveNbor(1,2)) then    ! East face
     i=nxl
     do j=2,nyl-1
        ydot(i,j) = c1*(y(i-1,j)+Erecv(j)) + c2*(y(i,j-1)+y(i,j+1)) + c3*y(i,j)
     enddo
  endif
  if (HaveNbor(2,1)) then    ! South face
     j=1
     do i=2,nxl-1
        ydot(i,j) = c1*(y(i-1,j)+y(i+1,j)) + c2*(Srecv(i)+y(i,j+1)) + c3*y(i,j)
     enddo
  endif
  if (HaveNbor(2,2)) then    ! West face
     j=nyl
     do i=2,nxl-1
        ydot(i,j) = c1*(y(i-1,j)+y(i+1,j)) + c2*(y(i,j-1)+Nrecv(i)) + c3*y(i,j)
     enddo
  endif
  if (HaveNbor(1,1) .and. HaveNbor(2,1)) then  ! South-West corner
     i=1
     j=1
     ydot(i,j) = c1*(Wrecv(j)+y(i+1,j)) + c2*(Srecv(i)+y(i,j+1)) + c3*y(i,j)
  endif
  if (HaveNbor(1,1) .and. HaveNbor(2,2)) then  ! North-West corner
     i=1
     j=nyl
     ydot(i,j) = c1*(Wrecv(j)+y(i+1,j)) + c2*(y(i,j-1)+Nrecv(i)) + c3*y(i,j)
  endif
  if (HaveNbor(1,2) .and. HaveNbor(2,1)) then  ! South-East corner
     i=nxl
     j=1
     ydot(i,j) = c1*(y(i-1,j)+Erecv(j)) + c2*(Srecv(i)+y(i,j+1)) + c3*y(i,j)
  endif
  if (HaveNbor(1,2) .and. HaveNbor(2,2)) then  ! North-East corner
     i=nxl
     j=nyl
     ydot(i,j) = c1*(y(i-1,j)+Erecv(j)) + c2*(y(i,j-1)+Nrecv(i)) + c3*y(i,j)
  endif

  ydot = ydot + h         ! add in heat source

  ierr = 0                ! Return with success
  return
end subroutine farkifun
!-----------------------------------------------------------------

subroutine farkefun(t, y, ydot, ipar, rpar, ierr)
!-----------------------------------------------------------------
! Explicit portion of f routine (empty)
!-----------------------------------------------------------------
  ! declarations
  use UserData
  implicit none
  real(kind=REALTYPE), intent(in)  :: t, rpar
  integer*8, intent(in) :: ipar
  real(kind=REALTYPE), intent(in)  :: y(nxl,nyl)
  real(kind=REALTYPE), intent(out) :: ydot(nxl,nyl)
  integer, intent(out) :: ierr

  ! internals

  ! Initialize ydot to zero and return with success
  ydot = 0.d0
  ierr = 0
  return
end subroutine farkefun
!-----------------------------------------------------------------

subroutine farkpset(t, y, fy, jok, jcur, gamma, hcur, ipar, &
                    rpar, ierr)
!-----------------------------------------------------------------
! Preconditioner setup routine (fills inverse of Jacobian diagonal)
!-----------------------------------------------------------------
  ! declarations
  use UserData
  implicit none
  real(kind=REALTYPE), intent(in) :: t, gamma, hcur, rpar
  real(kind=REALTYPE), intent(in) :: y(nxl,nyl), fy(nxl,nyl)
  integer*8, intent(in) :: ipar
  integer, intent(in) :: jok
  integer, intent(out) :: jcur, ierr
  real(kind=REALTYPE) :: c

  ! internals
  c = 1.d0 + gamma*2.d0*(kx/dx/dx + ky/dy/dy)

  ! set all entries of d to the inverse of the diagonal values in interior
  ! (since boundary RHS is 0, set boundary diagonals to the same)
  d = 1.d0/c

  jcur = 1     ! update jcur flag
  ierr = 0     ! Return with success
  return
end subroutine farkpset

subroutine farkpsol(t, y, fy, r, z, gamma, delta, lr, &
                    ipar, rpar, ierr)
!-----------------------------------------------------------------
! Preconditioner solve routine
!-----------------------------------------------------------------
  ! declarations
  use UserData
  implicit none
  real(kind=REALTYPE), intent(in)  :: t, gamma, delta, rpar
  integer*8, intent(in) :: ipar
  real(kind=REALTYPE), intent(in)  :: y(nxl,nyl), fy(nxl,nyl), r(nxl,nyl)
  real(kind=REALTYPE), intent(out) :: z(nxl,nyl)
  integer, intent(in)  :: lr
  integer, intent(out) :: ierr

  ! internals
  z = r*d      ! perform Jacobi iteration (whole array operation)
  ierr = 0     ! Return with success
  return
end subroutine farkpsol
!-----------------------------------------------------------------


! Copyright (c) 2021, University of Colorado Denver. All rights reserved.
!
! This file is part of <T>LAPACK.
! <T>LAPACK is free software: you can redistribute it and/or modify it under
! the terms of the BSD 3-Clause license. See the accompanying LICENSE file.

module tblas
    use, intrinsic :: iso_c_binding
    use constants
    public

    include "tblas.fi"

contains

    subroutine saxpy ( n, alpha, x, incx, y, incy )
    implicit none
        integer, parameter :: wp = sp

        integer(blas_size) :: n
        integer(blas_int)  :: incx, incy
        real(wp)           :: alpha
        real(wp), target   :: x(*), y(*)

        call saxpy_( n, alpha, c_loc(x), incx, c_loc(y), incy )
    end subroutine

    subroutine daxpy ( n, alpha, x, incx, y, incy )
    implicit none
        integer, parameter :: wp = dp

        integer(blas_size) :: n
        integer(blas_int)  :: incx, incy
        real(wp)           :: alpha
        real(wp), target   :: x(*), y(*)

        call daxpy_( n, alpha, c_loc(x), incx, c_loc(y), incy )
    end subroutine

    subroutine caxpy ( n, alpha, x, incx, y, incy )
    implicit none
        integer, parameter :: wp = sp

        integer(blas_size) :: n
        integer(blas_int)  :: incx, incy
        complex(wp)           :: alpha
        complex(wp), target   :: x(*), y(*)

        call caxpy_( n, alpha, c_loc(x), incx, c_loc(y), incy )
    end subroutine

    subroutine zaxpy ( n, alpha, x, incx, y, incy )
    implicit none
        integer, parameter :: wp = dp

        integer(blas_size) :: n
        integer(blas_int)  :: incx, incy
        complex(wp)           :: alpha
        complex(wp), target   :: x(*), y(*)

        call zaxpy_( n, alpha, c_loc(x), incx, c_loc(y), incy )
    end subroutine

    subroutine ssymm ( &
        layout, side, uplo, m, n, alpha, A, lda, B, ldb, beta, C, ldc )
    implicit none
        integer, parameter :: wp = sp

        character          :: layout, side, uplo
        integer(blas_size) :: m, n, lda, ldb, ldc
        real(wp)           :: alpha, beta
        real(wp), target   :: A, B, C

        character(c_char) :: c_layout, c_side, c_uplo
        c_layout = layout
        c_side = side
        c_uplo = uplo

        call ssymm_ ( &
            c_layout, c_side, c_uplo, m, n, alpha, &
            c_loc(A), lda, c_loc(B), ldb, beta, c_loc(C), ldc )
    end subroutine

end module


!
! SPDX-License-Identifier: MIT
!
module mod_funcs
  !
  use mod_param, only: pi
  use mod_types, only: rp
  !
  implicit none
  !
  private
  public ssign,heaviside,dirac,efun,interp_d,interp_g
  !
  contains
  !
  function ssign(delta,phi)
    !
    ! smooth sign function
    !
    implicit none
    !
    real(rp), intent(in) :: delta,phi
    real(rp)             :: ssign
    !
    ssign = sign(1._rp,phi)
    if(abs(phi).le.delta) then
      ssign = phi/(sqrt(phi**2+delta**2))
    endif
    !
    return
  end function ssign
  !
  function heaviside(r,eps)
    !
    ! smooth step function based
    ! on cosine/sine
    !
    implicit none
    !
    real(rp), intent(in) :: r,eps
    real(rp)             :: heaviside
    !
    if(r.lt.-eps) then
      heaviside = 0._rp
    elseif(r.lt.eps) then
      heaviside = 0.5_rp + 0.5_rp*r/eps + 0.5_rp/pi*sin(pi*r/eps)
    else
      heaviside = 1._rp
    endif
    !
    return
  end function heaviside
  !
  function dirac(r,eps)
    !
    ! smooth impulse function
    ! (note: the derivative of heaviside function w.r.t. eps)
    !
    implicit none
    !
    real(rp), intent(in) :: r,eps
    real(rp)             :: dirac
    !
    if(abs(r).ge.eps) then
      dirac = 0._rp
    else
      dirac = 0.5_rp/eps + 0.5_rp/eps*cos(pi*r/eps)
    endif
    !
    return
  end function dirac
  !
  function efun(r,eps)
    !
    ! smooth step function based
    ! on the error function
    !
    implicit none
    !
    real(rp), intent(in) :: r,eps
    real(rp)             :: efun
    !
    efun = 0.5_rp*( 1._rp+erf(r/eps) )
    !
    return
  end function efun
  !
  function dir_efun(r,eps)
    !
    ! smooth impulse function based
    ! on the error function
    ! (note: the derivative of error function w.r.t. eps)
    !
    implicit none
    !
    real(rp), intent(in) :: r,eps
    real(rp)             :: dir_efun
    !
    dir_efun = (1._rp/(eps*pi))*exp(-(r/eps)**2._rp)
    !
    return
  end function dir_efun
  !
  function interp_d(vec,vel,q) result(flux) ! divergence form
    !
    ! QUICK discretization (by Leonard) in divergence form
    ! (see, e.g.: Numerical simulation of incompressible flows, pag. 112)
    !
    implicit none
    !
    real(rp), intent(in), dimension(-2:2) :: vec
    real(rp), intent(in) :: vel ! the transporting velocity (in d(uu)/dx is u, in d(uv)/dy is v)
    integer , intent(in) :: q   ! (q=-1 if f_i, q=0 if f_i+1 with f is the flux)
    !
    real(rp) :: flux
    !
    !flux = 0.5_rp*vel*(vec(0+q)+vec(1+q)) + 0.5_rp*abs(vel)*(+vec(0+q)-vec(1+q))
    !
    flux =      0.0625_rp*(vel)*(-vec(-1+q)+9.0_rp*vec(0+q)+9.0_rp*vec(1+q)-vec(2+q)) &
           + 0.0625_rp*abs(vel)*(-vec(-1+q)+3.0_rp*vec(0+q)-3.0_rp*vec(1+q)+vec(2+q))
    !
    return
  end function interp_d
  !
  function interp_g(vec,vel,dli) result(vel_grad) ! gradient form
    !
    ! II order (Kawamura and Kuwahara equation) discretization in gradient form
    ! (see, e.g.: Numerical simulation of incompressible flows, pag. 113)
    !
    implicit none
    !
    real(rp), intent(in), dimension(-2:2) :: vec
    real(rp), intent(in)                  :: vel ! the transporting velocity (in ud(f)/dx is u, in vd(f)/dy is v)
    real(rp), intent(in)                  :: dli
    !
    real(rp) :: vel_grad
    !
    !vel_grad = 0.5_rp*(vel+abs(vel))*(vec(0)-vec(-1))*dli + 0.5_rp*(vel-abs(vel))*(vec(1)-vec(0))*dli
    !
    vel_grad =             (vel)*(vec(-2)-8.0_rp*vec(-1)               +8.0_rp*vec(+1)-vec(+2))*(1.0_rp/12.0_rp)*dli &
               + 3.0_rp*abs(vel)*(vec(-2)-4.0_rp*vec(-1)+6.0_rp*vec(+0)-4.0_rp*vec(+1)+vec(+2))*(1.0_rp/12.0_rp)*dli
    !
    return
  end function interp_g
  !
end module mod_funcs


program reg_beta
use statistical
implicit none
integer,parameter :: rs=8
real(rs) :: z,a,b
character(len=80) :: arg

if (command_argument_count() /= 3) then
   write(*,'(a)') 'Usage: reg_beta [z] [a] [b]'
   stop
endif

call get_command_argument(1,arg) ; read(arg,*) z
call get_command_argument(2,arg) ; read(arg,*) a
call get_command_argument(3,arg) ; read(arg,*) b

write(*,*) reg_beta_func(z,a,b)

end program