module test_trapz
    use stdlib_kinds, only: sp, dp, qp
    use testdrive, only : new_unittest, unittest_type, error_type, check
    use stdlib_quadrature, only: trapz, trapz_weights

    implicit none

contains

    !> Collect all exported unit tests
    subroutine collect_trapz(testsuite)
        !> Collection of tests
        type(unittest_type), allocatable, intent(out) :: testsuite(:)

        testsuite = [ &
            new_unittest("trapz_sp", test_trapz_sp), &
            new_unittest("trapz_dp", test_trapz_dp), &
            new_unittest("trapz_qp", test_trapz_qp), &
            new_unittest("trapz_weights_sp", test_trapz_weights_sp), &
            new_unittest("trapz_weights_dp", test_trapz_weights_dp), &
            new_unittest("trapz_weights_qp", test_trapz_weights_qp), &
            new_unittest("trapz_zero_sp", test_trapz_zero_sp), &
            new_unittest("trapz_zero_dp", test_trapz_zero_dp), &
            new_unittest("trapz_zero_qp", test_trapz_zero_qp) &
            ]
    end subroutine collect_trapz

    subroutine test_trapz_sp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 17
        real(sp), dimension(n) :: y
        real(sp), dimension(n) :: x
        real(sp) :: val
        real(sp) :: ans
        integer :: i

        y = [(real(i-1, sp), i = 1, n)]

        val = trapz(y, 1.0_sp)
        ans = 128.0_sp
        call check(error, abs(val - ans) < epsilon(ans))

        val = trapz(y, 0.5_sp)
        ans = 64.0_sp
        call check(error, abs(val - ans) < epsilon(ans))

        x = [((i-1)*4.0_sp/real(n-1, sp), i = 1, n)]
        val = trapz(y, x)
        ans = 32.0_sp
        call check(error, abs(val - ans) < epsilon(ans))

        x = y**2
        val = trapz(y, x)
        ans = 2728.0_sp
        call check(error, abs(val - ans) < epsilon(ans))
    end subroutine test_trapz_sp

    subroutine test_trapz_dp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 17
        real(dp), dimension(n) :: y
        real(dp), dimension(n) :: x
        real(dp) :: val
        real(dp) :: ans
        integer :: i

        y = [(real(i-1, dp), i = 1, n)]

        val = trapz(y, 1.0_dp)
        ans = 128.0_dp
        call check(error, abs(val - ans) < epsilon(ans))

        val = trapz(y, 0.5_dp)
        ans = 64.0_dp
        call check(error, abs(val - ans) < epsilon(ans))

        x = [((i-1)*4.0_dp/real(n-1, dp), i = 1, n)]
        val = trapz(y, x)
        ans = 32.0_dp
        call check(error, abs(val - ans) < epsilon(ans))

        x = y**2
        val = trapz(y, x)
        ans = 2728.0_dp
        call check(error, abs(val - ans) < epsilon(ans))
    end subroutine test_trapz_dp

    subroutine test_trapz_qp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 17
        real(qp), dimension(n) :: y
        real(qp), dimension(n) :: x
        real(qp) :: val
        real(qp) :: ans
        integer :: i

        y = [(real(i-1, qp), i = 1, n)]

        val = trapz(y, 1.0_qp)
        ans = 128.0_qp
        call check(error, abs(val - ans) < epsilon(ans))

        val = trapz(y, 0.5_qp)
        ans = 64.0_qp
        call check(error, abs(val - ans) < epsilon(ans))

        x = [((i-1)*4.0_qp/real(n-1, qp), i = 1, n)]
        val = trapz(y, x)
        ans = 32.0_qp
        call check(error, abs(val - ans) < epsilon(ans))

        x = y**2
        val = trapz(y, x)
        ans = 2728.0_qp
        call check(error, abs(val - ans) < epsilon(ans))
    end subroutine test_trapz_qp

    subroutine test_trapz_weights_sp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 17
        real(sp), dimension(n) :: y
        real(sp), dimension(n) :: x
        real(sp), dimension(n) :: w
        integer :: i
        real(sp) :: val
        real(sp) :: ans

        y = [(real(i-1, sp), i = 1, n)]

        x = y
        w = trapz_weights(x)
        val = dot_product(w, y)
        ans = trapz(y, x)
        call check(error, abs(val - ans) < epsilon(ans))

        x = y**2
        w = trapz_weights(x)
        val = dot_product(w, y)
        ans = trapz(y, x)
        call check(error, abs(val - ans) < epsilon(ans))

    end subroutine test_trapz_weights_sp

    subroutine test_trapz_weights_dp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 17
        real(dp), dimension(n) :: y
        real(dp), dimension(n) :: x
        real(dp), dimension(n) :: w
        integer :: i
        real(dp) :: val
        real(dp) :: ans

        y = [(real(i-1, dp), i = 1, n)]

        x = y
        w = trapz_weights(x)
        val = dot_product(w, y)
        ans = trapz(y, x)
        call check(error, abs(val - ans) < epsilon(ans))

        x = y**2
        w = trapz_weights(x)
        val = dot_product(w, y)
        ans = trapz(y, x)
        call check(error, abs(val - ans) < epsilon(ans))

    end subroutine test_trapz_weights_dp

    subroutine test_trapz_weights_qp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 17
        real(qp), dimension(n) :: y
        real(qp), dimension(n) :: x
        real(qp), dimension(n) :: w
        integer :: i
        real(qp) :: val
        real(qp) :: ans

        y = [(real(i-1, qp), i = 1, n)]

        x = y
        w = trapz_weights(x)
        val = dot_product(w, y)
        ans = trapz(y, x)
        call check(error, abs(val - ans) < epsilon(ans))

        x = y**2
        w = trapz_weights(x)
        val = dot_product(w, y)
        ans = trapz(y, x)
        call check(error, abs(val - ans) < epsilon(ans))

    end subroutine test_trapz_weights_qp

    subroutine test_trapz_zero_sp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        real(sp), dimension(0) :: a

        call check(error, abs(trapz(a, 1.0_sp)) < epsilon(0.0_sp))
        call check(error, abs(trapz([1.0_sp], 1.0_sp)) < epsilon(0.0_sp))
        call check(error, abs(trapz(a, a)) < epsilon(0.0_sp))
        call check(error, abs(trapz([1.0_sp], [1.0_sp])) < epsilon(0.0_sp))
    end subroutine test_trapz_zero_sp

    subroutine test_trapz_zero_dp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        real(dp), dimension(0) :: a

        call check(error, abs(trapz(a, 1.0_dp)) < epsilon(0.0_dp))
        call check(error, abs(trapz([1.0_dp], 1.0_dp)) < epsilon(0.0_dp))
        call check(error, abs(trapz(a, a)) < epsilon(0.0_dp))
        call check(error, abs(trapz([1.0_dp], [1.0_dp])) < epsilon(0.0_dp))
    end subroutine test_trapz_zero_dp

    subroutine test_trapz_zero_qp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        real(qp), dimension(0) :: a

        call check(error, abs(trapz(a, 1.0_qp)) < epsilon(0.0_qp))
        call check(error, abs(trapz([1.0_qp], 1.0_qp)) < epsilon(0.0_qp))
        call check(error, abs(trapz(a, a)) < epsilon(0.0_qp))
        call check(error, abs(trapz([1.0_qp], [1.0_qp])) < epsilon(0.0_qp))
    end subroutine test_trapz_zero_qp

end module test_trapz

program tester
    use, intrinsic :: iso_fortran_env, only : error_unit
    use testdrive, only : run_testsuite, new_testsuite, testsuite_type
    use test_trapz, only : collect_trapz
    implicit none
    integer :: stat, is
    type(testsuite_type), allocatable :: testsuites(:)
    character(len=*), parameter :: fmt = '("#", *(1x, a))'

    stat = 0

    testsuites = [ &
        new_testsuite("trapz", collect_trapz) &
        ]

    do is = 1, size(testsuites)
        write(error_unit, fmt) "Testing:", testsuites(is)%name
        call run_testsuite(testsuites(is)%collect, error_unit, stat)
    end do

    if (stat > 0) then
        write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
        error stop
    end if
end program


	SUBROUTINE DEGRADE_RESOLUTION(X,Y,N,FWHMS,XS,YS,NS)

c	Degrades STELIB sed in (x,y) to lower resolution sed by applying a
c	gaussian broadening function. The FWHM of the gaussian is supposed
c	to be constant (= FWHM) as a function of wavelength.

c	Returns smoothed spectrum in array (x,ys)

c	Array declaration
	real x(n),y(n),xs(n),ys(n),u(1000),g(1000)

c	Check if fwhms = 0
	if (fwhms.le.0) then
		ns=n
		do i=1,ns
		xs(i)=x(i)
		ys(i)=y(i)
		enddo
		return
	endif

c	Number of sigmas to perform integration
	m=6

c	FWHM of STELIB seds = 3 A (Leborgne et al. 2002)
	fwhm_stelib = 3.

c	Perform smoothing
	fwhm2 = fwhms**2 - fwhm_stelib**2
	fwhm  = sqrt(fwhm2)

c	Note: FWHM = 2*sqrt[2*ln(2)]*sigma = 2.3548*sigma
	sigma=fwhm/2.3548
	do i=1,n
	xmax=x(i)+m*sigma
	call locate(x,n,xmax,i1)
	m2=i1+1
	m1=2*i-m2
	if (m1.lt.1) m1=1
	if (m2.gt.n) m2=n
	k=0
	do j=m1,m2
	k=k+1
	u(k)=x(j)
	g(k)=y(j)*gauss(x(j),x(i),sigma)
	enddo
	ys(i)=trapz1(u,g,k)
	xs(i)=x(i)
	enddo

c	Suppress points at both ends of smoothed sed
	k=fwhms
c	Not really
	k=0
	ns=0
	do i=1+k,n-k
	ns=ns+1
	xs(ns)=xs(i)
	ys(ns)=ys(i)
	enddo

	return
	end


!==========================================
! particle2d.f90
! Author: Devansh Shukla
!------------------------------------------
program particle_2D
    ! Program to compute motion of a particle moving in a circle with uniform velocity

    implicit none
    real*8 :: x0, y0, t0, tf, dt, t
    real*8 :: x, y, vx, vy, lx0, lx1, ly0, ly1
    character(len=*), parameter :: fmt1 = "(F10.4,x,F10.4,x,F10.4,x,F10.4,x,F10.4)"

    open(unit=8, file="Particle2D.dat")

    print *, "---------------------------------------"
    print *, "Enter initial position x0, y0"
    read *, x0, y0

    print *, "Enter velocity vx, vy"
    read *, vx, vy

    print *, "Enter bounds lx0, lx1"
    read *, lx0, lx1

    print *, "Enter bounds ly0, ly1"
    read *, ly0, ly1

    print *, "Enter t0, tf, dt"
    read *, t0, tf, dt
    print *, "---------------------------------------"

    print "(x,A,F10.4,F10.4)", "x0, y0=", x0, y0
    print "(x,A,F10.4,F10.4)", "lx0, lx1=", lx0, lx1
    print "(x,A,F10.4,F10.4)", "ly0, ly1=", ly0, ly1
    print "(x,A,F10.4,F10.4,F10.4)", "t0, tf, dt=", t0, tf, dt
    print *, "---------------------------------------"

    print "(A10,A10,A10,xA10,xxA10)", "time", "x(t)", "y(t)", "vx(t)", "vy(t)"
    t = t0
    x = x0
    y = y0
    ! Formatting l0, l1 to our standards for fortran floating point arithmatic
    lx1 = lx1 - dt
    ly1 = ly1 - dt
    do while (t <= tf)
        write (*, fmt1) t, x, y, vx, vy
        write (8, fmt1) t, x, y, vx, vy
        x = x + vx * dt
        y = y + vy * dt
        t = t + dt
        if (x < lx0 .or. x > lx1) vx = -vx
        if (y < ly0 .or. y > ly1) vy = -vy
    enddo
    print *, "---------------------------------------"
    close(8)
end program particle_2D


!
! Test_ApodFunction
!
! Program to test the FFT Spectral Utility ApodFunction procedure
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 26-Nov-2006
!                       paul.vandelst@noaa.gov

PROGRAM Test_ApodFunction

  ! Environment setup
  ! ...Module use
  USE Type_Kinds          , ONLY: fp=>fp_kind
  USE File_Utility        , ONLY: Get_Lun
  USE Message_Handler     , ONLY: SUCCESS, Program_Message
  USE FFT_Spectral_Utility, ONLY: ApodFunction     , &
                                  BARTLETT         , &
                                  WELCH            , &
                                  CONNES           , &
                                  COSINE           , &
                                  HAMMING          , &
                                  HANNING          , &
                                  NORTONBEER_WEAK  , &
                                  NORTONBEER_MEDIUM, &
                                  NORTONBEER_STRONG, &
                                  BLACKMANHARRIS_3 , &
                                  BLACKMANHARRIS_4 , &
                                  BLACKMANHARRIS_4M, &
                                  FFT_Spectral_UtilityVersion
  ! ...Disable all implicit typing
  IMPLICIT NONE

  ! Parameters
  CHARACTER(*),  PARAMETER :: PROGRAM_NAME   = 'Test_ApodFunction'
  CHARACTER(*),  PARAMETER :: PROGRAM_VERSION_ID = &
  INTEGER,  PARAMETER :: N = 1000
  INTEGER,  PARAMETER :: NHALF = N/2
  REAL(fp), PARAMETER :: MAXX = 1.0_fp
  REAL(fp), PARAMETER :: ONE = 1.0_fp
  INTEGER,  PARAMETER :: NAPOD = 12
  INTEGER,  PARAMETER :: IAPOD(NAPOD) = (/ BARTLETT         , &
                                           WELCH            , &
                                           CONNES           , &
                                           COSINE           , &
                                           HAMMING          , &
                                           HANNING          , &
                                           NORTONBEER_WEAK  , &
                                           NORTONBEER_MEDIUM, &
                                           NORTONBEER_STRONG, &
                                           BLACKMANHARRIS_3 , &
                                           BLACKMANHARRIS_4 , &
                                           BLACKMANHARRIS_4M /)
  CHARACTER(*), PARAMETER :: CAPOD(NAPOD) = (/ 'BARTLETT         ', &
                                               'WELCH            ', &
                                               'CONNES           ', &
                                               'COSINE           ', &
                                               'HAMMING          ', &
                                               'HANNING          ', &
                                               'NORTONBEER_WEAK  ', &
                                               'NORTONBEER_MEDIUM', &
                                               'NORTONBEER_STRONG', &
                                               'BLACKMANHARRIS_3 ', &
                                               'BLACKMANHARRIS_4 ', &
                                               'BLACKMANHARRIS_4M' /)

  ! Variables
  CHARACTER(256) :: Id
  INTEGER :: i, fileId
  REAL(fp), DIMENSION(N) :: x, y

  ! Output header
  CALL Program_Message( PROGRAM_NAME, &
                        'Program to test the ApodFunction procedure.', &
                        '$Revision: $' )

  ! Version output
  CALL FFT_Spectral_UtilityVersion(Id)
  WRITE( *,'(a)' ) TRIM(Id)

  ! Create optical delay array
  x(NHALF:N)   = MAXX * (/(REAL(i,fp),i=0,NHALF)/) / REAL(NHALF,fp)
  x(1:NHALF-1) = -ONE * x(N-1:NHALF+1:-1)

  ! Open ASCII file for viewing results
  fileId=Get_Lun()
  OPEN(fileId,FILE='Test_ApodFunction.dat',STATUS='UNKNOWN')
  WRITE(fileId,*) NAPOD+1, N
  WRITE(fileId,*) x

  ! Call the function repeatedly
  WRITE(*, '(/5x,"Computing apodisation function...")')
  DO i=1,NAPOD
    WRITE(*, '(7x,a)') CAPOD(i)
    y=ApodFunction(n, apodType=i)
    WRITE(fileId,*) CAPOD(i)
    WRITE(fileId,*) y
  END DO

  ! Default option
  WRITE(*, '(7x,a)')'DEFAULT'
  y=ApodFunction(n)
  WRITE(fileId,*) 'DEFAULT'
  WRITE(fileId,*) y

  CLOSE(fileId)

