module commondata
    implicit none

    integer, parameter :: total_nx = 65, total_ny = 65, total_nz = 65
    integer :: nx, ny, nz
    real(8), parameter :: Reynolds=1000.0d0
    real(8), parameter :: rho0=1.0d0
    real(8), parameter :: U0=0.1d0
    real(8), parameter :: tauf=U0*dble(total_nx)/Reynolds*3.0d0+0.5d0

    integer :: itc
    integer, parameter :: itc_max=INT(50000000)

    real(8) :: errorU
    real(8), parameter :: eps=1e-6

    real(8) :: xp(0:total_nx+1), yp(0:total_ny+1), zp(0:total_nz+1)
    real(8), allocatable :: u(:, :, :), v(:, :, :), w(:, :, :)
    real(8), allocatable :: rho(:, :, :)
    real(8), allocatable :: up(:, :, :), vp(:, :, :), wp(:, :, :)

    real(8), allocatable :: f(:, :, :, :), f_post(:, :, :, :)

    integer :: idx
    ! real(8), parameter :: omega(0:18) = (/ 1.0d0/3.0d0, &
    !         1.0d0/18.0d0, 1.0d0/18.0d0, 1.0d0/18.0d0, 1.0d0/18.0d0, 1.0d0/18.0d0, 1.0d0/18.0d0, &
    !         1.0d0/36.0d0, 1.0d0/36.0d0, 1.0d0/36.0d0, 1.0d0/36.0d0, 1.0d0/36.0d0, 1.0d0/36.0d0, &
    !         1.0d0/36.0d0, 1.0d0/36.0d0, 1.0d0/36.0d0, 1.0d0/36.0d0, 1.0d0/36.0d0, 1.0d0/36.0d0 /)
    real(8), parameter :: omega(0:18) = (/ 1.0d0/3.0d0, &
                                        (1.0d0/18.0d0, idx = 1, 6), &
                                        (1.0d0/36.0d0, idx = 7, 18) /)
    integer, parameter :: ex(0:18) = (/ 0,  &
                                        1, -1,  0,  0,  0,  0, &
                                        1, -1,  1, -1,  1, -1,  1, -1,  0,  0,  0,  0 /)
    integer, parameter :: ey(0:18) = (/ 0, &
                                        0,  0,  1, -1,  0,  0, &
                                        1,  1, -1, -1,  0,  0,  0,  0,  1, -1,  1, -1 /)
    integer, parameter :: ez(0:18) = (/ 0, &
                                        0,  0,  0,  0,  1, -1, &
                                        0,  0,  0,  0,  1,  1, -1, -1,  1,  1, -1, -1 /)

    real(8), parameter :: Snu=1.0d0/tauf, Sq=8.0d0*(2.0d0*tauf-1.0d0)/(8.0d0*tauf-1.0d0)

    ! mpi data
    integer :: rc, rank, num_process
    integer :: dims(0:2) = (/ 0, 0, 0 /), coords(0:2)
    logical :: periods(0:2) = (/ .false., .false., .false. /)
    integer :: comm3d, rank3d
    integer :: nbr_surface(1:6)
    integer :: nbr_line(7:18)
    integer :: surface_x, surface_y, surface_z  ! surface data perpendicular to axis x, y, z
    integer :: line_x, line_y, line_z       ! line data parallel to axis x, y, z

end module commondata


c     program DRDMPVAL
c     Demonstrates DMPDRV, DMPINT, and DMPVAL.
c>> 1997-05-29 DRDMPVAL Krogh Special code for C conversion.
c>> 1996-05-28 DRDMPVAL Krogh Added external statement.
c>> 1994-10-19 DRDMPVAL Krogh  Changes to use M77CON
c>> 1993-02-04 DRDMPVAL CLL
c>> 1987-12-09 DRDMPVAL Lawson  Initial Code.
c     ------------------------------------------------------------------
c--D replaces "?": DR?MPVAL, ?MPDRV, ?MPINT, ?MPVAL
c     ------------------------------------------------------------------
c++ Code for .C. is inactive
c%%   long int n;
c++ End
      integer NQ, NR
      external DMPVAL
      double precision     P(6),Q(7),R(6),Z,DMPVAL
      data     P/ 5.D0, 2.D0, 4.D0, -4.D0, 12.D0, 16.D0 /
c     ------------------------------------------------------------------
      call DMPINT(P, 3,Q,NQ)
      call DMPDRV(Q,NQ,R,NR)
      Z = DMPVAL(Q,NQ,6.D0) - DMPVAL(Q,NQ,4.D0)
c++ Code for ~.C. is active
      print '(21x,''P ='',2f4.0,2x,4f7.2/)', P
      print '('' INTEGRAL OF P.      Q ='',2f4.0,2x,5f7.2/)', Q
      print '('' DERIVATIVE OF Q.    R ='',2f4.0,2x,4f7.2/)', R
      print '('' DEFINITE INTEGRAL.  Z ='',f20.8)', Z
c++ Code for .C. is inactive
c%%   printf( "                     P =%4.0f%4.0f", p[0], p[1] );
c%%   for(n=2L; n < (long)(sizeof(p)/sizeof(p[1])); n++)
c%%           printf( "%7.2f", p[n] );
c%%   printf( "\n" );
c%%   printf( " INTEGRAL OF P.      Q =%4.0f%4.0f", q[0], q[1] );
c%%   for(n=2L; n < (long)(sizeof(q)/sizeof(q[1])); n++)
c%%           printf( "%7.2f", q[n] );
c%%   printf( "\n" );
c%%   printf( " DERIVATIVE OF Q.    R =%4.0f%4.0f", r[0], r[1] );
c%%   for(n=2L; n < (long)(sizeof(r)/sizeof(r[1])); n++)
c%%           printf( "%7.2f", r[n] );
c%%   printf( "\n" );
c%%   printf( " DEFINITE INTEGRAL.  Z =%20.8f\n", z );
c++ End
      stop
      end


program main
    use mpi
    implicit none
    integer :: ntasks, rank, ierr
    integer, allocatable :: status(:)
    integer, parameter :: n = 500
    integer :: i, j, k
    real(8), parameter :: pi = acos(-1.d0)
    real(8), parameter :: phi_l = 0.d0, phi_u = 2 * pi, rho_l = 0.d0, rho_u = 3.d0, z_l = -3.d0, z_u = 3.d0
    real(8), parameter :: d_phi = (phi_u - phi_l) / dble(n), d_rho = (rho_u - rho_l) / dble(n), d_z = (z_u - z_l) / dble(n)
    real(8) :: phi, rho, z, f, H
    real(8) :: integral_local = 0.d0, integral
    real :: start, finish, time

    ! initialize the MPI environment
    call MPI_INIT(ierr)
    call MPI_COMM_SIZE(MPI_COMM_WORLD, ntasks, ierr)
    call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)
    allocate(status(MPI_STATUS_SIZE))

    call CPU_TIME(start)

    phi = phi_l - d_phi / dble(2)
    do i = 1, n
        phi = phi + d_phi
        rho = rho_l - d_rho + d_rho / dble(ntasks) / dble(2) + d_rho / dble(ntasks) * dble(rank)
        do j = 1, n
            rho = rho + d_rho
            z = z_l - d_z / dble(2)
            do k = 1, n
                z = z + d_z
                call func(phi, rho, z, f)
                call inArea(phi, rho, z, H)
                integral_local = integral_local + f * H
            end do
        end do
    end do

    call MPI_REDUCE(integral_local, integral, 1, MPI_REAL8, MPI_SUM, 0, MPI_COMM_WORLD, ierr)

    if (rank == 0) then
        integral = (phi_u - phi_l) * (rho_u - rho_l) * (z_u - z_l) / dble(ntasks) / dble(n**3) * integral
        write(*,'(f10.5)') integral
    end if

    call CPU_TIME(finish)
    call MPI_REDUCE(finish - start, time, 1, MPI_REAL, MPI_SUM, 0, MPI_COMM_WORLD, ierr)
    if (rank == 0) then
        write(*,'(f10.5)') time
    end if

    call MPI_FINALIZE(ierr)
end program main

subroutine func(phi, rho, z, f)
    ! the function to be integrated
    implicit none
    real(8), intent(in) :: phi, rho, z
    real(8), intent(out) :: f

    f = rho**3
end subroutine func

subroutine inArea(phi, rho, z, H)
    ! judge whether the dot is in the integral area
    real(8), intent(in) :: phi, rho, z
    real(8), intent(out) :: H

    if ((z > -sqrt(9.d0 - rho**2)) .and. (z < sqrt(9.d0 - rho**2))) then
        H = 1.d0
    else
        H = 0.d0
    end if
end subroutine inArea


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   Example 3: The A->B->C chemical reaction
!----------------------------------------------------------------------
!----------------------------------------------------------------------
!
!----------------------------------------------------------------------

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

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

   DOUBLE PRECISION x1,x2,x3,d,alpha,beta,b,s,e,x1c

   x1 = U(1)
   x2 = U(2)
   x3 = U(3)

   d = PAR(1)
   alpha = PAR(2)
   beta = PAR(3)
   b = PAR(4)
   s = PAR(5)

   e = dexp(X3)
   x1c = 1 - X1

   F(1) = -x1 + d*x1c*e
   F(2) = -x2 + d*e*(x1c - s*x2)
   F(3) = -x3 - beta*x3 + d*b*e*(x1c + alpha*s*x2)

   IF(IJAC.EQ.0)RETURN

   DFDU(1,1) = -1.D0 - d*e
   DFDU(1,2) = 0.D0
   DFDU(1,3) = d*x1c*e

   DFDU(2,1) = -d*e
   DFDU(2,2) = -1.D0 - d*e*s
   DFDU(2,3) = d*e*(x1c - s*x2)

   DFDU(3,1) = -d*b*e
   DFDU(3,2) = d*b*e*alpha*s
   DFDU(3,3) = -1.D0 - beta + d*b*e*(x1c + alpha*s*x2)

   IF(IJAC.EQ.1)RETURN

   DFDP(1,1) = x1c*e
   DFDP(1,2) = 0.D0
   DFDP(1,3) = 0.D0
   DFDP(1,4) = 0.D0
   DFDP(1,5) = 0.D0
   DFDP(2,1) = e*(x1c - s*x2)
   DFDP(2,2) = 0.D0
   DFDP(2,3) = 0.D0
   DFDP(2,4) = 0.D0
   DFDP(2,5) = -d*e*x2
   DFDP(3,1) = b*e*(x1c + alpha*s*x2)
   DFDP(3,2) = d*b*e*s*x2
   DFDP(3,3) = -x3
   DFDP(3,4) = d*e*(x1c + alpha*s*x2)
   DFDP(3,5) = d*b*e*alpha*x2

 END SUBROUTINE FUNC

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

   IMPLICIT NONE
   INTEGER, INTENT(IN) :: NDIM
   DOUBLE PRECISION, INTENT(IN) :: T
   DOUBLE PRECISION, INTENT(OUT) :: U(NDIM), PAR(*)

   PAR(1:5)=(/0.0,1.0,1.55,8.,0.04/)

   U(1:3)=0.

 END SUBROUTINE STPNT

 SUBROUTINE BCND
 END SUBROUTINE BCND

 SUBROUTINE ICND
 END SUBROUTINE ICND

 SUBROUTINE FOPT
 END SUBROUTINE FOPT

 SUBROUTINE PVLS
 END SUBROUTINE PVLS


subroutine compute_percentile(arr_unsorted,length,percentile,p_percentile)
use nrtype;use dimensions;use grids
implicit none
integer,intent(in)::length,percentile
real(SP),intent(in)::arr_unsorted(length)
real(SP),intent(out)::p_percentile
real(SP)::arr(length)
interface
    function kernel_d(u)
    use nrtype
    implicit none
    real(SP)::kernel_d
    real(SP)::u
    end function
end interface

arr=arr_unsorted
call sort(arr,length)
p_percentile=arr(int(real(length)*real(percentile)/100.0_sp))

end subroutine

subroutine compute_pdf(arr_unsorted,length,point,density_p)
    use nrtype;use dimensions;use grids
    implicit none
    integer,intent(in)::length
    real(SP),intent(in)::arr_unsorted(length),point
    real(SP),intent(out)::density_p
    real(SP)::arr(length)
    real(SP)::h_i(length),pdf_i(length)
    real(SP),dimension(nkk)::x
    real(SP)::h,std
    integer::x_l,x_l2
    character::pause_k
    interface
        function kernel_d(u)
        use nrtype
        implicit none
        real(SP)::kernel_d
        real(SP)::u
        end function
    end interface

    arr=arr_unsorted
    call sort(arr,length)

    !Optimal bandwidth
    std=sum((arr-sum(arr)/dble(length))**2)/(dble(length)-1)
    if (arr(int(real(length)/4.0_sp*3.0_sp))-arr(int(real(length)/4.0_sp))>0.0_sp) then
        h=0.9_sp*real(length)**(-1.0_sp/5.0_sp)*min(std,1.34_sp*(arr(int(real(length)/4.0_sp*3.0_sp))-arr(int(real(length)/4.0_sp))))
    else
        h=0.9_sp*real(length)**(-1.0_sp/5.0_sp)*std
    end if
    do x_l=1,length
        pdf_i(x_l)=0.0_sp
        do x_l2=1,length
            pdf_i(x_l)=pdf_i(x_l)+kernel_d((arr(x_l)-arr(x_l2))/h)
        end do
        pdf_i(x_l)=pdf_i(x_l)/real(length)/h
    end do
    !Variable bandwidth following Silverman
    h_i=log(pdf_i)-1.0/dble(length)*sum(log(pdf_i))
    h_i=exp(-0.5_sp*h_i)*h !sensitivity parameter
    density_p=0.0_sp
    do x_l2=1,length
        density_p=density_p+1.0_sp/h_i(x_l2)*kernel_d((point-arr(x_l2))/h_i(x_l2))  !sum(exp(-((x(x_l)-arr)/h_i)**2.0_sp/2.0_sp)/sqrt(2.0_sp*PI)/h_i)/real(length)
    end do
    density_p=density_p/real(length)

    if (isnan(density_p)) then
        print*,'error in compute_pdf'
        print*,point
        print*,arr
        read*,pause_k
    end if

end subroutine

