!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module constant_values
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
implicit none

integer,parameter		:: n_max = 1000
integer,parameter		:: m_max = 10

real(4),parameter		:: x_min = 0.0
real(4),parameter		:: x_max = 1.0
real(8),parameter 		:: dx   = (x_max -x_min)/dble(m_max)	!! 空間刻み幅
real(8),parameter 		:: dt   = 1.0/dble(n_max)						!! 時間刻み幅

real(4),parameter		:: kappa = 0.5	!! 拡散係数

end module constant_values

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module set_functions
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
contains

end module set_functions

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program main
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

use constant_values
use set_functions

implicit none

integer										:: i
integer										:: j
real,dimension(0:m_max)		:: u
real,dimension(0:m_max)		:: x
real,dimension(0:n_max)			:: t
character(len=50) :: filename
character(len=50) :: tmp
real lambda

lambda = kappa * (dt/(dx**2))	!! 刻み幅定数

u(0) = 0.0
u(m_max) = 0.0

do i = 0, m_max
 x(i) = dx * i
end do

if (lambda <= 0.5) then

	filename='diffusion_0.dat'
	open(9, file = filename, status="replace")

	call get_ICs(u)

	do i = 0, m_max
		write(9,*) x(i), u(i)
	end do

	close(9)

	do j = 1, n_max+1
		t = dt * j
		call calculation_unew(u)
		if (mod(j,10)==0) then
			write(tmp,'(i4)') j
			filename='diffusion_'//trim(adjustl(tmp))//'.dat'
			open(10, file = filename, status="replace")

			do i = 0, m_max
				write(10,*) x(i), u(i)
			end do

			close(10)

		end if
	end do

else
	write(*,*) "この拡散数は Von Neumann の安定条件を満たしていない."

end if

stop
end program main

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine get_ICs(u)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
use constant_values
use set_functions

implicit none
integer									:: i
real										:: x
real,dimension(0:m_max)	:: u

do i = 1, m_max-1
	x = dx * i

	if (x >= 0.25 .and. x < 0.75) then
		u(i) = 1.0
	else
		u(i) = 0.0
	end if

end do

end subroutine get_ICs

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine calculation_unew(u)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
use constant_values
use set_functions

implicit none
integer			  						:: i
real,dimension(0:m_max)	:: u
real,dimension(0:m_max)	:: u_old
real lambda

lambda = kappa * (dt/(dx**2))	!! 刻み幅定数

do i = 0, m_max
	u_old(i) = u(i)
end do

do i = 1, m_max-1
	u(i) = u_old(i) + lambda * (u_old(i+1) - 2*u_old(i) + u_old(i-1))
end do

end subroutine calculation_unew


module types
  implicit none

  integer, parameter:: dp=kind(0.d0)
end module

!==============================================================================
! interpolation function
!==============================================================================
module interp
  implicit none

  contains

    subroutine idxsearch(ar1, ar2, k1, k2, idx)
      ! =====================================================
      ! Called by linear_interp
      !   ar1 and ar2  assumed to be monotonically decreasing or increasing
      !   idx(k) means ar2(k) is between ar1(k) and ar1(k+1)
      !   idx(k) = 0 or size(ar1) indicates ar2(k) is outside the range of ar1
      ! =====================================================
      use types
      integer,intent(in)   :: k1, k2
      real(dp), intent(in) :: ar1(k1) !sequence value to search
      real(dp), intent(in) :: ar2(k2) !set of value to serach for
      integer, intent(out) :: idx(k2) !interval locations

      integer  :: i, j
      real(dp) :: val

      if (ar1(1) < ar1(k1)) then
        !monotonically increasing case
        do i = 1, k2
          val = ar2(i)
          if (val <= ar1(1)) then
            idx(i) = 0
            cycle
          else if ( val >= ar1(k1)) then
            idx(i) = k1
            cycle
          end if
          do j = 1, k1-1
            if (val <= ar1(j+1)) then
              idx(i) = j
              exit
            end if
          end do
        end do
      else
        !monotonically decreasing case
        do i = 1, k2
          val = ar2(i)
          if (val >= ar1(1)) then
            idx(i) = 0
            cycle
          else if ( val <= ar1(k1)) then
            idx(i) = k1
            cycle
          end if
          do j = 1, k1-1
            if (val >= ar1(j+1)) then
              idx(i) = j
              exit
            end if
          end do
        end do
      end if
    end subroutine idxsearch

    subroutine linear_interp(in,zin,zout,xnin,znin,znout,out)
      ! =====================================================
      ! 2D vertical linear interpolation.
      ! in   : (xnin, znin) values used for interpolation.
      ! zin  : vertical coordinates for in array.
      ! zout : vertical levels which interpolating applied.
      ! xnin,znin,znout : dimensions for in, zin and zout.
      ! =====================================================
      use types
      integer,  intent(in)  :: xnin, znin, znout
      real(dp), intent(in)  :: in(xnin,znin), zin(xnin,znin), zout(znout)
      real(dp), intent(out) :: out(xnin,znout)

      !f2py intent(in) :: in, zin, zout
      !f2py intent(out) :: out

      integer idx(znout)
      real(dp) :: a, x(znin), y(znin)
      integer  :: i, j, jo

      do i = 1, xnin
        x = zin(i,:)
        y = in(i,:)
        call idxsearch(x, zout, znin, znout, idx)
        do j = 1, znout
          jo = idx(j)
          if (jo == 0) then ! outside of bottom level is constant
            out(i,j) = y(1)
          else if (jo == znin) then !outside of top level is constant
            out(i,j) = y(znin)
          else !linear interpolation
            a = (y(jo+1) - y(jo))/(x(jo+1) - x(jo))
            out(i,j) = a*(zout(j) - x(jo)) + y(jo)
          end if
        end do
      end do
    end subroutine linear_interp

    function binarysearch(length, array, value, delta)
      ! Given an array and a value, returns the index of the element that
      ! is closest to, but less than, the given value.
      ! Uses a binary search algorithm.
      ! "delta" is the tolerance used to determine if two values are equal
      ! if ( abs(x1 - x2) <= delta) then
      !    assume x1 = x2
      ! endif
      ! https://github.com/cfinch/Shocksolution_Examples/blob/master/FORTRAN/BilinearInterpolation/interpolation.f90
      use types
      implicit none
      integer, intent(in) :: length
      real(dp), dimension(length), intent(in) :: array
      real(dp), intent(in) :: value
      real(dp), intent(in), optional :: delta

      !f2py intent(in) :: length, array, value
      !f2py intent(in), optional :: delta
      !f2py depend(length) :: array

      integer  :: binarysearch
      integer  :: left, middle, right
      real(dp) :: d

      if (present(delta) .eqv. .true.) then
        d = delta
      else
        d = 1e-9
      endif

      left = 1
      right = length
      do
        if (left > right) then
          exit
        endif
        middle = nint((left+right) / 2.0)
        if ( abs(array(middle) - value) <= d) then
          binarySearch = middle
          return
        else if (array(middle) > value) then
          right = middle - 1
        else
          left = middle + 1
        end if
      end do
      binarysearch = right

    end function binarysearch

    subroutine bilinear_interp(x_array, y_array, f, x, y, z, x_len, y_len, p_len, delta)
      ! This function uses bilinear interpolation to estimate the value
      ! of a function f at points (x,y)
      ! f is assumed to be sampled on a regular grid, with the grid x values specified
      ! by x_array and the grid y values specified by y_array
      ! Reference: http://en.wikipedia.org/wiki/Bilinear_interpolation
      ! https://github.com/cfinch/Shocksolution_Examples/blob/master/FORTRAN/BilinearInterpolation/interpolation.f90
      use types
      implicit none
      integer, intent(in) :: x_len, y_len, p_len
      real(dp), dimension(x_len), intent(in) :: x_array
      real(dp), dimension(y_len), intent(in) :: y_array
      real(dp), dimension(x_len, y_len), intent(in) :: f
      real(dp), dimension(p_len), intent(in) :: x, y
      real(dp), dimension(p_len), intent(out) :: z
      real(dp), intent(in), optional :: delta
      !f2py depend(x_len) :: x_array, f
      !f2py depend(y_len) :: y_array, f
      !f2py depend(p_len) :: x, y, z

      real(dp) :: denom, x1, x2, y1, y2
      integer :: i, j, p

      do p=1, p_len
        i = binarysearch(x_len, x_array, x(p))
        j = binarysearch(y_len, y_array, y(p))

        x1 = x_array(i)
        x2 = x_array(i+1)

        y1 = y_array(j)
        y2 = y_array(j+1)

        denom = (x2 - x1)*(y2 - y1)

        z(p) = (f(i,j)*(x2-x(p))*(y2-y(p)) + f(i+1,j)*(x(p)-x1)*(y2-y(p)) + &
            f(i,j+1)*(x2-x(p))*(y(p)-y1) + f(i+1, j+1)*(x(p)-x1)*(y(p)-y1))/denom
      end do
    end subroutine bilinear_interp

end module interp

!==============================================================================
! grid manipulating function
!==============================================================================
module grid
  implicit none

  contains

    subroutine smooth_area_average(in_field, lon, lat, radius, out_field, n, nlon, nlat)
      ! =====================================================
      ! smoothing grid field with area average
      ! in_field  : 3D field array used to smoothing, the 2, 3 dimension are lat and lon.
      ! lon, lat  : 2D array lon and lat coorindates for the in_field.
      ! radius    : smoothing radius.
      ! out_field : return smoothed field.
      ! =====================================================
      use types
      real(dp), intent(in)  :: n, nlon, nlat
      real(dp), intent(in)  :: in_field(n, nlat, nlon), lon(nlat, nlon), lat(nlat, nlon)
      real(dp), intent(in)  :: radius
      real(dp), intent(out) :: out_field(n, nlat, nlon)

      !f2py intent(in) :: in_field, lon, lat, radius
      !f2py intent(out) :: out_field

      integer :: i, j, k, ii, jj
      real(dp) :: dlat(nlat, nlon), dlon(nlat, nlon), lat1, lat2(nlat, nlon)
      real(dp) :: a(nlat, nlon), dist(nlat, nlon), flag(nlat, nlon), numb
      real(dp), parameter :: earth_radius = 6371000.0
      real(dp), parameter :: deg_to_rad = atan(1.0)/45

      flag = 1.0
      do j=1, nlat
        do i=1, nlon
          ! great circle distance
          dlat = (lat-lat(j,i)) * deg_to_rad
          dlon = (lon-lon(j,i)) * deg_to_rad
          lat1 = lat(j,i) * deg_to_rad
          lat2 = lat * deg_to_rad
          a = (sin(dlat/2))**2 + cos(lat1)*cos(lat2)*(sin(dlon/2))**2
          dist = earth_radius*2.0*asin(sqrt(a))

          numb = sum(flag, mask=dist <= radius)
          if (numb > 0) then
            do k=1, n
              out_field(k, j, i) = sum(in_field(k, :, :), mask=dist <= radius) / numb
            end do
          else
            out_field(:, j, i) = in_field(:, j, i)
          end if
        end do
      end do
    end subroutine smooth_area_average

    subroutine smooth_gaussian(in_field, lon, lat, radius, sigma, out_field, n, nlon, nlat)
      ! =====================================================
      ! smoothing grid field with area average
      ! in_field  : 3D field array used to smoothing, the 2, 3 dimension are lat and lon.
      ! lon, lat  : 2D array lon and lat coorindates for the in_field.
      ! radius    : smoothing radius.
      ! sigma     : gaussian sigma parameter.
      ! out_field : return smoothed field.
      ! =====================================================
      use types
      real(dp), intent(in) :: n, nlon, nlat
      real(dp), intent(in) :: in_field(n, nlat, nlon), lon(nlat, nlon), lat(nlat, nlon)
      real(dp), intent(in) :: radius, sigma    ! sigma is an adjustable smoothing length scale.
      real(dp), intent(out) :: out_field(n, nlat, nlon)
      !f2py intent(in) :: in_field, lon, lat, radius, sigma
      !f2py intent(out) :: out_field

      integer :: i, j, k, ii, jj
      real(dp) :: dlat(nlat, nlon), dlon(nlat, nlon), lat1, lat2(nlat, nlon)
      real(dp) :: a(nlat, nlon), dist(nlat, nlon), field(nlat, nlon), flag(nlat, nlon), numb
      real(dp), parameter :: earth_radius = 6371000.0
      real(dp), parameter :: deg_to_rad = atan(1.0)/45
      real(dp), parameter :: pi = 3.1415926535897932_8

      flag = 1.0
      do j=1, nlat
        do i=1, nlon
          ! great circle distance
          dlat = (lat-lat(j,i)) * deg_to_rad
          dlon = (lon-lon(j,i)) * deg_to_rad
          lat1 = lat(j,i) * deg_to_rad
          lat2 = lat * deg_to_rad
          a = (sin(dlat/2))**2 + cos(lat1)*cos(lat2)*(sin(dlon/2))**2
          dist = earth_radius*2.0*asin(sqrt(a))

          numb = sum(flag, mask=dist <= radius)
          if (numb > 0) then
            do k=1, n
              ! gaussian filter value
              field = exp(-0.5*(dist/sigma)**2)*in_field(k, :, :)/(2*pi*sigma**2)
              out_field(k, j, i) = sum(field, mask=dist <= radius) / numb
            end do
          else
            out_field(:, j, i) = in_field(:, j, i)
          end if
        end do
      end do
    end subroutine smooth_gaussian

end module grid