END PROGRAM Test_ApodFunction


subroutine geometry_multigrid(dx_mg, dy_mg, delx_mg, dely_mg, imax, jmax)
use kind_parameters
implicit none

integer, intent(in):: imax, jmax
real(kind=dp), intent(inout), dimension(imax):: dx_mg
real(kind=dp), intent(inout), dimension(jmax)::  dy_mg
real(kind=dp), intent(inout), dimension(imax-1):: delx_mg
real(kind=dp), intent(inout), dimension(jmax-1):: dely_mg
real(kind=dp):: Lx, Ly, it, jt

Lx = 0.10d0
Ly = 0.10d0

! Calculate control volumes

dx_mg(1) = 0.0

do it=2,imax-1

 dx_mg(it) = Lx/(imax-2)

end do

dx_mg(imax) = 0.0

dy_mg(1) = 0.0

do jt = 2,jmax-1

 dy_mg(jt) = Ly/(jmax-2)

end do

dy_mg(jmax) = 0.0

! Calculate diffusion lengths

delx_mg(1) = 0.5*dx_mg(2)

do it = 2,imax-2

 delx_mg(it) = 0.5*(dx_mg(it)+dx_mg(it+1))

end do

delx_mg(imax-1) = 0.5*dx_mg(imax-1)

dely_mg(1) = 0.5*dy_mg(2)

do jt = 2,jmax-2

 dely_mg(jt) = 0.5*(dy_mg(jt) + dy_mg(jt+1))

end do

dely_mg(jmax-1) = 0.5*dy_mg(jmax-1)

end subroutine


      subroutine dmmul(A , na, B, nb, C, nc, l, m, n)
*
*     PURPOSE
*        computes the matrix product C = A * B
*            C   =   A   *   B
*          (l,n)   (l,m) * (m,n)
*
*     PARAMETERS
*        input
*        -----
*        A : (double) array (l, m) with leading dim na
*
*        B : (double) array (m, n) with leading dim nb
*
*        na, nb, nc, l, m, n : integers
*
*        output
*        ------
*        C : (double) array (l, n) with leading dim nc
*
*     NOTE
*        (original version substituted by a call to the blas dgemm)

      implicit none

      integer na, nb, nc, l, m, n
      double precision A(na,m), B(nb,n), C(nc,n)

      call dgemm('n','n', l, n, m, 1.d0, A, na, B, nb, 0.d0, C, nc)

      end


 subroutine apply_Gaussian_function( &
     slitfwhm,              nwave,                 wavelength,            &
     solar_irradiance,      earthray_radiance,     earth_radiance,        &
     solar_irradiance_sat,  earthray_radiance_sat, &
     earth_radiance_sat)

!-----------------------------------------------------------
! Subroutine:
!
! Purpose:
!
! Output:
!
!------------------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8) !double precision

! atmospheric signal ---------------------------------

  integer,intent(in):: &
    nwave

  real(kind=dp),intent(in):: &
    wavelength(nwave),        &
    earthray_radiance(nwave), &
    earth_radiance(nwave),    &
    solar_irradiance(nwave)

! instrument ------------------------

! nwave_sat == nwave in this function

  real(kind=dp),intent(in):: &
    slitfwhm

  real(kind=dp):: &
    slitfwhm_cm1

  integer:: &
     i,   &
     ii,  &
     di

  real(kind=dp):: &
     funk,      &
     normfunk

! function
  real(kind=dp),external:: &
     GaussianResp

  real(kind=dp),intent(out):: &
    earthray_radiance_sat(nwave), &
    earth_radiance_sat(nwave), &
    solar_irradiance_sat(nwave)

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

  do i=1,nwave
    earth_radiance_sat(i)    = 0.d0
    earthray_radiance_sat(i) = 0.d0
    solar_irradiance_sat(i)  = 0.d0
  enddo

  di = 80 ! cm-1

  do i=1+di,nwave-di

     normfunk = 0.d0

     ! nm -> cm-1
     slitfwhm_cm1 = 0.5* (dabs(1e7/(wavelength(i)-slitfwhm)-1e7/wavelength(i)) +  &
                          dabs(1e7/(wavelength(i)+slitfwhm)-1e7/wavelength(i)) )

     do ii=-di,di
        funk = GaussianResp(dble(ii),slitfwhm_cm1)

        normfunk = normfunk + funk

        earth_radiance_sat(i) = earth_radiance_sat(i) + &
                                 funk * earth_radiance(i+ii)

        earthray_radiance_sat(i) = earthray_radiance_sat(i) + &
                                 funk * earthray_radiance(i+ii)

        solar_irradiance_sat(i) = solar_irradiance_sat(i) + &
                                   funk * solar_irradiance(i+ii)
     enddo

     if(normfunk.ne.0.d0)then
        earth_radiance_sat(i)    = earth_radiance_sat(i)/normfunk
        earthray_radiance_sat(i) = earthray_radiance_sat(i)/normfunk
        solar_irradiance_sat(i)  = solar_irradiance_sat(i)/normfunk
     endif

  enddo

  return
  end subroutine apply_Gaussian_function

!------------------------------------------------------------
! Gaussian response function
!------------------------------------------------------------
  function GaussianResp(x, slitfwhm_cm1)
  implicit none
  integer,parameter::dp=selected_real_kind(8) !double precision
  real(kind=dp),intent(in):: &
      x,        & !wavenr
      slitfwhm_cm1    !slitfwhm_cm1
  real(kind=dp)::pi,sigma
  real(kind=dp)::GaussianResp
  if(abs(x).ge.4.d0*slitfwhm_cm1)then
     GaussianResp = 0.d0
     return
  endif
  GaussianResp = 1.d0
  pi = 2.d0*asin(1.d0)
  sigma = slitfwhm_cm1/(2.d0*sqrt(2.d0*log(2.d0)))
  GaussianResp = exp(-x*x/(2.d0*sigma*sigma)) !/(sigma*sqrt(2.d0*pi))
  return
  end function GaussianResp


!> Called before each call to step2.
!! Use to set time-dependent aux arrays or perform other tasks.
!!
!! This default version does nothing.

subroutine clawpack46_b4step2(maxmx,maxmy,mbc,mx,my,meqn,q,xlower,ylower, &
    dx,dy,t,dt,maux,aux)

    implicit none
    integer maxmx, maxmy, mbc,mx,my,meqn,maux
    double precision  xlower,ylower,dx,dy,t,dt
    double precision  q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
    double precision  aux(1-mbc:mx+mbc,1-mbc:my+mbc,maux)

    integer i,j
    double precision xc,yc, vel(3)

    !! # Cell-centered velocities : entries (4,5,6)
    DO i = 1-mbc,mx+mbc
        DO j = 1-mbc,my+mbc
            xc = xlower + (i-0.5)*dx
            yc = ylower + (j-0.5)*dy

            CALL annulus_center_velocity(xc,yc,t, vel)

            aux(i,j,2) = vel(1)
            aux(i,j,3) = vel(2)
        end do
    end do

end subroutine clawpack46_b4step2


! 6.2.4 Matrix distribution
! Distribute a global N x N matrix over P processes so that each process has a
! local portion of it in its memory.  Initialize such a portion with the process
! rank.  N is not necessarily divisible by P.
! Each process sends its first and last columns (in F) to neighbors: the fist to
! the left rank, the last to the right rank.  Each process must allocate extra
! ghost cells with two columns.
!
! Compile and run:
! $ mpifort -O0 -Wall -Wextra -fcheck=bounds -fbacktrace parallel_sum.f90
! $ mpirun -np 3 --oversubscribe ./a.out
! Enter size 10.
program matrix_distribution
    use mpi_f08
    implicit none

    integer, parameter :: N = 10
    integer :: my_rank, n_ranks, left_rank, right_rank, r
    type(MPI_Status) :: status
    type(MPI_Comm) :: comm = MPI_COMM_WORLD
    integer :: remainder, n_col, row
    integer, allocatable :: matrix(:, :)

    call MPI_Init()
    call MPI_Comm_rank(comm, my_rank)
    call MPI_Comm_size(comm, n_ranks)

    left_rank  = mod(n_ranks + my_rank - 1, n_ranks)
    right_rank = mod(n_ranks + my_rank + 1, n_ranks)

    remainder = mod(N, n_ranks)
    n_col     = (N - remainder) / n_ranks ! this is the quotient
    ! First processes have one extra column for even division.
    if (my_rank < remainder) then
        n_col = n_col + 1
    end if

    allocate(matrix(N, 0:n_col + 1))
    matrix(:, :) = my_rank

    ! If you don't use MPI_Sendrecv but use a pair of MPI_Send--MPI_Recv, then
    ! you must take care of a possible deadlock yourself.
    call MPI_Sendrecv(                                       &
        matrix(1,         1), N, MPI_INTEGER, left_rank,  0, &
        matrix(1, n_col + 1), N, MPI_INTEGER, right_rank, 0, comm, status)
    call MPI_Sendrecv(                                   &
        matrix(1, n_col), N, MPI_INTEGER, right_rank, 1, &
        matrix(1,     0), N, MPI_INTEGER, left_rank,  1, comm, status)

    do r = 0, n_ranks - 1
        if (r == my_rank) then
            print '(a, i0)', "Rank ", my_rank
            do row = 1, N
                print '(*(i0, 2x))', matrix(row, :)
            end do
        end if
        call MPI_Barrier(comm)
    end do

    deallocate(matrix)
    call MPI_Finalize()
end program matrix_distribution


      SUBROUTINE UPINV(RIN,N, ROUT, W )                                 UPIN0010
C                                                                       UPIN0020
C           THIS SUBROUTINE  INVERTS  A  PACKED  UPPER  TRIANGULAR      UPIN0030
C           MATRIX  RIN, AND  STORES THE INVERSE  IN  ROUT              UPIN0040
C                                                                       UPIN0050
C           RIN AND ROUT  ARE BOTH SINGLE DIMENSIONED  ARRAYS           UPIN0060
C           IN WHICK THE MATRIX IS STORED  COLUMNWISE                   UPIN0070
C                                                                       UPIN0080
C           RIN  CAN  EQUAL ROUT                                        UPIN0090
C                                                                       UPIN0100
      DOUBLE PRECISION  RIN(1), ROUT(1), W(1), WORK, ONE, ZERO ,DIN     UPIN0110
      DATA  ONE/1.0D0/,ZERO/ 0.0D0/                                     UPIN0120
      IPV =   N*(N+1)/2                                                 UPIN0130
      IN  = IPV                                                         UPIN0140
      DO 6    I=1,N                                                     UPIN0150
      DIN   =        ONE/ RIN(IPV)                                      UPIN0160
      ROUT( IPV )  = DIN                                                UPIN0170
      MIN =N                                                            UPIN0180
      KEND = I-1                                                        UPIN0190
      LANF  =   N - KEND                                                UPIN0200
      IF(KEND) 5, 5, 2                                                  UPIN0210
    2 J= IN                                                             UPIN0220
C                                                                       UPIN0230
C             INITIALIZE  ROW LOOP                                      UPIN0240
C                                                                       UPIN0250
      DO 4   K=1,KEND                                                   UPIN0260
      WORK =ZERO                                                        UPIN0270
      MIN= MIN -  1                                                     UPIN0280
      LIN= IPV                                                          UPIN0290
      LOT= J                                                            UPIN0300
C                                                                       UPIN0310
C            START  INNER LOOP                                          UPIN0320
C                                                                       UPIN0330
      DO 3   L=LANF, MIN                                                UPIN0340
      LIN= LIN+L                                                        UPIN0350
      LOT= LOT+1                                                        UPIN0360
    3 WORK = WORK  + RIN(LIN)* ROUT(LOT)                                UPIN0370
      ROUT(J)  =   -WORK* DIN                                           UPIN0380
   4  J=  J- MIN                                                        UPIN0390
    5 IPV =  IPV -MIN                                                   UPIN0400
    6 IN= IN -1                                                         UPIN0410
      RETURN                                                            UPIN0420
      END                                                               UPIN0430


! normal_quad.f90 -- Gauss-Hermite integration of Normal expectation
!
! Copyright (C) 2011 Jason R. Blevins
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
! 1. Redistributions of source code must retain the above copyright
!    notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
!    notice, this list of conditions and the following disclaimer in the
!    documentation  and/or other materials provided with the distribution.
! 3. Neither the names of the copyright holders nor the names of any
!    contributors may be used to endorse or promote products derived from
!    this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.

program normal_quad
  implicit none

  ! Mathematical constants
  real, parameter :: SQRT2 = 1.4142135623730950488016887242096981
  real, parameter :: SQRTPI = 1.7724538509055160272981674833411452

  ! Order of quadrature
  integer, parameter :: n = 8

  ! Parameters of Normal distribution
  real, parameter :: mu = 2.0
  real, parameter :: sigma = 5.0

  ! Local variables
  real, dimension(:), allocatable :: x, w, z, zw
  real :: zwsum, int
  integer :: i

  ! Allocate memory
  allocate(x(n), w(n), z(n), zw(n))

  ! Set up Gauss-Hermite quadrature
  select case (n)
  case (3)

     x = [ -1.22474, 0.0,     1.22474  ]
     w = [ 0.295409, 1.18164, 0.295409 ]

  case (5)

     x = [ -2.02018287046, -0.958572464614, 0.0, 0.958572464614, 2.02018287046 ]
     w = [ 0.019953242059, 0.393619323152, 0.945308720483, 0.393619323152, 0.019953242059 ]

  case (8)

     x = [ -2.930637420257244, -1.981656756695843, -1.157193712446780, &
           -0.3811869902073221, 0.3811869902073221, 1.157193712446780, &
            1.981656756695843, 2.930637420257244 ]
     w = [ 0.000199604072211, 0.0170779830074, 0.207802325815, &
           0.661147012558, 0.661147012558, 0.207802325815, &
           0.0170779830074, 0.000199604072211 ]

  end select

  ! Transform weights and abscissas to approximate expectation of func
  ! with respect to Z \sim N(mu, sigma^2).
  z = mu + SQRT2 * sigma * x
  zw = w / SQRTPI
  zwsum = sum(zw)

  ! Perform quadrature
  int = 0.0
  do i = 1, n
     int = int + zw(i) * func(z(i))
  end do
  int = int / zwsum

  print *, 'E[func(Z)] with Z ~ N(mu, sigma^2) = ', int

  ! Deallocate memory
  deallocate(x, w, z, zw)