function kernel_d(u)
    use nrtype
    implicit none
    real(SP)::kernel_d
    real(SP)::u

    !Epanechnikov
    if (abs(u)<=1.0_sp) then
        kernel_d=3.0_sp/4.0_sp*(1.0_sp-u**2.0_sp)
    else
        kernel_d=0.0_sp
    end if
    !Gaussian Kernel
    !kernel_d=1.0_sp/sqrt(2*pi)*exp(-0.5_sp*u**2)

end function


module initial_mod

  use real_type_mod
  use parameters_mod
  use variables_mod
  use conversion_mod

  implicit none

contains

  subroutine initial(x, n_up)

    real(kind=wp), dimension(1-gz:np+gz), intent(out) :: x
    real(kind=wp), dimension(NF, NV, 1-gz:np+gz), intent(out) :: n_up

    real(kind=wp) :: n, v, w
    real(kind=wp) :: pi = 4.d0 * atan(1.d0)

    integer :: i, f

    do i = 1-gz, np+gz
      x(i) = (dble(i) - 0.5_wp) * dx + xmin

!!$      Primitive variables; simple trig functions for now
!!$      This is essentially random - something more useful should be found

      do f = 1, NF

        select case (perturbation_type)

          case ('trig')

            n = initial_n(f) * (1.0_wp + &
                 initial_ptbn_n(f) * sin( pi * initial_period_n(f) * &
                                          (x(i) - initial_phase_n(f)) ) )
            v = initial_v(f) + &
                 initial_ptbn_v(f) * sin( pi * initial_period_v(f) * &
                                          (x(i) - initial_phase_v(f)) )

          case ('gaussian')

            n = initial_n(f) * (1.0_wp + &
                 initial_ptbn_n(f) * &
                 exp(-(x(i) - 0.5_wp * (xmin + xmax))**2 / 0.05_wp**2) )
            v = initial_v(f) + initial_ptbn_v(f) * &
                 exp(-(x(i) - 0.5_wp * (xmin + xmax))**2 / 0.15_wp**2)

          case ('doublegaussian')

            n = initial_n(f) * (1.0_wp + &
                 initial_ptbn_n(f) * &
                 exp(-(x(i) - &
                     1.0_wp / 3.0_wp * (xmin + xmax))**2 / 0.075_wp**2) + &
                 initial_ptbn_n(f) * &
                 exp(-(x(i) -  &
                     2.0_wp / 3.0_wp * (xmin + xmax))**2 / 0.075_wp**2) )
            v = initial_v(f) + initial_ptbn_v(f) * &
                 exp(-(x(i) - &
                     1.0_wp / 3.0_wp * (xmin + xmax))**2 / 0.075_wp**2) + &
                initial_ptbn_v(f) * &
                 exp(-(x(i) -  &
                     2.0_wp / 3.0_wp * (xmin + xmax))**2 / 0.075_wp**2)

          case default

            write(*,*) &
                 'Parameter ''perturbation_type'' takes an unknown value ', &
                 perturbation_type
            stop

        end select

        w = 1.0_wp / sqrt(1.0_wp - v**2)

        n_up(f, 1, i) = n * w
        n_up(f, 2, i) = n * w * v

      end do

    end do

  end subroutine initial

end module initial_mod


	FUNCTION PS_BVPD  ( datain, nparm, clev, ivcord )
C************************************************************************
C* PS_BVPD								*
C*									*
C* This function computes the Brunt-Vaisala Period.			*
C*									*
C* REAL PS_BVPD  ( DATAIN, NPARM, CLEV, IVCORD )			*
C*									*
C* Input parameters:							*
C*	DATAIN		REAL		Station data			*
C*	NPARM		INTEGER		Number of data set parameters	*
C*	CLEV		REAL		Vertical level			*
C*	IVCORD		INTEGER 	Vertical coordinate number	*
C*									*
C* Output parameters:							*
C*	PS_BVPD		REAL		Brunt-Vaisala Period		*
C**									*
C* Log:									*
C* K. Brill /NMC	 7/90						*
C* T. Lee/GSC		 8/97	Changed default depth to RMISSD 	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		stndb (10), stndt (10), stndl (10)
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------------
	PS_BVPD = RMISSD
C
C*	Get depth information.
C
	dfdpth = RMISSD
	idfcrd = 3
	CALL PC_DPTH  ( datain, nparm, clev, ivcord, dfdpth, idfcrd, 1,
     +			depth, idcord, stndl, stndb, stndt, ier )
C
C*	Check for missing data.
C
	IF  ( ( ier .ne. 0 ) .or. ERMISS ( stndt (1) ) .or.
     +		ERMISS ( stndb (1) ) .or. ERMISS ( stndt (2) ) .or.
     +		ERMISS ( stndb (2) ) .or. ERMISS ( stndt (6) ) .or.
     +		ERMISS ( stndb (6) ) )  RETURN
	depth = stndt (6) - stndb (6)
	IF  ( depth .eq. 0.0 )  RETURN
C*
	thtop = PR_THTA ( stndt (2), stndt (1) )
	thbot = PR_THTA ( stndb (2), stndb (1) )
        theta = .5 * ( thtop + thbot )
        bvfsqd = ( GRAVTY / theta ) * ( thtop - thbot ) / depth
	IF ( bvfsqd .le. 0.0 ) RETURN
C*
	PS_BVPD = 2. * PI / SQRT ( bvfsqd )
C*
	RETURN
	END


!##############################################################################
!# Tutorial 005a: Basic math
!##############################################################################

module tutorial005a

  ! Include basic Feat-2 modules
  use fsystem
  use genoutput
  use mprimitives

  implicit none
  private

  public :: start_tutorial005a