!==============================================================================
! regridding function
!==============================================================================
module regrid
  implicit none

  contains

  subroutine box_average(field0, lon0, lat0, lon1, lat1, width, field1, nlon0, nlat0, nlon1, nlat1)
    ! =====================================================
    ! regridding high resolution field0 to coarse field1 with box_average.
    ! field0: 2D array (nlat1, nlon0) for input high resolution, with missing value is -9999.0
    ! lon0, lat0: 2D coordinates for field0
    ! field1: 2D array (nlat1, nlon0) for output coarse resolution.
    ! lon1, lat1: 2D coordinates for field1
    ! width: box width
    ! =====================================================
    use types
    real(dp), intent(in) :: width, nlon0, nlat0, nlon1, nlat1
    real(dp), intent(in) :: field0(nlat0, nlon0), lon0(nlat0, nlon0), lat0(nlat0, nlon0)
    real(dp), intent(in) :: lon1(nlat1, nlon1), lat1(nlat1, nlon1)
    real(dp), intent(out) :: field1(nlat1, nlon1)
    !f2py intent(in) :: field0, lon0, lat0, lon1, lat1, width
    !f2py intent(out) :: feild1

    integer :: i, j, k, ii, jj, numb
    logical :: mask(nlat0, nlon0)

    do j=1, nlat1
      do i=1, nlon1
        mask = (lon0 >= (lon1(j,i)-width)) .and. (lon0 <= (lon1(j,i)+width)) .and. &
               (lat0 >= (lat1(j,i)-width)) .and. (lat0 <= (lat1(j,i)+width)) .and. &
               (field0 /= -9999.0)
        numb = count(mask)
        if (numb > 0) then
          field1(j, i) = sum(field0, mask=mask) / numb
        else
          field1(j, i) = -9999.0
        end if
      end do
    end do
  end subroutine box_average
end module regrid


subroutine coarse_to_fine_ls(e_2h, nx, ny, xi_2h, xf_2h, xi_h, xf_h, e_h, delx, dely)
!USE variables
use kind_parameters
implicit none
include 'mpif.h'

integer:: i, j, nx, ny, io, jo, ie, je
integer:: xi_h, xf_h, xi_2h, xf_2h
real(kind=dp), intent(in), dimension(-1:nx+2,xi_2h-3:xf_2h+3):: e_2h
real(kind=dp), intent(out), dimension(-1:nx*2,xi_h-3:xf_h+3):: e_h
real(kind=dp), dimension(-2:2*nx):: delx
real(kind=dp), dimension(-2:2*ny):: dely

!write(*,*) nx, xi_2h, xf_2h

! Apply linear interpolation to get values from coarse to fine grid
! Input
! e_2h   Variable in coarse grid
! hx, hy     grid spacing
!
! Output
! e_h     Variable in fine grid

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012
! Indices Rechecked on Jan 13, 2013

!do j = xi_2h,xf_2h
!
!    do i = 2,nx-2
!
!    if (j /= ny-1) then
!
!        e_h(2*i,2*j) = (1.0/16.0)*(9.0*e_2h(i+1,j+1) + 3.0*e_2h(i,j+1) + 3.0*e_2h(i+1,j) + e_2h(i,j))
!        e_h(2*i,2*j-1) = (1.0/16.0)*(9.0*e_2h(i+1,j) + 3.0*e_2h(i,j) + 3.0*e_2h(i+1,j+1) + e_2h(i,j+1))
!        e_h(2*i-1,2*j) = (1.0/16.0)*(9.0*e_2h(i,j+1) + 3.0*e_2h(i,j) + 3.0*e_2h(i+1,j+1) + e_2h(i+1,j))
!        e_h(2*i-1,2*j-1) = (1.0/16.0)*(9.0*e_2h(i,j) + 3.0*e_2h(i+1,j) + 3.0*e_2h(i,j+1) + e_2h(i+1,j+1))
!
!    end if
!
!    end do
!
!end do

do j = xi_h,xf_h

    do i = 2,2*nx-3

    io = (i+1)/2
    jo = (j+1)/2

    ie = i/2
    je = j/2

    if (i .eq. 2) then

        if (j .eq. 2) then

        e_h(i,j) =  (1.0/4.0)*(e_2h(ie,je) + e_2h(ie,je+1) + e_2h(ie+1,je) + e_2h(ie+1,je+1))

        else if (j .eq. 2*ny-3) then

        e_h(i,j) = (1.0/4.0)*(e_2h(ie,jo) + e_2h(ie,jo+1) + e_2h(ie+1,jo) + e_2h(ie+1,jo+1))

        else

            if(mod(j,2) .eq. 0) then

            e_h(i,j) = (1.0/8.0)*(3.0*e_2h(ie,je+1) + 3.0*e_2h(ie+1,je+1) + e_2h(ie,je) + e_2h(ie+1,je))

            else

            e_h(i,j) = (1.0/8.0)*(e_2h(ie,jo+1) + e_2h(ie+1,jo+1) + 3.0*e_2h(ie,jo) + 3.0*e_2h(ie+1,jo))

            end if

        end if

   else if (i .eq. 2*nx-3) then

        if (j .eq. 2) then

        e_h(i,j) =  (1.0/4.0)*(e_2h(io,je) + e_2h(io,je+1) + e_2h(io+1,je) + e_2h(io+1,jo+1))

        else if (j .eq. 2*ny-3) then

        e_h(i,j) = (1.0/4.0)*(e_2h(io,jo) + e_2h(io,jo+1) + e_2h(io+1,jo) + e_2h(io+1,jo+1))

        else

            if(mod(j,2) .eq. 0) then

            e_h(i,j) = (1.0/8.0)*(3.0*e_2h(io,je+1) + 3.0*e_2h(io+1,je+1) + e_2h(io,je) + e_2h(io+1,je))

            else

            e_h(i,j) = (1.0/8.0)*(e_2h(io,jo+1) + e_2h(io+1,jo+1) + 3.0*e_2h(io,jo) + 3.0*e_2h(io+1,jo))

            end if

        end if

    else

        if (j .eq. 2) then

            if(mod(i,2) .eq. 0) then

            e_h(i,j) = (1.0/8.0)*(3.0*e_2h(ie+1,je) + 3.0*e_2h(ie+1,je+1) + e_2h(ie,je) + e_2h(ie,je+1))

            else

            e_h(i,j) = (1.0/8.0)*(e_2h(io+1,je) + e_2h(io+1,je+1) + 3.0*e_2h(io,je) + 3.0*e_2h(io,je+1))

            end if

        else if (j .eq. 2*ny-3) then

            if(mod(i,2) .eq. 0) then

            e_h(i,j) = (1.0/8.0)*(3.0*e_2h(ie+1,jo+1) + 3.0*e_2h(ie+1,jo) + e_2h(ie,jo) + e_2h(ie,jo+1))

            else

            e_h(i,j) = (1.0/8.0)*(3.0*e_2h(io,jo+1) + e_2h(io+1,jo+1) + 3.0*e_2h(io,jo) + e_2h(io+1,jo))

            end if

        else

            if (mod(i,2) .ne. 0 .and. mod(j,2) .ne. 0) e_h(i,j) = (1.0/16.0)*(9.0*e_2h(io,jo) + 3.0*e_2h(io,jo+1) + 3.0*e_2h(io+1,jo) + e_2h(io+1,jo+1))
            if (mod(i,2) .eq. 0 .and. mod(j,2) .eq. 0) e_h(i,j) = (1.0/16.0)*(e_2h(ie,je) + 3.0*e_2h(ie,je+1) + 3.0*e_2h(ie+1,je) + 9.0*e_2h(ie+1,je+1))
            if (mod(i,2) .ne. 0 .and. mod(j,2) .eq. 0) e_h(i,j) = (1.0/16.0)*(3.0*e_2h(io,je) + 3.0*e_2h(io+1,je+1) + e_2h(io+1,je) + 9.0*e_2h(io,je+1))
            if (mod(i,2) .eq. 0 .and. mod(j,2) .ne. 0) e_h(i,j) = (1.0/16.0)*(3.0*e_2h(ie,jo) + 3.0*e_2h(ie+1,jo+1) + 9.0*e_2h(ie+1,jo) + e_2h(ie,jo+1))

        end if

    end if

    end do

end do

!  e_h(1,xi_h-3:xf_h+3) = e_h(2,xi_h-3:xf_h+3) + delx(1)*(e_h(2,xi_h-3:xf_h+3) - e_h(3,xi_h-3:xf_h+3))/delx(2)
!  e_h(0,xi_h-3:xf_h+3) = e_h(1,xi_h-3:xf_h+3) + delx(0)*(e_h(1,xi_h-3:xf_h+3) - e_h(2,xi_h-3:xf_h+3))/delx(1)
!  e_h(-1,xi_h-3:xf_h+3) = e_h(0,xi_h-3:xf_h+3)+ delx(-1)*(e_h(0,xi_h-3:xf_h+3) - e_h(1,xi_h-3:xf_h+3))/delx(0)
!
!  e_h(nx,xi_h-3:xf_h+3) = e_h(nx-1,xi_h-3:xf_h+3) + delx(nx-1)*(e_h(nx-1,xi_h-3:xf_h+3) - e_h(nx-2,xi_h-3:xf_h+3))/delx(nx-2)
!  e_h(nx+1,xi_h-3:xf_h+3) = e_h(nx,xi_h-3:xf_h+3)+ delx(nx)*(e_h(nx,xi_h-3:xf_h+3) - e_h(nx-1,xi_h-3:xf_h+3))/delx(nx-1)
!  e_h(nx+2,xi_h-3:xf_h+3) = e_h(nx+1,xi_h-3:xf_h+3)+ delx(nx+1)*(e_h(nx+1,xi_h-3:xf_h+3) - e_h(nx,xi_h-3:xf_h+3))/delx(nx)
!
!if (xf_h .eq. ny-1) then
!
!  e_h(:,ny) = e_h(:,ny-1) + dely(ny-1)*(e_h(:,ny-1) - e_h(:,ny-2))/dely(ny-2)
!  e_h(:,ny+1) = e_h(:,ny) + dely(ny)*(e_h(:,ny) - e_h(:,ny-1))/dely(ny-1)
!  e_h(:,ny+2) = e_h(:,ny+1)+ dely(ny+1)*(e_h(:,ny+1) - e_h(:,ny))/dely(ny)
!
!end if
!
!if (xi_h .eq. 2) then
!
!  e_h(:,1) = e_h(:,2)+ dely(1)*(e_h(:,2) - e_h(:,3))/dely(2)
!  e_h(:,0) = e_h(:,1)+ dely(0)*(e_h(:,1) - e_h(:,2))/dely(1)
!  e_h(:,-1) = e_h(:,0)+ dely(-1)*(e_h(:,0) - e_h(:,1))/dely(0)
!
!end if
!
call exchange_lsdata(e_h, nx*2+2, xi_h, xf_h)
!if (xi_2h .eq. 2) then
!
!j = 1
!
!    e_h(2,2*j) = (1.0/4.0)*(e_2h(1,j) + e_2h(1,j+1) + e_2h(2,j) + e_2h(2,j+1))
!
!    do i = 2,nx-2
!
!        e_h(2*i-1,2*j) = (1.0/8.0)*(3.0*e_2h(i,j) + 3.0*e_2h(i,j+1) + e_2h(i+1,j) + e_2h(i+1,j+1))
!        e_h(2*i,2*j) = (1.0/8.0)*(e_2h(i,j) + e_2h(i,j+1) + 3.0*e_2h(i+1,j) + 3.0*e_2h(i+1,j+1))
!
!    end do
!
!    e_h(2*nx-3,2*j) = (1.0/4.0)*(e_2h(nx-1,j) + e_2h(nx-1,j+1) + e_2h(nx,j) + e_2h(nx,j+1))
!
!
!end if
!
!do j = xi_2h,xf_2h
!
!if( j /= ny-1) then
!
!    i = 1
!
!        e_h(2*i,2*j-1) = (1.0/8.0)*(3.0*e_2h(i,j) + 3.0*e_2h(i+1,j) + e_2h(i,j+1) + e_2h(i+1,j+1))
!        e_h(2*i,2*j) = (1.0/8.0)*(e_2h(i,j) + e_2h(i+1,j) + 3.0*e_2h(i,j+1) + 3.0*e_2h(i+1,j+1))
!
!    i = nx-1
!
!        e_h(2*i-1,2*j-1) = (1.0/8.0)*(3.0*e_2h(i,j) + 3.0*e_2h(i+1,j) + e_2h(i,j+1) + e_2h(i+1,j+1))
!        e_h(2*i-1,2*j) = (1.0/8.0)*(e_2h(i,j) + e_2h(i+1,j) + 3.0*e_2h(i,j+1) + 3.0*e_2h(i+1,j+1))
!
!end if
!
!end do
!
!
!if (xf_2h .eq. ny-1) then
!
!j = ny-1
!
!    e_h(2,2*j-1) = (1.0/4.0)*(e_2h(1,j) + e_2h(1,j+1) + e_2h(2,j) + e_2h(2,j+1))
!
!    do i = 2,nx-2
!
!        e_h(2*i-1,2*j-1) = (1.0/8.0)*(3.0*e_2h(i,j) + 3.0*e_2h(i,j+1) + e_2h(i+1,j) + e_2h(i+1,j+1))
!        e_h(2*i,2*j-1) = (1.0/8.0)*(e_2h(i,j) + e_2h(i,j+1) + 3.0*e_2h(i+1,j) + 3.0*e_2h(i+1,j+1))
!
!    end do
!
!    e_h(2*nx-3,2*j-1) = (1.0/4.0)*(e_2h(nx-1,j) + e_2h(nx-1,j+1) + e_2h(nx,j) + e_2h(nx,j+1))
!
!end if

!string = '(   (1x, e10.3))'
!
!write(string(2:4),'(i3)')(nx*2-2)
!
!if (taskid .eq. 0) then
!
!filename = 'e_h0_prev.txt'
!
!open (unit = 13, file = filename)
!
!do jt=xi_h-1,xf_h+1
!
! write(13,string) e_h(1:nx*2-2,jt)
!
!end do
!
!write(13,*) 'xi_h = ',xi_h, 'xf_h= ',xf_h
!write(13,*) 'xi2 = ',xi_2h, 'xf2= ',xf_2h
!
!close(13)
!
!else
!
!filename = 'e_h1_prev.txt'
!
!open (unit = 13, file = filename)
!
!do jt=xi_h-1,xf_h+1
!
! write(13,string) e_h(1:nx*2-2,jt)
!
!end do
!
!write(13,*) 'xi_h = ',xi_h, 'xf_h= ',xf_h
!write(13,*) 'xi2 = ',xi_2h, 'xf2= ',xf_2h
!
!close(13)
!
!end if
!
!call exchange_data(e_h, nx*2-2, xi_h, xf_h)
!
!string = '(   (1x, e10.3))'
!
!write(string(2:4),'(i3)')(nx*2-2)
!
!if (taskid .eq. 0) then
!
!filename = 'e_h0.txt'
!
!open (unit = 13, file = filename)
!
!do jt=xi_h-1,xf_h+1
!
! write(13,string) e_h(1:nx*2-2,jt)
!
!end do
!
!close(13)
!
!else
!
!filename = 'e_h1.txt'
!
!open (unit = 13, file = filename)
!
!do jt=xi_h-1,xf_h+1
!
! write(13,string) e_h(1:nx*2-2,jt)
!
!end do
!
!close(13)
!
!end if