contains

  function func(z) result(f)
    real, intent(in) :: z
    real :: f
    f = (z - mu)**2
  end function func

end program normal_quad


SUBROUTINE gauss_band(pb,work)
!
! This subroutine performs gaussian reduction of an unsymmetric
! banded matrix pb. Array work used as working space.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN OUT)::pb(:,:),work(:,:)
 REAL(iwp)::s,zero=0.0_iwp,small=1.e-10_iwp
 INTEGER::n,iwp1,iq,iqp,iwp11,i,j,k,l,ip,k1
 n=UBOUND(pb,1)
 iwp1=(UBOUND(pb,2)-1)/2+1
 iq=2*iwp1-1
 iqp=iwp1
 iwp11=iwp1-1
 DO i=1,iwp11
   DO j=1,iq
     IF(j>=iwp1+i)THEN
       pb(i,j)=zero
       pb(n-i+1,j)=zero
     ELSE
       pb(i,j)=pb(i,j+iwp1-i)
     END IF
   END DO
 END DO
 DO k=1,n
   l=k+iwp1-1
   IF(l>n)l=n
   ip=0
   s=small
   DO i=k,l
     IF(ABS(pb(i,1))<=s)CYCLE
     s=ABS(pb(i,1))
     ip=i
   END DO
   IF(ip==0)THEN
     WRITE(6,'("singular")')
     EXIT
   END IF
   IF(k==n)EXIT
   work(iwp1,k)=ip
   iqp=iqp-1
   j=iwp1+ip-k
   IF(iqp<j)iqp=j
   IF(j/=iwp1)THEN
     DO j=1,iqp
       s=pb(k,j)
       pb(k,j)=pb(ip,j)
       pb(ip,j)=s
     END DO
   END IF
   k1=k+1
   DO i=k1,l
     s=pb(i,1)/pb(k,1)
     DO j=2,iq
       IF(j>iqp)THEN
         pb(i,j-1)=pb(i,j)
       ELSE
         pb(i,j-1)=pb(i,j)-s*pb(k,j)
       END IF
     END DO
     pb(i,iq)=zero
     work(i-k,k)=s
   END DO
 END DO
RETURN
END SUBROUTINE gauss_band


c=======================================================================
c
c     subroutine GLKERN
c
c     GENERAL SUBROUTINE FOR KERNEL SMOOTHING:
c     COMPUTATION OF ITERATIVE PLUG-IN ALGORITHM FOR GLOBAL BANDWIDTH
c     SELECTION FOR KERNELS WITH (NUE,KORD) = (0,2),(0,4),(1,3) OR (2,4).
c
c     THE RAW DATA SHOULD BE GIVEN BY THE POINTS (T(1),X(1)),...,(T(N),X(N))
c
c     THE RESULTING ESTIMATOR OF THE NUE-TH DERIVATIVE OF THE
c     REGRESSION CURVE IS GIVEN THROUGH THE POINTS
c     (TT(1),Y(1)),...,(TT(M),Y(M))
c
c     THE PLUG-IN BANDWIDTH IS GIVEN BY B
c
c-----------------------------------------------------------------------
      SUBROUTINE GLKERN(T, X, N, TT, M, IHOM, NUE, KORD, IRND,
     &                  ISMO, M1, TL, TU, S, SIG, WN, W1, B, Y)
C----------------------------------------------------------------------
C
C  INPUT    T(N)         INPUT GRID (T(1)<T(2)<...<T(N))
C  INPUT    X(N)         DATA
C  INPUT    N            LENGTH OF X
C
C  INPUT    TT(M)        OUTPUT GRID, SHOULD BE ORDERED
C  INPUT    M            LENGTH OF TT
C
C  INPUT    IHOM         HOMOSZEDASTICY OF VARIANCE
C                        0: HOMOSZEDASTIC ERROR VARIABLES,
C                        <> 0: IF THE VARIANCE SHOULD ESTIMATED AS
C                              SMOOTH FUNCTION.
C                        ****** DEFAULT VALUE: IHOM=0
C
C  INPUT    NUE          ORDER OF DERIVATIVE (0-4) OF THE REGRESSION
C                        FUNCTION WHICH SHALL BE ESTIMATED
C                        ****** DEFAULT VALUE: NUE=0
C
C  INPUT    KORD         ORDER OF KERNEL (<=6), FOR ISMO=0  ONLY
C                        NUE=0, KORD=2 OR KORD=4
C                        OR NUE=1, KORD=3 OR NUE=2, KORD=4 ARE ALLOWED
C                        ****** DEFAULT VALUE: KORD=NUE+2
C
C  INPUT    IRND         0: IF RANDOM GRID POINTS T MAY OCCUR
C                        <>0 ELSE  (ONLY NECESSARY IF S SHOULD BE
C                            COMPUTED)
C                        ****** DEFAULT VALUE IRND=0
C
C  INPUT    ISMO         0:ESTIMATING THE OPTIMAL GLOBAL BANDWIDTH
C                        <>0 USING GLOBAL INPUT BANDWIDTH B
C                        ****** DEFAULT VALUE ISMO=0
C
C  INPUT    M1           >=10, LENGTH OF W1, LARGE VALUES WILL INCREASE
C                        THE ACCURACY OF THE INTEGRAL APPROXIMATION
C                        ****** DEFAULT VALUE: M1=400
C
C IN/OUTPUT TL/TU        LOWER/UPPER BOUND FOR INTEGRAL APPROXIMATION
C                        AND VARIANCE ESTIMATION (IF SIG=0 AND IHOM=0),
C                        IF TU<=TL, [TL,TU] ARE COMPUTED AS ABOUT
C                        THE 87% MIDDLE PART OF [T(1),T(N)]
C                        ****** DEFAULT VALUES: TL=1.0, TU=0.0
C
C IN/OUTPUT S(0:N)       IF S(N)<=S(0) THIS ARRAY IS COMPUTED AS
C                        MIDPOINTS OF T, FOR NON-RANDOM DESIGN AND AS
C                        SMOOTHED QUANTILES FOR RANDOM DESIGN
C                        ****** DEFAULT VALUES: S(0)=1.0, S(N)=0.0
C                               AND THE OTHER S(I) CAN BE UNDEFINED
C
C IN/OUTPUT SIG          RESIDUAL VARIANCE, ESTIMATED FOR SIG=0 OR
C                        IHOM<>0, ELSE GIVEN BY INPUT
C                        ****** DEFAULT VALUE: SIG=-1.0
C
C IN/OUTPUT B            GLOBAL PLUG-IN BANDWIDTH
C                        ****** B CAN BE UNDIFINED IF ISMO=0
C
C
C WORK     WN(0:N,5)     WORK ARRAY FOR KERNEL SMOOTHING ROUTINE
C                        OR NUE=1, KORD=3 OR NUE=2, KORD=4 ARE ALLOWED
C                        ****** WILL BE SET IN SUBROUTINE
C WORK     W1(M1,3)      WORK ARRAY FOR INTEGRAL APPROXIMATION
C                        ****** WILL BE SET IN SUBROUTINE
C
C OUTPUT   Y(M)          KERNEL ESTIMATE WITH BOP(=B0 FOR ISMO<>0)
C                        ****** WILL BE SET IN SUBROUTINE
C-----------------------------------------------------------------------
C  USED SUBROUTINES: COFF, RESEST, KERNEL WITH FURTHER SUBROUTINES
C                    WHICH ARE CONTAINED IN THE FILE subs.f
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION X(N),T(N),TT(M),Y(M),WN(0:N,5),S(0:N)
      DIMENSION W1(M1,3)
      DIMENSION BIAS(2,0:2),VARK(2,0:2),FAK2(2:4)
C-
C-------- 1. INITIALISATIONS AND SOME ERROR-CHECKS
      DATA BIAS/.2,.04762,.4286,.1515,1.33,.6293/
      DATA VARK/.6,1.250,2.143,11.93,35.0,381.6/
      DATA FAK2/4.,36.,576./
      NYG=0
      INPUTS=0
C-------- IF NO ERRORS SHOULD BE WRITTEN ON STANDARD OUTPUT, SET IPRINT=1
C-------- IF ERRORS AND VERY DETAILED WARNINGS SHOULD BE WRITTEN ON
C--------           STANDARD OUTPUT, SET IPRINT < 0
      IPRINT=0
C
      IF(NUE.GT.4.OR.NUE.LT.0) THEN
        IF(IPRINT.EQ.0)
     .     PRINT *,'glkern: Order of derivative not allowed'
        STOP
      END IF
      IF(NUE.GT.2.AND.ISMO.EQ.0) THEN
        IF(IPRINT.EQ.0)
     .     PRINT *,'glkern: Order of derivative not allowed'
        STOP
      END IF
      IF(N.LE.2) THEN
        IF(IPRINT.EQ.0)
     .     PRINT *,'glkern: Number of data too small'
        STOP
      END IF
      IF(M.LT.1) THEN
        IF(IPRINT.EQ.0)
     .    PRINT *,'glkern: No output points'
        STOP
      END IF
      IF(M1.LT.10) THEN
        IF(IPRINT.EQ.0)
     .     PRINT *,'glkern: Variable M1 is choosen too small'
         STOP
      END IF
      KK=(KORD-NUE)/2
      IF(2*KK+NUE.NE.KORD) THEN
        IF(IPRINT.EQ.0)
     .    PRINT *,'glkern: Kernel order not allowed, set to ',NUE+2
        KORD=NUE+2
      END IF
      IF(KORD.GT.4.AND.ISMO.EQ.0) THEN
        IF(IPRINT.EQ.0)
     .    PRINT *,'glkern: Kernel order not allowed, set to ',NUE+2
        KORD=NUE+2
      END IF
      IF(KORD.GT.6.OR.KORD.LE.NUE) THEN
        IF(IPRINT.EQ.0)
     .    PRINT *,'glkern: Kernel order not allowed, set to ',NUE+2
        KORD=NUE+2
      END IF
      IF(ISMO.NE.0.AND.B.LE.0) THEN
        IF(IPRINT.EQ.0)
     .    PRINT *,'glkern: Plug-in bandwidth is used'
        ISMO=0
      END IF
      RVAR=SIG
C-
C-------- 2. COMPUTATION OF S-SEQUENCE
      S0=1.5*T(1)-0.5*T(2)
      SN=1.5*T(N)-0.5*T(N-1)
      IF(S(N).LE.S(0)) THEN
        INPUTS=1
        DO 20 I=1,N-1
20        S(I)=.5*(T(I)+T(I+1))
        S(0)=S0
        S(N)=SN
        IF(ISMO.NE.0.AND.IRND.NE.0) GOTO 160
      ELSE
        IF(ISMO.NE.0) GOTO 160
      END IF
C-
C-------- 3. COMPUTATION OF MINIMAL, MAXIMAL ALLOWED BANDWIDTH
      BMAX=(SN-S0)*.5
      BMIN=(SN-S0)/DBLE(N)*DBLE(KORD-1)*.6
C-
C-------- 4. WARNINGS IF TT-GRID LARGER THAN T-GRID
      IF(TT(1).LT.S0.AND.TT(M).GT.SN.AND.IPRINT.LT.0) PRINT *,
     .  'glkern: Extrapolation at both boundaries not optimized'
      IF(TT(1).LT.S0.AND.TT(M).LE.SN.AND.IPRINT.LT.0) PRINT *,
     .   'glkern: Extrapolation at left boundary not optimized'
      IF(TT(1).GE.S0.AND.TT(M).GT.SN.AND.IPRINT.LT.0) PRINT *,
     .   'glkern: Extrapolation at right boundary not optimized'
C-
C-------- 5. COMPUTE TL,TU AND THEIR T-GRID AS INNER PART FOR
C            INTEGRAL APPROXIMATION IN THE ITERATIONS
      ITT=0
51    IF (TU.LE.TL) THEN
        TL=.933*S0+.067*SN
        TU=.067*S0+.933*SN
        ITT=ITT+1
      END IF
      TL=MAX(TL,S0)
      TU=MIN(TU,SN)
      IL=1
      IU=N
      WN(1,1)=0.0
      WN(N,1)=0.0
      DO 50 I=1,N
        IF(T(I).LE.TL.OR.T(I).GE.TU) WN(I,1)=0.0
        IF(T(I).GT.TL.AND.T(I).LT.TU) WN(I,1)=1.0
        IF(T(I).LT.TL) IL=I+1
50      IF(T(I).LE.TU) IU=I
      NN=IU-IL+1
      IF(NN.EQ.0.AND.ITT.EQ.0) THEN
        TU=TL-1.0
        GOTO 51
      END IF
      IF(NN.EQ.0.AND.ITT.EQ.1) THEN
        TU=SN
        TL=S0
        GOTO 51
      END IF
C-
C-------- 6. COMPUTE T-GRID FOR INTEGRAL APPROXIMATION
      DO 60 I=1,M1
         W1(I,2)=1.0
60       W1(I,1)=TL+(TU-TL)*DBLE(I-1)/DBLE(M1-1)
C-
C-------- 7. CALCULATION OF WEIGHT FUNCTION
      ALPHA=1.D0/DBLE(13)
      DO 70 I=IL,IU
        XI=(T(I) - TL)/ALPHA/(TU-TL)
        IF(XI.GT.1) GOTO 71
70      WN(I,1)=(10.0-15*XI+6*XI*XI)*XI*XI*XI
71    DO 72 I=IU,IL,-1
        XI=(TU-T(I))/ALPHA/(TU-TL)
        IF(XI.GT.1) GOTO 73
72      WN(I,1)=(10.0-15*XI+6*XI*XI)*XI*XI*XI
73    DO 74 I=1,M1
        XI=(W1(I,1)-TL)/ALPHA/(TU-TL)
        IF(XI.GT.1) GOTO 75
74      W1(I,2)=(10.0-15*XI+6*XI*XI)*XI*XI*XI
75    DO 76 I=M1,1,-1
        XI=(TU-W1(I,1))/ALPHA/(TU-TL)
        IF(XI.GT.1) GOTO 77