contains

  ! ***************************************************************************

  subroutine start_tutorial005a

    ! Declare some variables
    real(DP) :: dval1, dval2, dval3
    real(DP), dimension(4) :: Dcoeff

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 005a")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Kronecker Symbol
    ! =================================

    call output_line ("kronecker(3,5) = " // trim(sys_siL(mprim_kronecker(3,5),10)) )
    call output_line ("kronecker(5,5) = " // trim(sys_siL(mprim_kronecker(5,5),10)) )

    ! =================================
    ! Signum
    ! =================================

    call output_line ("signum(-5) = " // trim(sys_siL(mprim_signum(-5_I32),10)) )
    call output_line ("signum( 0) = " // trim(sys_siL(mprim_signum( 0_I32),10)) )
    call output_line ("signum( 2) = " // trim(sys_siL(mprim_signum( 2_I32),10)) )

    ! =================================
    ! Linear rescaling
    ! =================================

    ! Linear interpolation of [0,1] to [5,7]
    call mprim_linearRescale(0.00_DP,0.0_DP,1.0_DP,5.0_DP,7.0_DP,dval1)
    call mprim_linearRescale(0.25_DP,0.0_DP,1.0_DP,5.0_DP,7.0_DP,dval2)
    call mprim_linearRescale(1.00_DP,0.0_DP,1.0_DP,5.0_DP,7.0_DP,dval3)

    call output_line ("linrescale(0.00,[0,1],[5,7]) = " // trim(sys_sdL(dval1,10)) )
    call output_line ("linrescale(0.25,[0,1],[5,7]) = " // trim(sys_sdL(dval2,10)) )
    call output_line ("linrescale(1.00,[0,1],[5,7]) = " // trim(sys_sdL(dval3,10)) )

    ! =================================
    ! Quadratic interpolation
    ! =================================

    ! Quadratic interpolation, i.e. evaluate a quadratic
    ! polynomial p with p(-1)=2, p(0)=0, p(1)=2
    call mprim_quadraticInterpolation (-1.0_DP,2.0_DP,0.0_DP,2.0_DP,dval1)
    call mprim_quadraticInterpolation ( 0.0_DP,2.0_DP,0.0_DP,2.0_DP,dval2)
    call mprim_quadraticInterpolation ( 0.5_DP,2.0_DP,0.0_DP,2.0_DP,dval3)

    call output_line ("quadinterpol(-1.0,[2,0,2]) = " // trim(sys_sdL(dval1,10)) )
    call output_line ("quadinterpol( 0.0,[2,0,2]) = " // trim(sys_sdL(dval2,10)) )
    call output_line ("quadinterpol( 0.5,[2,0,2]) = " // trim(sys_sdL(dval3,10)) )

    ! =================================
    ! Parabolic profile
    ! =================================

    ! This is a quadratic polynomial p with p(0)=p(len)=0, p(mid)=max.
    dval1 = mprim_getParabolicProfile (0.5_DP,2.0_DP,10.0_DP)
    dval2 = mprim_getParabolicProfile (1.0_DP,2.0_DP,10.0_DP)
    dval3 = mprim_getParabolicProfile (1.5_DP,2.0_DP,10.0_DP)

    call output_line ("parprofile(0.5,len=2,max=10) = " // trim(sys_sdL(dval1,10)) )
    call output_line ("parprofile(1.0,len=2,max=10) = " // trim(sys_sdL(dval2,10)) )
    call output_line ("parprofile(1.5,len=2,max=10) = " // trim(sys_sdL(dval3,10)) )

    ! =================================
    ! Conversion of polar coordinates
    ! in cartesian coordinates
    ! =================================

    call mprim_polarToCartesian(0.5_DP,0.0_DP,dval1,dval2)
    call output_line ("polar(0.5,0.0    )  = " // trim(sys_sdL(dval1,10)) // "," &
                                               // trim(sys_sdL(dval2,10)))

    call mprim_polarToCartesian(0.5_DP,0.25_DP*SYS_PI,dval1,dval2)
    call output_line ("polar(0.5,0.25 Pi)  = " // trim(sys_sdL(dval1,10)) // "," &
                                               // trim(sys_sdL(dval2,10)))

    call mprim_polarToCartesian(0.5_DP,-0.75*SYS_PI,dval1,dval2)
    call output_line ("polar(0.5,-0.75 Pi) = " // trim(sys_sdL(dval1,10)) // "," &
                                               // trim(sys_sdL(dval2,10)))

    ! =================================
    ! Conversion of cartesian coordinates
    ! in polar coordinates
    ! =================================

    call mprim_cartesianToPolar(0.5_DP,0.0_DP,dval1,dval2)
    call output_line ("cartesian(0.5,0.0)         = " // trim(sys_sdL(dval1,10)) // "," &
                                                      // trim(sys_sdL(dval2,10)))

    call mprim_cartesianToPolar(0.25_DP*sqrt(2.0_DP),0.25_DP*sqrt(2.0_DP),dval1,dval2)
    call output_line ("cartesian(0.3535,0.3535)   = " // trim(sys_sdL(dval1,10)) // "," &
                                                      // trim(sys_sdL(dval2,10)))

    call mprim_cartesianToPolar(-0.25_DP*sqrt(2.0_DP),-0.25_DP*sqrt(2.0_DP),dval1,dval2)
    call output_line ("cartesian(-0.3535,-0.3535) = " // trim(sys_sdL(dval1,10)) // "," &
                                                      // trim(sys_sdL(dval2,10)))

    ! =================================
    ! Horner scheme
    ! =================================

    ! Initialise a cubic polynomial: p(x,y) = x^3 - 2x^2 - 3*x + 4
    Dcoeff(:) = (/ 4.0_DP, 3.0_DP, -2.0_DP, 1.0_DP /)

    ! Get the function value as well as 1st and 2nd derivative in x=2.
    dval1 = mprim_horner   (2.0_DP,Dcoeff)
    dval2 = mprim_hornerd1 (2.0_DP,Dcoeff)
    dval3 = mprim_hornerd2 (2.0_DP,Dcoeff)

    call output_line ("p  (2.0) = " // trim(sys_sdL(dval1,10)) )
    call output_line ("p' (2.0) = " // trim(sys_sdL(dval2,10)) )
    call output_line ("p''(2.0) = " // trim(sys_sdL(dval3,10)) )

  end subroutine

end module


program test
use iso_fortran_env, only: real64, real32
!use f95_precision
use blas95
use lapack95
implicit none
integer, parameter :: n = 1000, pr = real64
real(pr)           :: a(n,n), b(n,n), c(n,n)
real(pr)           :: x(n), sigma
integer            :: i, j, info, ipiv(n)

! construct a symmetric positive definite matrix
call random_number(x)
x = n*x
sigma = 1.0
do i = 1, n
   a(i,i) = 1.0
end do
do i = 1, n-1
   do j = i+1, n
      a(i,j) = exp( -(x(i)-x(j))**2/(2*sigma**2) )
      a(j,i) = a(i,j)
   end do
end do

! b is going to be inverse of a
b = a

! use lapack for inversion
call getrf(b,ipiv,info)
if( info/=0 ) call sysexit('LU decompositions not successful')
call getri(b,ipiv,info)
if( info/=0 ) call sysexit('Inversion not successful')

! c = I
!c = matmul( a, b )
call gemm( a, b, c )

! check if c = I
do i = 1, n
   c(i,i) = c(i,i) - 1.0
end do
write(*,*) 'residual:', sum( c**2 )/n**2

contains

        subroutine show_matrix(a)
        implicit none
        real a(:,:)
        integer i
        do i = 1, size(a,1)
           write(*,*) ( a(i,j), j=1,size(a,2) )
        end do
        end subroutine

        subroutine sysexit(input)
        class(*), intent(in) :: input
        select type(input)
        type is (character(len=*))
                print*, input
        end select
        stop
        end subroutine

end program


program main
  use timers
  type(TimerType) :: seriesTime,monteTime,totalTime

  integer npoints,nthreads,maxthreads,i,ierr
  parameter (npoints=300000,maxthreads=16)
  complex*16 c(npoints)
  real*8 r1,r2,halfpi,err1,area,err2
  real rand
  integer numinside,lnuminside(maxthreads)
  integer omp_get_num_threads
  external monte
  external omp_set_num_threads,omp_get_num_threads

  call TimerCreate(seriesTime,"series")
  call TimerCreate(monteTime,"monte")
  call TimerCreate(totalTime,"Series+monte")

! GENERATE RANDOM NUMBERS

  call srand(54321)
  do i=1,npoints
     r1=rand()
     r2=rand()
     c(i)=CMPLX(-2.0+2.5*r1,1.125*r2)
  end do

  call TimerOn(totalTime)

!  CALCULATE PI/2 FROM GREGORY'S FORMULA

  call TimerOn(seriesTime)
  call series(halfpi,err1)
  call TimerOff(seriesTime)

!  CALCULATE AREA OF MANDELBROT SET BY MONTE CARLO SAMPLING

  call TimerOn(monteTime)
!  INVOKE monte in parallel

!$omp parallel

!  GET NUMBER OF THREADS BEING USED
  nthreads = omp_get_num_threads()

  call monte(c,lnuminside)
!$omp end parallel

!  SUM UP CONTRIBUTIONS FROM EACH THREAD
  numinside = 0
  do i=1,nthreads
     numinside = numinside + lnuminside(i)
  end do

  call TimerOff(monteTime)
  call TimerOff(totalTime)

!  OUTPUT RESULTS

  area = 2.0*2.5*1.125 * real(numinside)/real(npoints)
  err2 = area/sqrt(real(npoints))
  print *, "Pi/2 = ", halfpi," +/- ",err1
  print *, "Area of Mandelbrot set = ",area," +/- ",err2

!  OUTPUT TIMING DATA

  call TimerPrint(seriesTime)
  call TimerPrint(monteTime)
  call TimerPrint(totalTime)

  stop
end program main

subroutine series(halfpi,err)

  real*8 halfpi,err,sum
  integer sign,terms,denom,i
  parameter (terms = 100000000)

  sum=0.0d0
  sign=1
  denom=1

  do i=1,terms
     sum=sum + sign*(1.0d0/denom)
     sign=(-sign)
     denom=denom + 2
  end do

  halfpi = 2.0d0 * sum
  err = 2.0d0/terms
  return
end subroutine series

subroutine monte(c,lnuminside)

  integer npoints,maxiter,i,j,num,slice,myid,ilo,ihi
  integer nthreads,maxthreads
  parameter (npoints=300000,maxiter=10000,maxthreads=16)
  complex*16 c(npoints),z
  integer lnuminside(maxthreads)
  integer omp_get_num_threads,omp_get_thread_num
  external omp_get_num_threads,omp_get_thread_num

  nthreads = omp_get_num_threads()
  slice = (npoints+nthreads-1)/nthreads
  myid =  omp_get_thread_num()
  ilo = slice * myid + 1
  ihi = min(npoints,(myid+1)*slice)

  num=0
  do i=ilo,ihi
     z=(0.0,0.0)
     do j=1,maxiter
        z = z*z +c(i)
        if (abs(z).gt.2.0) goto 10
     end do
     num = num +1
10   continue
  end do

  lnuminside(myid+1) = num

  return
end subroutine monte


!
! The Great Computer Language Shootout
! http://shootout.alioth.debian.org/
!
! Contributed by Sebastien Loisel
!
! OVERVIEW: In this test, we solve an ordinary differential equation
!    u'=f(t,u)
! using the Trapezoid numerical method, which can be written as
!    (u[k+1]-u[k])=(f(t[k],u[k])+f(t[k]+dt,u[k+1]))*dt/2,
! where t[k], u[k], dt and the function f are known and u[k+1] is the
! unknown.
!
! Since u[k+1] appears on both sides of the equation, we use an iterative
! solver called the newton iteration to compute u[k+1]. The newton iteration
! computes the solution to
!    h(x)=0
! where h is a known function and x is the unknown 0 of h, using the method
!    x[k+1]=x[k]-f(x[k])/f'(x[k]).
! Here, f' denotes the derivative of f.
!
! This version uses the traditional central-difference approximation to f'
!
! Summary of classes:
!
! fl -- low precision floating point type
! mycomplex -- complex numbers whose real and imaginary parts can be fl
! trapezoid_method_rooter -- implements the function that the trapezoid method
!                            must solve

program implicitode
  use function_params
  implicit none

  real*8, external  :: mysqrt, rat, simple
  real*8            :: res
  type(fdata)       :: gparams
  type(fdata)       :: tparams
  character(len=33) :: str
  real*8            :: x, dt, y0, r, u_t0, t1, t0
  integer           :: i,n,ns
  character(len=8)  :: argv

  call getarg(1,argv)
  if (len(trim(argv)) == 0) then
     n = 50
  else
     read(argv,*) n
  end if
  x = rat(0.25d0)
  res = D(rat,0.25d0)
  write(*,'(2(a,es27.20e2))') 'rational_taylor_series: ',x,' ',res

  gparams%a = 2.0d0
  x = newton(mysqrt,gparams,1.0d0,10)
  write(*,'(2(a,es27.20e2))') 'newton-sqrt_2:',x
  x = newton(rat,gparams,-1.0d0,6)
  res = rat(x)
  write(*,'(a,es27.20e2)') 'newton-rat: ',x
  !
  ! Simple case that enables easy verification of the trapezoidal implementation:
  !
  !              u' = 1/(2u) with u(1) = 2
  !
  !           => u = sqrt(t+3)
  !
  ! so the test is to ensure u(6) = 3
  !
  t0 = 1.0d0            ! Initial value of the parameter
  u_t0 = 2.0d0          ! Value of u at t0: u(1) = 2
  t1 = 6.0d0            ! Final (target) value of parameter t
  dt = (t1 - t0)/n      ! Parameter step size
  call trapezoidal(simple,gparams,t0,dt,u_t0,n,r)
  write(*,'(a,es27.20e2)') 'u(6) = ',r
  call rk4(simple,gparams,t0,dt,u_t0,n,r)
  write(*,'(a,es27.20e2)') 'u(6) = ',r

  x = 1.0d0
  dt = 0.02d0
  y0 = 1.0d0/(4*n)
!  call integrate_functions(x,dt,y0,4*n)

contains

  subroutine integrate_functions(t0,dt,y0,n)
    real*8, intent(in)  :: t0
    real*8, intent(in)  :: dt
    real*8, intent(in)  :: y0
    integer, intent(in) :: n
    call trapezoidal(mysqrt,gparams,x,dt,y0,n,r)
    print *, 'trap 1: ',r
    call rk4(mysqrt,gparams,x,dt,y0,n,r)
    print *, 'rk4 1: ',r
    call trapezoidal(rat,gparams,x,dt,y0,n,r)
    print *, 'i2: ',r
  end subroutine integrate_functions

  subroutine trapezoidal(g,gparams,t0,dt,y0,numsteps,r)
    real*8, external      :: g
    type(fdata), intent(in)         :: gparams
    real*8, intent(in)    :: t0
    real*8, intent(in)    :: dt
    real*8, intent(in)    :: y0
    integer, intent(in)             :: numsteps
    real*8, intent(inout) :: r

    real*8                :: y, y1
    integer                         :: i, j
    real*8                :: t1
    !    (u[k+1]-u[k])=(f(t[k],u[k])+f(t[k]+dt,u[k+1]))*dt/2,
    y = y0
    do i=1,numsteps
       t1 = t0 + i*dt
       y1 = y
       do j=1,10
          y1 = y1 - ((g(y,gparams) + g(y1,gparams))*(dt/2.0d0) + y - y1)/(D(g,y1,gparams)*(dt/2.0d0) - 1.0d0)
       end do
       y = y1
    end do
    r = y
  end subroutine trapezoidal

  subroutine rk4(g,gparams,t0,dt,y0,numsteps,r)
    real*8, external      :: g
    type(fdata), intent(in)         :: gparams
    real*8, intent(in)    :: t0
    real*8, intent(in)    :: dt
    real*8, intent(in)    :: y0
    integer, intent(in)             :: numsteps
    real*8, intent(inout) :: r

    real*8                :: y, y1
    integer                         :: i, j
    real*8                :: t1
    real*8                :: k1, k2, k3, k4
    !
    ! u[k+1] = u[k] + k1/6 + k2/3 + k3/3 + k4/6
    !
    ! k1 = h*f(t[n]    ,u[k])
    !
    ! k2 = h*f(t[n]+h/2,u[n]+k1/2)
    !
    ! k3 = h*f(t[n]+h/2,u[n]+k2/2)
    !
    ! k4 = h*f(t[n]+h  ,u[n]+k3)
    !
    y = y0
    do i=1,numsteps
       t1 = t0 + i*dt
       k1 = dt*g(y,gparams)
       k2 = dt*g(y+0.5d0*k1,gparams)
       k3 = dt*g(y+0.5d0*k2,gparams)
       k4 = dt*g(y,k3,gparams)
       y1 = y + (k1 + 2*k2 + 2*k3 + k4)/6
       y = y1
    end do
    r = y

  end subroutine rk4

  subroutine irk4(g,gparams,t0,dt,y0,numsteps,r)
    ! Hammer-Hollingsworth
    real*8, external        :: g
    type(fdata), intent(in) :: gparams
    real*8, intent(in)      :: t0
    real*8, intent(in)      :: dt
    real*8, intent(in)      :: y0
    integer, intent(in)     :: numsteps
    real*8, intent(inout)   :: r

    real*8                  :: y, y1
    integer                 :: i, j
    real*8                  :: t1
    real*8                  :: k1, k2, k3, k4, c1, c2, b1, b2
    real*8, dimension(2,2)  :: A
    real*8, dimension(2)    :: b, c, k, ks
    !
    ! u[k+1] = u[k] + h * _b_ . _k_
    !
    ! k[i] = f(t0+c[i]*h, y0 + A[i]*_k_)
    !
    c = (/ (3-sqrt(3.0d0))/6 , (3+sqrt(3.0d0))/6 /)
    b = (/0.5d0 , 0.5d0/)
    A = reshape((/0.25d0,0.25d0-sqrt(3.0d0)/6,0.25d0+sqrt(3.0d0)/6,0.25d0/),(/2,2/))
    y = y0
    do i=1,numsteps
       t1 = t0 + i*dt
       do j=1,10

       end do
       y1 = y + dt*dot_product(b,k)
       y = y1
    end do
    r = y

  end subroutine irk4

  real*8 function newton(g,params,x,n)
    real*8, external                  :: g
    real*8, intent(in)                :: x
    type(fdata), optional, intent(in) :: params
    integer, optional, intent(in)     :: n
    integer :: i
    if (present(n)) then
       ns = n
    else
       ns = 10
    end if
    newton = x
    do i=1,ns
       newton = newton - g(newton,params)/D(g,newton,params)
    end do
  end function newton

  real*8 function D(g,x,params,step)
    ! Calculate the central-difference approximation to g'(x)
    real*8, external                  :: g
    real*8, intent(in)                :: x
    type(fdata), intent(in), optional :: params
    real*8, intent(in), optional      :: step
    real*8, parameter                 :: fstep = 1.0d-6
    real*8                            :: lstep
    if (present(step)) then
       lstep = step
    else
       lstep = fstep
    end if
    D = (g(x+0.5d0*lstep,params) -  g(x-0.5d0*lstep,params))/lstep
  end function D

end program implicitode

real*8 function rat(x, params)
  use function_params

  real*8, intent(in) :: x
  type(fdata), intent(in), optional :: params

  rat = (1 + 2*x + 3*x**2 + 7*x**6 + 5*x**11) / (2 + 5*x - 6*x**3 - 3*x**7)

end function rat

real*8 function mysqrt(x, params)
  use function_params

  real*8, intent(in)    :: x
  type(fdata), intent(in), optional :: params
  mysqrt = x*x - params%a
end function mysqrt

real*8 function simple(x, params)
  use function_params

  real*8, intent(in)    :: x
  type(fdata), intent(in), optional :: params

  simple = 0.5d0/x
end function simple


program main
    use plantfem
    implicit none

    type(Random_) :: random
    type(IO_) :: f,z
    integer(int32) :: i, n, nn,count
    real(real64) :: g_n, g_nn, period, period_list(1000)
    real(real64),allocatable :: histogram(:,:)

    ! get random wave & zero crossing
    call f%open("random_wave.csv")

    g_n = -1.0d0
    g_nn= 0.0d0
    n = 0
    nn = 0
    period = 0.0d0
    count=0
    period_list(:) = 0.0d0
    do i=1,1000
        g_nn = random%Gauss(mu=0.0d0, sigma=1.0d0)
        !g_nn = random%ChiSquared(k=1.0d0)

        if( g_n*g_nn < 0.0d0 )then
            count=count+1
            nn = i
            period = dble(nn) - dble(n)
            period_list(count) = period
            n = nn
            g_n = g_nn
        endif

        call f%write( trim(str(dble(i))) //", "//str(g_nn) )

    enddo
    call f%close()

    ! get histogram
    histogram =  random%histogram(list=period_list,division=20)
    call z%open("zero_cross.csv")

    do i=1,size(histogram,1)
        write(z%fh,*) histogram(i,1),histogram(i,2)
    enddo

    call z%close()

end program main


program reductions

    implicit none
    real(kind=4), dimension(10) :: v
    integer                     :: i

    do i = 1, size(v)
        v(i) = size(v) + 1 - i
    end do

    write(*,*) "shape of original v: ", shape(v);
    write(*,*) "original v = ", v
    v = reshape((/1,2,3,4,5,6,7,8,9,10/), (/10/))
    write(*,*) "shape of v reshaped: ", shape(v);
    write(*,*) "v reshaped = ", v

    ! all, any, count
    print *, all(v > 5)
    print *, all(v > 5, 1)
    print *, any(v > 50)
    print *, any(v > 50, 1)
    print *, count(v > 5)
    print *, count(v > 5, 1)

    ! maxval, minval
    print *, maxval(v)
    print *, maxval(v, 1)
    print *, maxval(v, v > 5)
    print *, maxval(v, 1, v > 5)
    print *, minval(v)
    print *, minval(v, 1)
    print *, minval(v, v > 5)
    print *, minval(v, 1, v > 5)

    ! product, sum
    print *, product(v)
    print *, product(v, 1)
    print *, product(v, v > 5)
    print *, product(v, 1, v > 5)
    print *, sum(v)
    print *, sum(v, 1)
    print *, sum(v, v > 5)
    print *, sum(v, 1, v > 5)

end program reductions


program ch1006
    ! Reading Using Array Sections
    implicit none

    integer, parameter :: nrow = 5
    integer, parameter :: ncol = 6
    real, dimension(1:nrow,1:ncol) :: exam_results = 0.
    real, dimension(1:nrow) :: people_average = 0.
    real, dimension(1:ncol) :: subject_average = 0.
    integer :: r, c

    open(100,file='ch1006.txt',status='old')
    do r = 1, nrow
        read(100,100) exam_results(r, 1:ncol)
        people_average(r) = sum(exam_results(r,1:ncol))
    end do
    close(100)

    people_average = people_average/ncol
    do c = 1, ncol
        subject_average(c) = sum(exam_results(1:nrow,c))
    end do
    subject_average = subject_average/nrow
    do r = 1, nrow
        print 110, (exam_results(r,c),c=1,ncol), people_average(r)
    end do
    print *, '  ====  ====  ====  ====  ====  ===='
    print 120, subject_average(1:ncol)

100 format(1x,6(1x,f5.1))
110 format(1x,6(1x,f5.1),'  = ',f6.2)
120 format(1x,6(1x,f5.1))
end program


!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

! Even Fibonacci numbers
!
! Each new term in the Fibonacci sequence is generated by adding the previous
! two terms. By starting with 1 and 2, the first 10 terms will be:
!                1, 2, 3, 5, 8, 13, 21, 34, 55, 89, ...
! By considering the terms in the Fibonacci sequence whose values do not exceed
! four million, find the sum of the even-valued terms.
module MPEProblem2

    implicit none
    private

    type, public :: TPEProblem2
    contains
        procedure, nopass :: present
    end type
contains
    subroutine present
        write (*, '(A)') 'Problem 2. Even Fibonacci numbers.'

        write (*, '(A, I)') 'Even 1: ', even1()
        write (*, '(A, I)') 'Even 2: ', even2()
    end subroutine

    ! A direct translation of the problem statement
    function even1()
        integer even1
        integer prev
        integer cur
        integer temp

        ! initial values
        even1 = 0
        prev  = 1
        cur   = 1
        temp  = 0

        do while (cur <= 4000000)
            if (mod(cur, 2) .eq. 0) then
                even1 = even1 + cur
            end if

            temp = cur
            cur  = cur + prev
            prev = temp
        end do
    end function

    ! only every third number is added
    function even2()
        integer even2
        integer prev
        integer cur
        integer temp

        ! initial values
        even2 = 0
        prev  = 1
        cur   = 1
        temp  = prev + cur

        do while (temp < 4000000)
            even2 = even2 + temp
            prev  = cur   + temp
            cur   = temp  + prev
            temp  = prev  + cur
        end do
    end function
end module


module RPAdielectric
  use utils, only : dp, pi
  implicit none
  private
  public FDD, redielectric, imdielectric, elf

contains

  function FDD(E, a, b, g_in)
    ! Fermi-Dirac Distriution function.
    real(dp), intent(in) :: E, a, b
    real(dp), intent(in), optional :: g_in ! density of states
    real(dp) :: FDD, maxarg, g

    if (present(g_in)) then
       g = g_in
    else
       g = 1
    end if

    maxarg = 300. ! Upper cutoff for exponential function
    FDD = g/(1+exp(min((E-a)/b, maxarg)))
  end function FDD

  function reintegrand(p, k, w, kbT, mu, singulartol)
    ! The integrand in the integral to calculate the real part of the dielectric
    ! function. Assuming p, k, w are positive.
    !
    ! Parameters:
    ! ___________
    ! p: scalar
    !   The integration variable, which is also the momemtum of the electronic
    !   state.
    ! k: scalar
    !   The change of momentum for an incident photon with momentum k0
    !   scattering to a state with momentum k1: k = |k1-k0|, in a.u.
    ! w: scalar
    !   The change of energy for an incident photon with energy w0
    !   scattering to a state with energy w1: w = w0-w1, in a.u.
    ! kbT: scalar
    !   Thermal energy (kb - Boltzmann's constant, T is temperature) in a.u.
    ! mu: scalar
    !   Chemical potential in a.u.
    ! singulartol: scalar
    !   tolerance to handle singularities, where the arguments in the
    !   logarithms become 0.

    real(dp), intent(in) :: p, k, w, mu, kbT, singulartol
    real(dp) :: logpart, reintegrand, logtol, a, b, c, d, p1, p2

    logtol = 1e-3

    a = k**2 + 2*p*k + 2*w
    b = k**2 - 2*p*k + 2*w
    c = k**2 + 2*p*k - 2*w
    d = k**2 - 2*p*k - 2*w

    p1 = k**2 / (2*p*k + 2*w)
    p2 = k**2 / (2*p*k - 2*w)

    ! low "x" approximation for log(1+x)
    if (abs(p2) < logtol) then ! p1 < p2
       logpart = 2*p1 + 2*p2
    else
       ! tol avoids the singularities
       logpart = 0.5 * log((a**2 + singulartol)/(d**2 + singulartol)) &
            + 0.5*log((c**2 + singulartol)/(b**2 + singulartol))
       ! ! Equivalent expression
       ! logpart = log(abs(1+p1)) - log(abs(1-p1)) &
       !           + log(abs(1+p2)) - log(abs(1-p2))

    end if

    reintegrand = FDD(p**2/2, mu, kbT)*p*logpart

  end function reintegrand

  function redielectric(k, w, kbT, mu, usertol, printmssg_in) result(er)
    ! Returns the real part of the RPA dielectric function.
    ! Integrates reintegrand while avoiding the singularities.
    !
    ! Parameters:
    ! ___________
    ! usertol: scalar
    !   A user set tolerance used to decide if an approximation of the
    !   integral is okay. This is to make sure our treatment of the singular
    !   points is fine.

    real(dp), intent(in) :: k, w, mu, kbT
    real(dp), intent(in), optional :: usertol
    logical, optional  :: printmssg_in ! Print warning message if .true.
    real(dp) :: xmax, x, dx, er, er2, tol, singular_tol, error
    integer  :: i, imax, loopcount
    logical :: printmssg

    if (present(usertol)) then
       tol = usertol
    else
       tol = 1e-4
    end if

    if (.not. present(printmssg_in)) then
       printmssg = .false.
    else
       printmssg = .true.
       end if

    singular_tol = 1e-6 ! singularity tolerance

    xmax = sqrt(2*(mu + 20*kbT)) ! 1/exp(20) \approx 1e-9
    imax = 2000
    dx = xmax/imax

    ! integrate
    er = 0.0
    do i=1,imax
       x = i*dx
       er = er + reintegrand(x, k, w, kbT, mu, singular_tol)*dx
    end do
    er2 = er ! treat er2 as a temporary place holder
    er = er2 + tol + 1 ! Need to get into do-while loop

    ! integrate at least twice to make sure our treatment of singularities is
    ! satisfactory.
    error = abs(er - er2)/er
    loopcount = 0
    do while ((er /= 0) .and. (error > tol)) ! Just a while loop
       ! Don't get stuck in a loop forever.
       if (loopcount >= 10) then
          ! We failed. Go home!
          if (printmssg) then
             print *, "RPAdielectric: Convergence failed due to singularities in ",&
                  "redielectric(): "
             print "(a, e9.4, a, e9.4, a, e9.2)", "k = ", k, "; w = ", w,&
                  "; confidence in result: ", error
          end if
          ! Return our best guess
          er = 1 + 2 / pi / k**3 * er2
          return
       end if
       loopcount = loopcount + 1

       er = er2 ! Hold previous er2 value
       er2 = 0.
       ! Try a smaller number for the singularities
       singular_tol = singular_tol/10

       do i=1,imax
          x = i*dx
          er2 = er2 + reintegrand(x, k, w, kbT, mu, singular_tol)*dx
       end do
       error = abs(er - er2)/er
    end do

    er = 1 + 2 / pi / k**3 * er2

  end function redielectric

  function imdielectric(k, w, kbT, mu) result(ei)
    ! Returns the imaginary part of the RPA dielectric.

    real(dp), intent(in) :: k, w, mu, kbT
    real(dp) :: ei, a, b

    a=abs(2*w-k**2)/2./k
    b=abs(2*w+k**2)/2./k
    ei=2 * kbT/k**3 * log(FDD(mu, b**2/2, kbT)/FDD(mu, a**2/2, kbT))
  end function imdielectric

  function elf(k, w, kbT, mu, printmssg)
    real(dp), intent(in) :: k, w, mu, kbT
    logical, intent(in), optional :: printmssg
    real(dp) :: elf, er, ei

    ! I'm surprised passing an optional arg unchecked worked (for now)...
    er = redielectric(k, w, kbT, mu, printmssg_in=printmssg)
    ei = imdielectric(k, w, kbT, mu)
    elf = ei / (ei**2 + er**2)
  end function elf

end module RPAdielectric


! Simplified calling sequence for blas matrix multiplication ZGEMM on square matrices.
! Computes R = c * A*B where A,B matrices and c is a scaler.
! Arguments
!   A   (input) Complex*16, dimension(NxN) - Matrix A
!   B   (input) Complex*16, dimension(NxN) - Matrix B
!   c   (input) Complex*16 - scaler c
!   R   (output) Complex*16 - Matrix R = c*A*B

subroutine ZMM(A,B,c,R)
    implicit none
    complex(dp), intent(in)    :: A(:,:), B(:,:), c
    complex(dp), intent(out)   :: R(:,:)
    integer :: n
    n = size(A,1)
    ! For Details http://www.math.utah.edu/software/lapack/lapack-blas/zgemm.html
    call ZGEMM('N','N',n,n,n,c,A,n,B,n,0.0_dp,R,n)
end subroutine ZMM


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Logical function INSIDE: Returns TRUE if point is inside or on boundary of a
C    polygon with N corners.  Returns FALSE otherwise.
C
C The method is to trace a ray from the POINT in the positive x direction
C (ie, a horizontal ray to the right), and count the number of intersections
C with the edge.  If the point is inside the polygon, it will have an odd
C number of intersections; if it is outside, the number of intersections
C will be even.  Special handling is necessary for the case where the ray
C touches a vertex, but does not cross the polygon boundary.  This does
C not count as an intersection.
C
      LOGICAL FUNCTION INSIDE(POINT,CORNER,N)
      IMPLICIT NONE
      INTEGER N		!Number of vertices in the polygon
      REAL POINT(2)	! (x,y) coordinates of the given point
      REAL CORNER(2,N)	! (x,y) coordinates of the N vertices of the polygon

C POINT and CORNER may be given as (x,y), (LINE,SAMPLE), or (SAMPLE,LINE)
C as long the usage is consistent between POINT and CORNER.

      INTEGER I,I2,NUM
      REAL X,Y,X0,X1,X2,Y1,Y2
      REAL XMIN,YMIN,XMAX,YMAX

      INSIDE = .TRUE.
      NUM = 0
      X = POINT(1)
      Y = POINT(2)

      DO 50 I=1,N		!Loop through each edge of polygon
      I2 = MOD(I,N) + 1
      X1 = CORNER(1,I)		!First vertex is (X1,Y1)
      Y1 = CORNER(2,I)
      X2 = CORNER(1,I2)		!Second vertex is (X2,Y2)
      Y2 = CORNER(2,I2)

C     ...Eliminate obvious cases where ray would never intersect edge
      YMIN = MIN(Y1,Y2)
      YMAX = MAX(Y1,Y2)
      IF (Y.LT.YMIN .OR. Y.GT.YMAX) GOTO 50
      XMIN = MIN(X1,X2)
      XMAX = MAX(X1,X2)
      IF (X.GT.XMAX) GOTO 50

C     ...Horizontal edges are ignored unless the point is on it
      IF (Y1 .EQ. Y2) THEN
         IF (X.GE.XMIN) RETURN		!Point is on this edge
         GOTO 50
      ENDIF

C     ...Check if ray passes through a vertex
      IF (Y.EQ.YMIN) THEN		!Ignore YMAX case to avoid dble-counting
         X0 = X1			!Find the X associated with YMIN
         IF (Y2.LT.Y1) X0=X2
         IF (X.LT.X0) THEN		!Ray passes through vertex
            NUM = NUM + 1
            GOTO 50
         ENDIF
      ENDIF

C     ...Normal case: Y is between Y1 and Y2
      X0 = (Y-Y2)*(X2-X1)/(Y2-Y1) + X2	!compute intersection
      IF (X.EQ.X0) RETURN		!Point is on this edge
      IF (Y.EQ.Y1 .OR. Y.EQ.Y2) GOTO 50	!Skip to avoid double-counting
      IF (X.LT.X0) NUM=NUM+1		!Ray intersects edge
   50 CONTINUE

      INSIDE = MOD(NUM,2) .NE. 0
      RETURN
      END


C$PROCEDURE       MMAB
      SUBROUTINE MMAB (A,B,N,M,L,C,NN,MM,LL)
C$    PURPOSE
C    SUBROUTINE MMAB AND ITS ENTRY POINTS MMABT AND MMATB
C    PERFORM MATRIX MULTIPLICATION BETWEEN MATRICES A AND B
C    IN THREE DIFFERENT WAYS:
C     1) MMAB COMPUTES C = A*B
C     2) MMABT COMPUTES C1 = A*(B Transpose)
C     3) MMATB COMPUTES C2 = (A Transpose)*B
C$     INPUT_ARGUMENTS
C     CALLING SEQUENCE ARGUMENTS FOR MMAB --
C
C    NAME       DESCRIPTION
C
C    A          DP MATRIX PREMULTIPLIED ON DP MATRIX B
C
C    B          DP MATRIX POSTMULTIPLIED ON DP MATRIX A
C
C    L          NUMBER OF COLUMNS IN OUTPUT MATRIX C AND FROM B
C
C    LL         ROW DIMENSION OF PRODUCT MATRIX C
C
C    M          NUMBER OF COLUMNS OF A AND ROWS OF B IN
C               MATRIX PRODUCT
C
C    MM         ROW DIMENSION OF MATRIX B
C
C    N          NUMBER OF ROWS OF A IN MATRIX PRODUCT AND
C               IN OUTPUT MATRIX C
C
C    NN         ROW DIMENSION OF MATRIX A
C
C     CALLING SEQUENCE ARGUMENTS FOR MMABT --
C
C    A          DP MATRIX POSTMULTIPLIED BY B TRANSPOSE
C
C    B          DP MATRIX WHOSE TRANSPOSE IS PREMULTIPLIED BY A
C
C    L          NUMBER OF ROWS IN OUTPUT MATRIX AND FROM A
C
C    LL         SAME AS FOR MMAB
C
C    M          NUMBER OF COLUMNS OF MATRICES A AND B IN PRODUCT
C
C    MM         SAME AS FOR MMAB
C
C    N          NUMBER OF COLUMNS IN OUTPUT MATRIX AND ROWS FROM B
C
C    NN         SAME AS FOR MMAB
C
C     CALLING SEQUENCE ARGUMENTS FOR MMATB --
C
C    A          DP MATRIX WHOSE TRANSPOSE IS POSTMULTIPLIED BY B
C
C    B          DP MATRIX WHICH IS PREMULTIPLIED BY A TRANSPOSE
C
C    L          NUMBER OF COLUMNS IN OUTPUT MATRIX AND FROM B
C
C    LL         SAME AS FOR MMAB
C
C    M          NUMBER OF ROWS FROM BOTH MATRICES A AND B IN PRODUCT
C
C    MM         SAME AS FOR MMAB
C
C    N          NUMBER OF ROWS IN OUTPUT MATRIX AND COLUMNS FROM A
C
C    NN         SAME AS FOR MMAB
C$    OUTPUT_ARGUMENTS
C     CALLING SEQUENCE ARGUMENTS --
C
C    NAME       DESCRIPTION
C
C    C          OUTPUT MATRIX FROM MMAB
C
C    C1         OUTPUT MATRIX FROM ENTRY POINT MMABT
C
C    C2         OUTPUT MATRIX FROM ENTRY POINT MMATB
C-&
      DOUBLE PRECISION A(NN,1),B(MM,1),C(LL,1)
      DOUBLE PRECISION C1(LL,1),C2(LL,1)
C$     METHOD
C-&
C1    SEE PURPOSE AND ARGUMENT DESCRIPTIONS. MATRIX MULTIPLICATIONS ARE
C1    PERFORMED THROUGH THE STANDARD NESTED DO LOOP APPROACH.
C
C     A(N,M)  B(M,L)  C(N,L)
C
C     MULTIPLY TWO MATRICES, A*B, PLACE PRODUCT IN C
C     A - FIRST INPUT MATRIX
C     B - SECOND INPUT MATRIX
C     C - PRODUCT MATRIX A*B
C
C     NN- ROW DIMENSION OF A MATRIX
C     MM- ROW DIMENSION OF B MATRIX
C     LL- ROW DIMENSION OF C MATRIX
C
C     N - NUMBER OF ROWS OF A, ROWS OF C
C     M - NUMBER OF COLS OF A, ROWS OF B
C     L - NUMBER OF COLS OF B, COLS OF C
C
      DO 100 I=1,N
      DO 100 J=1,L
      C(I,J)=0.D0
      DO 100 K=1,M
  100 C(I,J)=C(I,J)+A(I,K)*B(K,J)
      RETURN
      ENTRY MMABT(A,B,L,M,N,C1,NN,MM,LL)
C
C             B(N,M)
C     A(L,M) BT(M,N)  C(L,N)
C
C     FORM PRODUCT A POSTMULTIPLIED BY TRANSPOSE OF B
C     A - FIRST INPUT MATRIX
C     B - SECOND INPUT MATRIX
C     C - PRODUCT MATIRX A*BT
C
C     L - NUMBER OF ROWS OF C
C     M - NUMBER OF COLS OF A, COLS OF B
C     N - NUMBER OF ROWS OF B, COLS OF C
C
      DO 200 I=1,L
      DO 200 J=1,N
      C1(I,J)=0.D0
      DO 200 K=1,M
  200 C1(I,J)=C1(I,J)+A(I,K)*B(J,K)
      RETURN
      ENTRY MMATB(A,B,M,N,L,C2,NN,MM,LL)
C
C      A(M,N)
C     AT(N,M)  B(M,L)  C(N,L)
C
C     FORM PRODUCT A-TRANSPOSE POSTMULTIPLIED BY B, PRODUCT IN C
C
C     A - FIRST  INPUT MATRIX
C     B - SECOND INPUT MATRIX
C     C - PRODUCT MATRIX AT*B
C
C
C     M - NUMBER OF ROWS OF A, ROWS OF B
C     N - NUMBER OF COLS OF A, ROWS OF C
C     L - NUMBER OF COLS OF B,COLS OF C
C
      DO 300 I=1,N
      DO 300 J=1,L
      C2(I,J)=0.D0
      DO 300 K=1,M
  300 C2(I,J)=C2(I,J)+A(K,I)*B(K,J)
      RETURN
      END


FUNCTION rtbis_s(func,x1,x2,xacc)
  USE mo_kind, only: sp, i4
  USE mo_nrutil, ONLY : nrerror
  IMPLICIT NONE
  REAL(SP), INTENT(IN) :: x1,x2,xacc
  REAL(SP) :: rtbis_s
  INTERFACE
     FUNCTION func(x)
       USE mo_kind
       IMPLICIT NONE
       REAL(SP), INTENT(IN) :: x
       REAL(SP) :: func
     END FUNCTION func
  END INTERFACE
  INTEGER(I4), PARAMETER :: MAXIT=40
  INTEGER(I4) :: j
  REAL(SP) :: dx,f,fmid,xmid
  fmid=func(x2)
  f=func(x1)
  if (f*fmid >= 0.0_sp) call nrerror('rtbis_s: root must be bracketed')
  if (f < 0.0_sp) then
     rtbis_s=x1
     dx=x2-x1
  else
     rtbis_s=x2
     dx=x1-x2
  end if
  do j=1,MAXIT
     dx=dx*0.5_sp
     xmid=rtbis_s+dx
     fmid=func(xmid)
     if (fmid <= 0.0_sp) rtbis_s=xmid
     if (abs(dx) < xacc .or. fmid == 0.0_sp) RETURN
  end do
  call nrerror('rtbis_s: too many bisections')
END FUNCTION rtbis_s

FUNCTION rtbis_d(func,x1,x2,xacc)
  USE mo_kind, only: dp, i4
  USE mo_nrutil, ONLY : nrerror
  IMPLICIT NONE
  REAL(DP), INTENT(IN) :: x1,x2,xacc
  REAL(DP) :: rtbis_d
  INTERFACE
     FUNCTION func(x)
       USE mo_kind
       IMPLICIT NONE
       REAL(DP), INTENT(IN) :: x
       REAL(DP) :: func
     END FUNCTION func
  END INTERFACE
  INTEGER(I4), PARAMETER :: MAXIT=40
  INTEGER(I4) :: j
  REAL(DP) :: dx,f,fmid,xmid
  fmid=func(x2)
  f=func(x1)
  if (f*fmid >= 0.0_dp) call nrerror('rtbis_d: root must be bracketed')
  if (f < 0.0_dp) then
     rtbis_d=x1
     dx=x2-x1
  else
     rtbis_d=x2
     dx=x1-x2
  end if
  do j=1, MAXIT
     dx=dx*0.5_dp
     xmid=rtbis_d+dx
     fmid=func(xmid)
     if (fmid <= 0.0_dp) rtbis_d=xmid
     if (abs(dx) < xacc .or. fmid == 0.0_dp) RETURN
  end do
  call nrerror('rtbis_d: too many bisections')
END FUNCTION rtbis_d


      SUBROUTINE CIROVA( RAD1, RAD2, DCEN, AREA, PI)
      IMPLICIT NONE
C ********************************************************************
C *                                                                  *
C * This software is an unpublished work containing confidential and *
C * proprietary information of Birkbeck College. Use, disclosure,    *
C * reproduction and transfer of this work without the express       *
C * written consent of Birkbeck College are prohibited. This notice  *
C * must be attached to all copies or extracts of the software.      *
C *                                                                  *
C * (c) 1996 Oliver Smart & Birkbeck College, All rights reserved    *
C *                                                                  *
C ********************************************************************

C this s/r calculates the overlap area of two circles radius RAD1
C and RAD2. Their centres are distance DCEN apart.
C The result is returned as AREA.

C passed variables *********************

C see opening comment - leave all unchanged expect area on return
      DOUBLE PRECISION			RAD1, RAD2, DCEN, AREA

C constant PI
      DOUBLE PRECISION			PI

C internal vbles ***********************

C two distances, two angles
      DOUBLE PRECISION			B, C, ALPHA, BETA

C end of decs **************************

C possibilities
C (a) no overlap
      IF (DCEN.GT.(RAD1+RAD2)) THEN
        AREA = 0.

C (b) circle 2 is completly within circle 1
      ELSEIF ((DCEN+RAD2).LE.RAD1) THEN
        AREA = PI*(RAD2**2)

C (c) circle 1 is completly within circle 2
      ELSEIF ((DCEN+RAD1).LE.RAD2) THEN
        AREA = PI*(RAD1**2)

C (d) a partial overlap has occured
      ELSE
C formulae on j100 lab-book
        B = (RAD2**2 + DCEN**2 - RAD1**2)/(2.*DCEN)
        ALPHA  = ACOS((DCEN-B)/RAD1)
        BETA   = ACOS(B/RAD2)
        C = RAD2*SIN(BETA)
        AREA = ALPHA*(RAD1**2) + BETA*(RAD2**2) - DCEN*C
      ENDIF

C return here
      RETURN
      END


      module MOD_WMOM0_F
      contains
      SUBROUTINE WMOM0_F (ND,NP,R,p,WLK)
C***  The Following Modul computes the Integration Weights for the
C***  calculation of the 0-order Moment in COMPXJ

C***  INTEGRATION OF THE ZERO-MOMENT OF THE RADIATION FIELD (MEAN INTENSITY)
C***  THE INTEGRATION WEIGHTS ARE GENERATED (ARRAY WLK)
C***  RADIUS-MESH R and P-mesh ARE GIVEN
C***  WEIGHTS ARE ACCORDING TO TRAPEZOIDAL RULE IN Z=SQRT(R*R-P*P)
      implicit real*8(a-h,o-z)

c-old      DIMENSION R(ND),Z(ND,NP),WLK(ND,NP)
      DIMENSION R(ND),p(NP),WLK(ND,NP)
      DO L=1,ND
        DO JP=1,NP
          WLK(L,JP)=0.0
        ENDDO
      ENDDO
      DO L=1,ND
        JMAX=NP-(L-1)
        RL2=2.*R(L)
        rr =r(l)*r(l)
C***  FIRST STEP
c-old        ZJ=Z(L,1)
c-old        ZNEXT=Z(L,2)
        zj    = sqrt(rr - p(1)*p(1) )
        znext = sqrt(rr - p(2)*p(2) )
        WLK(L,1)=(ZJ-ZNEXT)/RL2
C***  MIDDLE STEPS
        DO 1 J=3,JMAX
        ZLAST=ZJ
        ZJ=ZNEXT
c-old        ZNEXT=Z(L,J)
        znext = sqrt(rr-p(j)*p(j))
        WLK(L,J-1)=(ZLAST-ZNEXT)/RL2
    1   CONTINUE
C***  LAST STEP, IMPLYING Z(L,JMAX)=.0
    2   WLK(L,JMAX)=ZJ/RL2
    3   CONTINUE
      ENDDO

      RETURN
      END subroutine
      end module


\ Double Number Arithmetic by Wil Baden, tweaked by Brad Eckert
\
\ TUM* TUM/ triple Unsigned Mixed Multiply and Divide.
\
\ T+ T- triple Add and Subtract.
\
\ DU/MOD Double Unsigned Division with Remainder.  Given an unsigned 2-
\ cell dividend and an unsigned 2-cell divisor,  return a 2-cell
\ remainder and a 2-cell quotient.  The algorithm is based on Knuth's
\ algorithm in volume 2 of his Art of Computer Programming, simplified
\ for two-cell dividend and two-cell divisor.

there
applets [if] .(     Applet bytes: { )   \ }
paged applet  paged [then]

: +carry  ( a b -- a+b carry )          \ 0 tuck d+
   +c carry                             \ speeds up t
;
: -borrow ( a b -- a-b borrow )         \ 0 tuck d-
   swap invert +c invert carry negate   \ speeds up t-
;

: tum* ( n . mpr -- t . . ) 2>r  r@ um*  0 2r>  um* d+ ;
: tum/ ( t . . dvr -- n . ) dup >r um/mod r> swap >r um/mod nip r> ;

: t+  ( t1 . . t2 . . -- t3 . . )
   >r rot >r  >r swap >r +carry  0 r> r> +carry d+ r> r> + +
;
: t-  ( t1 . . t2 . . -- t3 . . )
   >r rot >r  >r swap >r -borrow  s>d r> r> -borrow d+ r> r> - +
;

: normalize-divisor  ( divr . -- divr' . shift )
   0 >r  begin  dup 0< 0=  while
      d2*  r> 1+ >r
   repeat  r> ;

: du/mod ( divd . divr . -- rem . quot . )
   4 stack(
   ?dup 0= if  ( there is a leading zero "digit" in divisor. )
      >r  0 r@ um/mod  r> swap >r  um/mod  0 swap r>  )stack exit
   then  normalize-divisor dup >r rot rot 2>r
   1 swap lshift tum*
   ( guess leading "digit" of quotient. )
   dup  r@ = if  -1  else  2dup  r@ um/mod nip  then
   ( multiply divisor by trial quot and subtract from divd. )
   2r@  rot dup >r  tum*  t-
   dup 0< if ( if negative, decrement quot and add to dividend. )
      r> 1-  2r@  rot >r  0 t+
      dup 0< if ( if still negative, do it one more time. )
         r> 1-  2r@  rot >r  0 t+
   then  then ( undo normalization of dividend to get remainder. )
   r>  2r> 2drop  1 r>  rot >r  lshift tum/  r> 0  )stack
;

\ Ratio search, based on the Farey sequence, by Brad Eckert
\
\ Given an unsigned double number `frac` between 0 and 1 scaled to
\ 2^(2*cellsize) = 1, find two integers that fit into a specified bit
\ width and most closely approximate `frac` using unsigned integer
\ division.
\
\ For vast majority of cases, a very accurate fraction can be found.
\ Less than 0.1% of the time, there is significant error.
\ If you can work around these cases, it's a good way to get very
\ precise scale factors.

2variable ratio_x1                      \ a c
2variable ratio_x2                      \ b d
2variable expected                      \ unsigned 0 to 1
variable maxden                         \ maximum allowed denominator

: dfrac  ( num denom -- d_frac )        \ (num << (2*b/cell)) / den
   >r >r 0 dup r> r> tum/
;
: exhausted?  ( -- flag )               \ finished with search?
   ratio_x2 2@  maxden @ u<  swap maxden @ u<  and 0=
;
: /ratio  ( maxden -- )                 \ initialize
   maxden !
   0 1 ratio_x1 2!
   1 1 ratio_x2 2!
;
: ratio/  ( flag -- n d )
   0=  cell and                         \ true returns c d
   dup>r ratio_x1 + @  ratio_x2 r> + @  \ false returns a b
;

\ Find the (num, den) pair that best satisfies frac = num / den.
\ `bits` is the width of the num and den results.
\ Don't search for anything very close to 0, it will take forever.

: ratio  ( d_frac maxden -- num den )
   3 stack(
   /ratio  expected 2!
   begin
      ratio_x1 2@ +  ratio_x2 2@ +  2dup dfrac    \ a+c b+d d_actual
      2dup expected 2@ d= if            \ exact match
         2drop  dup
         maxden @ u< if exit then       \ a+c b+d
         2drop  ratio_x2 2@ u< ratio/  exit
      then
      expected 2@ du<  cell and
      dup>r ratio_x2 + !  r> ratio_x1 + !
   exhausted? until
   ratio_x2 @ maxden @ u<  ratio/
   )stack
;

\ For 24-bit cells and 20-bit results, you can usually get to within
\ 0.01 PPB on the approximation of d_frac. The error of the compound
\ number (a + b/c) would be less by a factor of a.
\
\ Examples on a 24-bit machine:
\ 100000000005000. 1048575 ratio swap . .  \ dfrac = 323978 / 911917
\ 100000000005500. 1048575 ratio swap . .  \ dfrac = 194159 / 546509
\
\ `ud*` supports scaling of d_frac at this precision.

applets [if] end-applet  paged swap - . .( }; ) [then]

\ Probably want this in the kernel to keep it fast.
\ A short applet would save 40 instructions.

: d+c  ( d1 d2 -- d3 carry )            \ double add with carry out
   >r swap >r +c  carry r> +  r> +c carry
;

\ Unsigned double * double -> quad product
: ud*  ( ud1 ud2 -- uq )
   over >r  ratio_x2 2!
   over >r  ratio_x1 2!  r> r>  um*
   ratio_x1 @  dup>r
   ratio_x2 @  dup>r  um*               \ d_low d_hi | H1 H2
   r> [ ratio_x1 cell + ] literal @ um*
   r> [ ratio_x2 cell + ] literal @ um*  d+c  t+
;

there swap - . .( instructions used by bignum) cr


        DOUBLE PRECISION FUNCTION LOOKUP(TAB,NTAB,POS)
*
*  Module number: HRS/FOS UTILITY
*
*  Module name: LOOKUP
*
*  Keyphrase:
*  ----------
*       Tabular function value
*  Description:
*  ------------
*       This routines looks for the value in a table
*       at a given position.
*       It is equivalent to result=TAB(POS) except
*       that POS is may be a fractional table position.
*       Therefore linear interpolation/extrapolation is
*       used to compute the value.
*
*  FORTRAN name: lookup.for
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*       none
*
*  Subroutines Called:
*  -------------------
*       none
*
*  History:
*  --------
*  Version      Date        Author          Description
*     1         Sept. 87   D. Lindler   Designed and coded
*-------------------------------------------------------------------------------
C
C INPUT PARAMETERS
C
C       TAB - VECTOR OF VALUES (REAL*8)
C       NTAB - NUMBER OF VALUES IN TAB (INTEGER)
C       POS - POSITION IN TABLE DESIRED (REAL*8)
C
C OUTPUT PARAMETERS
C       RESULT IS RETURNED AS FUNCTION VALUE
C
C----------------------------------------------------------------------------
	IMPLICIT NONE
        DOUBLE PRECISION  TAB(*),POS
        INTEGER NTAB,IPOS
C
C DETERMINE FIRST OF PAIR OF TABLE VALUES TO USE
C
        IPOS=POS
        IF(IPOS.LT.1)IPOS=1
        IF(IPOS.GE.NTAB)IPOS=NTAB-1
C
C INTERPOLATE
C
        LOOKUP=TAB(IPOS)+(POS-IPOS)*(TAB(IPOS+1)-TAB(IPOS))
        RETURN
        END


module globalmodule

  integer, parameter :: fdp = selected_real_kind(10, 200)
  integer, parameter :: fsp = selected_real_kind(5, 50)
  integer, parameter :: idp = selected_int_kind(9)
  integer, parameter :: isp = selected_int_kind(6)
  integer, parameter :: cdp = fdp
  integer, parameter :: csp = fsp

  real(fdp), parameter :: pi = 3.14159265359, &
       & h = 6.626075540d-34, &
       & hbar = h/2.0d0/pi

  complex(cdp), parameter :: ii = (0.0d0, 1.0d0)

end module globalmodule


    program demo_acos
    use, intrinsic :: iso_fortran_env, only : real_kinds,real32,real64,real128
    implicit none
    character(len=*),parameter :: all='(*(g0,1x))'
    real(kind=real64) :: x = 0.866_real64
    real(kind=real64),parameter :: d2r=acos(-1.0_real64)/180.0_real64

        print all,'acos(',x,') is ', acos(x)
        print all,'90 degrees is ', d2r*90.0_real64, ' radians'
        print all,'180 degrees is ', d2r*180.0_real64, ' radians'
        print all,'for reference &
        &PI ~ 3.14159265358979323846264338327950288419716939937510'
        print all,'elemental',acos([-1.0,-0.5,0.0,0.50,1.0])

    end program demo_acos


MODULE spline_mod

CONTAINS

SUBROUTINE spl2d(nx,ny,hx,hy,mx,my,f,spl)

! Makes a 2-dimensional cubic spline of function f(x,y)
!
! Input:  nx, ny              number of values in x and y
!         hx, hy              step size in x and y (aequidistant)
!         mx, my              spline mode (0: standard, 1: periodic)
!         f(nx,ny)            f(x,y)-values
! Output: spl                 Array with spline parameters

  USE neo_precision

  IMPLICIT NONE

  INTEGER,                             INTENT(in)  :: nx, ny, mx, my
  REAL(kind=dp),                       INTENT(in)  :: hx, hy
  REAL(kind=dp), DIMENSION(nx,ny)    , INTENT(in)  :: f
  REAL(kind=dp), DIMENSION(4,4,nx,ny), INTENT(out) :: spl

  REAL(kind=dp), DIMENSION(:),         ALLOCATABLE :: bi, ci, di, s
  INTEGER                                          :: i, j, k

  ALLOCATE ( bi(nx), ci(nx), di(nx), s(nx) )
  DO j = 1,ny
     DO i = 1,nx
        s(i) = f(i,j)
     END DO
     IF (mx .EQ. 0) THEN
        CALL splreg(nx,hx,s,bi,ci,di)
     ELSE
        CALL splper(nx,hx,s,bi,ci,di)
     ENDIF
     DO i = 1,nx
        spl(1,1,i,j) = s(i)
        spl(2,1,i,j) = bi(i)
        spl(3,1,i,j) = ci(i)
        spl(4,1,i,j) = di(i)
     END DO
  END DO
  DEALLOCATE ( bi, ci, di, s )

  ALLOCATE ( bi(ny), ci(ny), di(ny), s(ny) )
  DO k = 1,4
     DO i = 1,nx
        DO j = 1,ny
           s(j) = spl(k,1,i,j)
        END DO
        IF (my .EQ. 0) THEN
           CALL splreg(ny,hy,s,bi,ci,di)
        ELSE
           CALL splper(ny,hy,s,bi,ci,di)
        ENDIF
        DO j=1,ny
           spl(k,2,i,j)=bi(j)
           spl(k,3,i,j)=ci(j)
           spl(k,4,i,j)=di(j)
        END DO
     END DO
  END DO
  DEALLOCATE ( bi, ci, di, s )

  RETURN
END SUBROUTINE spl2d
!=====================================================
SUBROUTINE eva2d(nx,ny,ix,iy,dx,dy,spl,spval)

! Evaluates a 2-dimensional cubic spline of function f(x,y)
!
! Input:  nx, ny              number of values in x and y
!         ix, iy              pointer into the spline array spl
!         dx, dy              distance from x(ix) and y(iy)
!         spl                 array with spline data
! Output: spval               evaluated function value

  USE neo_precision

  IMPLICIT NONE

  INTEGER,                             INTENT(in)  :: nx, ny, ix, iy
  REAL(kind=dp),                       INTENT(in)  :: dx, dy
  REAL(kind=dp), DIMENSION(4,4,nx,ny), INTENT(in)  :: spl
  REAL(kind=dp),                       INTENT(out) :: spval

  REAL(kind=dp), DIMENSION(4)                      :: a
  INTEGER                                          :: l

  DO l=1,4
     a(l) = spl(1,l,ix,iy) + dx*(spl(2,l,ix,iy) +              &
          dx*(spl(3,l,ix,iy) + dx* spl(4,l,ix,iy)))
  END DO
  spval = a(1)+dy*(a(2)+dy*(a(3)+dy*a(4)))

  RETURN
END SUBROUTINE eva2d
!=====================================================
SUBROUTINE eva2d_fd(nx,ny,ix,iy,dx,dy,spl,spval)

! Evaluates the first derivatives of 2-dimensional cubic spline of function f(x,y)
!
! Input:  nx, ny              number of values in x and y
!         ix, iy              pointer into the spline array spl
!         dx, dy              distance from x(ix) and y(iy)
!         spl                 array with spline data
! Output: spval(2)            evaluated function value
!                             spval(1) = df/dx
!                             spval(2) = df/dy

  USE neo_precision

  IMPLICIT NONE

  INTEGER,                             INTENT(in)  :: nx, ny, ix, iy
  REAL(kind=dp),                       INTENT(in)  :: dx, dy
  REAL(kind=dp), DIMENSION(4,4,nx,ny), INTENT(in)  :: spl
  REAL(kind=dp), DIMENSION(2),         INTENT(out) :: spval

  INTEGER                                          :: i,j
  REAL(kind=dp)                                    :: muli, mulj

  spval = 0.0_dp

! df/dx
  DO i=2,4
     IF (i == 2) THEN
        muli = 1.0_dp
     ELSE
        muli = dx**(i-2)
     END IF
     muli = muli * (i-1)
     DO j=1,4
       IF (j == 1) THEN
           mulj = 1.0_dp
        ELSE
           mulj = dy**(j-1)
        END IF
        spval(1) = spval(1) + spl(i,j,ix,iy) * muli * mulj
     END DO
  END DO

! df/dy
  DO i=1,4
     IF (i == 1) THEN
        muli = 1.0_dp
     ELSE
        muli = dx**(i-1)
     END IF
     DO j=2,4
        IF (j == 2) THEN
           mulj = 1.0_dp
        ELSE
           mulj = dy**(j-2)
        END IF
        mulj = mulj * (j-1)
        spval(2) = spval(2) + spl(i,j,ix,iy) * muli * mulj
     END DO
  END DO

  RETURN
END SUBROUTINE eva2d_fd
!=====================================================
SUBROUTINE eva2d_sd(nx,ny,ix,iy,dx,dy,spl,spval)

! Evaluates the second derivatives of 2-dimensional cubic spline of function f(x,y)
!
! Input:  nx, ny              number of values in x and y
!         ix, iy              pointer into the spline array spl
!         dx, dy              distance from x(ix) and y(iy)
!         spl                 array with spline data
! Output: spval(3)            evaluated function values
!                             spval(1) = d^2f/dx^2
!                             spval(2) = d^2f/(dxdy)
!                             spval(3) = d^2f/dy^2

  USE neo_precision

  IMPLICIT NONE

  INTEGER,                             INTENT(in)  :: nx, ny, ix, iy
  REAL(kind=dp),                       INTENT(in)  :: dx, dy
  REAL(kind=dp), DIMENSION(4,4,nx,ny), INTENT(in)  :: spl
  REAL(kind=dp), DIMENSION(3),         INTENT(out) :: spval

  INTEGER                                          :: i,j
  REAL(kind=dp)                                    :: muli, mulj

  spval = 0.0_dp

! d^2f/dx^2
  DO i=3,4
     IF (i == 3) THEN
        muli = 1.0_dp
     ELSE
        muli = dx**(i-3)
     END IF
     muli = muli * (i-1) * (i-2)
     DO j=1,4
        IF (j == 1) THEN
           mulj = 1.0_dp
        ELSE
           mulj = dy**(j-1)
        END IF
        spval(1) = spval(1) + spl(i,j,ix,iy) * muli * mulj
     END DO
  END DO

! d^2f/(dxdy)
  DO i=2,4
     IF (i == 2) THEN
        muli = 1.0_dp
     ELSE
        muli = dx**(i-2)
     END IF
     muli = muli * (i-1)
     DO j=2,4
        IF (j == 2) THEN
           mulj = 1.0_dp
        ELSE
           mulj = dy**(j-2)
        END IF
        mulj = mulj * (j-1)
        spval(2) = spval(2) + spl(i,j,ix,iy) * muli * mulj
     END DO
  END DO

! d^2f/dy^2
  DO i=1,4
     IF (i == 1) THEN
        muli = 1.0_dp
     ELSE
        muli = dx**(i-1)
     END IF
     DO j=3,4
        IF (j == 3) THEN
           mulj = 1.0_dp
        ELSE
           mulj = dy**(j-3)
        END IF
        mulj = mulj * (j-1) * (j-2)
        spval(3) = spval(3) + spl(i,j,ix,iy) * muli * mulj
     END DO
  END DO

  RETURN
END SUBROUTINE eva2d_sd
!=====================================================
SUBROUTINE splreg(n,h,y,bi,ci,di)

! Makes a cubic spline of function y(x)
!
! Input:  n                   number of values in y
!         h                   step size in x (aequidistant)
!         y(n)                y-values
! Output: bi(n),ci(n),di(n)   Spline parameters

  USE neo_precision

  IMPLICIT NONE

  INTEGER,                     INTENT(in)  :: n
  REAL(kind=dp),               INTENT(in)  :: h
  REAL(kind=dp), DIMENSION(n), INTENT(in)  :: y
  REAL(kind=dp), DIMENSION(n), INTENT(out) :: bi, ci, di

  REAL(kind=dp)                            :: ak1, ak2, am1, am2, c, e, c1
  REAL(kind=dp), DIMENSION(:), ALLOCATABLE :: al, bt
  INTEGER                                  :: k, n2, i, i5

  ALLOCATE ( al(n), bt(n) )

  ak1 = 0.d0
  ak2 = 0.d0
  am1 = 0.d0
  am2 = 0.d0
  k = n-1
  al(1) = ak1
  bt(1) = am1
  n2 = n-2
  c = -4.d0*h
  DO i = 1,n2
     e = -3.d0*((y(i+2)-y(i+1))-(y(i+1)-y(i)))/h
     c1 = c-al(i)*h
     al(i+1) = h/c1
     bt(i+1) = (h*bt(i)+e)/c1
  END DO
  ci(n) = (am2+ak2*bt(k))/(1.d0-al(k)*ak2)
  DO i = 1,k
     i5 = n-i
     ci(i5) = al(i5)*ci(i5+1)+bt(i5)
  END DO
  n2 = n-1
  DO i = 1,n2
     bi(i) = (y(i+1)-y(i))/h-h*(ci(i+1)+2.d0*ci(i))/3.d0
     di(i) = (ci(i+1)-ci(i))/h/3.d0
  END DO
  DEALLOCATE ( al, bt )

  RETURN
END SUBROUTINE splreg
!=====================================================
SUBROUTINE splper(n,h,y,bi,ci,di)

! Makes a cubic spline of periodic function y(x)
!
! Input:  n                   number of values in y
!         h                   step size in x (aequidistant)
!         y(n)                y-values
! Output: bi(n),ci(n),di(n)   Spline parameters

  USE neo_precision

  IMPLICIT NONE

  INTEGER,                     INTENT(in)  :: n
  REAL(kind=dp),               INTENT(in)  :: h
  REAL(kind=dp), DIMENSION(n), INTENT(in)  :: y
  REAL(kind=dp), DIMENSION(n), INTENT(out) :: bi, ci, di

  REAL(kind=dp)                            :: psi, ss
  REAL(kind=dp), DIMENSION(:), ALLOCATABLE :: bmx, yl
  REAL(kind=dp), DIMENSION(:), ALLOCATABLE :: amx1, amx2, amx3
  INTEGER                                  :: nmx, n1, n2, i, i1

  ALLOCATE ( bmx(n), yl(n), amx1(n), amx2(n), amx3(n) )

  bmx(1) = 1.d30

  nmx=n-1
  n1=nmx-1
  n2=nmx-2
  psi=3.d0/h/h

  CALL spfper(n,amx1,amx2,amx3)

  bmx(nmx) = (y(nmx+1)-2.d0*y(nmx)+y(nmx-1))*psi
  bmx(1)   =(y(2)-y(1)-y(nmx+1)+y(nmx))*psi
  DO i = 3,nmx
     bmx(i-1) = (y(i)-2.d0*y(i-1)+y(i-2))*psi
  END DO
  yl(1) = bmx(1)/amx1(1)
  DO i = 2,n1
     i1 = i-1
     yl(i) = (bmx(i)-yl(i1)*amx2(i1))/amx1(i)
  END DO
  ss = 0.d0
  DO i = 1,n1
     ss = ss+yl(i)*amx3(i)
  END DO
  yl(nmx) = (bmx(nmx)-ss)/amx1(nmx)
  bmx(nmx) = yl(nmx)/amx1(nmx)
  bmx(n1) = (yl(n1)-amx2(n1)*bmx(nmx))/amx1(n1)
  DO i = n2,1,-1
     bmx(i) = (yl(i)-amx3(i)*bmx(nmx)-amx2(i)*bmx(i+1))/amx1(i)
  END DO
  DO i = 1,nmx
     ci(i) = bmx(i)
  END DO

  DO i = 1,n1
     bi(i) = (y(i+1)-y(i))/h-h*(ci(i+1)+2.d0*ci(i))/3.d0
     di(i) = (ci(i+1)-ci(i))/h/3.d0
  END DO
  bi(nmx) = (y(n)-y(n-1))/h-h*(ci(1)+2.d0*ci(nmx))/3.d0
  di(nmx) = (ci(1)-ci(nmx))/h/3.d0
!
! Fix of problems at upper periodicity boundary
!
  bi(n) = bi(1)
  ci(n) = ci(1)
  di(n) = di(1)

  DEALLOCATE ( bmx, yl, amx1, amx2, amx3 )

  RETURN
END SUBROUTINE splper
!=====================================================
SUBROUTINE spfper(np1,amx1,amx2,amx3)

! Helper routine for splfi

  USE neo_precision

  IMPLICIT NONE

  INTEGER,                       INTENT(in)  :: np1
  REAL(kind=dp), DIMENSION(np1), INTENT(out) :: amx1, amx2, amx3
  REAL(kind=dp)                              :: beta, ss
  INTEGER                                    :: n, n1, i, i1

  n = np1-1

  n1 = n-1
  amx1(1) = 2.d0
  amx2(1) = 0.5d0
  amx3(1) = 0.5d0
  amx1(2) = SQRT(15.d0)/2.d0
  amx2(2) = 1.d0/amx1(2)
  amx3(2) = -.25d0/amx1(2)
  beta = 3.75d0
  DO i = 3,n1
     i1 = i-1
     beta = 4.d0-1.d0/beta
     amx1(i) = SQRT(beta)
     amx2(i) = 1.d0/amx1(i)
     amx3(i) = -amx3(i1)/amx1(i)/amx1(i1)
  END DO
  amx3(n1) = amx3(n1)+1.d0/amx1(n1)
  amx2(n1) = amx3(n1)
  ss = 0.0d0
  DO i = 1,n1
     ss = ss+amx3(i)*amx3(i)
  END DO
  amx1(n) = SQRT(4.d0-ss)

  RETURN
END SUBROUTINE spfper
!=====================================================
SUBROUTINE poi2d(hx,hy,mx,my,                         &
     xmin,xmax,ymin,ymax,                             &
     x,y,ix,iy,dx,dy,ierr)
! Creates Pointers for eva2d
!
! Input:  hx, hy              increment in x and y
!         mx, my              standard (0) or periodic (1) spline
!         xmin, xmax          Minimum and maximum x
!         ymin, ymax          Minimum and maximum y
!         x, y                x and y values for spline avaluation
! Output: spval               evaluated function value
!         ix, iy              pointer into the spline array spl
!         dx, dy              distance from x(ix) and y(iy)
!         ierr                error (> 0)

  USE neo_precision

  IMPLICIT NONE

  REAL(kind=dp),                       INTENT(in)  :: hx, hy
  INTEGER,                             INTENT(in)  :: mx, my
  REAL(kind=dp),                       INTENT(in)  :: xmin, xmax, ymin, ymax
  REAL(kind=dp),                       INTENT(in)  :: x, y

  INTEGER,                             INTENT(out) :: ix, iy
  REAL(kind=dp),                       INTENT(out) :: dx, dy
  INTEGER,                             INTENT(out) :: ierr

  REAL(kind=dp)                                    :: dxx, x1, dyy, y1
  REAL(kind=dp)                                    :: dxmax, dymax

  ierr = 0

  dxx = x-xmin
  IF (mx .EQ. 0) THEN
     IF (dxx .LT. 0.d0) THEN
        ierr = 1
        RETURN
     END IF
     IF (x .GT. xmax) THEN
        ierr = 2
        RETURN
     END IF
  ELSE
     dxmax = xmax - xmin
     IF(dxx .LT. 0.d0) THEN
        dxx = dxx+DBLE(float(1+INT(ABS(dxx/dxmax))))*dxmax
     ELSE IF(dxx .GT. dxmax) THEN
        dxx = dxx-DBLE(float(INT(ABS(dxx/dxmax))))*dxmax
     END IF
  END IF
  x1 = dxx/hx
  ix = INT(x1)
  dx = hx*(x1-DBLE(float(ix)))
  ix = ix+1

  dyy = y-ymin
  IF (my .EQ. 0) THEN
     IF (dyy .LT. 0.d0) THEN
        ierr = 3
        RETURN
     END IF
     IF (y .GT. ymax) THEN
        ierr = 4
        RETURN
     END IF
  ELSE
     dymax = ymax - ymin
     IF(dyy .LT. 0.d0) THEN
        dyy = dyy+DBLE(float(1+INT(ABS(dyy/dymax))))*dymax
     ELSE IF(dyy .GT. dymax) THEN
        dyy = dyy-DBLE(float(INT(ABS(dyy/dymax))))*dymax
     END IF
  END IF
  y1 = dyy/hy
  iy = INT(y1)
  dy = hy*(y1-DBLE(float(iy)))
  iy = iy+1

  RETURN
END SUBROUTINE poi2d

END MODULE spline_mod


!  *********************************************************************
!  *                                                                   *
!  *                         subroutine chkne3                         *
!  *                                                                   *
!  *********************************************************************
!  Single Precision Version 1.11
!  Written by Gordon A. Fenton, TUNS, Jul 14, 2000
!  Latest Update: Oct 18, 2002
!
!  PURPOSE	checks nxe, nye, and nze to ensure that they are compatible
!		with random fields produced by LAS3G
!
!  DESCRIPTION
!  This routine checks nxe, nye, and nze to ensure that they can be written
!  in the form;
!		nxe = k1*(2**m)
!		nye = k2*(2**m)
!		nze = k3*(2**m)
!
!  If not, the random field size given by (nrfx,nrfy,nrfz) is adjusted
!  upwards until the integers nrfx, nrfy, and nrfz do satisfy the
!  above equations for some non-negative integer m and positive integers
!  (k1,k2,k3) with k1*k2*k3 <= MXK.
!
!  ARGUMENTS
!
!   istat	unit number connected to a file to which error and warning
!		messages can be issued. (input)
!
!   iterm	unit number connected to the screen. If verbos is true, then
!		error and warning messages are also sent to the screen. (input)
!
!  verbos	logical flag which is true if error, warning, and progress
!		messages are allowed to be sent to the screen. (output)
!
!     nxe	integer giving the number of elements describing the pillar
!		in the x-direction (width). (input)
!
!     nye	integer giving the number of elements describing the pillar
!		in the y-direction (depth). (input)
!
!     nze	integer giving the number of elements describing the pillar
!		in the z-direction (height). (input)
!
!    nrfx	integer giving the number of cells in the x-direction in the
!		simulated random field. This is normally equal to nxe, but if
!		nxe is not an integer of the form nxe = k1*(2**m), where m is
!		a non-negative integer, and k1 is a positive integer with
!		k1*k2*k3 < MXK then nrfx is set to the next larger
!		possible integer that does satisfy this requirement of LAS3G.
!		(input)
!
!    nrfy	integer giving the number of cells in the y-direction in the
!		simulated random field. This is normally equal to nye, but if
!		nye is not an integer of the form nye = k2*(2**m), where m is
!		a non-negative integer, and k2 is a positive integer with
!		k1*k2*k3 < MXK then nrfy is set to the next larger
!		possible integer that does satisfy this requirement of LAS3G.
!		(input)
!
!    nrfz	integer giving the number of cells in the z-direction in the
!		simulated random field. This is normally equal to nze, but if
!		nze is not an integer of the form nze = k3*(2**m), where m is
!		a non-negative integer, and k3 is a positive integer with
!		k1*k2*k3 < MXK then nrfz is set to the next larger
!		possible integer that does satisfy this requirement of LAS3G.
!		(input)
!
!  PARAMETERS:
!  MXK	maximum value that k1*k2*k3 can be. This should be identical to that
!	prescribed in GAF77 library routine las3g.f.
!
!  REVISION HISTORY:
!  1.11	added data definition for zero (Oct 18/02)
!-------------------------------------------------------------------------
      subroutine chkne3(istat,iterm,verbos,nxe,nye,nze,nrfx,nrfy,nrfz)
      parameter (MXK = 512)
      logical verbos
      data zero/0.0/, half/0.5/, pt9/0.99999/, two/2.0/

   1  format(a)
!					compute minimum m
      aa = float(nxe*nye*nze)/float(MXK)
      am = alog(aa)/(two*alog(two))
      if( am .lt. zero ) am = zero
      m  = int(am + pt9)		! round m up
      tm = two**m
!					now compute minimum k's
      ak1 = float(nxe)/tm
      k1  = int(ak1 + pt9)
      ak2 = float(nye)/tm
      k2  = int(ak2 + pt9)
      ak3 = float(nze)/tm
      k3  = int(ak3 + pt9)
!					new nxe, nye, and nze
      nrfx = k1*int(tm + half)
      nrfy = k2*int(tm + half)
      nrfz = k3*int(tm + half)
!					warn if we're changing anything

      if( (nrfx .ne. nxe) .or.                                            &
         (nrfy .ne. nye) .or.                                             &
         (nrfz .ne. nze) ) then
         if( verbos ) then
            call print3(iterm,                                            &
             'Note: desired number of elements (%i, %i, %i)%n',           &
              nxe,nye,nze)
            write(iterm,1)'         incompatible with LAS3G simulator.'
            call print3(iterm,                                            &
             '         Adjusting random field size to (%i, %i, %i)%n',    &
                       nrfx,nrfy,nrfz)
         endif
         call print3(istat,                                               &
          'Note: desired number of elements (%i, %i, %i)%n',              &
           nxe,nye,nze)
         write(istat,1)'         incompatible with LAS3G simulator.'
         call print3(istat,                                               &
          '         Adjusting random field size to (%i, %i, %i)%n',       &
                    nrfx,nrfy,nrfz)
      endif

      return
      end


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

       subroutine error_norm(rms)

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

c---------------------------------------------------------------------
c this function computes the norm of the difference between the
c computed solution and the exact solution
c---------------------------------------------------------------------

       include 'header.h'

       integer i, j, k, m, d
       double precision xi, eta, zeta, u_exact(5), rms(5), add

       double precision rmsz(5,0:KMAX-1)
!hpf$ distribute(*,block) :: rmsz

       interface
         extrinsic (hpf_local) pure subroutine
     >                       exact_solution(xi,eta,zeta,dtemp)
           double precision, intent(in)::  xi, eta, zeta
           double precision, dimension (:), intent(out) :: dtemp
         end subroutine exact_solution
       end interface

!hpf$ independent, new(add, u_exact)
       do   k = 0, grid_points(3)-1
          do    m = 1, 5
             rmsz(m,k) = 0.0d0
          end do

          zeta = dble(k) * dnzm1
          do   j = 0, grid_points(2)-1
             eta = dble(j) * dnym1
             do   i = 0, grid_points(1)-1
                xi = dble(i) * dnxm1
                call exact_solution(xi, eta, zeta, u_exact(:))
                do   m = 1, 5
                   add = u(m,i,j,k)-u_exact(m)
                   rmsz(m,k) = rmsz(m,k) + add*add
                end do
             end do
          end do
       end do

       do    m = 1, 5
          rms(m) = sum( rmsz(m,0:grid_points(3)-1) )
          do    d = 1, 3
             rms(m) = rms(m) / dble(grid_points(d)-2)
          end do
          rms(m) = dsqrt(rms(m))
       end do

       return
       end

       subroutine rhs_norm(rms)

       include 'header.h'

       integer i, j, k, d, m
       double precision rms(5), add

       double precision rmsz(5,0:KMAX-1)
!hpf$ distribute(*,block) :: rmsz

!hpf$ independent, new(add)
       do k = 1, nz2
          do   m = 1, 5
             rmsz(m,k) = 0.0d0
          end do

          do j = 1, ny2
             do i = 1, nx2
       	       do m = 1, 5
                  add = rhs(m,i,j,k)
                  rmsz(m,k) = rmsz(m,k) + add*add
               end do
             end do
          end do
       end do

       do   m = 1, 5
          rms(m) = sum( rmsz(m,1:nz2) )
          do   d = 1, 3
             rms(m) = rms(m) / dble(grid_points(d)-2)
          end do
          rms(m) = dsqrt(rms(m))
       end do

       return
       end


!this module is use to solve the three diag matrix Ax=b
MODULE threediag_mod
    IMPLICIT NONE
    PUBLIC threediag
CONTAINS
    SUBROUTINE threediag(n,a,b,c,d,x)
        INTEGER(4),INTENT(IN)::n
        REAL(8),DIMENSION(:),INTENT(IN)::a(n),b(n),c(n),d(n)
        REAL(8),DIMENSION(:),INTENT(INOUT)::x(n)
        REAL(8),ALLOCATABLE::y(:),u(:),l(:)
        INTEGER(4)::i
        ALLOCATE(y(n))
        ALLOCATE(u(n))
        ALLOCATE(l(n))
        x=0
        y=0
        u=0
        l=0
        u(1)=b(1)
        y(1)=d(1)
        DO i=2,n
            l(i)=a(i)/u(i-1)
            u(i)=b(i)-l(i)*c(i-1)
            y(i)=d(i)-l(i)*y(i-1)
        END DO
        x(n)=y(n)/u(n)
        DO i=n-1,1,-1
            x(i)=(y(i)-c(i)*x(i+1))/u(i)
        END DO
        DEALLOCATE(y)
        DEALLOCATE(u)
        DEALLOCATE(l)
    END SUBROUTINE
END MODULE


! Generic math subroutines
module math_mod

    implicit none
    real,parameter :: pi = 3.14159265358979323846264338327950288419716939937510 ! No, this is not at all excessive
    real,parameter :: inf = huge(0.) ! Reason #403929 why Fortran is the best: huge() is an intrinsic function

contains

function isinf(x) result(is)
  ! Checks if x is infinite

  implicit none

  real,intent(in) :: x

  logical :: is

  ! Check for infinity
  if (x >= inf .or. x <= -inf) then
    is = .true.
  else
    is = .false.
  end if

end function isinf

function sign(x) result(s)
  ! Returns the sign of x

  implicit none

  real,intent(in) :: x

  integer :: s

  if (x < 0.) then
    s = -1
  else if (x > 0.) then
    s = 1
  else
    s = 0
  end if

end function sign

function plane_normal(p1, p2, p3) result(n)
  ! Computes the normal vector to a plane defined by 3 points

  implicit none

  real,dimension(3),intent(in) :: p1, p2, p3
  real,dimension(3) :: a, b, n

  a = p2 - p1
  b = p3 - p1
  n = cross(a,b)
  n = n/norm(n)

end function plane_normal

function reflect_point(A, B, C, D, P) result(P_refl)
  ! Somehow reflects a point P

  implicit none

  real,intent(in) :: A, B, C, D
  real,dimension(3),intent(in) :: P(3)
  real,dimension(3) :: P_refl

  real :: mult

  mult = 2.0*(A*P(1) + B*P(2) + C*P(3) + D)/(A**2 + B**2 + C**2)

  P_refl(1) = P(1) - mult*A
  P_refl(2) = P(2) - mult*B
  P_refl(3) = P(3) - mult*C

end function reflect_point

function dist(a, b) result(c)
  ! Calculates the cartesian distance between 2 points

    implicit none

    real,dimension(3),intent(in) :: a, b
    real :: c

    c = sqrt(sum((a-b)**2))

end function dist

function cross(a, b) result(c)
  ! Calculates the cross-product of two 3-element vectors

    implicit none

    real,dimension(3),intent(in) :: a, b

    real,dimension(3) :: c

    c(1) = a(2)*b(3) - a(3)*b(2)
    c(2) = a(3)*b(1) - a(1)*b(3)
    c(3) = a(1)*b(2) - a(2)*b(1)

end function cross

function inner(a, b) result(c)
  ! Calculates the 3D Euclidean inner product

  implicit none
  real, dimension(3) :: a, b
  real :: c

  c = a(1)*b(1)+a(2)*b(2)+a(3)*b(3)

end function inner

function inner2(a, b) result(c)
  ! Calculates the 2D Euclidean inner product

  implicit none
  real, dimension(2) :: a, b
  real :: c

  c = a(1)*b(1)+a(2)*b(2)

end function inner2

function outer(a, b) result(c)
  ! Calculates the outer product of two vectors

  implicit none

  real,dimension(3) :: a, b
  real,dimension(3,3) :: c

  integer :: i

  c = 0.

  do i=1,3
    c(i,:) = a(i)*b(:)
  end do

end function

function norm(a) result(c)
  ! Calculates the norm of the vector

  implicit none
  real, dimension(3) :: a
  real :: c

  c = sqrt(inner(a, a))

end function norm

function det3(a) result(c)
  ! Calculates the determinant of a 3x3 matrix

  implicit none

  real,dimension(3,3) :: a
  real :: c

  c = a(1,1)*(a(2,2)*a(3,3)-a(2,3)*a(3,2))
  c = c - a(1,2)*(a(2,1)*a(3,3)-a(2,3)*a(3,1))
  c = c + a(1,3)*(a(2,1)*a(3,2)-a(3,1)*a(2,2))

end function det3

function rot_x(v, theta) result(v_rot)
  ! Rotates v about the x axis by theta (in radians)

    implicit none

    real,dimension(3),intent(in) :: v
    real,intent(in) :: theta
    real,dimension(3) :: v_rot

    real,dimension(3,3) :: rm(3,3) = 0.

    rm(1,1) = 1.
    rm(2,2) = cos(theta)
    rm(2,3) = -sin(theta)
    rm(3,2) = sin(theta)
    rm(3,3) = cos(theta)

    v_rot = matmul(rm, v)

end function rot_x

function rot_y(v, theta) result(v_rot)
  ! Rotates v about the y axis by theta (in radians)

    implicit none

    real,dimension(3),intent(in) :: v
    real,intent(in) :: theta
    real,dimension(3) :: v_rot

    real,dimension(3,3) :: rm(3,3) = 0.

    rm(1,1) = cos(theta)
    rm(1,3) = sin(theta)
    rm(2,2) = 1.0
    rm(3,1) = -sin(theta)
    rm(3,3) = cos(theta)

    v_rot = matmul(rm, v)

end function rot_y

function rot_z(v, theta) result(v_rot)
  ! Rotates v about the z axis by theta (in radians)

    implicit none

    real,dimension(3),intent(in) :: v
    real,intent(in) :: theta
    real,dimension(3) :: v_rot

    real,dimension(3,3) :: rm(3,3) = 0.

    rm(1,1) = cos(theta)
    rm(1,2) = -sin(theta)
    rm(2,1) = sin(theta)
    rm(2,2) = cos(theta)
    rm(3,3) = 1.0

    v_rot = matmul(rm, v)

end function rot_z

end module math_mod


! Fizzbuzz program in FORTRAN
! SupreethRao99
PROGRAM fizzbuzz
      IMPLICIT NONE
      INTEGER :: counter

      DO counter=0,100
          IF (MOD(counter,15) == 0) THEN
              WRITE (*,'(A8)') "FizzBuzz"
          ELSE IF (MOD(counter,5) == 0) THEN
              WRITE (*,'(A4)') "Buzz"
          ELSE IF (MOD(counter,3) == 0) THEN
              WRITE (*,'(A4)') "Fizz"
          ELSE
              WRITE (*,'(I2)') counter
          END IF
      END DO

END PROGRAM fizzbuzz


! $UWHPSC/codes/fortran/optimize/timings.f90

! Illustrate timing utilities in Fortran.
!  system_clock can be used to compute elapsed time between
!      two calls (wall time)
!  cpu_time can be used to compute CPU time used between two calls.

! Try compiling with different levels of optimization, e.g. -O3

program timings

    implicit none
    integer, parameter :: ntests = 20
    integer :: n
    real(kind=8), allocatable, dimension(:,:) :: a,b,c
    real(kind=8) :: t1, t2, elapsed_time
    integer(kind=8) :: tclock1, tclock2, clock_rate
    integer :: i,j,k,itest

    call system_clock(tclock1)

    print *, "Will multiply n by n matrices, input n: "
    read *, n

    allocate(a(n,n), b(n,n), c(n,n))

    ! fill a and b with 1's just for demo purposes:
    a = 1.d0
    b = 1.d0

    call cpu_time(t1)   ! start cpu timer
    do itest=1,ntests
        do j = 1,n
            do i = 1,n
                c(i,j) = 0.d0
                do k=1,n
                    c(i,j) = c(i,j) + a(i,k)*b(k,j)
                    enddo
                enddo
            enddo
        enddo

    call cpu_time(t2)   ! end cpu timer
    print 10, ntests, t2-t1
 10 format("Performed ",i4, " matrix multiplies: CPU time = ",f12.8, " seconds")

    call system_clock(tclock2, clock_rate)
    elapsed_time = float(tclock2 - tclock1) / float(clock_rate)
    print 11, elapsed_time
 11 format("Elapsed time = ",f12.8, " seconds")

end program timings


PROGRAM diffusion_test

USE omp_lib
USE diffusion, only : GetRHSDiffusion, InitializeDiffusion

IMPLICIT NONE

INCLUDE 'mpif.h'

DOUBLE PRECISION, PARAMETER :: pi = 3.1415926535897932_8 ! underscore indicates rounding to real(8) precision
INTEGER, PARAMETER :: Nthreads = 1

DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: Q, RQ, RQex
DOUBLE PRECISION :: dx, dy, dz, x, y, z
INTEGER :: mpi_thread_provided, ierr, Nx, Ny, Nz, i, j, k, nt, &
    i_start, j_start, k_start, i_end, j_end, k_end, order, nn

INTEGER, DIMENSION(6), PARAMETER :: N_v = (/ 10, 100, 200, 300, 400, 500 /)
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: err_v, convrate

CALL MPI_INIT_THREAD(MPI_THREAD_FUNNELED, mpi_thread_provided, ierr)

DO order=2,4,2

    i_start = 1
    j_start = 1
    k_start = 1

    ALLOCATE(err_v(1:SIZE(N_v)))
    ALLOCATE(convrate(1:SIZE(N_v)-1))

    DO nn=1,SIZE(N_v)

        Nx = N_v(nn)
        Ny = N_v(nn)
        Nz = N_v(nn)

        i_end = i_start + Nx - 1
        j_end = j_start + Ny - 1
        k_end = k_start + Nz - 1

        dx = 1.0/DBLE(Nx)
        dy = 1.0/DBLE(Ny)
        dz = 1.0/DBLE(Nz)

        ALLOCATE(Q(   i_start-2:i_end+2, j_start-2:j_end+2, k_start-2:k_end+2, 0:Nthreads-1))
        ALLOCATE(RQ(  i_start-2:i_end+2, j_start-2:j_end+2, k_start-2:k_end+2, 0:Nthreads-1))
        ALLOCATE(RQex(i_start-2:i_end+2, j_start-2:j_end+2, k_start-2:k_end+2, 0:Nthreads-1))

        CALL InitializeDiffusion(i_start-2, i_end+2, j_start-2, j_end+2, k_start-2, k_end+2, DBLE(1.0))
        !$OMP PARALLEL DO schedule(static)
        DO nt=0,Nthreads-1
            Q(:,:,:,nt)  = 0.0
            RQ(:,:,:,nt) = 0.0
        END DO
        !$OMP END PARALLEL DO

        DO k=k_start-2,k_end+2
            DO j=j_start-2,j_end+2
                DO i=i_start-2,i_end+2
                    x = 0.5*dx + DBLE(i - i_start)*dx
                    y = 0.5*dy + DBLE(j - j_start)*dy
                    z = 0.5*dz + DBLE(k - k_start)*dz

                    Q(i,j,k,:)    = SIN(2.0*pi*x)*SIN(2.0*pi*y)*SIN(2.0*pi*z)
                    RQex(i,j,k,:) = -12.0*pi*pi*SIN(2.0*pi*x)*SIN(2.0*pi*y)*SIN(2.0*pi*z)

                END DO
            END DO
        END DO

        !$OMP PARALLEL DO schedule(static)
        DO nt=0,Nthreads-1
            CALL GetRHSDiffusion(Q(:,:,:,nt), RQ(:,:,:,nt), dx, dy, dz, i_start, i_end, j_start, j_end, k_start, k_end, order)
        END DO
        !$OMP END PARALLEL DO

        err_v(nn) = MAXVAL(ABS(RQ(i_start:i_end,j_start:j_end,k_start:k_end,:) &
            -RQex(i_start:i_end,j_start:j_end,k_start:k_end,:)))/MAXVAL(ABS(RQex(i_start:i_end,j_start:j_end,k_start:k_end,:)))

        DEALLOCATE(Q)
        DEALLOCATE(RQ)
        DEALLOCATE(RQex)

    END DO

    DO nn=2,SIZE(N_v)
        convrate(nn-1) = LOG10(err_v(nn)/err_v(nn-1)) / LOG10( DBLE(N_v(nn-1)) / DBLE(N_v(nn)) )
    END DO

    IF (MINVAL(convrate)<=0.95*order) THEN
        WRITE(*,'(A, I1)') 'ERROR: Failed to verify convergence order for order = ', order
        DO nn=1,SIZE(N_v)
            WRITE(*,'(F9.3)') convrate(nn)
        END DO
        STOP
    END IF

    DEALLOCATE(err_v)
    DEALLOCATE(convrate)

END DO

CALL MPI_FINALIZE(ierr)

PRINT*, '\x1B[32m[0] -- Successful: Diffusion module produces expected rates of convergence.\x1B[0m'

END PROGRAM diffusion_test