!stop

end subroutine


program problem39
  implicit none
  integer, parameter        :: limit = 1000
  integer, dimension(limit) :: perimeters
  integer                   :: a,b,abc,best=1
  double precision          :: c

  do a=1,limit
     perimeters(a)=0
  end do

  do a=1,limit
     do b=a,limit
        c = sqrt(dble(a**2 + b**2))
        if ((a + b + c) > limit) exit
        if (mod(c,1.0) == 0.0) then
           abc=a+b+int(c)
           perimeters(abc)=perimeters(abc)+1
        end if
     end do
  end do

  do a=1,limit
     if (perimeters(a) > perimeters(best)) best=a
  end do

  print *, best

end program problem39


c     program DRDRANUS
c>> 1995-10-23 DRDRANUS Krogh  Reduced N to work on PC in D.P.
c>> 1994-10-19 DRDRANUS Krogh  Changes to use M77CON
c>> 1992-03-13 DRDRANUS CLL
c
c     Driver to demonstrate use of DRANUS to generate random numbers
c     from the uniform distribution between A and A+B.
c     Program computes histogram for N numbers
c     ------------------------------------------------------------------
c--D replaces "?": DR?RANUS, ?RANUS, ?STAT1, ?STAT2
c     ------------------------------------------------------------------
      integer N, NCELLS
      parameter(N = 8000, NCELLS = 10+2)
      double precision A, B, STATS(5), YTAB(N)
      integer IHIST(NCELLS)
      data A, B / 20.0d0, 10.0d0/
c     ------------------------------------------------------------------
      STATS(1) = 0.0d0
c                          Get array of scaled random numbers.
c
      call DRANUS(YTAB, N, A, B)
c
c                          Compute statistics and histogram.
c
        call DSTAT1(YTAB, N, STATS, IHIST, NCELLS, A, A+B)
c
c                          Print the statistics and histogram.
c
      write(*,'(13x,a//)') 'Uniform random numbers from DRANUS'
      call DSTAT2(STATS, IHIST, NCELLS, A, A+B)
      end


program planetmotion
use velocityverlet
implicit none
real(16),allocatable :: p(:,:),a(:,:),a1(:,:),m(:),x(:),y(:),z(:),vx(:),vy(:),vz(:)
real(16) :: t,d,ax,ay,az,G=6.67e-11
integer :: i,w,ios,k,l,n,j,b=0,c=0

open(unit=1,file='planets.txt',iostat=ios,status='old')   !reading the input file
  if(ios/=0) then
    print '(a)','Error opening planets.txt'
    stop
  end if
  read(1,*,iostat=ios) n,t,i,w
  allocate(p(n,7),a(n,3),a1(n,3),m(n),x(n),y(n),z(n),vx(n),vy(n),vz(n))
  k=1
  do
    read(1,*,iostat=ios) m(k),x(k),y(k),z(k),vx(k),vy(k),vz(k)
    if(ios<0) exit
    p(k,1)=m(k)
    p(k,2)=x(k)
    p(k,3)=y(k)
    p(k,4)=z(k)
    p(k,5)=vx(k)
    p(k,6)=vy(k)
    p(k,7)=vz(k)
        k=k+1
  end do
close(1)

a=0
do k=1,i
  if(modulo(c,w)==0) then  !printing and writing if the interval criterium is met
    open(unit=1,file='plot.dat',iostat=ios,position='append')
    if(ios/=0) then
      print '(a)','Error opening plot.dat'
      stop
    end if
    open(unit=2,file='plot.xyz',iostat=ios,position='append')
    if(ios/=0) then
      print '(a)','Error opening plot.xyz'
      stop
    end if
    b=b+1
    print'(a,i9,a,g15.5,a,i9)','Step: ',k,'   Time: ',k*t,'   Steps written to file: ', b
    write(2,'(i3)') n
    write(2,*)
    do l=1,n
      write(1,'(3g20.10)') p(l,2),p(l,3),p(l,4)
      write(2,'(i3,3g20.10)') l,p(l,2),p(l,3),p(l,4)
      print'(i3,3g20.10)',l,p(l,2),p(l,3),p(l,4)
    end do
    print*,
    close(1)
  end if
  c=c+1
  do l=1,n
    p(l,2:4)=positions(p(l,2),p(l,3),p(l,4),p(l,5),p(l,6),p(l,7),a(l,:),t)   !using verlet module to calculate new postions
  end do
  do l=1,n  !iterating new accelerations
    ax=0
    ay=0
    az=0
    do j=1,n
      if(j/=l) then   !don't want to calculate acceleration toward itself
        d=sqrt((p(l,2)-p(j,2))**2+(p(l,3)-p(j,3))**2+(p(l,4)-p(j,4))**2)
        ax=ax+p(j,1)/d**3*(p(j,2)-p(l,2))
        ay=ay+p(j,1)/d**3*(p(j,3)-p(l,3))
        az=az+p(j,1)/d**3*(p(j,4)-p(l,4))
      end if
    end do
    a1(l,:)=[G*ax,G*ay,G*az]
  end do
  do l=1,n
    p(l,5:7)=velocities(p(l,5),p(l,6),p(l,7),a(l,:),a1(l,:),t)     !verlet module to get new velocities
  end do
  a=a1
end do
print'(a)','Completed'   !Shows when the program is done
end program planetmotion


      SUBROUTINE SB08ND( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute a real polynomial E(z) such that
C
C        (a)  E(1/z) * E(z) = A(1/z) * A(z) and
C        (b)  E(z) is stable - that is, E(z) has no zeros with modulus
C             greater than 1,
C
C     which corresponds to computing the spectral factorization of the
C     real polynomial A(z) arising from discrete optimality problems.
C
C     The input polynomial may be supplied either in the form
C
C     A(z) = a(0) + a(1) * z + ... + a(DA) * z**DA
C
C     or as
C
C     B(z) = A(1/z) * A(z)
C          = b(0) + b(1) * (z + 1/z) + ... + b(DA) * (z**DA + 1/z**DA)
C                                                                    (1)
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     ACONA   CHARACTER*1
C             Indicates whether the coefficients of A(z) or B(z) =
C             A(1/z) * A(z) are to be supplied as follows:
C             = 'A':  The coefficients of A(z) are to be supplied;
C             = 'B':  The coefficients of B(z) are to be supplied.
C
C     Input/Output Parameters
C
C     DA      (input) INTEGER
C             The degree of the polynomials A(z) and E(z).  DA >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (DA+1)
C             On entry, if ACONA = 'A', this array must contain the
C             coefficients of the polynomial A(z) in increasing powers
C             of z, and if ACONA = 'B', this array must contain the
C             coefficients b ,b ,...,b   of the polynomial B(z) in
C                           0  1      DA
C             equation (1). That is, A(i) = b    for i = 1,2,...,DA+1.
C                                            i-1
C             On exit, this array contains the coefficients of the
C             polynomial B(z) in eqation (1). Specifically, A(i)
C             contains b   ,  for i = 1,2,...DA+1.
C                       i-1
C
C     RES     (output) DOUBLE PRECISION
C             An estimate of the accuracy with which the coefficients of
C             the polynomial E(z) have been computed (see also METHOD
C             and NUMERICAL ASPECTS).
C
C     E       (output) DOUBLE PRECISION array, dimension (DA+1)
C             The coefficients of the spectral factor E(z) in increasing
C             powers of z.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= 5*DA+5.
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             = 2:  if on entry, ACONA = 'B' but the supplied
C                   coefficients of the polynomial B(z) are not the
C                   coefficients of A(1/z) * A(z) for some real A(z);
C                   in this case, RES and E are unassigned;
C             = 3:  if the iterative process (see METHOD) has failed to
C                   converge in 30 iterations;
C             = 4:  if the last computed iterate (see METHOD) is
C                   unstable. If ACONA = 'B', then the supplied
C                   coefficients of the polynomial B(z) may not be the
C                   coefficients of A(1/z) * A(z) for some real A(z).
C
C     METHOD
C         _                                               _
C     Let A(z) be the conjugate polynomial of A(z), i.e., A(z) = A(1/z).
C
C     The method used by the routine is based on applying the
C     Newton-Raphson iteration to the function
C               _       _
C        F(e) = A * A - e * e,
C
C     which leads to the iteration formulae (see [1] and [2])
C
C        _(i)   (i)  _(i)   (i)     _      )
C        q   * x   + x   * q    = 2 A * A  )
C                                          )   for i = 0, 1, 2,...
C         (i+1)    (i)   (i)               )
C        q     = (q   + x   )/2            )
C
C     The iteration starts from
C
C         (0)                                        DA
C        q   (z) = (b(0) + b(1) * z + ... + b(DA) * z  ) / SQRT( b(0))
C
C     which is a Hurwitz polynomial that has no zeros in the closed unit
C                                            (i)
C     circle (see [2], Theorem 3). Then lim q   = e, the convergence is
C     uniform and e is a Hurwitz polynomial.
C
C     The iterates satisfy the following conditions:
C              (i)
C        (a)  q    has no zeros in the closed unit circle,
C              (i)     (i-1)
C        (b)  q    <= q     and
C              0       0
C              DA   (i) 2    DA     2
C        (c)  SUM (q   )  - SUM (A )  >= 0.
C             k=0   k       k=0   k
C                                     (i)
C     The iterative process stops if q    violates (a), (b) or (c),
C     or if the condition
C                       _(i) (i)  _
C        (d)  RES  = ||(q   q   - A A)|| < tol,
C
C     is satisfied, where || . || denotes the largest coefficient of
C                     _(i) (i)  _
C     the polynomial (q   q   - A A) and tol is an estimate of the
C                                                    _(i)  (i)
C     rounding error in the computed coefficients of q    q   . If
C                                            (i-1)
C     condition (a) or (b) is violated then q      is taken otherwise
C      (i)
C     q    is used. Thus the computed reciprocal polynomial E(z) = z**DA
C     * q(1/z) is stable. If there is no convergence after 30 iterations
C     then the routine returns with the Error Indicator (INFO) set to 3,
C     and the value of RES may indicate whether or not the last computed
C     iterate is close to the solution.
C                                               (0)
C     If ACONA = 'B', then it is possible that q    is not a Hurwitz
C     polynomial, in which case the equation e(1/z) * e(z) = B(z) has no
C     real solution (see [2], Theorem 3).
C
C     REFERENCES
C
C     [1] Kucera, V.
C         Discrete Linear Control, The polynomial Approach.
C         John Wiley & Sons, Chichester, 1979.
C
C     [2] Vostry, Z.
C         New Algorithm for Polynomial Spectral Factorization with
C         Quadratic Convergence I.
C         Kybernetika, 11, pp. 415-422, 1975.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997.
C     Supersedes Release 2.0 routine SB08BD by F. Delebecque and
C     A.J. Geurts.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Factorization, Laplace transform, optimal control, optimal
C     filtering, polynomial operations, spectral factorization, zeros.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, HALF, ONE, TWO
      PARAMETER         ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,
     $                    TWO  = 2.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         ACONA
      INTEGER           DA, INFO, LDWORK
      DOUBLE PRECISION  RES
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), DWORK(*), E(*)
C     .. Local Scalars ..
      LOGICAL           CONV, HURWTZ, LACONA
      INTEGER           I, J, K, LALPHA, LAMBDA, LETA, LQ, LRO, NC, NCK
      DOUBLE PRECISION  A0, RES0, S, SA0, TOLQ, W
C     .. External Functions ..
      LOGICAL           LSAME
      INTEGER           IDAMAX
      EXTERNAL          IDAMAX, LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DSCAL, DSWAP, SB08NY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, SQRT
C     .. Executable Statements ..
C
      INFO = 0
      LACONA = LSAME( ACONA, 'A' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LACONA .AND. .NOT.LSAME( ACONA, 'B' ) ) THEN
         INFO = -1
      ELSE IF( DA.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDWORK.LT.5*DA + 5 ) THEN
         INFO = -7
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB08ND', -INFO )
         RETURN
      END IF
C
      NC = DA + 1
      IF ( .NOT.LACONA ) THEN
         IF ( A(1).LE.ZERO ) THEN
            INFO = 2
            RETURN
         END IF
         CALL DCOPY( NC, A, 1, E, 1 )
      ELSE
         CALL SB08NY( DA, A, E, W )
      END IF
C
C     Initialization.
C
      LALPHA = 1
      LRO = LALPHA + NC
      LETA = LRO + NC
      LAMBDA = LETA + NC
      LQ = LAMBDA + NC
C
      A0 = E(1)
      SA0 = SQRT( A0 )
      S = ZERO
C
      DO 20 J = 1, NC
         W = E(J)
         A(J) = W
         W = W/SA0
         E(J) = W
         DWORK(LQ-1+J) = W
         S = S + W**2
   20 CONTINUE
C
      RES0 = S - A0
C
C     The contents of the arrays is, cf [1], Section 7.6,
C
C     E : the last computed Hurwitz polynomial q   ;
C                                               i-1
C     DWORK(LALPHA,..,LALPHA+DA-K)  : alpha(k,0),...alpha(k,n-k);
C          (LRO,...,LRO+DA-K)       : alpha(k,n-k),...,alpha(k);
C          (LETA,...,LETA+DA)       : eta(0),...,eta(n);
C          (LAMBDA,...,LAMBDA+DA-1) : lambda(0),...,lambda(n-1)
C
C     DWORK(LQ,...,LQ+DA) : the last computed polynomial q .
C                                                         i
      I = 0
      CONV = .FALSE.
      HURWTZ = .TRUE.