76      W1(I,2)=(10.0-15*XI+6*XI*XI)*XI*XI*XI
77    CONTINUE
C-
C-------- 8. COMPUTE CONSTANTS FOR ITERATION
      EX=1./DBLE(KORD+KORD+1)
      KK2=(KORD-NUE)
      KK=KK2/2
C-
C-------- 9. ESTIMATING VARIANCE AND SMOOTHED PSEUDORESIDUALS
      IF((SIG.LE..0).AND.(IHOM.EQ.0))
     .     CALL RESEST(T(IL),X(IL),NN,WN(IL,2),R2,SIG)
      IF(IHOM.NE.0) THEN
        CALL RESEST(T,X,N,WN(1,2),SNR,SIG)
        BRES=MAX(BMIN,.2*NN**(-.2)*(S(IU)-S(IL-1)))
        DO 91 I=1,N
          WN(I,3)=T(I)
91        WN(I,2)=WN(I,2)*WN(I,2)
        CALL KERNEL(T,WN(1,2),N,BRES,0,KK2,NYG,S,
     .            WN(IL,3),NN,WN(IL,4))
      ELSE
        CALL COFF(WN(1,4),N,SIG)
      END IF
C-
C-------- 10. ESTIMATE/COMPUTE INTEGRAL CONSTANT
100   VI=0.
      DO 101 I=IL,IU
101      VI=VI+WN(I,1)*N*(S(I)-S(I-1))**2*WN(I,4)
C-
C-------- 11. REFINEMENT OF S-SEQUENCE FOR RANDOM DESIGN
      IF(INPUTS.EQ.1.AND.IRND.EQ.0) THEN
        DO 110 I=0,N
          WN(I,5)=DBLE(I)/DBLE(N+1)
          WN(I,2)=(DBLE(I)+.5)/DBLE(N+1)
110       WN(I,3)=WN(I,2)
        EXS=-DBLE(3*KORD+1)/DBLE(6*KORD+3)
        EXSVI=DBLE(KORD)/DBLE(6*KORD+3)
        BS=0.1*(VI/(SN-S0)**2)**EXSVI*N**EXS
        CALL KERNEL(WN(1,5),T,N,BS,0,2,NYG,WN(0,3),WN(0,2),N+1,S(0))
111     ISORT=0
        VI=0.0
        DO 112 I=1,N
        VI=VI+WN(I,1)*N*(S(I)-S(I-1))**2*WN(I,4)
          IF(S(I).LT.S(I-1)) THEN
            SSI=S(I-1)
            S(I-1)=S(I)
            S(I)=SSI
            ISORT=1
          END IF
112     CONTINUE
        IF(ISORT.EQ.1) GOTO 111
        IF(ISMO.NE.0) GOTO 160
      END IF
      B=BMIN*2.
C-
C-------- 12. COMPUTE INFLATION CONSTANT AND EXPONENT AND LOOP OF ITERATIONS
      CONST=DBLE(2*NUE+1)*FAK2(KORD)*VARK(KK,NUE)*VI
     .       /(DBLE(2*KORD-2*NUE)*BIAS(KK,NUE)**2*DBLE(N))
      FAC=1.1*(1.+(NUE/10.)+0.05*(KORD-NUE-2.))
     .       *N**(2./DBLE((2*KORD+1)*(2*KORD+3)))
      ITENDE=1+2*KORD+KORD*(2*KORD+1)

      DO 120 IT=1,ITENDE
C-
C-------- 13. ESTIMATE DERIVATIVE OF ORDER KORD IN ITERATIONS
        B2=B*FAC
        B2=MAX(B2,BMIN/DBLE(KORD-1)*DBLE(KORD+1))
        B2=MIN(B2,BMAX)
        CALL KERNEL(T,X,N,B2,KORD,KORD+2,NYG,S,W1(1,1),M1,W1(1,3))
C-
C-------- 14. ESTIMATE INTEGRALFUNCTIONAL IN ITERATIONS
        XMY2=.75*(W1(1,2)*W1(1,3)*W1(1,3)+W1(M1,2)*W1(M1,3)*W1(M1,3))
        DO 140 I=2,M1-1
140       XMY2=XMY2+W1(I,2)*W1(I,3)*W1(I,3)
        XMY2=XMY2*(TU-TL)/DBLE(M1)
C-
C-------- 15. FINISH OF ITERATIONS
        B=(CONST/XMY2)**EX
        B=MAX(BMIN,B)
        B=MIN(BMAX,B)
120     CONTINUE
C-
C-------- 16  COMPUTE SMOOTHED FUNCTION WITH PLUG-IN BANDWIDTH
160   CALL KERNEL(T,X,N,B,NUE,KORD,NYG,S,TT,M,Y)
C-
C-------- 17. VARIANCE CHECK
      IF(IHOM.NE.0) SIG=RVAR
      IF(RVAR.EQ.SIG.OR.R2.LT..88.OR.IHOM.NE.0.OR.NUE.GT.0) RETURN
      II=0
      IIL=0
      J=2
      TLL=MAX(TL,TT(1))
      TUU=MIN(TU,TT(M))
      DO 170 I=IL,IU
         IF(T(I).LT.TLL.OR.T(I).GT.TUU) GOTO 170
         II=II+1
         IF(IIL.EQ.0) IIL=I
171       IF(TT(J).LT.T(I)) THEN
            J=J+1
            IF(J.LE.M) GOTO 171
            END IF
       WN(II,3)=X(I)-Y(J)+(Y(J)-Y(J-1))*(TT(J)-T(I))/(TT(J)-TT(J-1))
170    CONTINUE
      IF(IIL.EQ.0.OR.II-IIL.LT.10) THEN
        CALL RESEST(T(IL),WN(1,3),NN,WN(1,4),SNR,RVAR)
       ELSE
        CALL RESEST(T(IIL),WN(1,3),II,WN(1,4),SNR,RVAR)
      END IF
      Q=SIG/RVAR
      IF(Q.LE.2.) RETURN
      IF(Q.GT.5..AND.R2.GT..95) RVAR=RVAR*.5
      SIG=RVAR
      CALL COFF(WN(1,4),N,SIG)
      GOTO 100
      END


      subroutine DCONCM(N, COEFF)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 DCONCM Krogh   Declared all vars.
c>> 1994-10-20 DCONCM Krogh  Changes to use M77CON
c>> 1992-06-04 DCONCM Krogh  Corrected line below.
c>> 1992-01-31 DCONCM Krogh  Initial Code.
c--D replaces "?": ?CONCM
c
c Converts COEFF in Chebyshev basis to the monomial basis.
c
      integer N, J, I
      double precision COEFF(0:N), TP
c
      if (N .le. 0) return
      TP = 1.D0
      do 20 J = 0, N-2
         do 10 I = N-2, J, -1
            COEFF(I) = COEFF(I) - COEFF(I+2)
   10    continue
         COEFF(J+1) = .5D0 * COEFF(J+1)
         COEFF(J) = TP * COEFF(J)
         TP = 2.D0 * TP
   20 continue
      COEFF(N) = TP * COEFF(N)
      COEFF(N-1) = TP * COEFF(N-1)
      return
      end


MODULE interpolate
!
  IMPLICIT none
!
CONTAINS
!
  SUBROUTINE bilinear (x1,x2,ygrid,y1grid,y2grid,ansy,ansy1,ansy2)
    !
    USE nrutil, ONLY : nrerror
    USE fields, ONLY: numrpts,numzpts,Lr,Lz
    USE basic
    IMPLICIT none
    DOUBLE PRECISION, INTENT(IN) :: x1,x2
    DOUBLE PRECISION, DIMENSION(0:numrpts,0:numzpts), INTENT(IN)  :: ygrid,y1grid,y2grid
    DOUBLE PRECISION, INTENT(OUT) :: ansy,ansy1,ansy2
    ! Linear interpolation method for two dimensional function...
    ! Given an m by n array of
    ! function values ya(0:m, 0:n), tabulated at the grid points defined elsewhere; and
    ! given values x1 and x2 of the independent variables; this routine returns an interpolated
    ! function value y.
    INTEGER :: j,k,m,n,ndum,x1l,x2l,x1u,x2u
    DOUBLE PRECISION :: t,u,d1,d2
    DOUBLE PRECISION, DIMENSION(4) :: y,y1,y2

    m = numrpts ! these require fields_mod and are input parameters
    n = numzpts

    d1 = Lr/m
    d2 = Lz/n

    IF (x1 .lt. 0 .or. x2 .lt. 0) STOP 'killed: trying to interpolate for value lt zero'

    ! determine the interval in which the point of interest lies
    ! the following method finds the index
    x1l = int(x1/d1)
    x1u = x1l + 1
    x2l = int(x2/d2)
    x2u = x2l + 1
    ! find the tabulated function values for performing interpolation
    IF (x1u == x1l .or. x2u == x2l) CALL &
      nrerror('bilinear: problem with input values - boundary pair equal?')

    y(1) = ygrid(x1l,x2l)      ! numbered counterclockwise from lower left, as required by bcucof
    y(2) = ygrid(x1u,x2l)
    y(3) = ygrid(x1u,x2u)
    y(4) = ygrid(x1l,x2u)

    y1(1) = y1grid(x1l,x2l)     ! numbered counterclockwise from lower left, as required by bcucof
    y1(2) = y1grid(x1u,x2l)
    y1(3) = y1grid(x1u,x2u)
    y1(4) = y1grid(x1l,x2u)

    y2(1) = y2grid(x1l,x2l)     ! numbered counterclockwise from lower left, as required by bcucof
    y2(2) = y2grid(x1u,x2l)
    y2(3) = y2grid(x1u,x2u)
    y2(4) = y2grid(x1l,x2u)

    ! compute the bilinear coefficients - the normalized distance from the
    ! interpolant point to the grid point
    t = x1/d1 - x1l
    u = x2/d2 - x2l
    ! find the interpolated function value
    ansy  = (1. - t)*(1. - u)*y (1) + t*(1. - u)*y (2) + t*u*y (3) + (1. - t)*u*y (4)
    ansy1 = (1. - t)*(1. - u)*y1(1) + t*(1. - u)*y1(2) + t*u*y1(3) + (1. - t)*u*y1(4)
    ansy2 = (1. - t)*(1. - u)*y2(1) + t*(1. - u)*y2(2) + t*u*y2(3) + (1. - t)*u*y2(4)

  END SUBROUTINE bilinear

  SUBROUTINE bcuint(x1,x2,ygrid,y1grid,y2grid,y12grid,ansy,ansy1,ansy2)
    USE fields, ONLY: numrpts,numzpts,Lr,Lz
    USE basic
    USE tracers
    USE nrutil, ONLY : nrerror, bcucof
    IMPLICIT none
    DOUBLE PRECISION, INTENT(IN)  :: x1,x2
    DOUBLE PRECISION, DIMENSION(0:numrpts,0:numzpts), INTENT(IN)  :: ygrid,y1grid,y2grid,y12grid
    DOUBLE PRECISION, INTENT(OUT) :: ansy,ansy1,ansy2
    ! This routine has been modified from the NR original to work more smoothly with the
    ! framework of this code (KBG@CRPP, 5/3/2010).
    !Bicubic interpolation within a grid square. Needed quantities are y,y1,y2,y12 (as described
    !in bcucof); x1l and x1u, the lower and upper coordinates of the grid square in the 1-
    !direction; x2l and x2u likewise for the 2-direction; and x1,x2, the coordinates of the
    !desired point for the interpolation. The interpolated function value is returned as ansy,
    !and the interpolated gradient values as ansy1 and ansy2. This routine calls bcucof.
    INTEGER :: i,m,n,x1l,x2l,x1u,x2u
    DOUBLE PRECISION :: t,u,d1,d2
    DOUBLE PRECISION, DIMENSION(4) :: y,y1,y2,y12
    DOUBLE PRECISION, DIMENSION(4,4) :: c

    m = numrpts ! these require fields_mod and are input parameters
    n = numzpts

    d1 = Lr/m
    d2 = Lz/n
    ! determine the interval in which the point of interest lies
    ! the following method finds the index
    x1l = int(x1/d1)
    x1u = x1l + 1.
    x2l = int(x2/d2)
    x2u = x2l + 1.

    IF (x1 .lt. 0 .or. x2 .lt. 0) STOP 'killed: trying to interpolate for value lt zero'

    IF (x1u .gt. m .or. x2u .gt. n .or. x1l .gt. m .or. x2l .gt. n) THEN
	write(*,*) 'Index problem: x1l=', x1l, ' x1u=', x1u, ' x2l=', x2l, ' x2u=', x2u, ' numrpts=', numrpts, ' numzpts=', numzpts
	STOP 'Killed'
    END IF

    y(1) = ygrid(x1l,x2l)      ! numbered counterclockwise from lower left, as required by bcucof
    y(2) = ygrid(x1u,x2l)
    y(3) = ygrid(x1u,x2u)
    y(4) = ygrid(x1l,x2u)

    y1(1) = y1grid(x1l,x2l)     ! numbered counterclockwise from lower left, as required by bcucof
    y1(2) = y1grid(x1u,x2l)
    y1(3) = y1grid(x1u,x2u)
    y1(4) = y1grid(x1l,x2u)

    y2(1) = y2grid(x1l,x2l)     ! numbered counterclockwise from lower left, as required by bcucof
    y2(2) = y2grid(x1u,x2l)
    y2(3) = y2grid(x1u,x2u)
    y2(4) = y2grid(x1l,x2u)

    y12(1) = y12grid(x1l,x2l) ! numbered counterclockwise from lower left, as required by bcucof
    y12(2) = y12grid(x1u,x2l)
    y12(3) = y12grid(x1u,x2u)
    y12(4) = y12grid(x1l,x2u)

    CALL bcucof(y,y1,y2,y12,d1,d2,c) ! get the c values from nrutil.f90

    IF (x1u == x1l .or. x2u == x2l) CALL &
      nrerror('bcuint: problem with input values - boundary pair equal?')

    t= x1/d1 - x1l ! same as for bilinear
    u= x2/d2 - x2l

    ansy=0.0
    ansy1=0.0
    ansy2=0.0

    DO i=4,1,-1 !Equation (3.6.6) in NR Fortran90 - linear combinations of the c values
      ansy =  t*ansy + ((c(i,4)*u + c(i,3))*u + c(i,2))*u + c(i,1)
      ansy1 = u*ansy1 + (3.*c(4,i)*t + 2.*c(3,i))*t + c(2,i)
      ansy2 = t*ansy2 + (3.*c(i,4)*u + 2.*c(i,3))*u + c(i,2)
    END DO
    ansy1=ansy1/d1 ! renormalize the derivatives to the grid spacing
    ansy2=ansy2/d2

  END SUBROUTINE bcuint

  SUBROUTINE lineart
    !
    USE basic
    USE fields
    USE tracers
    IMPLICIT none