C
C     WHILE ( I < 30 and CONV = FALSE and HURWTZ = TRUE ) DO
   40 IF ( I.LT.30 .AND. .NOT.CONV .AND. HURWTZ ) THEN
         I = I + 1
         CALL DCOPY( NC, A, 1, DWORK(LETA), 1 )
         CALL DSCAL( NC, TWO, DWORK(LETA), 1 )
         CALL DCOPY( NC, DWORK(LQ), 1, DWORK(LALPHA), 1 )
C
C        Computation of lambda(k) and eta(k).
C
         K = 1
C
C        WHILE ( K <= DA and HURWTZ = TRUE ) DO
   60    IF ( ( K.LE.DA ) .AND. HURWTZ ) THEN
            NCK = NC - K
            CALL DCOPY( NCK+1, DWORK(LALPHA), -1, DWORK(LRO), 1 )
            W = DWORK(LALPHA+NCK)/DWORK(LRO+NCK)
            IF ( ABS( W ).GE.ONE ) HURWTZ = .FALSE.
            IF ( HURWTZ ) THEN
               DWORK(LAMBDA+K-1) = W
               CALL DAXPY( NCK, -W, DWORK(LRO), 1, DWORK(LALPHA), 1 )
               W = DWORK(LETA+NCK)/DWORK(LALPHA)
               DWORK(LETA+NCK) = W
               CALL DAXPY( NCK-1, -W, DWORK(LALPHA+1), -1,
     $                     DWORK(LETA+1), 1 )
               K = K + 1
            END IF
            GO TO 60
         END IF
C        END WHILE 60
C
C        HURWTZ = The polynomial q    is a Hurwitz polynomial.
C                                 i-1
         IF ( HURWTZ ) THEN
            CALL DCOPY( NC, DWORK(LQ), 1, E, 1 )
C
C           Accuracy test.
C
            CALL SB08NY( DA, E, DWORK(LQ), TOLQ )
            CALL DAXPY( NC, -ONE, A, 1, DWORK(LQ), 1 )
            RES = ABS( DWORK( IDAMAX( NC, DWORK(LQ), 1 ) + LQ - 1 ) )
            CONV = ( RES.LT.TOLQ ) .OR. ( RES0.LT.ZERO )
C
            IF ( .NOT.CONV ) THEN
               DWORK(LETA) = HALF*DWORK(LETA)/DWORK(LALPHA)
C
C              Computation of x  and q .
C                              i      i
C              DWORK(LETA,...,LETA+DA)   : eta(k,0),...,eta(k,n)
C                   (LRO,...,LRO+DA-K+1) : eta(k,n-k+1),...,eta(k,0)
C
               DO 80 K = DA, 1, -1
                  NCK = NC - K + 1
                  CALL DCOPY( NCK, DWORK(LETA), -1, DWORK(LRO), 1 )
                  W = DWORK(LAMBDA+K-1)
                  CALL DAXPY( NCK, -W, DWORK(LRO), 1, DWORK(LETA), 1 )
   80          CONTINUE
C
               S = ZERO
C
               DO 100 J = 0, DA
                  W = HALF*( DWORK(LETA+J) + E(J+1) )
                  DWORK(LQ+J) = W
                  S = S + W**2
  100          CONTINUE
C
               RES0 = S - A0
C
C              Test on the monotonicity of q .
C                                           0
               CONV = DWORK(LQ).GT.E(1)
               GO TO 40
            END IF
         END IF
      END IF
C     END WHILE 40
C
C     Reverse the order of the coefficients in the array E.
C
      CALL DSWAP( NC, E, 1, DWORK, -1 )
      CALL DSWAP( NC, DWORK, 1, E, 1 )
C
      IF ( .NOT.CONV ) THEN
         IF ( HURWTZ ) THEN
            INFO = 3
         ELSE IF ( I.EQ.1 ) THEN
            INFO = 2
         ELSE
            INFO = 4
         END IF
      END IF
C
      RETURN
C *** Last line of SB08ND ***
      END


	Subroutine SET_NUTATE( DJD )
C
C	Calculate the amount of nutation in ecliptic longitude (d_Psi)
C	and in the obliquity of the ecliptic (d_Eps) in degrees
C	for a given DJD
C			Based on a BASIC routine in "Astronomy with your
C			Personal Computer" (Duffett-Smith), CUP
C					FORTRAN version by KM, 23 Oct 1988
C
	Implicit none
C
        double precision deg2rad
	Double Precision whole
        parameter( deg2rad = 1.74532925199433d-02 )
*                          = pi / 180, converts from degrees to radians
	Parameter( whole = 3.60D+02 )
C
	Double Precision DJD
C
	Double Precision T, T2, A, B, DIFF
	Double Precision LS, LS2, LD, LD2, MS, MD, NM, NM2
C
	Double Precision did_DJD
	Save did_DJD
C
	Double Precision d_Psi, d_Eps, RCP, RSP, Height
	Common / astro1 / d_Psi, d_Eps, RCP, RSP, Height
C
	DIFF = DJD - did_DJD
	If( Abs( DIFF ) .lt. 0.01D+00 ) Return
	T = DJD / 3.6525D+04
	T2 = T * T
	A = 1.000021358D+02 * T
	B = whole * ( A - Int( A ) )
	LS = 2.796967D+02 + 3.03D-04 * T2 + B
	LS = LS * deg2rad
	A = 1.336855231D+03 * T
	B = whole * ( A - Int( A ) )
	LD = 2.704342D+02 - 1.133D-03 * T2 + B
	LD = LD * deg2rad
	A = 9.999736056D+01 * T
	B = whole * ( A - Int( A ) )
	MS = 3.584758D+02 - 1.5D-04 * T2 + B
	MS = MS * deg2rad
	A = 1.325552359D+07 * T
	B = whole * ( A - Int( A ) )
	MD = 2.961046D+02 + 9.192D-03 * T2 * B
	MD = MD * deg2rad
	A = 5.372616667D+00 * T
	B = whole * ( A - Int( A ) )
	NM = 2.591833D+02 + 2.078D-03 * T2 - B
	NM = NM * deg2rad
	LS2 = LS * 2.0D+00
	LD2 = LD * 2.0D+00
	NM2 = NM * 2.0D+00
C
	d_Psi = ( -1.72327D+01 - 1.737D-02 * T ) * Sin( NM )
     &	+ ( -1.2729D+00 - 1.3D-04 * T ) * Sin( LS2 )
     &	+ 2.088D-01 * Sin( NM2 ) - 2.037D-01 * Sin( LD2 )
     &	+ ( 1.261D-01 - 3.1D-04 * T ) * Sin( MS )
     &	+ 6.75D-02 * Sin( MD )
     &	- ( 4.97D-02 - 1.2D-04 * T ) * Sin( LS2 + MS )
     &	- 3.42D-02 * Sin( LD2 - NM )
     &  - 2.61D-02 * Sin( LD2 + MD )
     &	+ 2.14D-02 * Sin( LS2 - MS )
     &	- 1.49D-02 * Sin( LS2 - LD2 + MD )
     &	+ 1.24D-02 * Sin( LS2 - NM )
     &  + 1.14D-02 * Sin( LD2 - MD )
	d_Psi = d_Psi / 3.6D+03
	d_Eps = ( 9.21D+00 + 9.1D-04 * T ) * Cos( NM )
     &	+ ( 5.522D-01 - 2.9D-04 * T ) * Cos( LS2 )
     &	- 9.04D-02 * Cos( NM2 ) + 8.84D-02 * Cos( LD2 )
     &	+ 2.16D-02 * Cos( LS2 + MS )
     &  + 1.83D-02 * Cos( LD2 - NM )
     &	+ 1.13D-02 * Cos( LD2 + MD )
     &  - 9.3D-03 * Cos( LS2 - MS )
     & 	- 6.6D-03 * Cos( LS2 - NM )
	d_Eps = d_Eps / 3.6D+03
C
	did_DJD = DJD
C
	End


      SUBROUTINE LOGLOG (A,B,C,D,E,F)
C
C     WRITTEN BY G.CHAN/UNISYS  7/92, THE 1992 SUMMER OLYMPIC WEEK
C
C     LOG-LOG TABLE LOOKUP           10 +------+------+------+--+
C                                     D                 *
C     INPUT : A,B, C,D, AND E         8 +------+-------/-----+--+
C     OUTPUT: F                                       /
C                                                    /
C     ALL A,B,C,D,E,F IN LOG          4 +------+----/-+------+--+
C     SCALE                           F            *
C                                                 /
C     LINEAR EVALUATION ON LOG        2 +------+-/-----+------+--+
C     SCALE (NO POLYNOMIAL            B         *
C     EVALUATION)
C                                     1 +------+------+------+--+
C                                       1      2A  E  4 C    8  10
      AA = ALOG10(A)
      BB = ALOG10(B)
      CC = ALOG10(C) - AA
      DD = ALOG10(D) - BB
      EE = ALOG10(E) - AA
      F  = 10.**(EE*DD/CC + BB)
      RETURN
C
C
      ENTRY SMILOG (A,B,C,D,E,F)
C     ==========================
C
C     SEMI-LOG TABLE LOOKUP       10 +--+--+--+--+--+--+--+--+--+
C                                  D                *
C     INPUT : A,B, C,D, AND E      8 +--+--+--+--+-/+--+--+--+--+
C     OUTPUT: F                                   /
C                                                /
C     A,C,E IN LINEAR SCALE        4 +--+--+--+-/+--+--+--+--+--+
C     B,D,F IN LOG SCALE           F           *
C                                             /
C                                  2 +--+--+-/+--+--+--+--+--+--+
C                                  B        *
C
C                                  1 +--+--+--+--+--+--+--+--+--+
C                                    0  1  2A 3E 4  C  6  7  8  9
      BB = ALOG10(B)
      CC = C - A
      DD = ALOG10(D) - BB
      EE = E - A
      F  = 10.**(EE*DD/CC + BB)
      RETURN
C
C
      ENTRY LOGSMI (A,B,C,D,E,F)
C     ==========================
C
C     LOG-SEMI TABLE LOOKUP          10 +-----+-----+-----+--+
C                                     D                 *
C     INPUT:  A,B, C,D, AND E         8 +-----+-----+--/--+--+
C     OUTPUT: F                                       /
C                                     6 +-----+-----+/----+--+
C     A,C,E IN LOG SCALE                            /
C     B,D,F IN LINEAR SCALE           4 +-----+----/+-----+--+
C                                     F           *
C                                     2 +-----+--/--+-----+--+
C                                     B         *
C                                     0 +-----+-----+-----+--+
C                                       1     2 A E 4   C 8  10
      AA = ALOG10(A)
      CC = ALOG10(C) - AA
      DD = D - B
      EE = ALOG10(E) - AA
      F  = EE*DD/CC + B
      RETURN
      END


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none

    ! commons
    real*8, parameter :: alpha(2) = (/0.3d0, 0.4d0/)
    real*8, parameter :: a0(2) = (/0.2d0, 0.2d0/)
    real*8, parameter :: a(2, 2) = reshape((/ 0d0, 0.3d0, 0.2d0, 0d0 /),(/2,2/))
    real*8, parameter :: G = 3d0
    real*8, parameter :: ID(2, 2) = reshape((/ 1d0, 0d0, 0d0, 1d0 /),(/2,2/))
    real*8            :: r

    ! country specific
    real*8, parameter :: Tbar(2) = (/30d0, 10d0/)
    real*8, parameter :: Kbar(2) = (/10d0, 30d0/)
    real*8, parameter :: beta(2, 2) = reshape((/ 0.3d0, 0.6d0, 0.3d0, 0.6d0 /),(/2,2/))
    real*8            :: tauw(2) = (/0d0, 0d0/)
    real*8            :: taur(2) = (/0d0, 0d0/)
    real*8            :: tauc(2,2) = 0d0
    real*8            :: Ybarn(2), q(2,2), p(2,2), w(2), wn(2), rn(2)
    real*8            :: Xd(2,2), Y(2,2), ky(2,2), ly(2,2), K(2,2), L(2,2), ell(2)

contains

    ! function to determine market equilibrium
    function markets(x)

        use toolbox

        implicit none
        real*8, intent(in) :: x(:)
        real*8 :: markets(size(x, 1))
        real*8 :: mat(4, 4), vec(4)
        integer :: i

        ! copy producer prices and taxes
        w(1)      = 1d0
        w(2)      = x(1)
        r         = x(2)
        tauc(1,1) = x(3)
        tauc(1,2) = x(4)
        tauc(2,:) = tauc(1,:)

        ! 1. calculate K/Y and L/Y
        do i = 1, 2
            ky(:,i) = a0*((1d0-beta(:,i))/beta(:,i)*w(i)/r)**beta(:,i)
            ly(:,i) = a0*(beta(:,i)/(1d0-beta(:,i))*r/w(i))**(1d0-beta(:,i))
        enddo

        ! 2. determine producer prices
        q(:,1) = w(1)*ly(:,1)+r*ky(:,1)
        call lu_solve(ID-transpose(a), q(:,1))
        q(1,2) = (a(2,1)*q(2,1)+w(2)*ly(1,2)+r*ky(1,2))/(1d0-a(1,1))
        q(2,2) = q(2,1)

        ! 3. consumer prices and demands
        do i = 1, 2
            p(:,i) = q(:,i)*(1d0+tauc(:,i))
            wn(i) = w(i)*(1d0-tauw(i))
            rn(i) = r*(1d0-taur(i))
            Ybarn(i) = wn(i)*Tbar(i)+rn(i)*Kbar(i)
            Xd(:,i) = alpha/p(:,i)*Ybarn(i)
            ell(i)  = (1d0-alpha(1)-alpha(2))/wn(i)*Ybarn(i)
        enddo

        ! 4. determine output levels
        vec(1) = Xd(1,1)+G
        vec(2) = Xd(2,1)+Xd(2,2)
        vec(3) = Xd(1,2)+G
        vec(4) = Tbar(1)-ell(1)

        mat(1, :) = (/1d0-a(1,1), -a(1,2), 0d0, 0d0/)
        mat(2, :) = (/-a(2,1), 1d0-a(2,2), -a(2,1), 1d0-a(2,2)/)
        mat(3, :) = (/0d0, 0d0, 1d0-a(1,1), -a(1,2)/)
        mat(4, :) = (/ly(1,1), ly(2,1), 0d0, 0d0/)

        call lu_solve(mat, vec)
        Y(1,1) = vec(1)
        Y(2,1) = vec(2)
        Y(1,2) = vec(3)
        Y(2,2) = vec(4)

        ! 5. compute K and L
        K = ky*Y
        L = ly*Y

        ! 6. check markets and budget
        markets(1) = L(1,2)+L(2,2)-(Tbar(2)-ell(2))
        markets(2) = sum(K)-sum(Kbar)
        markets(3) = q(1,1)*G-sum(tauc(:,1)*q(:,1)*Xd(:,1))-&
            tauw(1)*w(1)*(Tbar(1)-ell(1))-taur(1)*r*Kbar(1)
        markets(4) = q(1,2)*G-sum(tauc(:,2)*q(:,2)*Xd(:,2))-&
            tauw(2)*w(2)*(Tbar(2)-ell(2))-taur(2)*r*Kbar(2)

    end function

end module


      real function shear(a,b,c,x)
c
c     + + + PURPOSE + + +
c     Calculates nondimensional shear stress.
c
c     Called from subroutine XCRIT.
c     Author(s): G. Foster
c     Reference in User Guide:
c
c     Changes:
c
c     Version: This module recoded from WEPP version 90.92.
c     Date recoded: 01/08/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real a, b, c, x
c
c     + + + ARGUMENT DEFINITIONS + + +
c     a      - shear stress coefficient for current slope
c              section
c     b      - shear stress coefficient for current slope
c              section
c     c      - shear stress coefficient for current slope
c              section
c     x      - nondimensional distance at which shear stress
c              is to be calculated
c
c     + + + LOCAL VARIABLES + + +
c     value  -
      real value
c
c     + + + END SPECIFICATIONS + + +
c
      value = a * x ** 2 + b * x + c
      if (value.lt.0.0) value = 0.0
      shear = value ** 0.66666667
      if (shear.le.0.0) shear = 0.0001
c
      return
      end


!============================================================================
      MODULE math_utilities
!--------------------------------------------------------------------------
!
! FUNCTION: Module containing routines necessary to compute the line-integrated
!           Faraday rotation angle and the line-integrated polarization phase shift.
!
!------------------------------------------------------------------------------
      USE stel_kinds
      USE stel_constants
      IMPLICIT NONE

      CONTAINS
!=============================================================================
      REAL(KIND=rprec) FUNCTION MAGNITUDE(vec)
!--------------------------------------------------------------------------
! FUNCTION: calculates the magnitude of 3D input vector.
!
!---------------------------------------------------------------------------
      USE stel_kinds
      IMPLICIT NONE

      REAL(rprec), DIMENSION(3), INTENT(IN) ::                                 &
     &            vec           ! 3D vector

      MAGNITUDE = SQRT( vec(1)*vec(1) + vec(2)*vec(2) + vec(3)*vec(3) )

      RETURN
      END FUNCTION MAGNITUDE

!=============================================================================
      SUBROUTINE UNIT_VECTOR(v1, v1_unit)
!--------------------------------------------------------------------------
! FUNCTION: calculates the magnitude of 3D input vector.
!
!---------------------------------------------------------------------------
      USE stel_kinds
      IMPLICIT NONE

      REAL(rprec), DIMENSION(3), INTENT(IN) ::                                 &
     &            v1           ! 3D vector

      REAL(rprec), DIMENSION(3), INTENT(OUT) ::                                &
     &            v1_unit        ! 3D vector

      v1_unit = v1 / MAGNITUDE(v1)

      RETURN
      END SUBROUTINE UNIT_VECTOR

!=============================================================================
      REAL(KIND=rprec) FUNCTION DIST(v1, v2)
!--------------------------------------------------------------------------
! FUNCTION: calculates the absolute distance between 2 input vectors.
!
!---------------------------------------------------------------------------
      USE stel_kinds
      IMPLICIT NONE

      REAL(rprec), DIMENSION(3), INTENT(IN) ::                                 &
     &            v1, v2           ! 3D vectors

      REAL(rprec), DIMENSION(3) ::                                             &
     &            v3           ! difference vector btwn v1 & v2

      v3 = ABS( v2 - v1 )
      DIST = SQRT( v3(1)*v3(1) + v3(2)*v3(2) + v3(3)*v3(3) )

      RETURN
      END FUNCTION DIST

!==================================================================================
      SUBROUTINE CROSS_PRODUCT(A, B, C)
!----------------------------------------------------------------------------------
!  FUNCTION:  computes the cross product (C) for input CARTESIAN vectors A and B.
!
!  LOGIC:  C = A .cross. B
!
!  created by J. Shields 2/15/06
!
!--------------------------------------------------------------------------------------
      USE stel_kinds
      IMPLICIT NONE

!........passed variables....................................................!
      REAL(rprec), DIMENSION(3), INTENT(IN) ::  A   ! input Cartesian vector

      REAL(rprec), DIMENSION(3), INTENT(IN) ::  B   ! input Cartesian vector

      REAL(rprec), DIMENSION(3), INTENT(OUT) :: C   ! Cross product:  A .cross. B

!.................local variables...................................!
      INTEGER(iprec) :: i
      character(len=*), PARAMETER ::  subname = 'CROSS_PRODUCT'

!..................X component.....................................!
      C(1) = A(2) * B(3)  -  A(3) * B(2)

!...................Y component.....................................!
      C(2) = A(3) * B(1)  -  A(1) * B(3)

!...................Z component.....................................!
      C(3) = A(1) * B(2)  -  A(2) * B(1)

      RETURN
      END SUBROUTINE CROSS_PRODUCT

      END MODULE math_utilities


C$Procedure  VSEPG ( Angular separation of vectors, general dimension )

      DOUBLE PRECISION FUNCTION VSEPG ( V1, V2, NDIM )

C$ Abstract
C
C      VSEPG finds the separation angle in radians between two double
C      precision vectors of arbitrary dimension. This angle is defined
C      as zero if either vector is zero.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C      ANGLE,  VECTOR
C
C$ Declarations

      DOUBLE PRECISION   V1 ( * )
      DOUBLE PRECISION   V2 ( * )
      INTEGER            NDIM

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C       V1        I     First vector.
C       V2        I     Second vector.
C       NDIM      I     The number of elements in V1 and V2.
C
C$ Detailed_Input
C
C      V1      is any double precision vector of arbitrary dimension.
C      V2      is also a double precision vector of arbitrary dimension.
C              V1 or V2 or both may be the zero vector.
C      NDIM    is the dimension of the both of the input vectors
C              V1 and V2.
C
C$ Detailed_Output
C
C      VSEPG   is the angle between V1 and V2 expressed in radians.
C              VSEPG is strictly non-negative.  For input vectors of
C              four or more dimensions, the angle is defined as the
C              generalization of the definition for three dimensions.
C              If either V1 or V2 is the zero vector, then VSEPG is
C              defined to be 0 radians.
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C      In four or more dimensions this angle does not have a physically
C      realizable interpretation.  However, the angle is defined as
C      the generalization of the following definition which is valid in
C      three or two dimensions:
C
C      In the plane, it is a simple matter to calculate the angle
C      between two vectors once the two vectors have been made to be
C      unit length.  Then, since the two vectors form the two equal
C      sides of an isosceles triangle, the length of the third side
C      is given by the expression
C
C            LENGTH = 2.0 * SINE ( VSEPG/2.0 )
C
C      The length is given by the magnitude of the difference of the
C      two unit vectors
C
C            LENGTH = NORM ( U1 - U2 )
C
C      Once the length is found, the value of VSEPG may be calculated
C      by inverting the first expression given above as
C
C            VSEPG = 2.0 * ARCSINE ( LENGTH/2.0 )
C
C      This expression becomes increasingly unstable when VSEPG gets
C      larger than PI/2 or 90 degrees.  In this situation (which is
C      easily detected by determining the sign of the dot product of
C      V1 and V2) the supplementary angle is calculated first and
C      then VSEPG is given by
C
C            VSEPG = PI - SUPPLEMENTARY_ANGLE
C
C$ Examples
C
C      The following table gives sample values for V1, V2 and VSEPG
C      implied by the inputs.
C
C      V1               V2               NDIM          VSEPG
C      -----------------------------------------------------------------
C      (1, 0, 0, 0)     (1, 0, 0, 0)       4           0.0D0
C      (1, 0, 0)        (0, 1, 0)          3           PI/2 (=1.71...)
C      (3, 0)           (-5, 0)            2           PI   (=3.14...)
C
C$ Restrictions
C
C      The user is required to insure that the input vectors will not
C      cause floating point overflow upon calculation of the vector
C      dot product since no error detection or correction code is
C      implemented.  In practice, this is not a significant
C      restriction.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C      None
C
C$ Author_and_Institution
C
C     C.A. Curzon     (JPL)
C     K.R. Gehringer  (JPL)
C     H.A. Neilan     (JPL)
C     W.L. Taber      (JPL)
C
C$ Literature_References
C
C      None
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 29-FEB-1996 (KRG)
C
C        The declaration for the SPICELIB function PI is now
C        preceded by an EXTERNAL statement declaring PI to be an
C        external function. This removes a conflict with any
C        compilers that have a PI intrinsic function.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (CAC)
C
C-&

C$ Index_Entries
C
C     angular separation of n-dimensional vectors
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.1.0, 29-FEB-1996 (KRG)
C
C        The declaration for the SPICELIB function PI is now
C        preceded by an EXTERNAL statement declaring PI to be an
C        external function. This removes a conflict with any
C        compilers that have a PI intrinsic function.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (CAC)
C
C-    Beta Version 1.1.0, 02-MAR-1989 (HAN)
C
C        The variable MAGDIFF was changed to MAGDIF in order to
C        comply with the ANSI Fortran Standard six character
C        variable name length restriction.
C
C-    Beta Version 1.0.1, 10-JAN-1989 (WLT)
C
C        Error free specification added.
C
C-&

C
C     SPICELIB functions
C
      EXTERNAL              PI
      DOUBLE PRECISION      PI
      DOUBLE PRECISION      VNORMG
      DOUBLE PRECISION      VDOTG
C
C     Local Variables
C
C     The following declarations represent, respectively:
C        Magnitudes of V1, V2
C        Reciprocals of the magnitudes of V1, V2
C        Magnitude of either of the difference vectors: V1-V2 or
C           V1-(-V2)
C
      DOUBLE PRECISION      DMAG1
      DOUBLE PRECISION      DMAG2
      DOUBLE PRECISION      R1
      DOUBLE PRECISION      R2
      DOUBLE PRECISION      MAGDIF

      INTEGER               I
C
C     Calculate the magnitudes of V1 and V2; if either is 0, VSEPG = 0
C
      DMAG1 = VNORMG ( V1, NDIM )
      IF ( DMAG1 .EQ. 0.D0 ) THEN
         VSEPG = 0.D0
         RETURN
      END IF

      DMAG2 = VNORMG ( V2, NDIM )
      IF ( DMAG2 .EQ. 0.D0 ) THEN
         VSEPG = 0.D0
         RETURN
      END IF

      IF      ( VDOTG (V1, V2, NDIM) .GT. 0 ) THEN

         R1 = 1.0D0/DMAG1
         R2 = 1.0D0/DMAG2

         MAGDIF = 0.0D0
         DO I = 1, NDIM
            MAGDIF = MAGDIF + ( V1(I)*R1 - V2(I)*R2 )**2
         END DO
         MAGDIF = DSQRT(MAGDIF)

         VSEPG = 2.0D0 * ASIN (0.5D0 * MAGDIF)

      ELSE IF ( VDOTG (V1, V2, NDIM) .LT. 0 ) THEN

         R1 = 1.0D0/DMAG1
         R2 = 1.0D0/DMAG2

         MAGDIF = 0.0D0
         DO I = 1, NDIM
            MAGDIF = MAGDIF + ( V1(I)*R1 + V2(I)*R2 )**2
         END DO
         MAGDIF = DSQRT(MAGDIF)

         VSEPG = PI() - 2.0D0 * ASIN (0.5D0 * MAGDIF)

      ELSE
         VSEPG = PI() / 2.0D0
      END IF

      RETURN
      END


subroutine delsph(flat1,flon1,flat2,flon2,del)
  implicit none
  real,parameter:: R=6371.0
  REAL,parameter:: pi=3.1415926535898
  real flat1,flat2
  real flon1,flon2
  real del

  real dlat
  real dlon
  real lat1
  real lat2
  real a
  real c

  !dlat=(flat2-flat1)*pi/180
  !dlon=(flon2-flon1)*pi/180
  !lat1=flat1*pi/180
  !lat2=flat2*pi/180
  dlat=flat2-flat1
  dlon=flon2-flon1
  lat1=pi/2-flat1
  lat2=pi/2-flat2
  a=sin(dlat/2)*sin(dlat/2)+sin(dlon/2)*sin(dlon/2)*cos(lat1)*cos(lat2)
  c=2*atan2(sqrt(a),sqrt(1-a))
  del=R*c
end subroutine


double precision function cubicfilter(x, c0, c1, c2, c3)
    ! filter 4 values using cubic splines
    double precision x, c0, c1, c2, c3
    double precision w0, w1, w2, w3
    w0 = x*(x*(-x + 3d0) - 3d0) + 1d0
    w1 = x*x*(3d0*x - 6d0) + 4d0;
    w2 =  x*(x*(-3d0*x + 3d0) + 3d0) + 1d0
    w3 =  x*x*x
    cubicfilter = (c0 * w0 + c1 * w1 + c2 * w2 + c3 * w3) * 0.16666666666666666d0
end