!
    ! One dimension linear interpolation in time for electrostatic potential.
    ! Uses the fieldtimestep and numtpts input parameters and gives
    ! values to es_potgrid using the 3 dimensional (r,z',t)
    ! array es_potgrid_t.
    DOUBLE PRECISION    :: intert, sintert
    !INTEGER             :: i,GBSidx
    !CHARACTER(LEN=64)   :: tail

    ! this definition means that tracerdeltat should be a multiple of fieldtimestep
    intert = tracertime/fieldtimestep - FLOOR(tracertime/fieldtimestep)
    sintert = 1. - intert
!    i = 1
!    DO WHILE (i < stagbin)
!      IF (strmfstart < tA .AND. tA < strmfstart + i*stagdist) THEN
!        GBSidx = i
!      ELSE
!        i = i + 1
!      END IF
!    END DO
!
!    write(tail,7001) i
!    7001 FORMAT(i2.2)
!    arraystrmf = 'es_pot'//tail

    es_potgrid        = sintert*es_potgrid_t(:,:,tA) + intert*es_potgrid_t(:,:,tB)
    dpotdrtiltgrid    = sintert*dpotdrtiltgrid_t(:,:,tA) + intert*dpotdrtiltgrid_t(:,:,tB)
    dpotdztiltgrid    = sintert*dpotdztiltgrid_t(:,:,tA) + intert*dpotdztiltgrid_t(:,:,tB)
    d2potdrdztiltgrid = sintert*d2potdrdztiltgrid_t(:,:,tA) + intert*d2potdrdztiltgrid_t(:,:,tB)

  END SUBROUTINE lineart

END MODULE interpolate


!********************************************************
! Global variables
!********************************************************
module vars
implicit none

	real(kind=8), parameter :: PK = 1.3806503d-16, UMA = 1.66053873d-24, PC = 2.99792458d10
	real(kind=8), parameter :: PH = 6.62606876d-27, PHK = PH / PK, PHC = 2.d0 * PH / PC**2
	real(kind=8), parameter :: PME = 9.10938188d-28, PE = 4.8032d-10, PI = 3.14159265359d0
	real(kind=8), parameter :: PHC2 = 2.d0 * PH * PC**2, OPA = PI * PE**2 / (PME * PC)
	real(kind=8), parameter :: SQRTPI = 1.77245385091d0, EARTH_SUN_DISTANCE = 1.495979d13
	real(kind=8), parameter :: LARMOR = PE/(4.d0*PI*PME*PC), PMP = 1.67262158d-24
	real(kind=8), parameter :: NUCLEAR_MAGNETON = PE*PH/(2.d0*PI*PMP)
	real(kind=8), parameter :: BOHR_MAGNETON = PE*PH/(2.d0*PI*PME)
	real(kind=8), parameter :: PH2C3 = 2.d0 * PH**2 * PC**3, PERTURBATION = 0.005d0

	real(kind=8), allocatable :: zeeman_voigt(:,:), zeeman_faraday(:,:)

	type stokes_type
		integer :: nlambda
		real(kind=8), pointer :: stokes(:,:), lambda(:), sigma(:,:)
	end type stokes_type

	type modelo_type
		real(kind=8) :: Bfield, theta, chi, vmac, damping, B0, B1, mu, doppler, kl
	end type modelo_type

	type line_type
		character(len=2) :: theory
		integer :: nLambda
		real(kind=8) :: lambdaInit, lambdaStep, lambda
		real(kind=8) :: wave0, Jup, Jlow, gup, glow
	end type line_type

	type(stokes_type) :: Observation, Emergent, Stokes_unperturbed, Stokes_perturbed
	type(stokes_type) :: Stokes_Syn

	type(modelo_type) :: model
	type(line_type) :: line(10)
	integer :: nLines

	real(kind=8), allocatable :: ki(:), kq(:), ku(:), kv(:), fq(:), fu(:), fv(:), stokes(:,:), delta(:)
	real(kind=8), allocatable :: ki_partial(:), kq_partial(:), ku_partial(:), kv_partial(:)
	real(kind=8), allocatable :: fq_partial(:), fu_partial(:), fv_partial(:)

	real(kind=8), allocatable :: profile(:,:), v(:)

end module vars


      SUBROUTINE DE01OD( CONV, N, A, B, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the convolution or deconvolution of two real signals
C     A and B.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     CONV    CHARACTER*1
C             Indicates whether convolution or deconvolution is to be
C             performed as follows:
C             = 'C':  Convolution;
C             = 'D':  Deconvolution.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of samples.  N must be a power of 2.  N >= 2.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain the first signal.
C             On exit, this array contains the convolution (if
C             CONV = 'C') or deconvolution (if CONV = 'D') of the two
C             signals.
C
C     B       (input) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain the second signal.
C             NOTE that this array is overwritten.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     This routine computes the convolution or deconvolution of two real
C     signals A and B using an FFT algorithm (SLICOT Library routine
C     DG01MD).
C
C     REFERENCES
C
C     [1] Rabiner, L.R. and Rader, C.M.
C         Digital Signal Processing.
C         IEEE Press, 1972.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires 0( N*log(N) ) operations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C     Supersedes Release 2.0 routine DE01CD by R. Dekeyser, State
C     University of Gent, Belgium.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Convolution, deconvolution, digital signal processing, fast
C     Fourier transform, real signals.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, HALF, ONE
      PARAMETER         ( ZERO = 0.0D0, HALF=0.5D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         CONV
      INTEGER           INFO, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), B(*)
C     .. Local Scalars ..
      LOGICAL           LCONV
      INTEGER           J, KJ, ND2P1
      DOUBLE PRECISION  AC, AS, AST, BC, BS, CI, CR
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DG01MD, DLADIV, DSCAL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, MAX, MOD
C     .. Executable Statements ..
C
      INFO = 0
      LCONV = LSAME( CONV, 'C' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LCONV .AND. .NOT.LSAME( CONV, 'D' ) ) THEN
         INFO = -1
      ELSE
         J = 0
         IF( N.GE.2 ) THEN
            J = N
C           WHILE ( MOD( J, 2 ).EQ.0 ) DO
   10       CONTINUE
            IF ( MOD( J, 2 ).EQ.0 ) THEN
               J = J/2
               GO TO 10
            END IF
C           END WHILE 10
         END IF
         IF ( J.NE.1 ) INFO = -2
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'DE01OD', -INFO )
         RETURN
      END IF
C
C     Fourier transform.
C
      CALL DG01MD( 'Direct', N, A, B, INFO )
C
      IF ( LCONV ) THEN
         AST = A(1)*B(1)
      ELSE
         IF ( B(1).EQ.ZERO ) THEN
            AST = ZERO
         ELSE
            AST = A(1)/B(1)
         END IF
      END IF
C
      ND2P1 = N/2 + 1
      J = ND2P1
C
      DO 20 KJ = ND2P1, N
C
C        Components of the transform of function A.
C
         AC = HALF*( A(J) + A(KJ) )
         AS = HALF*( B(J) - B(KJ) )
C
C        Components of the transform of function B.
C
         BC = HALF*( B(KJ) + B(J) )
         BS = HALF*( A(KJ) - A(J) )
C
C        Deconvolution by complex division if CONV = 'D';
C        Convolution by complex multiplication if CONV = 'C'.
C
         IF ( LCONV ) THEN
            CR = AC*BC - AS*BS
            CI = AS*BC + AC*BS
         ELSE
            IF ( MAX( ABS( BC ), ABS( BS ) ).EQ.ZERO ) THEN
               CR = ZERO
               CI = ZERO
            ELSE
               CALL DLADIV( AC, AS, BC, BS, CR, CI )
            END IF
         END IF
C
         A(J)  =  CR
         B(J)  =  CI
         A(KJ) =  CR
         B(KJ) = -CI
         J = J - 1
   20 CONTINUE
      A(1) = AST
      B(1) = ZERO
C
C     Inverse Fourier transform.
C
      CALL DG01MD( 'Inverse', N, A, B, INFO )
C
      CALL DSCAL( N, ONE/DBLE( N ), A, 1 )
C
      RETURN
C *** Last line of DE01OD ***
      END


module mod_monolis_c3d8_shape
  use mod_monolis_prm
  use mod_monolis_shape_util
  implicit none

  private

  real(kdouble), parameter :: gsp(3,8) = reshape([ &
    -0.577350269189626d0,-0.577350269189626d0,-0.577350269189626d0, &
     0.577350269189626d0,-0.577350269189626d0,-0.577350269189626d0, &
    -0.577350269189626d0, 0.577350269189626d0,-0.577350269189626d0, &
     0.577350269189626d0, 0.577350269189626d0,-0.577350269189626d0, &
    -0.577350269189626d0,-0.577350269189626d0, 0.577350269189626d0, &
     0.577350269189626d0,-0.577350269189626d0, 0.577350269189626d0, &
    -0.577350269189626d0, 0.577350269189626d0, 0.577350269189626d0, &
     0.577350269189626d0, 0.577350269189626d0, 0.577350269189626d0  &
    ], [3,8])

  real(kdouble), parameter :: np(3,8) = reshape([ &
     -1.0d0, -1.0d0,-1.0d0, &
      1.0d0, -1.0d0,-1.0d0, &
      1.0d0,  1.0d0,-1.0d0, &
     -1.0d0,  1.0d0,-1.0d0, &
     -1.0d0, -1.0d0, 1.0d0, &
      1.0d0, -1.0d0, 1.0d0, &
      1.0d0,  1.0d0, 1.0d0, &
     -1.0d0,  1.0d0, 1.0d0  &
    ], [3,8])

  integer(kint), parameter :: monolis_C3D8_surf(4,6) = reshape([ &
     4, 3, 2, 1, &
     5, 6, 7, 8, &
     1, 2, 6, 5, &
     2, 3, 7, 6, &
     3, 4, 8, 7, &
     4, 1, 5, 8  ], [4,6])

    public :: monolis_C3D8_num_gauss_point
    public :: monolis_C3D8_weight
    public :: monolis_C3D8_integral_point
    public :: monolis_C3D8_node_point
    public :: monolis_C3D8_shapefunc
    public :: monolis_C3D8_shapefunc_deriv
    public :: monolis_C3D8_surf
    public :: monolis_C3D8_get_global_position
    public :: monolis_C3D8_get_global_deriv

contains

  function monolis_C3D8_num_gauss_point()
    implicit none
    integer(kint) :: monolis_C3D8_num_gauss_point
    monolis_C3D8_num_gauss_point = 8
  end function monolis_C3D8_num_gauss_point

  function monolis_C3D8_weight(i)
    implicit none
    integer(kint), optional :: i
    real(kdouble) :: monolis_C3D8_weight
    monolis_C3D8_weight = 1.0d0
  end function monolis_C3D8_weight

  subroutine monolis_C3D8_integral_point(i, r)
    implicit none
    integer(kint) :: i
    real(kdouble) :: r(3)

    r(1) = gsp(1,i)
    r(2) = gsp(2,i)
    r(3) = gsp(3,i)
  end subroutine monolis_C3D8_integral_point

  subroutine monolis_C3D8_node_point(i, r)
    implicit none
    integer(kint) :: i
    real(kdouble) :: r(3)

    r(1) = np(1,i)
    r(2) = np(2,i)
    r(3) = np(3,i)
  end subroutine monolis_C3D8_node_point

  subroutine monolis_C3D8_get_global_position(node, r, pos)
    implicit none
    real(kdouble) :: node(3,8), r(3), pos(3)
    real(kdouble) :: func(8)

    call monolis_C3D8_shapefunc(r, func)
    pos = matmul(node, func)
  end subroutine monolis_C3D8_get_global_position

  subroutine monolis_C3D8_get_global_deriv(node, r, dndx, det)
    implicit none
    real(kdouble) :: node(3,8), r(3), dndx(8,3), deriv(8,3)
    real(kdouble) :: xj(3,3), inv(3,3), det
    logical :: is_fail

    call monolis_C3D8_shapefunc_deriv(r, deriv)
    xj = matmul(node, deriv)
    call monolis_get_inverse_matrix_3d(xj, inv, det, is_fail)
    dndx = matmul(deriv, inv)
  end subroutine monolis_C3D8_get_global_deriv

  subroutine monolis_C3D8_shapefunc(local, func)
    implicit none
    real(kdouble) :: local(3), func(8)

    func(1) = 0.125d0*(1.0d0-local(1))*(1.0d0-local(2))*(1.0d0-local(3))
    func(2) = 0.125d0*(1.0d0+local(1))*(1.0d0-local(2))*(1.0d0-local(3))
    func(3) = 0.125d0*(1.0d0+local(1))*(1.0d0+local(2))*(1.0d0-local(3))
    func(4) = 0.125d0*(1.0d0-local(1))*(1.0d0+local(2))*(1.0d0-local(3))
    func(5) = 0.125d0*(1.0d0-local(1))*(1.0d0-local(2))*(1.0d0+local(3))
    func(6) = 0.125d0*(1.0d0+local(1))*(1.0d0-local(2))*(1.0d0+local(3))
    func(7) = 0.125d0*(1.0d0+local(1))*(1.0d0+local(2))*(1.0d0+local(3))
    func(8) = 0.125d0*(1.0d0-local(1))*(1.0d0+local(2))*(1.0d0+local(3))
  end subroutine monolis_C3D8_shapefunc

  subroutine monolis_C3D8_shapefunc_deriv(local, func)
    implicit none
    real(kdouble) :: local(3), func(8,3)

    func(1,1) = -0.125d0*(1.0d0-local(2))*(1.0d0-local(3))
    func(2,1) =  0.125d0*(1.0d0-local(2))*(1.0d0-local(3))
    func(3,1) =  0.125d0*(1.0d0+local(2))*(1.0d0-local(3))
    func(4,1) = -0.125d0*(1.0d0+local(2))*(1.0d0-local(3))
    func(5,1) = -0.125d0*(1.0d0-local(2))*(1.0d0+local(3))
    func(6,1) =  0.125d0*(1.0d0-local(2))*(1.0d0+local(3))
    func(7,1) =  0.125d0*(1.0d0+local(2))*(1.0d0+local(3))
    func(8,1) = -0.125d0*(1.0d0+local(2))*(1.0d0+local(3))

    func(1,2) = -0.125d0*(1.0d0-local(1))*(1.0d0-local(3))
    func(2,2) = -0.125d0*(1.0d0+local(1))*(1.0d0-local(3))
    func(3,2) =  0.125d0*(1.0d0+local(1))*(1.0d0-local(3))
    func(4,2) =  0.125d0*(1.0d0-local(1))*(1.0d0-local(3))
    func(5,2) = -0.125d0*(1.0d0-local(1))*(1.0d0+local(3))
    func(6,2) = -0.125d0*(1.0d0+local(1))*(1.0d0+local(3))
    func(7,2) =  0.125d0*(1.0d0+local(1))*(1.0d0+local(3))
    func(8,2) =  0.125d0*(1.0d0-local(1))*(1.0d0+local(3))

    func(1,3) = -0.125d0*(1.0d0-local(1))*(1.0d0-local(2))
    func(2,3) = -0.125d0*(1.0d0+local(1))*(1.0d0-local(2))
    func(3,3) = -0.125d0*(1.0d0+local(1))*(1.0d0+local(2))
    func(4,3) = -0.125d0*(1.0d0-local(1))*(1.0d0+local(2))
    func(5,3) =  0.125d0*(1.0d0-local(1))*(1.0d0-local(2))
    func(6,3) =  0.125d0*(1.0d0+local(1))*(1.0d0-local(2))
    func(7,3) =  0.125d0*(1.0d0+local(1))*(1.0d0+local(2))
    func(8,3) =  0.125d0*(1.0d0-local(1))*(1.0d0+local(2))
  end subroutine monolis_C3D8_shapefunc_deriv

end module mod_monolis_c3d8_shape


!********************************************************************************
!* This file is part of:
!* BAFFLE (https://github.com/ATHannington/BAFFLE)
!* BAFFLE: BAsic Fortran FLuids Engine
!*
!* BAFFLE:
!* Copyright (C) 2017 Andrew Hannington (ath4@st-andrews.ac.uk)
!*
!* This software is a derivative of work by Bert Vandenbroucke
!* (bert.vandenbroucke@gmail.com)
!* Find more work by Bert Vandenbroucke at: (https://github.com/bwvdnbro)
!*
!* BAFFLE is a free software: you can redistribute it and/or modify it under the
!* terms of the GNU Affero General Public License
!* as published by the Free Software Foundation, either version 3 of the License, or
!* (at your option) any later version.
!*
!* BAFFLE is distributed in the hope that it will
!* be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!* GNU Affero General Public License for more details.
!*
!* You should have received a copy of the GNU Affero General Public License
!* along with BAFFLE. If not, see
!* <http://www.gnu.org/licenses/>.
!********************************************************************************

!********************************************************************************
!* @file init_conds_KH.f90
!*
!* @Initial Conditions subroutine for 2D Kelvin Helmholtz instability Simulation
!* : Fortran 90 version.
!*
!* @author Andrew Hannington (ath4@st-andrews.ac.uk)
!********************************************************************************

!===============================================================================
!
!*** 				INITIAL CONDITIONS			     ***
!
!-------------------------------------------------------------------------------
!Subroutine for initial conditions functions for density, velocity, and pressure
!& as a function of x.
!-------------------------------------------------------------------------------
subroutine init_conds(x,y,z,rho,ux,uy,uz,p)
	use constants								!Tells program to use global constants
	implicit none

		Real*8, intent(in) :: x,y,z
		Real*8, intent(out) :: rho,ux,uy,uz,p
		Real*8 :: d,A,sig_sqrd,freq_arg						!Middle layer thickness; constants A and sigma
		Real*8 :: exparg1, exparg2, uxarglow,uxarghigh			!arguments for functions in velocities

!	uy=0.d0
	uz=0.d0

!	Set constants for Kelvin-Helmholtz:
	d=0.025d0!0.025d0
	A=0.1d0!0.1d0
	sig_sqrd= 0.00125d0!0.0125d0!0.005d0/Dsqrt(2.0d0)!0.00125d0

	freq_arg=1.d0

!Sets values of density according to starting conditions for 2D Kelvin-Helmholtz
	If ((y>=0.d0).and.(y<0.25d0)) then
		rho=1.d0
	else if ((y>=0.25d0).and.(y<=0.75d0)) then
		rho=10.d0
	else if ((y>0.75d0).and.(y<=1.0d0)) then
		rho=1.d0
	else
		Print*,"Invalid coordinate [density]! Program will terminate!"		!Exits program if y lies outside of 1 to 0 range
		STOP
	endif

!Set ux arguments:
	uxarglow = ((y+d-0.25d0)/(2.d0*d))
	uxarghigh = ((y+d-0.75d0)/(2.d0*d))

!Set X-Velocity for K-H:
	If ((y>=0.d0).and.(y<=(0.25d0-d)))then
		ux=-0.5d0
	else if ((y>(0.25d0-d)).and.(y<(0.25d0+d))) then
		ux=-0.5d0+uxarglow
	else if ((y>=(0.25d0+d)).and.(y<=(0.75d0-d))) then
		ux=0.5d0
	else if ((y>(0.75d0-d)).and.(y<(0.75d0+d))) then
		ux=0.5d0-uxarghigh
	else if ((y>=0.75d0+d).and.(y<=1.d0)) then
		ux=-0.5d0
	else

!	If ((y>=0.d0).and.(y<0.25d0)) then
!		ux=-0.5d0
!	else if ((y>=0.25d0).and.(y<=0.75d0)) then
!		ux=0.5d0
!	else if ((y>0.75d0).and.(y<=1.d0)) then
!		ux=-0.5d0
!	else
		Print*,"Invalid coordinate [Vx]! Program will terminate!"		!Exits program if y lies outside of 1 to 0 range
		STOP
	endif

!Set y-velocity:

	exparg1= -1.d0*(((y-0.25d0)**2)/(2.d0*(sig_sqrd)))
	exparg2= -1.d0*(((y-0.75d0)**2)/(2.d0*(sig_sqrd)))

	uy=(A*DSIN(freq_arg*4.d0*Pi*x))*(DEXP(exparg1)+DEXP(exparg2))

	p=2.5d0
end subroutine init_conds
!===============================================================================


!*****************************************************************************************
!> author: Jacob Williams
!
!  Halo Orbit generation example (Earth-Moon system).
!
!@note Requires pyplot-fortran module.

    program halo_test_2

    use fortran_astrodynamics_toolkit
    use pyplot_module

    implicit none

    real(wp),parameter :: mu_earth = 398600.436233_wp    !! \( \mu_{Earth} ~ (\mathrm{km}^3/\mathrm{s}^2) \)
    real(wp),parameter :: mu_moon  = 4902.800076_wp      !! \( \mu_{Moon}  ~ (\mathrm{km}^3/\mathrm{s}^2) \)
    real(wp),parameter :: em_distance = 384400.0_wp      !! earth-moon distance [km]
    real(wp),parameter :: A_z = 1000.0_wp    !! initial halo z-amplitude
    real(wp),parameter :: t1 = 0.0_wp        !! tau for halo orbit
    integer,parameter  :: n  = 6             !! number of state variables
    real(wp),parameter :: Az_step =1000.0_wp !! Az step size (km)

    real(wp),dimension(n)    :: rv     !! halo orbit initial state
    real(wp),dimension(n,n)  :: phi    !! monodromy matrix
    real(wp),dimension(n,2)  :: w      !! real and and imaginary parts of the eigenvalues of `phi`
    real(wp),dimension(n,n)  :: z      !! real and imaginary parts of the eigenvectors of `phi`
    complex(wp),dimension(n) :: lambda !! eigenvalues of `phi`
    integer  :: libpoint         !! libration point (1,2,3)
    integer  :: i                !! counter
    integer  :: j                !! counter
    real(wp) :: Az               !! halo z-amplitude (km)
    integer  :: info             !! minpack status code
    integer  :: sol_family       !! 1 or 3 (family)
    real(wp) :: period           !! halo period (normalized time)
    integer  :: ierr             !! output flag from [[compute_eigenvalues_and_eigenvectors]]
    real(wp) :: mu               !! CRTBP parameter
    real(wp),dimension(:),allocatable   :: e !! real eigenvalues
    real(wp),dimension(:,:),allocatable :: v !! normalized eigenvectors associated with the real eigenvalues
    integer :: n_results !! number of real eigenvalues

    mu = compute_crtpb_parameter(mu_earth,mu_moon)

    do libpoint = 1, 3
        write(*,*) ''
        write(*,*) '---------------------------'
        write(*,*) ' libpoint: ', libpoint
        write(*,*) '---------------------------'
        write(*,*) ''
        do sol_family = 1, 3, 2
            write(*,*) ''
            write(*,*) ' family: ', sol_family
            write(*,*) ''
            do i=1,10
                Az = A_z+(i-1)*Az_step
                call halo_to_rv_diffcorr(libpoint,mu_earth,mu_moon,em_distance,&
                                            Az,sol_family,t1,rv,info,period)
                if (info/=1) error stop 'error'
                write(*,*) ''
                write(*,*) az,' [', rv(1),',',&
                                    rv(2),',',&
                                    rv(3),',',&
                                    rv(4),',',&
                                    rv(5),',',&
                                    rv(6),']', period

                if (libpoint==1 .and. sol_family==1 .and. i==1) then

                    call compute_halo_monodromy_matrix(mu,rv,period,phi)
                    write(*,*) ''
                    write(*,*) 'monodromy matrix:'
                    write(*,*) ''
                    call print_matrix(phi)
                    write(*,*) ''

                    ! general method:
                    call compute_eigenvalues_and_eigenvectors(6, phi, w, z, ierr)
                    write(*,*) ''
                    write(*,*) 'eigenvalues:'
                    write(*,*) ''
                    call print_matrix(w)
                    write(*,*) ''
                    write(*,*) 'eigenvectors:'
                    write(*,*) ''
                    call print_matrix(z)
                    write(*,*) ''

                    ! quicker method for just the eigenvalues:
                    call compute_monodromy_matrix_eigenvalues(phi,lambda)
                    write(*,*) ''
                    write(*,*) 'lambda:'
                    write(*,*) lambda
                    write(*,*) ''

                    ! normalized values:
                    call compute_real_eigenvalues_and_normalized_eigenvectors(6, phi, e, v, n_results, ierr)
                    write(*,*) ''
                    write(*,*) 'real eigenvalues:', e
                    write(*,*) ''
                    write(*,*) 'normalized eigenvectors:'
                    write(*,*) ''
                    call print_matrix(v)
                    write(*,*) ''

                    ! the determinant should be 1.0 since matrix is sympletic
                    write(*,*) ''
                    write(*,*) '-----'
                    write(*,*) 'determinate of phi: ', matrix_determinant(6,phi)
                    write(*,*) '-----'
                    write(*,*) ''

                end if
            end do
        end do
    end do

    end program halo_test_2
!*****************************************************************************************


! This is a comment.

PROGRAM fizzbuzz
    IMPLICIT NONE !forbids implicit type declarations
    INTEGER :: i  !defines the variable `i`
    DO i = 1, 100
        IF (MOD(i, 3) == 0 .AND. MOD(i, 5) == 0) THEN
            PRINT "(a)", "FizzBuzz" !`"(a)"` is the format specifier for string.
        ELSE IF (MOD(i, 3) == 0) THEN
            PRINT "(a)", "Fizz"
        ELSE IF (MOD(i, 5) == 0) THEN
            PRINT "(a)", "Buzz"
        ELSE
            PRINT "(I0)", i !`"(I0)"` is the format specifier for integer.
        END IF
    END DO
END PROGRAM fizzbuzz


FUNCTION chebev_s(a,b,c,x)
	USE nrtype; USE nrutil, ONLY : nrerror
	IMPLICIT NONE
	REAL(SP), INTENT(IN) :: a,b,x
	REAL(SP), DIMENSION(:), INTENT(IN) :: c
	REAL(SP) :: chebev_s
	INTEGER(I4B) :: j,m
	REAL(SP) :: d,dd,sv,y,y2
	if ((x-a)*(x-b) > 0.0) call nrerror('x not in range in chebev_s')
	m=size(c)
	d=0.0
	dd=0.0
	y=(2.0_sp*x-a-b)/(b-a)
	y2=2.0_sp*y
	do j=m,2,-1
		sv=d
		d=y2*d-dd+c(j)
		dd=sv
	end do
	chebev_s=y*d-dd+0.5_sp*c(1)
END FUNCTION chebev_s

FUNCTION chebev_v(a,b,c,x)
	USE nrtype; USE nrutil, ONLY : nrerror
	IMPLICIT NONE
	REAL(SP), INTENT(IN) :: a,b
	REAL(SP), DIMENSION(:), INTENT(IN) :: c,x
	REAL(SP), DIMENSION(size(x)) :: chebev_v
	INTEGER(I4B) :: j,m
	REAL(SP), DIMENSION(size(x)) :: d,dd,sv,y,y2
	if (any((x-a)*(x-b) > 0.0)) call nrerror('x not in range in chebev_v')
	m=size(c)
	d=0.0
	dd=0.0
	y=(2.0_sp*x-a-b)/(b-a)
	y2=2.0_sp*y
	do j=m,2,-1
		sv=d
		d=y2*d-dd+c(j)
		dd=sv
	end do
	chebev_v=y*d-dd+0.5_sp*c(1)
END FUNCTION chebev_v

SUBROUTINE beschb_s(x,gam1,gam2,gampl,gammi)
	USE nrtype
	USE nr, ONLY : chebev
	IMPLICIT NONE
	REAL(DP), INTENT(IN) :: x
	REAL(DP), INTENT(OUT) :: gam1,gam2,gampl,gammi
	INTEGER(I4B), PARAMETER :: NUSE1=5,NUSE2=5
	REAL(SP) :: xx
	REAL(SP), DIMENSION(7) :: c1=(/-1.142022680371168_sp,&
		6.5165112670737e-3_sp,3.087090173086e-4_sp,-3.4706269649e-6_sp,&
		6.9437664e-9_sp,3.67795e-11_sp,-1.356e-13_sp/)
	REAL(SP), DIMENSION(8) :: c2=(/1.843740587300905_sp,&
		-7.68528408447867e-2_sp,1.2719271366546e-3_sp,&
		-4.9717367042e-6_sp, -3.31261198e-8_sp,2.423096e-10_sp,&
		-1.702e-13_sp,-1.49e-15_sp/)
	xx=8.0_dp*x*x-1.0_dp
	gam1=chebev(-1.0_sp,1.0_sp,c1(1:NUSE1),xx)
	gam2=chebev(-1.0_sp,1.0_sp,c2(1:NUSE2),xx)
	gampl=gam2-x*gam1
	gammi=gam2+x*gam1
END SUBROUTINE beschb_s

SUBROUTINE beschb_v(x,gam1,gam2,gampl,gammi)
	USE nrtype
	USE nr, ONLY : chebev
	IMPLICIT NONE
	REAL(DP), DIMENSION(:), INTENT(IN) :: x
	REAL(DP), DIMENSION(:), INTENT(OUT) :: gam1,gam2,gampl,gammi
	INTEGER(I4B), PARAMETER :: NUSE1=5,NUSE2=5
	REAL(SP), DIMENSION(size(x)) :: xx
	REAL(SP), DIMENSION(7) :: c1=(/-1.142022680371168_sp,&
		6.5165112670737e-3_sp,3.087090173086e-4_sp,-3.4706269649e-6_sp,&
		6.9437664e-9_sp,3.67795e-11_sp,-1.356e-13_sp/)
	REAL(SP), DIMENSION(8) :: c2=(/1.843740587300905_sp,&
		-7.68528408447867e-2_sp,1.2719271366546e-3_sp,&
		-4.9717367042e-6_sp, -3.31261198e-8_sp,2.423096e-10_sp,&
		-1.702e-13_sp,-1.49e-15_sp/)
	xx=8.0_dp*x*x-1.0_dp
	gam1=chebev(-1.0_sp,1.0_sp,c1(1:NUSE1),xx)
	gam2=chebev(-1.0_sp,1.0_sp,c2(1:NUSE2),xx)
	gampl=gam2-x*gam1
	gammi=gam2+x*gam1
END SUBROUTINE beschb_v


      PROGRAM xzbrac
C     driver for routine zbrac
      LOGICAL succes
      INTEGER i
      REAL bessj0,x1,x2
      EXTERNAL bessj0
      write(*,'(/1x,t4,a,t29,a/)') 'Bracketing values:',
     *     'Function values:'
      write(*,'(1x,t6,a,t16,a,t29,a,t41,a/)') 'X1','X2',
     *     'BESSJ0(X1)','BESSJ0(X2)'
      do 11 i=1,10
        x1=i
        x2=x1+1.0
        call zbrac(bessj0,x1,x2,succes)
        if (succes) then
          write(*,'(1x,f7.2,f10.2,7x,2f12.6)') x1,x2,
     *         bessj0(x1),bessj0(x2)
        endif
11    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xzbrac.for


program problem27
  use euler
  implicit none
  integer   :: a=1,b=41,n=39,i,j,k
  integer*8 :: temp

  do i=-999,999
     do j=-1000,1000

        ! Quick filter
        temp=n*n + i*n + j
        if (.not. is_prime(abs(temp))) then
           cycle
        end if

        ! Compute number of consecutive primes
        do k=0,1000*1000*1000
           temp=k*k + i*k + j
           if (.not. is_prime(abs(temp))) then
              exit
           end if
        end do

        ! Update if better
        if (k>n) then
           a=i
           b=j
           n=k
        end if
     end do
  end do

  print *, a*b

end program problem27


       FUNC(X)=EXP(X)
       EXACT=EXP(1.)-1.
30     PRINT *,'ENTER N EVEN (.LT. 2 TO STOP)'
       READ *, N
       IF (N .LT. 2) STOP
       IF (MOD(N,2) .NE. 0) N=N+1

       H=1./N
       SUM=FUNC(0.)
       FAC=2

       DO 10 I=1,N-1
          IF (FAC .EQ. 2.) THEN
             FAC=4
          ELSE
             FAC=2.
          END IF
          X=I*H
          SUM=SUM+FAC*FUNC(X)
10     CONTINUE

       SUM=SUM+FUNC(1.)
       XINT=SUM*H/3.
       DIFF=EXACT-XINT
       PRINT 20,N,DIFF
20     FORMAT (5X,'N=',I5,5X,'ERROR=',E15.8)

       GOTO 30
       END


use ArrayClass
use IOClass
implicit none

real(real64),allocatable :: t(:),Ft(:),Ft_observation(:)
real(real64) :: tau
type(IO_) :: f

tau = 100.0d0
t  = [0.0d0, 5.0d0, 6.0d0, 7.0d0, 10.0d0, 15.0d0]
Ft = [0.0d0, 1.0d0, 1.0d0,-1.0d0, -3.0d0,  0.0d0]

! Refine data plots!
! N=6 >> N=10000
call refine(  &
        x = t, &
        Fx = Ft, &
        x_range = [0.0d0, 20.0d0],&
        num_point = 10000 &
        )

! raw
call f%plot(t,Ft)
! velocity
call f%plot(t, I_dx(t,Ft) )
! displacement
call f%plot(t, I_dx(t,I_dx(t,Ft)) )

end


subroutine qinit(meqn,mbc,mx,xlower,dx,q,maux,aux)

    ! Set initial conditions for the q array.
    ! This default version simply sets eta = max(h + b,0)

    ! For more specific initial conditions
    !  copy this to an application directory and
    !  loop over all grid cells to set values of q(1:meqn, 1:mx).

    !use geoclaw_module, only: dry_tolerance !uncomment if needed
    !use geoclaw_module, only: grav  !uncomment if needed
    use grid_module, only: xcell,zcell

    implicit none

    integer, intent(in) :: meqn,mbc,mx,maux
    real(kind=8), intent(in) :: xlower,dx
    real(kind=8), intent(in) :: aux(maux,1-mbc:mx+mbc)
    real(kind=8), intent(inout) :: q(meqn,1-mbc:mx+mbc)

    !locals
    integer :: i
    real(kind=8) :: x,x0

    real(kind=8) :: eta, width

    width = 5    ! controls width of Gaussian
    x0 = 0.   ! initial location of Gaussian

    do i=1,mx
      x = xcell(i)  ! latitude in degrees
      eta = 2.d0 * exp(-((x-x0)/width)**2)
      if (eta < 1d-20) eta = 0.d0
      q(1,i) = max(0.0, eta - aux(1,i))
      q(2,i) = 0.d0
   enddo

end subroutine qinit


C Copyright 2021 Dennis Decker Jensen
C Date: 24-29 May 2021
C Purpose: Erastothene's prime number sieve
C Tectonics: gfortran -ffixed-form -c primesieve.f90

      SUBROUTINE ERASTOTHENE(SIEVE,NHIGH)
         LOGICAL SIEVE(NHIGH)

         DO 10 I=1,NHIGH
   10       SIEVE(I)=.TRUE.
         SIEVE(1)=.FALSE.
         DO 30 I=2,INT(SQRT(NHIGH))
            IF (SIEVE(I)) THEN
               DO 20 J=I+I,NHIGH,I
   20             SIEVE(J)=.FALSE.
            ENDIF
   30    CONTINUE
      END


      double complex function Lsm2_2m(t13bar,t23bar,qsq,msq)
      implicit none
      include 'constants.f'
      double precision qsq,msq,ddilog,r,omr,t13bar,t23bar
      double complex lnrat,dilogt,dilogu,wlog,dilog1,dilog2,dilogq

C     This function is equal to (in looptools notation)
c      Lsm2_2m_ff(t13-msq,t23-msq,qsq,msq)=
c     . (t13-msq)*(t23-msq)*D0(0,msq,0,qsq;t13,t23;0,0,msq,msq)
c     . -(t13-msq)*C0(0,msq,t13;0,0,msq)
c     . -(t23-qsq)*C0(0,t23,qsq;0,0,msq)

C     This function is equal to (in normal notation) Pg^2=Ps^2=0,Pc^2=m^2
c      Lsm2_2m_ff(2*Pg.Pc,2*Ps.Pc,qsq,msq)=
c     . (2*Pg.Pc)*(2*Ps.Pc)*D0(Pg,Pc,Ps,0,0,msq,msq)
c     . -(2*Pg.Pc)*C0(Pg,Pc,0,0,msq)
c     . +(2*Pg.(Pc+Ps))*C0(Pg,Pc+Ps;0,0,msq)

C     This function is equal to (in normal notation) Pg^2=Ps^2=0,Pc^2=m^2
c      D0(Pg,Pc,Ps,0,0,msq,msq)=
C      +C0(Pg,Pc,0,0,msq)/2/Ps.Pc
C      -C0(Pg,Pc+Ps;0,0,msq)*Pg.(Pc+Ps)/2/Pg.Pc/Ps.Pc
C      +Lsm2_2m_ff(2*Pg.Pc,2*Ps.Pc,qsq,msq)/4/Pg.Pc/Ps.Pc

c      dilogt ~ ddilog(t13/msq))
c      dilogu ~ ddilog(t23/msq))
c      dilogq ~ ddilog(qsq/msq)
c      dilog1 ~ ddilog((t13-qsq)/(t13-msq))
c      dilog2 ~ ddilog((t23-qsq)/(t23-msq))

C      t13=t13bar+msq
C      t23=t23bar+msq

      r=-t13bar/msq
      omr=1d0-r
      wlog=lnrat(-t13bar,msq)
      if (omr .gt. one) then
         dilogt=dcmplx(pisqo6-ddilog(r))-wlog*dcmplx(log(omr))
      else
         dilogt=dcmplx(ddilog(omr))
      endif

      r=-t23bar/msq
      omr=1d0-r
      wlog=lnrat(-t23bar,msq)
      if (omr .gt. one) then
         dilogu=dcmplx(pisqo6-ddilog(r))-wlog*dcmplx(log(omr))
      else
         dilogu=dcmplx(ddilog(omr))
      endif

      r=-(msq-qsq)/t13bar
      omr=1d0-r
      wlog=lnrat(msq-qsq,-t13bar)
      if (omr .gt. one) then
         dilog1=dcmplx(pisqo6-ddilog(r))-wlog*dcmplx(log(omr))
      else
         dilog1=dcmplx(ddilog(omr))
      endif

      r=-(msq-qsq)/t23bar
      omr=1d0-r
      wlog=lnrat(msq-qsq,-t23bar)
      if (omr .gt. one) then
         dilog2=dcmplx(pisqo6-ddilog(r))-wlog*dcmplx(log(omr))
      else
         dilog2=dcmplx(ddilog(omr))
      endif

      r=(msq-qsq)/msq
      omr=1d0-r
      wlog=lnrat(msq-qsq,msq)
      if (omr .gt. one) then
         dilogq=dcmplx(pisqo6-ddilog(r))-wlog*dcmplx(log(omr))
      else
         dilogq=dcmplx(ddilog(omr))
      endif

      Lsm2_2m=-lnrat(-t13bar,-t23bar)**2-dcmplx(pisqo6)
     . +dilogq-dilogt-dilogu-2d0*(dilog1+dilog2)

      return
      end


module DielectricStopping
  use utils, only : dp, pi
  use RPAdielectric, only : FDD, elf
  use MerminDielectric, only : mELF
  use integrate, only     : trapezoidal
  use ArrayOps, only      : linspace, logspace, bunchspace, binarysearch

  implicit none
  private
  public omegaintegral, stoppingintegral, sumrule, srdensity, FEGdensity, wp, BG_wp, modBG_wp

contains

  function sumrule(n)
    real(dp), intent(in) :: n
    real(dp) :: sumrule

    sumrule = pi/2 * wp(n)**2

    return
  end function sumrule

  function FEGdensity(kbT, mu) result(n)
    ! Calculate density of a free-electron gas given the temperature and
    ! chemical potential. Everything in atomic units.
    ! Currently assuming a smooth integrand, i.e. relatively large temperatures.

    real(dp), intent(in) :: kbT, mu
    real(dp) :: n
    integer  :: i
    real(dp) :: x(201)
    real(dp) :: y(size(x))

    ! ! integrate
    x = linspace(0._dp, mu + 10*kbT, size(x))!bunchspace(mu, mu - mu*1e-4, (size(x)+1)/2)
    do i=1,size(x)
       y(i) = FDD(x(i), mu, kbT, sqrt(x(i)))
    end do
    n = trapezoidal(y,x)

    n = sqrt(2._dp)/pi**2 * n

  end function FEGdensity

  function srdensity(kbT, mu) result(den)
    !! Compute density using the f-sum rule
    real(dp), intent(in) :: kBT, mu
    real(dp) :: den
    real(dp) :: k, v, n, int ! dummy variables
    logical  :: srcheck

    k = 1.
    ! Need an approximation to the density to start
    n = FEGdensity(kbT, mu)

    srcheck = .false.
    do while (.not. srcheck)
       ! In omegaintegral, we want k*v > ELFmaxpos + ELFwidth
       v = modBG_wp(n, kbT, mu)/k + sqrt(2*(20*kbT + mu))
       call omegaintegral(v, k, kbT, mu, n, int, srcheck)
       k = k + 1.
    end do

    ! int should be the sum rule
    den = int / (2 * pi**2)

  end function srdensity

  function wp(n)
    ! Basic plasma frequency, a.u.
    real(dp), intent(in) :: n
    real(dp) :: wp

    wp = sqrt(4*pi*n)
  end function wp

  function BG_wp(n, k, kbT)
    ! Bohm-Gross dispersion relation for the plasma frequency, in a.u.

    real(dp), intent(in) :: n, k, kbT
    real(dp) :: BG_wp

    BG_wp = sqrt(wp(n)**2 + 3*kbT*k**2)
  end function BG_wp

  function modBG_wp(n, k, kbT)
    ! Modified Bohm-Gross dispersion relation, given in Glezner & Redmer, Rev.
    ! Mod. Phys., 2009, Eqn (16).
    real(dp), intent(in) :: n, k, kbT
    real(dp) :: modBG_wp, therm_deBroglie
    therm_deBroglie = sqrt(2* pi / kbT)

    modBG_wp = sqrt(BG_wp(n, k, kbT)**2 + 3*kbT*k**2 &
               + 0.088 * n * therm_deBroglie**3 + k**4/4)
  end function modBG_wp

  subroutine omegaintegral(v, k, kbT, mu, density, omegaint, SRsatisfy)
    real(dp), intent(in)    :: v, k, kbT, mu, density
    real(dp), intent(inout) :: omegaint
    logical , intent(inout) :: SRsatisfy
    real(dp) :: int_allspace ! integral over all space, should give sum rule
    real(dp) :: sr ! sum rule value
    real(dp) :: ELFwidth, ELFmaxpos, ELFmin, ELFmax ! ELF variables
    ! real(dp), allocatable :: w(:), y(:) ! integration variable and integrand
    ! Three ranges in omega-space corresponding to 3 possible relative
    ! locations of k*v (upper limit of omega interval)
    real(dp) :: wminrange(100), wmaxrange(100), wELFrange(999)
    real(dp) :: yminrange(size(wminrange)), ymaxrange(size(wmaxrange))
    real(dp) :: yELFrange(size(wELFrange))
    real(dp) :: ytemp, wtemp ! tempararily holds values from w, y arrays.
    integer  :: i, N ! Number of steps for integration

    ! sum rule value
    sr = sumrule(density)

    ! Max position of ELF peak (approximation)
    ELFmaxpos = modBG_wp(density, k, kbT)
    ! approximate width of ELF peak
    ELFwidth = sqrt(2*(20*kbT + mu))*k
    ! Leftmost edge of ELF peak
    ELFmin = max(0.001_dp, ELFmaxpos - ELFwidth)
    ! Want ELFwidth < ELFmaxpos
    ELFwidth = ELFmaxpos - ELFmin
    ! rightmost edge of ELF peak
    ELFmax = ELFmaxpos + ELFwidth

    if (k*v < ELFmin) then
       ! kv < ELFmin: ELF peak not in integration range

       wminrange = linspace(0.001_dp, k*v, size(wminrange))
       do i = 1, size(wminrange)
          yminrange(i) = wminrange(i) * ELF(k, wminrange(i), kbT, mu)

       end do

       omegaint = trapezoidal(yminrange, wminrange)
       ! Don't check in this case since we are not dealing
       ! with the difficult part (peak) of the integrand
       SRsatisfy = .true.

       return
    end if

    ! ELFmin < kv < ELFmax or ELFmax < kv

    ! integral from (0, ELFmin)
    wminrange = linspace(0.001_dp, ELFmin, size(wminrange))
    do i = 1, size(wminrange)
       yminrange(i) = wminrange(i) * ELF(k, wminrange(i), kbT, mu)!
    end do

    omegaint = trapezoidal(yminrange, wminrange)

    ! points within the ELF peak
    wELFrange = bunchspace(ELFmaxpos, ELFwidth, (size(wELFrange)+1)/2)

    ! compute integrand for each point in w
    do i = 1, size(wELFrange)
       yELFrange(i) = wELFrange(i) * ELF(k, wELFrange(i), kbT, mu)
    end do

    ! ELFmin < kv < ELFmax
    if ((ELFmin < k*v) .and. (k*v < ELFmax)) then
       ! ! integral from (ELFmin, kv) and (kv, ELFmax)

       ! Find index corresponding to the upper limit of the integral (k*v)
       i = binarysearch(wELFrange, k*v)
       ! integral from [ELFmin, k*v]
       wtemp = wELFrange(i)
       ytemp = yELFrange(i)
       wELFrange(i) = k*v
       yELFrange(i) = wELFrange(i) * ELF(k, wELFrange(i), kbT, mu)

       omegaint = omegaint + trapezoidal(yELFrange(1:i), wELFrange(1:i))

       ! integral from [kv, ELFmax \approx \infty]
       ! (for integration over (0, \infty))
       wELFrange(i-1) = wELFrange(i)
       wELFrange(i) = wtemp
       yELFrange(i-1) = yELFrange(i)
       yELFrange(i) = ytemp
       int_allspace = omegaint + &
            trapezoidal(yELFrange(i-1:size(yELFrange)), &
                        wELFrange(i-1:size(wELFrange)))

    else ! kv > ELFmax
       ! integral from (ELFmin, ELFmax)
       omegaint = omegaint + trapezoidal(yELFrange, wELFrange)
       ! integral from (ELFmax, kv)
       wmaxrange = linspace(ELFmax, k*v, size(wmaxrange))
       do i = 1, size(wmaxrange)
          ymaxrange(i) = wmaxrange(i) * ELF(k, wmaxrange(i), kbT, mu)

       end do

       omegaint = omegaint + trapezoidal(ymaxrange, wmaxrange)
       ! In this case, the integral over (0, \infty) is the same as the
       ! integral over (0, kv)
       int_allspace = omegaint
    end if

    ! Is the sum rule satisfied?
    if (abs(sr - int_allspace) / sr > 1e-2)  then
       ! print *, "Convergence to sum rule failed in omega integral:"
       ! print "(a, e7.2)", "k = ", k
       ! print "(a, f9.4)", "sum rule = ", sr
       ! print "(a, f9.4)", "integral = ", int_allspace
       ! print "(a, f9.4)", "integral up to kv = ", omegaint
       SRsatisfy = .false.
    else
       SRsatisfy = .true.
    end if

  end subroutine omegaintegral

  subroutine stoppingintegral(v, kbT, mu, kint, upper_bound_err)
    real(dp), intent(in)    :: v, kbT, mu
    real(dp), intent(inout) :: kint ! stopping power integral
    real(dp), intent(inout) :: upper_bound_err ! upper bound on error
    real(dp)                :: density, width, kint_upperbound
    real(dp)                :: k(200) ! integration variable
    real(dp)                :: y(size(k)) ! integrand
    integer                 :: i, N ! Number of steps for integration
    logical                 :: SRsatisfy
    real(dp)                :: klowest ! Lowest value of k for which we satisfy
                                       ! the sum rule

    density = srdensity(kbT, mu)

    N = size(k)
    width = (2*(10*kbT + mu))**(0.5)
    kint_upperbound = 2*(v +  width)
    k = logspace(0.01_dp, kint_upperbound, N)
    y = 0. ! sets all elements to 0
    upper_bound_err = 0.
    klowest = 0.
    SRsatisfy = .true.
    ! call omegaintegral(v, k(5), kbT, mu, density, y(5), SRsatisfy)
    !print *,  y(1)
    do i = 1, N !N, 1, -1
       ! print *, i
       call omegaintegral(v, k(i), kbT, mu, density, y(i), SRsatisfy)
       ! print *, SRsatisfy
       y(i) = y(i) / k(i)
       if (.not. SRsatisfy) then
          ! If sum rule is not satisfied for some k*, it is unlikely to be
          ! satisfied for any k <= k* (the omega integrand becomes
          ! progressively harder to integrate).
          ! print *, "SR not satisfied, v = ", v, " k = ", k(i)
          klowest = k(i)
          y(i) = 0
          ! exit
       end if
    end do

    kint = trapezoidal(y, k)
    if (klowest * v > wp(density)) upper_bound_err = pi/2 * klowest * v

  end subroutine stoppingintegral

end module DielectricStopping


SUBROUTINE F_representation(Fx,Fy,Fz,Ftotal)

  USE FUNCIONES

  IMPLICIT NONE
  DOUBLE PRECISION, DIMENSION(:,:), INTENT(OUT):: Fx,Fy,Fz
  DOUBLE PRECISION, INTENT(IN) :: Ftotal
  INTEGER k,p,N_k
  double precision k_

  Fx = 0.0
  Fy = 0.0
  Fz = 0.0

  N_k = 2*Ftotal + 1
  k_ = -(N_k - 1.0)/2.0

  DO k=1,N_k
     Fz(k,k) = k_
     k_ = k_ + 1
  END DO

  k_ = -(N_k - 1.0)/2.0
  DO k=1,N_k
     DO p=1,N_k
        Fx(k,p) = 0.5*(SQRT(Ftotal*(Ftotal+1) - k_*(k_+1))*delta_kr_int(k+1,p)  +&
             &  SQRT(Ftotal*(Ftotal+1) - k_*(k_-1))*delta_kr_int(k-1,p))
        Fy(k,p) = 0.5*(SQRT(Ftotal*(Ftotal+1) - k_*(k_+1))*delta_kr_int(k+1,p)  -&
             & SQRT(Ftotal*(Ftotal+1) - k_*(k_-1))*delta_kr_int(k-1,p))

     END DO
     k_ = k_ + 1
  END DO

END SUBROUTINE F_representation


      SUBROUTINE A_PLUS_B
     &          (mxlat,nrlat,mxlon,nrlon,
     &           amp1,sig1,amp2,sig2,amp3,sig3)

c     Adds signal powers and computes combined standard deviation by
c     adding the separate standard deviations weighted by their powers.
c     Assumes inputs are all in dB.

      dimension     amp1(mxlon,mxlat),sig1(mxlon,mxlat),
     &              amp2(mxlon,mxlat),sig2(mxlon,mxlat),
     &              amp3(mxlon,mxlat),sig3(mxlon,mxlat)

      do l=1,nrlat
         do k=1,nrlon
            pwr1=10.**(amp1(k,l)/10.)
            pwr2=10.**(amp2(k,l)/10.)
            amp3(k,l)=10.*LOG10(pwr1+pwr2)
            sig3(k,l)=SQRT((sig1(k,l)**2*pwr1+sig2(k,l)**2*pwr2)
     &                    /(pwr1+pwr2))
         end do
      end do

      RETURN
      END      ! A_PLUS_B


c=======================================================================
c
c     subroutine ALLOCMV1
c
c     This function implements the Markowitz strategy (Mean-Variance)
c
c     Min[ w*Q*w ]
c      s.t.
c     rho*w >= delta           (target return)
c     C*w <= b                 (linear constraints)
c     Cinf <= w <= Csup        (lower/upper bounds)
c     #assets < pmax           (max. nb. assets)
c
c        w   : portfolio weights
c        Q   : covariance matrix
c        rho : assets performance
c
c-----------------------------------------------------------------------
      SUBROUTINE ALLOCMV1 ( n, cov, rho,
     &                     neq, nin, ccst, bcst, cinf, csup, mu, pmax,
     &                     iwork, dwork, wopt, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : portfolio size                             integer
c            cov    : covariance matrix (n*n)                     double
c            rho    : mean returns vector (n)                     double
c            neq    : number equality constraints                integer
c            nin    : number inequality constraints              integer
c            ccst   : matrix of constraints (nasset*(neq+nin))    double
c            bcst   : vector initial of constraints (neq+nin)     double
c            cinf   : lower bound (n)                             double
c            csup   : upper bound (n)                             double
c            mu     : performance target                          double
c            pmax   : max. number of assets                      integer
c
c     WORKSPACE
c            iwork  : 3*n + 2*nin + neq + 3                       integer
c            dwork  : n*(2*n+nin+neq+9) + 4*nin + 2*neq + 4        double
c
c     OUTPUT
c            wopt   : optimal portfolio (n)                        double
c            info   : diagnostic argument                         integer
c
c     CALL
c       YM      : copy a vectorized matrix in a vectorized matrix
c       OPMV    : computing optimization for ALLOCMV (cf. OPMV.F)
c       TESTSDP : test if covariance matrix is SDP
c       EVMAX   :
c       EVMIN   :
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, neq, nin, pmax
      DOUBLE PRECISION mu
      DOUBLE PRECISION cov(*), rho(*), cinf(*), csup(*),
     &                 ccst(n,*), bcst(*), wopt(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, piwo, pdwo, pisdp, pdsdp, nassets, ind
      DOUBLE PRECISION mutest, wmin, EPS
      PARAMETER (EPS = 1.E-8)
c
c     external subroutines
      EXTERNAL OPMV, TESTSDP
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      pisdp = 1
c     pisdp : pointer for TESTSDP (n)
      piwo  = 1
c     piwo  : pointer for OPMV (3*n + 2*nin + neq + 3)
c
c     Total size of iwork array = ( 3*n + 2*nin + neq + 3 )
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdsdp = 1
c     pdsdp : pointer for TESTSDP (n*(2*n + 7))
      pdwo  = 1
c     pdwo  : pointer for OPMV
c            ( n*( n + neq + nin + 9 ) + 2*neq + 4*nin + 4  )
c
c     Total size of dwork array = n*(2*n + nin + neq + 9) + 4*nin + 2*neq + 4
c
c-----------------------------------------------------------------------
c
c     test if pmax < n
      IF (pmax .GT. n) THEN
         info = -111
         RETURN
      ENDIF
c
c     covariance matrix SDP ?
      CALL TESTSDP (n, cov, iwork(pisdp), dwork(pdsdp), info)
      IF (info .NE. 0) THEN
         info = -108
         RETURN
      ENDIF
c
c     tests constraints compatibility
      mutest = -1.E+8
      CALL OPMV ( n, cov, rho, mutest,
     &            neq, nin, ccst, bcst, cinf, csup,
     &            iwork(piwo), dwork(pdwo), wopt, info )
      IF (info .EQ. 1001) THEN
        info = -100
        RETURN
      ENDIF
      GOTO 999
c
c     optimization (cf. OPMV.F)
999   CALL OPMV ( n, cov, rho, mu,
     &            neq, nin, ccst, bcst, cinf, csup,
     &            iwork(piwo), dwork(pdwo), wopt, info )
      IF (info .EQ. 1001) THEN
        info = -101
        RETURN
      ENDIF
c
c     nb. assets lower/upper constraints
      nassets = n
      DO i = 1,n
        IF (wopt(i) .LT. EPS) THEN
            wopt(i) = 101
            cinf(i) = 0
            csup(i) = 0
            nassets = nassets - 1
        ENDIF
      ENDDO
c
c     if nassets > pmax then goto 999
      IF (nassets .GT. pmax) THEN
        CALL EVMINI ( n, wopt, wmin, ind )
        cinf(ind) = 0
        csup(ind) = 0
        GOTO 999
      ENDIF
c
c     update small wopt(i)
      DO i =1,n
        IF (wopt(i) .GT. 100) THEN
            wopt(i) = 0
        ENDIF
      ENDDO
c
      RETURN
      END


! =====================================================================
! function KR2XV
!
! This function computes the expectation value of the radial momentum
! operator squared.
! ---------------------------------------------------------------------
      double precision function KR2XV(nRP,nR,nP,dR,R,RdRP,U)
      implicit none

      integer :: nRP
      integer :: nR
      integer :: nP
      double precision :: dR
      double precision :: R(nR)
      double precision :: RdRP(nR)
      double complex :: U(nRP)

      integer :: i
      integer :: j
      integer :: k
      double precision :: XV
      double precision :: XV1
      double precision :: XV2
      double precision :: XV3
      double precision :: XV4
      double complex :: a
      double complex :: b
      double complex :: c
      double complex :: d
      double complex :: e

      KR2XV = 0.0d0
      a = dcmplx(2.0d0/dR**2,0.0d0)
      b = dcmplx(1.0d0/dR**2,0.0d0)

      k = 0
      do j = 1, nP
         k = k + 1
         c = dcmplx(-0.25d0/(dR*R(1)**2),0.0d0)
         d = dcmplx(-0.25d0/R(1)**4,0.0d0)
         e = dcmplx(1.0d0/R(1)**3,0.0d0)
         XV1 = dble(dconjg(U(k))*(a*U(k)-b*U(k+1)))
         XV2 = dble(dconjg(U(k))*c*U(k+1))
         XV3 = dble(dconjg(U(k))*d*U(k))
         XV4 = dble(dconjg(U(k))*e*U(k))
         XV = XV1 + XV2 + XV3 + XV4
         KR2XV = KR2XV + XV*RdRP(1)
         do i = 2, nR-1
            k = k + 1
            c = dcmplx(-0.25d0/(dR*R(i)**2),0.0d0)
            d = dcmplx(-0.25d0/R(i)**4,0.0d0)
            e = dcmplx(1.0d0/R(i)**3,0.0d0)
            XV1 = dble(dconjg(U(k))*(a*U(k)-b*(U(k-1)+U(k+1))))
            XV2 = dble(dconjg(U(k))*c*(U(k+1)-U(k-1)))
            XV3 = dble(dconjg(U(k))*d*U(k))
            XV4 = dble(dconjg(U(k))*e*U(k))
            XV = XV1 + XV2 + XV3 + XV4
            KR2XV = KR2XV + XV*RdRP(i)
         enddo
         k = k + 1
         c = dcmplx(-0.25d0/(dR*R(nR)**2),0.0d0)
         d = dcmplx(-0.25d0/R(nR)**4,0.0d0)
         e = dcmplx(1.0d0/R(nR)**3,0.0d0)
         XV1 = dble(dconjg(U(k))*(a*U(k)-b*U(k-1)))
         XV2 = dble(dconjg(U(k))*c*-U(k-1))
         XV3 = dble(dconjg(U(k))*d*U(k))
         XV4 = dble(dconjg(U(k))*e*U(k))
         XV = XV1 + XV2 + XV3 + XV4
         KR2XV = KR2XV + XV*RdRP(nR)
      enddo

      return
      end
! =====================================================================