double precision function tex2d(ftl_map, i, j, nx, ny)
    ! nx : second dimension of array
    ! ny : first dimension of array
    double precision, intent(in) :: ftl_map(0:ny-1, 0:nx-1)
    integer, intent(in) :: nx, ny
    integer i, j

    if (i < 0)  i = mod(ny + i, ny)
    if (j < 0)  j = mod(nx + j, nx)
    if (i >= ny) i = mod(i, ny)
    if (j >= nx) j = mod(j, nx)
    tex2d = ftl_map(i, j)
end

double precision function eval(ftl_map, fx, fy, nx, ny)
    ! nx : second dimension of array
    ! ny : first dimension of array
    implicit none
    double precision, intent(in) :: ftl_map(0:ny-1, 0:nx-1), fx, fy
    integer, intent(in) :: nx, ny
    double precision, external :: cubicfilter, tex2d
    double precision gx, gy
    integer px, py

    px = floor(fx)
    py = floor(fy)
    gx = fx - px
    gy = fy - py
    eval = cubicfilter(gy, &
              cubicfilter(gx, tex2d(ftl_map, px-1, py-1,nx, ny), tex2d(ftl_map, px, py-1,nx, ny), &
                        tex2d(ftl_map, px+1, py-1,nx, ny), tex2d(ftl_map, px+2,py-1,nx, ny)), &
              cubicfilter(gx, tex2D(ftl_map, px-1, py, nx, ny),   tex2d(ftl_map, px, py,nx, ny),   &
                        tex2d(ftl_map, px+1, py, nx, ny),   tex2d(ftl_map, px+2, py,nx, ny)),&
              cubicfilter(gx, tex2D(ftl_map, px-1, py+1,nx, ny), tex2d(ftl_map, px, py+1,nx, ny), &
                        tex2d(ftl_map, px+1, py+1, nx, ny), tex2d(ftl_map, px+2, py+1,nx, ny)), &
              cubicfilter(gx, tex2D(ftl_map, px-1, py+2,nx, ny), tex2d(ftl_map, px, py+2,nx, ny), &
                        tex2d(ftl_map, px+1, py+2,nx, ny), tex2d(ftl_map, px+2, py+2,nx, ny)) )
end

integer function mod_test(i, npix)
    integer i, npix
    mod_test = i
    if (mod_test < 0) mod_test = mod(npix + mod_test, npix)
    if (mod_test >= npix)  mod_test = mod(mod_test, npix)
end function mod_test

subroutine deflect(output, ftl_map, fx, fy, nx, ny, npts)
    ! input ftl_map should be bicubic prefiltered map
    ! fx, fy new coordinate in grid units.
    !FIXME: misleading notation. fx is deflection in first ftl_map array dimension, fy in second dimension
    !FIXME: but nx is second dimension and ny first dimension.
    !FIXME: should rename fx <-> fy here and in eval and in tex2d

    implicit none
    double precision, intent(in) :: ftl_map(0:ny-1,0:nx-1)
    double precision, intent(in) :: fx(0:npts-1), fy(0:npts-1)
    double precision, intent(out) :: output(0:npts-1)
    double precision, external :: eval
    integer, intent(in) :: nx, ny, npts
    integer i
    do i = 0, npts - 1
        output(i) = eval(ftl_map, fx(i), fy(i), nx, ny)
    end do
end subroutine deflect


c
c
c ... file rgrd4.f
c
c     this file contains documentation for subroutine rgrd4 followed by
c     fortran code for rgrd4 and additional subroutines.
c
c ... author
c
c     John C. Adams (NCAR 1999)
c
c ... subroutine rgrd4(nx,ny,nz,nt,x,y,z,t,p,mx,my,mz,mt,xx,yy,zz,tt,q,
c    +                 intpol,w,lw,iw,liw,ier)
c
c ... purpose
c
c     subroutine rgrd4 interpolates the values p(i,j,k,l) on the orthogonal
c     grid
c
c       (x(i),y(j),z(k),t(l))
c
c       for i=1,...,nx;j=1,...,ny;k=1,...,nz;l=1,...,nt
c
c
c     onto q(ii,jj,kk,ll) on the orthogonal grid
c
c
c       (xx(ii),yy(jj),zz(kk),tt(ll))
c
c       for ii=1,...,mx;jj=1,...,my;kk=1,...,mz;ll=1,...,mt
c
c ... language
c
c     coded in portable FORTRAN77 and FORTRAN90
c
c ... test program
c
c     file trgrd4.f on regridpack includes a test program for subroutine rgrd4
c
c ... method
c
c     linear or cubic interpolation is used (independently) in
c     each direction (see argument intpol).
c
c ... required files
c
c     files rgrd3.f,rgrd2.f and rgrd1.f must be loaded with rgrd4.f.  they
c     include subroutines called by the routines in rgrd4.f
c
c ... requirements
c
c     each of the x,y,z,t grids must be strictly montonically increasing
c     and each of the xx,yy,zz,tt grids must be montonically increasing
c     (see ier = 4).  in addition the (X,Y,Z,T) region of the q grid
c
c      [xx(1),xx(mx)] X [yy(1),yy(my)] X [zz(1),zz(mz)] X [tt(1),tt(my)]
c
c     must lie within the (X,Y,Z,T) region of the p grid
c
c      [x(1),x(nx)] X [y(1),y(ny)] X [z(1),z(nz)] X [t(1),t(nt)].
c
c     extrapolation is not allowed (see ier=3).  if these (X,Y,Z,T)
c     regions are identical and the orthogonal grids are UNIFORM
c     in each direction then subroutine rgrd4u (see file rgrd4u.f)
c     should be used instead of rgrd4.
c
c ... efficiency
c
c     inner most loops in regridpack software vectorize. If
c     the integer arguments mx,my,mz,mt (see below) have different values,
c     optimal vectorization will be achieved if they are arranged so that
c     mx > my > mz > mt.
c
c *** input arguments
c
c ... nx
c
c     the integer dimension of the grid vector x and the first dimension of p.
c     nx > 1 if intpol(1) = 1 or nx > 3 if intpol(1) = 3 is required.
c
c ... ny
c
c     the integer dimension of the grid vector y and the second dimension of p.
c     ny > 1 if intpol(2) = 1 or ny > 3 if intpol(2) = 3 is required.
c
c ... nz
c
c     the integer dimension of the grid vector z and the third dimension of p.
c     nz > 1 if intpol(3) = 1 or nz > 3 if intpol(3) = 3 is required.
c
c ... nt
c
c     the integer dimension of the grid vector t and the fourth dimension of p.
c     nt > 1 if intpol(4) = 1 or nt > 3 if intpol(4) = 3 is required.
c
c ... x
c
c     a real nx vector of strictly increasing values which defines the x
c     portion of the orthogonal grid on which p is given
c
c ... y
c
c     a real ny vector of strictly increasing values which defines the y
c     portion of the orthogonal grid on which p is given
c
c ... z
c
c     a real nz vector of strictly increasing values which defines the z
c     portion of the orthogonal grid on which p is given
c
c ... t
c
c     a real nt vector of strictly increasing values which defines the t
c     portion of the orthogonal grid on which p is given
c
c ... p
c
c     a real nx by ny by nz by nt array of values given on the (x,y,z,t) grid
c
c ... mx
c
c     the integer dimension of the grid vector xx and the first dimension
c     of q.  mx > 0 is required.
c
c ... my
c
c     the integer dimension of the grid vector yy and the second dimension
c     of q.  my > 0 is required.
c
c ... mz
c
c     the integer dimension of the grid vector zz and the third dimension
c     of q.  mz > 0 is required.
c
c ... mt
c
c     the integer dimension of the grid vector tt and the fourth dimension
c     of q.  mt > 0 is required.
c
c ... xx
c
c     a real mx vector of increasing values which defines the x portion of the
c     orthogonal grid on which q is defined.  xx(1) < x(1) or xx(mx) > x(nx)
c     is not allowed (see ier = 3)
c
c ... yy
c
c     a real my vector of increasing values which defines the y portion of the
c     orthogonal grid on which q is defined.  yy(1) < y(1) or yy(my) > y(ny)
c     is not allowed (see ier = 3)
c
c ... zz
c
c     a real mz vector of increasing values which defines the z portion of the
c     orthogonal grid on which q is defined.  zz(1) < z(1) or zz(mz) > z(nz)
c     is not allowed (see ier = 3)
c
c ... tt
c
c     a real mt vector of increasing values which defines the t portion of the
c     orthogonal grid on which q is defined.  tt(1) < t(1) or tt(mt) > t(nt)
c     is not allowed (see ier = 3)
c
c ... intpol
c
c     an integer vector of dimension 4 which sets linear or cubic
c     interpolation in each of the x,y,z,t directions as follows:
c
c        intpol(1) = 1 sets linear interpolation in the x direction
c        intpol(1) = 3 sets cubic interpolation in the x direction.
c
c        intpol(2) = 1 sets linear interpolation in the y direction
c        intpol(2) = 3 sets cubic interpolation in the y direction.
c
c        intpol(3) = 1 sets linear interpolation in the z direction
c        intpol(3) = 3 sets cubic interpolation in the z direction.
c
c        intpol(4) = 1 sets linear interpolation in the t direction
c        intpol(4) = 3 sets cubic interpolation in the t direction.
c
c     values other than 1 or 3 in intpol are not allowed (ier = 6).
c
c ... w
c
c     a real work space of length at least lw which must be provided in the
c     routine calling rgrd4
c
c ... lw
c
c     the integer length of the real work space w.  let
c
c          lwx =   mx            if intpol(1) = 1
c          lwx = 4*mx            if intpol(1) = 3
c
c          lwy = my+2*mx         if intpol(2) = 1
c          lwy = 4*(my+mx)       if intpol(2) = 3
c
c          lwz = 2*mx*my+mz      if intpol(3) = 1
c          lwz = 4*(mx*my+mz)    if intpol(3) = 3
c
c          lwt = 2*mx*my*mz+mt   if intpol(4) = 1
c          lwt = 4*(mx*my*mz+mt) if intpol(4) = 3
c
c     then lw must be greater than or equal to lwx+lwy+lwz+lwt
c
c ... iw
c
c     an integer work space of length at least liw which must be provided in the
c     routine calling rgrd4
c
c ... liw
c
c     the integer length of the integer work space iw.  liw must be at least mx+my+mz+mt
c
c
c *** output arguments
c
c
c ... q
c
c     a real mx by my by mz by mt array of values on the (xx,yy,zz,tt) grid
c     which are interpolated from p on the (x,y,z,t) grid
c
c ... ier
c
c     an integer error flag set as follows:
c
c     ier = 0 if no errors in input arguments are detected
c
c     ier = 1 if  min0(mx,my,mz,mt) < 1
c
c     ier = 2 if nx < 2 when intpol(1)=1 or nx < 4 when intpol(1)=3 (or)
c                ny < 2 when intpol(2)=1 or ny < 4 when intpol(2)=3 (or)
c                nz < 2 when intpol(3)=1 or nz < 4 when intpol(3)=3 (or)
c                nt < 2 when intpol(4)=1 or nt < 4 when intpol(4)=3
c
c     ier = 3 if xx(1) < x(1) or x(nx) < xx(mx) (or)
c                yy(1) < y(1) or y(ny) < yy(my) (or)
c                zz(1) < z(1) or z(nz) < zz(mz) (or)
c                tt(1) < t(1) or t(nt) < tt(mt)
c
c *** to avoid this flag when end points are intended to be the
c     same but may differ slightly due to roundoff error, they
c     should be set exactly in the calling routine (e.g., if both
c     grids have the same y boundaries then yy(1)=y(1) and yy(my)=y(ny)
c     should be set before calling rgrd4)
c
c     ier = 4 if one of the grids x,y,z,t is not strictly monotonically
c             increasing or if one of the grids xx,yy,zz,tt is not
c             montonically increasing.  more precisely if:
c
c             x(i+1) <= x(i) for some i such that 1 <= i < nx (or)
c
c             y(j+1) <= y(j) for some j such that 1 <= j < ny (or)
c
c             z(k+1) <= z(k) for some k such that 1 <= k < nz (or)
c
c             t(l+1) <= t(l) for some l such that 1 <= l < nt (or)
c
c             xx(ii+1) < xx(ii) for some ii such that 1 <= ii < mx (or)
c
c             yy(jj+1) < yy(jj) for some jj such that 1 <= jj < my (or)
c
c             zz(kk+1) < zz(k)  for some kk such that 1 <= kk < mz (or)
c
c             tt(ll+1) < tt(l)  for some ll such that 1 <= ll < mt
c
c     ier = 5 if lw or liw is too small (insufficient work space)
c
c     ier = 6 if any of intpol(1),intpol(2),intpol(3),intpol(4)
c             is not equal to 1 or 3
c
c ************************************************************************
c
c     end of rgrd4 documentation, fortran code follows:
c
c ************************************************************************
c
      subroutine rgrd4(nx,ny,nz,nt,x,y,z,t,p,mx,my,mz,mt,xx,yy,zz,
     +                 tt,q,intpol,w,lw,iw,liw,ier)
      implicit none
      integer nx,ny,nz,nt,mx,my,mz,mt,lw,liw,ier
      integer iw(liw),intpol(4)
      real x(nx),y(ny),z(nz),t(nt),p(nx,ny,nz,nt),w(lw)
      real xx(mx),yy(my),zz(mz),tt(mt),q(mx,my,mz,mt)
      integer l2,l3,l4,l5,l6,l7,l8,l9
      integer k2,k3,k4,k5,k6,k7,k8,k9
      integer j2,j3,j4,j5,j6,j7,j8,j9
      integer i2,i3,i4,i5
      integer lwx,lwy,lwz,lwt,mxmy,mxmymz
      integer ii,jj,kk,ll,i,j,k,l
      integer jy,kz,lt
c
c     check input arguments
c
      ier = 1
c
c     check (xx,yy,zz,tt) grid resolution
c
      if (min0(mx,my,mz,mt) .lt. 1) return
c
c     check intpol
c
      ier = 6
      if (intpol(1).ne.1 .and. intpol(1).ne.3) return
      if (intpol(2).ne.1 .and. intpol(2).ne.3) return
      if (intpol(3).ne.1 .and. intpol(3).ne.3) return
      if (intpol(4).ne.1 .and. intpol(4).ne.3) return
c
c     check (x,y,z,t) grid resolution
c
      ier = 2
      if (intpol(1).eq.1 .and. nx.lt.2) return
      if (intpol(1).eq.3 .and. nx.lt.4) return
      if (intpol(2).eq.1 .and. ny.lt.2) return
      if (intpol(2).eq.3 .and. ny.lt.4) return
      if (intpol(3).eq.1 .and. nz.lt.2) return
      if (intpol(3).eq.3 .and. nz.lt.4) return
      if (intpol(4).eq.1 .and. nt.lt.2) return
      if (intpol(4).eq.3 .and. nt.lt.4) return
c
c     check work space length input and set minimum
c
      ier = 5
      mxmy = mx*my
      mxmymz = mxmy*mz
      if (intpol(1).eq.1) then
	lwx = mx
      else
	lwx = 4*mx
      end if
      if (intpol(2).eq.1) then
	lwy = (my+2*mx)
      else
	lwy = 4*(mx+my)
      end if
      if (intpol(3).eq.1) then
	lwz = (2*mxmy+mz)
      else
	lwz = 4*(mxmy+mz)
      end if
      if (intpol(4).eq.1) then
	lwt = (2*mxmymz+mt)
      else
	lwt = 4*(mxmymz+mt)
      end if
      if (lw .lt. lwx+lwy+lwz+lwt) return
      if (liw .lt. mx+my+mz+mt) return
c
c     check (xx,yy,zz,tt) grid contained in (x,y,z,t) grid
c
      ier = 31
      if (xx(1).lt.x(1) .or. xx(mx).gt.x(nx)) return
      ier= 32
      if (yy(1).lt.y(1) .or. yy(my).gt.y(ny)) return
      ier= 33
      if (zz(1).lt.z(1) .or. zz(mz).gt.z(nz)) return
      ier= 34
      if (tt(1).lt.t(1) .or. tt(mt).gt.t(nt)) return
c
c     check montonicity of grids
c
      ier = 4
      do i=2,nx
	if (x(i-1).ge.x(i)) return
      end do
      do j=2,ny
	if (y(j-1).ge.y(j)) return
      end do
      do k=2,nz
	if (z(k-1).ge.z(k)) return
      end do
      do l=2,nt
	if (t(l-1).ge.t(l)) return
      end do
      do ii=2,mx
	if (xx(ii-1).gt.xx(ii)) return
      end do
      do jj=2,my
	if (yy(jj-1).gt.yy(jj)) return
      end do
      do kk=2,mz
	if (zz(kk-1).gt.zz(kk)) return
      end do
      do ll=2,mt
	if (tt(ll-1).gt.tt(ll)) return
      end do
c
c     arguments o.k.
c
      ier = 0
c
c     set pointers for integer work space iw
c
      jy = mx+1
      kz = mx+my+1
      lt = mx+my+mz+1

      if (intpol(4).eq.1) then
c
c     linearly interpolate in nt, set work space pointers and scales
c
	l2 = 1
	l3 = l2
	l4 = l3+mt
	l5 = l4
	l6 = l5
	l7 = l6
	l8 = l7+mxmymz
	l9 = l8+mxmymz
	call linmx(nt,t,mt,tt,iw(lt),w(l3))
	k2 = l9

	if (intpol(3).eq.1) then
c     linear in z
	  k3 = k2
	  k4 = k3+mz
	  k5 = k4
	  k6 = k5
	  k7 = k6
	  k8 = k7+mxmy
	  k9 = k8+mxmy
	  call linmx(nz,z,mz,zz,iw(kz),w(k3))
	  j2 = k9
	else
c     cubic in z
	  k3 = k2+mz
	  k4 = k3+mz
	  k5 = k4+mz
	  k6 = k5+mz
	  k7 = k6+mxmy
	  k8 = k7+mxmy
	  k9 = k8+mxmy
	  call cubnmx(nz,z,mz,zz,iw(kz),w(k2),w(k3),w(k4),w(k5))
	  j2 = k9+mxmy
	end if

	if (intpol(2) .eq. 1) then
c     linear in y
	  j3 = j2
	  j4 = j3+my
	  j5 = j4
	  j6 = j5
	  j7 = j6
	  j8 = j7+mx
	  j9 = j8+mx
	  call linmx(ny,y,my,yy,iw(jy),w(j3))
	  i2 = j9
	else
c     cubic in y
	  j3 = j2+my
	  j4 = j3+my
	  j5 = j4+my
	  j6 = j5+my
	  j7 = j6+mx
	  j8 = j7+mx
	  j9 = j8+mx
	  call cubnmx(ny,y,my,yy,iw(jy),w(j2),w(j3),w(j4),w(j5))
	  i2 = j9+mx
	end if

	if (intpol(1) .eq. 1) then
c     linear in x
	  i3 = i2
	  i4 = i3
	  i5 = i4
	  call linmx(nx,x,mx,xx,iw,w(i3))
	else
c     cubic in x
	  i3 = i2+mx
	  i4 = i3+mx
	  i5 = i4+mx
	  call cubnmx(nx,x,mx,xx,iw,w(i2),w(i3),w(i4),w(i5))
	end if
c
c     linearly interpolate in t
c
	call lint4(nx,ny,nz,nt,p,mx,my,mz,mt,mxmy,mxmymz,q,intpol,
     +  iw(lt),w(l3),w(l7),w(l8),
     +  iw(kz),w(k2),w(k3),w(k4),w(k5),w(k6),w(k7),w(k8),w(k9),
     +  iw(jy),w(j2),w(j3),w(j4),w(j5),w(j6),w(j7),w(j8),w(j9),
     +  iw,w(i2),w(i3),w(i4),w(i5))
	return

      else
c
c     cubically interpolate in t
c
	l2 = 1
	l3 = l2+mt
	l4 = l3+mt
	l5 = l4+mt
	l6 = l5+mt
	l7 = l6+mxmymz
	l8 = l7+mxmymz
	l9 = l8+mxmymz
	call cubnmx(nt,t,mt,tt,iw(lt),w(l2),w(l3),w(l4),w(l5))
	k2 = l9+mxmymz

	if (intpol(3).eq.1) then
c     linear in z
	  k3 = k2
	  k4 = k3+mz
	  k5 = k4
	  k6 = k5
	  k7 = k6
	  k8 = k7+mxmy
	  k9 = k8+mxmy
	  call linmx(nz,z,mz,zz,iw(kz),w(k3))
	  j2 = k9
	else
c     cubic in z
	  k3 = k2+mz
	  k4 = k3+mz
	  k5 = k4+mz
	  k6 = k5+mz
	  k7 = k6+mxmy
	  k8 = k7+mxmy
	  k9 = k8+mxmy
	  call cubnmx(nz,z,mz,zz,iw(kz),w(k2),w(k3),w(k4),w(k5))
	  j2 = k9+mxmy
	end if

	if (intpol(2) .eq. 1) then
	  j3 = j2
	  j4 = j3+my
	  j5 = j4
	  j6 = j5
	  j7 = j6
	  j8 = j7+mx
	  j9 = j8+mx
	  call linmx(ny,y,my,yy,iw(jy),w(j3))
	  i2 = j9
	else
	  j3 = j2+my
	  j4 = j3+my
	  j5 = j4+my
	  j6 = j5+my
	  j7 = j6+mx
	  j8 = j7+mx
	  j9 = j8+mx
	  call cubnmx(ny,y,my,yy,iw(jy),w(j2),w(j3),w(j4),w(j5))
	  i2 = j9+mx
	end if
c
c     set work space portion and indices which depend on x interpolation
c
	if (intpol(1) .eq. 1) then
	  i3 = i2
	  i4 = i3
	  i5 = i4
	  call linmx(nx,x,mx,xx,iw,w(i3))
	else
	  i3 = i2+mx
	  i4 = i3+mx
	  i5 = i4+mx
	  call cubnmx(nx,x,mx,xx,iw,w(i2),w(i3),w(i4),w(i5))
	end if
c
c     cubically interpolate in t
c
	call cubt4(nx,ny,nz,nt,p,mx,my,mz,mt,mxmy,mxmymz,q,intpol,
     +  iw(lt),w(l2),w(l3),w(l4),w(l5),w(l6),w(l7),w(l8),w(l9),
     +  iw(kz),w(k2),w(k3),w(k4),w(k5),w(k6),w(k7),w(k8),w(k9),
     +  iw(jy),w(j2),w(j3),w(j4),w(j5),w(j6),w(j7),w(j8),w(j9),
     +  iw,w(i2),w(i3),w(i4),w(i5))
	return

      end if
      end

      subroutine lint4(nx,ny,nz,nt,p,mx,my,mz,mt,mxmy,mxmymz,q,intpol,
     +lt,dt,pt,ptp,kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,
     +jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
c
c     linearly interpolate in t direction
c
      implicit none
      integer nx,ny,nz,nt,mx,my,mz,mt,mxmy,mxmymz,lsave,ll,l,iijjkk
      integer lt(mt),kz(mz),jy(my),ix(mx),intpol(4)
      real p(nx,ny,nz,nt),q(mxmymz,mt)
      real dt(mt),pt(mxmymz),ptp(mxmymz)
      real dzm(mz),dz(mz),dzp(mz),dzpp(mz)
      real pkm(mxmy),pk(mxmy),pkp(mxmy),pkpp(mxmy)
      real dym(my),dy(my),dyp(my),dypp(my)
      real pjm(mx),pj(mx),pjp(mx),pjpp(mx)
      real dxm(mx),dx(mx),dxp(mx),dxpp(mx)

      if (intpol(3) .eq. 1) then
c
c     linear in z
c
      lsave = -1
      do ll=1,mt
	l = lt(ll)
	if (l.eq.lsave) then
c
c     l pointer has not moved since last pass (no updates or interpolation)
c
	else if (l.eq.lsave+1) then
c
c     update l and interpolate l+1
c
	  do iijjkk=1,mxmymz
	    pt(iijjkk) = ptp(iijjkk)
	  end do
	  call lint3(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,
     +    kz,dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,
     +    dxm,dx,dxp,dxpp)
	else
c
c     interpolate l,l+1 in pt,ptp on xx,yy,zz mesh
c
      call lint3(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,kz,
     +dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
      call lint3(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,
     +dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	end if
c
c     save l pointer for next pass
c
      lsave = l
c
c     linearly interpolate q(ii,jj,,kk,ll) from pt,ptp in t direction
c
	do iijjkk=1,mxmymz
	  q(iijjkk,ll) = pt(iijjkk)+dt(ll)*(ptp(iijjkk)-pt(iijjkk))
	end do
      end do
      return

      else
c
c     cubic in z
c
      lsave = -1
      do ll=1,mt
	l = lt(ll)
	if (l.eq.lsave) then
c
c     l pointer has not moved since last pass (no updates or interpolation)
c
	else if (l.eq.lsave+1) then
c
c     update l and interpolate l+1
c
	do iijjkk=1,mxmymz
	  pt(iijjkk) = ptp(iijjkk)
	end do
	call cubt3(nx,ny,nt,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,
     +  kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,
     +  jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	else
c
c     interpolate l,l+1 in pt,ptp on xx,yy,zz mesh
c
	call cubt3(nx,ny,nt,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,
     +  kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,
     +  jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	call cubt3(nx,ny,nt,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,
     +  kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,
     +  jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	end if
c
c     save l pointer for next pass
c
	lsave = l
c
c     linearly interpolate q(ii,jj,kk,ll) from pt,ptp in t direction
c
	do iijjkk=1,mxmymz
	  q(iijjkk,ll) = pt(iijjkk)+dt(ll)*(ptp(iijjkk)-pt(iijjkk))
	end do

      end do
      return

      end if
      end

      subroutine cubt4(nx,ny,nz,nt,p,mx,my,mz,mt,mxmy,mxmymz,q,intpol,
     +lt,dtm,dt,dtp,dtpp,ptm,pt,ptp,ptpp,
     +kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,
     +jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,
     +ix,dxm,dx,dxp,dxpp)
c
c     cubically interpolate in t
c
      implicit none
      integer nx,ny,nz,nt,mx,my,mz,mt,mxmy,mxmymz,lsave,ll,l,iijjkk
      integer lt(mt),kz(mz),jy(my),ix(mx),intpol(4)
      real p(nx,ny,nz,nt),q(mxmymz,mt)
      real dtm(mt),dt(mt),dtp(mt),dtpp(mt)
      real ptm(mxmymz),pt(mxmymz),ptp(mxmymz),ptpp(mxmymz)
      real dzm(mz),dz(mz),dzp(mz),dzpp(mz)
      real pkm(mxmy),pk(mxmy),pkp(mxmy),pkpp(mxmy)
      real dym(my),dy(my),dyp(my),dypp(my)
      real pjm(mx),pj(mx),pjp(mx),pjpp(mx)
      real dxm(mx),dx(mx),dxp(mx),dxpp(mx)
      if (intpol(3) .eq. 1) then
c
c     linear in z
c
      lsave = -3
      do ll=1,mt
	l = lt(ll)
	if (l.eq.lsave) then
c
c     l pointer has not moved since last pass (no updates or interpolation)
c
	else if (l.eq.lsave+1) then
c
c     update l-1,l,l+1 and interpolate l+2
c
	do iijjkk=1,mxmymz
	  ptm(iijjkk) = pt(iijjkk)
	  pt(iijjkk) = ptp(iijjkk)
	  ptp(iijjkk) = ptpp(iijjkk)
	end do
	call lint3(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,dz,
     +  pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	else if (l.eq.lsave+2) then
c
c     update l-1,l and interpolate l+1,l+2
c
	do iijjkk=1,mxmymz
	  ptm(iijjkk) = ptp(iijjkk)
	  pt(iijjkk) = ptpp(iijjkk)
	end do
	call lint3(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,dz,
     +  pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	call lint3(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,dz,
     +  pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
      else if (l.eq.lsave+3) then
c
c     update l-1 and interpolate l,l+1,l+2
c
	do iijjkk=1,mxmymz
	  ptm(iijjkk) = ptpp(iijjkk)
	end do
	call lint3(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,kz,dz,
     +  pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	call lint3(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,dz,
     +  pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	call lint3(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,dz,
     +  pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	else
c
c     interpolate all four l-1,l,l+1,l+2
c
	call lint3(nx,ny,nz,p(1,1,1,l-1),mx,my,mxmy,mz,ptm,intpol,kz,dz,
     +  pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	call lint3(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,kz,dz,
     +  pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	call lint3(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,dz,
     +  pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	call lint3(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,dz,
     +  pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	end if
c
c     save l pointer for next pass
c
	lsave = l
c
c     cubically interpolate q(ii,jj,kk,ll) from ptm,pt,ptp,ptpp in t direction
c
	do iijjkk=1,mxmymz
	  q(iijjkk,ll) = dtm(ll)*ptm(iijjkk) + dt(ll)*pt(iijjkk) +
     +                   dtp(ll)*ptp(iijjkk) + dtpp(ll)*ptpp(iijjkk)
	end do
      end do
      return

      else
c
c     cubic in z
c
      lsave = -3
      do ll=1,mt
	l = lt(ll)
	if (l.eq.lsave) then
c
c     l pointer has not moved since last pass (no updates or interpolation)
c
	else if (l.eq.lsave+1) then
c
c     update l-1,l,l+1 and interpolate l+2
c
	do iijjkk=1,mxmymz
	  ptm(iijjkk) = pt(iijjkk)
	  pt(iijjkk) = ptp(iijjkk)
	  ptp(iijjkk) = ptpp(iijjkk)
	end do
      call cubt3(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,dzm,
     +dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,
     +ix,dxm,dx,dxp,dxpp)
	else if (l.eq.lsave+2) then
c
c     update l-1,l and interpolate l+1,l+2
c
	do iijjkk=1,mxmymz
	  ptm(iijjkk) = ptp(iijjkk)
	  pt(iijjkk) = ptpp(iijjkk)
	end do
      call cubt3(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,dzm,
     +dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,
     +ix,dxm,dx,dxp,dxpp)
      call cubt3(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,dzm,
     +dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,
     +ix,dxm,dx,dxp,dxpp)
	else if (l.eq.lsave+3) then
c
c     update l-1 and interpolate l,l+1,l+2
c
	do iijjkk=1,mxmymz
	  ptm(iijjkk) = ptpp(iijjkk)
	end do
      call cubt3(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,kz,dzm,
     +dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,
     +ix,dxm,dx,dxp,dxpp)
      call cubt3(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,dzm,
     +dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,
     +ix,dxm,dx,dxp,dxpp)
      call cubt3(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,dzm,
     +dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,
     +ix,dxm,dx,dxp,dxpp)
	else
c
c     interpolate all four l-1,l,l+1,l+2
c
      call cubt3(nx,ny,nz,p(1,1,1,l-1),mx,my,mxmy,mz,ptm,intpol,kz,dzm,
     +dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,
     +ix,dxm,dx,dxp,dxpp)
      call cubt3(nx,ny,nz,p(1,1,1,l),mx,my,mxmy,mz,pt,intpol,kz,dzm,
     +dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,
     +ix,dxm,dx,dxp,dxpp)
      call cubt3(nx,ny,nz,p(1,1,1,l+1),mx,my,mxmy,mz,ptp,intpol,kz,dzm,
     +dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,
     +ix,dxm,dx,dxp,dxpp)
      call cubt3(nx,ny,nz,p(1,1,1,l+2),mx,my,mxmy,mz,ptpp,intpol,kz,dzm,
     +dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,
     +ix,dxm,dx,dxp,dxpp)
	end if
c
c     save l pointer for next pass
c
	lsave = l
c
c     cubically interpolate q(ii,jj,kk,ll) from ptm,pt,ptp,ptpp in t direction
c
	do iijjkk=1,mxmymz
	  q(iijjkk,ll) = dtm(ll)*ptm(iijjkk) + dt(ll)*pt(iijjkk) +
     +                   dtp(ll)*ptp(iijjkk) + dtpp(ll)*ptpp(iijjkk)
	end do
      end do
      return
      end if

      end


c
c
c =========================================================
       subroutine qinit(maxmx,meqn,mbc,mx,xlower,dx,q,maux,aux)
c =========================================================
c
c     # Set initial conditions for q.
c     # Pulse in pressure, zero velocity
c
c
      implicit double precision (a-h,o-z)
      dimension q(1-mbc:maxmx+mbc, meqn)
      dimension aux(1-mbc:maxmx+mbc, *)
      common /cqinit/ beta,ic
c
c
      do 150 i=1,mx
	 xcell = xlower + (i-0.5d0)*dx

	 go to (10,20,30) ic

   10    continue
c        # half ellipse:
	 if (xcell.gt.-4d0 .and. xcell.lt.-2d0) then
	     q(i,1) = dsqrt(1.d0 - (xcell+3.d0)**2)
	    else
	     q(i,1) = 0.d0
	    endif
	 q(i,2) = q(i,1)
         go to 150

   20    continue
c        # single discontinuity:
         if (xcell .lt. -2.d0) then
	     q(i,1) = 1.d0
	    else
	     q(i,1) = 0.d0
	    endif
	 q(i,2) = q(i,1)
         go to 150

   30    continue
c        # Gaussian and square pulse:
	 q(i,1) = dexp(-beta*(xcell+2.0d0)**2)
	 if (dabs(q(i,1)) .lt. 1d-30) q(i,1) = 0.d0
	 if (xcell.gt.-4.d0 .and. xcell.lt.-3.d0) then
	    q(i,1) = q(i,1) + 0.5d0
	    endif
	 q(i,2) = q(i,1)
         go to 150

  150    continue
c
      return
      end


! vim: set ft=fortran sw=4 ts=4 :

module mod_arrays

    implicit none

    private
    public :: reverse
    public :: average
    public :: std
    public :: moving_average
    public :: moving_std

contains

    pure function reverse(x)
        real, intent(in) :: x(:)
        real :: reverse(size(x))

        reverse = x(size(x):1:-1)
    end function reverse

    pure real function average(x)
        real, intent(in) :: x(:)

        average = sum(x) / size(x)
    end function average

    pure real function std(x)
        real, intent(in) :: x(:)

        std = sqrt(average((x -average(x))**2))
    end function std

    pure function moving_average(x, window_size) result(ma)
        real, intent(in) :: x(:)
        integer, intent(in) :: window_size
        real :: ma(size(x))
        integer :: i, lower_bound

        do i = 1, size(x)
            lower_bound = max(i - window_size, 1)
            ma(i) = average(x(lower_bound:i))
        end do
    end function moving_average

    pure function moving_std(x, window_size) result(ms)
        real, intent(in) :: x(:)
        integer, intent(in) :: window_size
        real :: ms(size(x))
        integer :: i, lower_bound

        do i = 1, size(x)
            lower_bound = max(i - window_size, 1)
            ms(i) = std(x(lower_bound:i))
        end do
    end function moving_std

end module


    Program dorgql_example

!     DORGQL Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dgeqlf, dorgql
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ifail, info, lda, lwork, m, n
      Character (30) :: title
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), tau(:), work(:)
!     .. Executable Statements ..
      Write (nout, *) 'DORGQL Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n
      lda = m
      lwork = nb*n
      Allocate (a(lda,n), tau(n), work(lwork))

!     Read A from data file

      Read (nin, *)(a(i,1:n), i=1, m)

!     Compute the QL factorization of A

      Call dgeqlf(m, n, a, lda, tau, work, lwork, info)

!     Form the leading N columns of Q explicitly

      Call dorgql(m, n, n, a, lda, tau, work, lwork, info)

!     Form the heading for NAGF_FILE_PRINT_MATRIX_REAL_GEN

      Write (title, 100) n
      Flush (nout)

!     Print the leading N columns of Q

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', m, n, a, lda, &
        title, ifail)

100   Format ('The leading ', I4, ' columns of Q')
    End Program


c     program DRDCHOL
c>> 1996-06-17 DRDCHOL Krogh  Minor format change for C conversion.
c>> 1996-05-28 DRDCHOL Krogh Added external statement.
c>> 1994-10-19 DRDCHOL Krogh  Changes to use M77CON
c>> 1994-08-09 DRDCHOL WVS remove '0' from formats
c>> 1992-03-04 DRDCHOL Krogh Initial version.
c  Demonstration driver for DCHOL
c     ------------------------------------------------------------------
c--D replaces "?": DR?CHOL, ?CHOL, ?DOT
c     ------------------------------------------------------------------
      integer LDP, M, N
      parameter (M = 3, N = 2, LDP = 2)
      integer I, IERR, J
      double precision A(M,N), B(M)
      external DDOT
      double precision P(LDP,LDP), D(LDP), U, DDOT
      data A(1,1), A(1,2), B(1) /  0.7D0,  0.6D0,  1.726D0 /
      data A(2,1), A(2,2), B(2) / -0.8D0,  0.5D0, -5.415D0 /
      data A(3,1), A(3,2), B(3) /  0.6D0, -0.7D0,  5.183D0 /
c     ------------------------------------------------------------------
      U = DDOT(M, B, 1, B, 1)
      do 20 I = 1, N
         D(I) = DDOT(M, A(1,I), 1, B, 1)
         do 10 J = 1, N
            P(I,J) = DDOT(M, A(1,I), 1, A(1, J), 1)
   10    continue
   20 continue
      call DCHOL(P, LDP, N, D, U, 0.0d0, IERR)
      print '('' X()   = '',2f15.6)', D(1), D(2)
      print '('' RNORM = '',f15.6)', U
      if (IERR .ne. 0) print '(
     *  '' Matrix failed conditioning test in DCHOL, IERR = '',I3)',IERR
      end


cc Copyright (C) 2004-2009: Leslie Greengard and June-Yub Lee
cc Contact: greengard@cims.nyu.edu
cc
cc This software is being released under a FreeBSD license
cc (see license.txt in this directory).
c***********************************************************************
      subroutine dirft1d1(nj,xj,cj, iflag, ms,fk)
      implicit none
      integer nj, iflag, ms
      real*8 xj(nj)
      complex*16 cj(nj), fk(-ms/2:(ms-1)/2)
c ----------------------------------------------------------------------
c     direct computation of nonuniform FFT
c
c                   nj
c     fk(k1)    =  SUM cj(j) exp(+/-i k1 xj(j))
c                  j=1
c
c     for -ms/2 <= k1 <= (ms-1)/2
c
c     If (iflag .ge.0) the + sign is used in the exponential.
c     If (iflag .lt.0) the - sign is used in the exponential.
c
c***********************************************************************
      integer j, k1
      complex*16 zf, cm1
c
      do k1 = -ms/2, (ms-1)/2
         fk(k1) = dcmplx(0d0,0d0)
      enddo
c
      do j = 1, nj
         if (iflag .ge. 0) then
            zf = dcmplx(dcos(xj(j)),+dsin(xj(j)))
         else
            zf = dcmplx(dcos(xj(j)),-dsin(xj(j)))
         endif
c
         cm1 = cj(j)
         do k1 = 0, (ms-1)/2
            fk(k1) = fk(k1) + cm1
            cm1 = cm1 * zf
         enddo
c
         zf = dconjg(zf)
         cm1 = cj(j)
         do k1 = -1, -ms/2, -1
            cm1 = cm1 * zf
            fk(k1) = fk(k1) + cm1
         enddo
      enddo
      end
c
c
c
c
c
c***********************************************************************
      subroutine dirft1d2(nj,xj,cj, iflag, ms,fk)
      implicit none
      integer nj, iflag, ms
      real*8 xj(nj)
      complex*16 cj(nj), fk(-ms/2:(ms-1)/2)
c ----------------------------------------------------------------------
c     direct computation of nonuniform FFT
c
c     cj(j) = SUM   fk(k1) exp(+/-i k1 xj(j))
c             k1
c                            for j = 1,...,nj
c
c     where -ms/2 <= k1 <= (ms-1)/2
c
c
c     If (iflag .ge.0) the + sign is used in the exponential.
c     If (iflag .lt.0) the - sign is used in the exponential.
c***********************************************************************
      integer j, k1
      complex*16 zf, cm1
c
      do j = 1, nj
         if (iflag .ge. 0) then
            zf = dcmplx(dcos(xj(j)),+dsin(xj(j)))
         else
            zf = dcmplx(dcos(xj(j)),-dsin(xj(j)))
         endif
c
         cj(j) = fk(0)
         cm1 = zf
         do k1 = 1, (ms-1)/2
            cj(j) = cj(j) + cm1*fk(k1)+dconjg(cm1)*fk(-k1)
            cm1 = cm1 * zf
         enddo
         if (ms/2*2.eq.ms) cj(j) = cj(j) + dconjg(cm1)*fk(-ms/2)
      enddo
      end
c
c
c
c
c
c
c***********************************************************************
      subroutine dirft1d3(nj,xj,cj, iflag, nk,sk,fk)
      implicit none
      integer nj, iflag, nk
      real*8 xj(nj), sk(nk)
      complex*16 cj(nj), fk(nk)
c ----------------------------------------------------------------------
c     direct computation of nonuniform FFT
c
c              nj
c     fk(k) = SUM cj(j) exp(+/-i s(k) xj(j))
c             j=1
c
c                    for k = 1, ..., nk
c
c     If (iflag .ge.0) the + sign is used in the exponential.
c     If (iflag .lt.0) the - sign is used in the exponential.
c
c***********************************************************************
      integer j, k
      real*8 ssk
c
      do k = 1, nk
         if (iflag .ge. 0) then
            ssk =  sk(k)
         else
            ssk =  -sk(k)
         endif
c
         fk(k) = dcmplx(0d0, 0d0)
         do j = 1, nj
            fk(k) = fk(k) +cj(j)*dcmplx(dcos(ssk*xj(j)),dsin(ssk*xj(j)))
         enddo
      enddo
      end