module interpolation

! Module for cubic splines, Lagrange and Hermite interpolation.
! Requires Lapack.

! Splines are fully specified by the interpolation points, except that
! at the ends, we have the freedom to prescribe the second derivatives.
! If we know a derivative at an end (exactly), then best is to impose that.
! Otherwise, it is better to use the "consistent" end conditions: the second
! derivative is determined such that it is smooth.
!
! High level API: spline3, spline3ders.
! Low level API: the rest of public soubroutines.
!
! Use the high level API to obtain cubic spline fit with consistent boundary
! conditions and optionally the derivatives. Use the low level API if more fine
! grained control is needed.
!
! This module is based on a code written by John E. Pask, LLNL.

use types, only: dp
use lapack, only: dgesv, dgbsv
use utils, only: stop_error, assert, newunit, white_char
implicit none
private
public spline3pars, spline3valder, iix, iixmin, iixun, iixexp, poly3, dpoly3, &
    d2poly3, spline3, spline3ders, hermite5interp, lagrange3interp, &
    hermite_basis_1, hermite_basis_2, loadtxt

contains

function spline3(x, y, xnew) result(ynew)
! Takes the function values 'y' on the grid 'x' and returns new values 'ynew'
! at the given grid 'xnew' using cubic splines interpolation with such
! boundary conditions so that the 2nd derivative is consistent with the
! interpolating cubic.
real(dp), intent(in) :: x(:), y(:), xnew(:)
real(dp) :: ynew(size(xnew))
real(dp) :: c(0:4, size(x)-1)
integer :: i, ip
! get spline parameters: 2nd derivs at ends determined by cubic interpolation
call spline3pars(x, y, [2, 2], [0._dp, 0._dp], c)

ip = 0
do i = 1, size(xnew)
    ip = iixmin(xnew(i), x, ip)
    ynew(i) = poly3(xnew(i), c(:, ip))
end do
end function

subroutine spline3ders(x, y, xnew, ynew, dynew, d2ynew)
! Just like 'spline', but also calculate 1st and 2nd derivatives
real(dp), intent(in) :: x(:), y(:), xnew(:)
real(dp), intent(out), optional :: ynew(:), dynew(:), d2ynew(:)
real(dp) :: c(0:4, size(x)-1)
integer :: i, ip
call spline3pars(x, y, [2, 2], [0._dp, 0._dp], c)

ip = 0
do i = 1, size(xnew)
    ip = iixmin(xnew(i), x, ip)
    if (present(  ynew))   ynew(i) =   poly3(xnew(i), c(:, ip))
    if (present( dynew))  dynew(i) =  dpoly3(xnew(i), c(:, ip))
    if (present(d2ynew)) d2ynew(i) = d2poly3(xnew(i), c(:, ip))
end do
end subroutine

subroutine spline3pars(xi,yi,bctype,bcval,c)
! Returns parameters c defining cubic spline interpolating x-y data xi, yi, with
! boundary conditions specified by bcytpe, bcvals
real(dp), intent(in):: xi(:)        ! x values of data
real(dp), intent(in):: yi(:)        ! y values of data
integer, intent(in):: bctype(2)     ! type of boundary condition at each end:
   ! bctype(1) = type at left end, bctype(2) = type at right end.
   ! 1 = specified 2nd derivative, 2 = 2nd derivative consistent with interpolating cubic.
real(dp), intent(in):: bcval(2)     ! boundary condition values at each end:
   ! bcval(1) = value at left end, bcval(2) = value at right end
real(dp), intent(out):: c(0:,:)     ! parameters defining spline: c(i,j) = ith parameter of jth
   ! spline polynomial, p_j = sum_{i=1}^4 c(i,j) (x-c(0,j))^(i-1), j = 1..n-1, n = # of data pts.
   ! dimensions: c(0:4,1:n-1)
real(dp) As(5,2*size(c,2))             ! spline eq. matrix -- LAPACK band form
real(dp) bs(2*size(c,2))               ! spline eq. rhs vector
real(dp) cs(2*size(c,2))               ! spline eq. solution vector
real(dp) hi(size(c,2))                 ! spline intervals
real(dp) Ae(4,4)                       ! end-cubic eq. matrix
real(dp) be(4)                         ! end-cubic eq. rhs vector
real(dp) ce(4)                         ! end-cubic eq. solution vector
real(dp) xe(4),ye(4)                   ! x,y values at ends
real(dp) d2p1,d2pn                     ! 2nd derivatives at ends
real(dp) x0                            ! expansion center
real(dp) c1,c2,c3,c4                   ! expansion coefficients
integer n                              ! number of data points
integer i,j,i2
! lapack variables
integer ipiv(4),ipiv2(2*size(c,2))
real(dp) bemat(4,1),bmat(2*size(c,2),1)
integer info

! check input parameters
if (bctype(1) < 1 .or. bctype(1) > 2) call stop_error("spline3pars error: bctype /= 1 or 2.")
if (bctype(2) < 1 .or. bctype(2) > 2) call stop_error("spline3pars error: bctype /= 1 or 2.")
if (size(c,1) /= 5) call stop_error("spline3pars error: size(c,1) /= 5.")
if (size(c,2) /= size(xi)-1) call stop_error("spline3pars error: size(c,2) /= size(xi)-1.")
if (size(xi) /= size(yi)) call stop_error("spline3pars error: size(xi) /= size(yi)")

! To get rid of compiler warnings:
d2p1 = 0
d2pn = 0

! initializations
n=size(xi)
do i=1,n-1
   hi(i)=xi(i+1)-xi(i)
end do

! compute interpolating-cubic 2nd derivs at ends, if required
   ! left end
if(bctype(1)==2) then
   if (n < 4) call stop_error("spline3pars error: n < 4")
   xe=xi(1:4)
   ye=yi(1:4)
   x0=xe(1) ! center at end
   do i=1,4
      do j=1,4
         Ae(i,j) = (xe(i)-x0)**(j-1)
      end do
   end do
   Ae(:,1) = 1    ! set 0^0 = 1
   be=ye; bemat(:,1)=be
   call dgesv(4, 1, Ae, 4, ipiv, bemat, 4, info)
   if (info /= 0) call stop_error("spline3pars error: dgesv error.")
   ce=bemat(:,1)
   d2p1=2*ce(3)
end if
   ! right end
if(bctype(2)==2) then
   if (n < 4) call stop_error("spline3pars error: n < 4")
   xe=xi(n-3:n)
   ye=yi(n-3:n)
   x0=xe(4) ! center at end
   do i=1,4
      do j=1,4
         Ae(i,j) = (xe(i)-x0)**(j-1)
      end do
   end do
   Ae(:,1) = 1    ! set 0^0 = 1
   be=ye; bemat(:,1)=be
   call dgesv(4, 1, Ae, 4, ipiv, bemat, 4, info)
   if (info /= 0) call stop_error("spline3pars error: dgesv error.")
   ce=bemat(:,1)
   d2pn=2*ce(3)
end if

! set 2nd derivs at ends
if(bctype(1)==1) d2p1=bcval(1)
if(bctype(2)==1) d2pn=bcval(2)
!write(*,*) d2p1,d2pn

! construct spline equations -- LAPACK band form
! basis: phi1 = -(x-x_i)/h_i, phi2 = (x-x_{i+1})/h_i, phi3 = phi1^3-phi1, phi4 = phi2^3-phi2
! on interval [x_i,x_{i+1}] of length h_i = x_{i+1}-x_i
!A=0  ! full matrix
As=0
   ! left end condition
!A(1,1)=6/hi(1)**2   ! full matrix
As(4,1)=6/hi(1)**2
bs(1)=d2p1
   ! internal knot conditions
do i=2,n-1
   i2=2*(i-1)
!   A(i2,i2-1) = 1/hi(i-1)    ! full matrix ...
!   A(i2,i2)   = 2/hi(i-1)
!   A(i2,i2+1) = 2/hi(i)
!   A(i2,i2+2) = 1/hi(i)
!   A(i2+1,i2) = 1/hi(i-1)**2
!   A(i2+1,i2+1) = -1/hi(i)**2
   As(5,i2-1) = 1/hi(i-1)
   As(4,i2)   = 2/hi(i-1)
   As(3,i2+1) = 2/hi(i)
   As(2,i2+2) = 1/hi(i)
   As(5,i2)   = 1/hi(i-1)**2
   As(4,i2+1) = -1/hi(i)**2
   bs(i2) = (yi(i+1) - yi(i))/hi(i) - (yi(i) - yi(i-1))/hi(i-1)
   bs(i2+1) = 0
end do
   ! right end condition
!A(2*(n-1),2*(n-1))=6/hi(n-1)**2 ! full matrix
As(4,2*(n-1))=6/hi(n-1)**2
bs(2*(n-1))=d2pn

! solve spline equations -- full matrix
!bmat(:,1)=bs
!call dgesv(2*(n-1), 1, A, 2*(n-1), ipiv2, bmat, 2*(n-1), info)
!if (info /= 0) call stop_error("spline3pars error: dgesv error.")
!cs=bmat(:,1)

! solve spline equations -- LAPACK band form
bmat(:,1)=bs
call dgbsv(2*(n-1), 1, 2, 1, As, 5, ipiv2, bmat, 2*(n-1), info)
if (info /= 0) call stop_error("spline3pars error: dgbsv error.")
cs=bmat(:,1)
!write(*,*) cs(1:6)
!write(*,*) cs(2*(n-1)-5:2*(n-1))

! transform to (x-x0)^(i-1) basis and return
do i=1,n-1
   ! coefficients in spline basis:
   c1=yi(i)
   c2=yi(i+1)
   c3=cs(2*i-1)
   c4=cs(2*i)
   ! coefficients in (x-x0)^(i-1) basis
   c(0,i)=xi(i)
   c(1,i)=c1
   c(2,i)=-(c1-c2+2*c3+c4)/hi(i)
   c(3,i)=3*c3/hi(i)**2
   c(4,i)=(-c3+c4)/hi(i)**3
end do
end subroutine

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

subroutine spline3valder(x,xi,c,val,der)
! Returns value and 1st derivative of spline defined by knots xi and parameters c
! returned by spline3pars
real(dp), intent(in):: x            ! point at which to evaluate spline
real(dp), intent(in):: xi(:)        ! spline knots (x values of data)
real(dp), intent(in):: c(0:,:)      ! spline parameters: c(i,j) = ith parameter of jth
   ! spline polynomial, p_j = sum_{i=1}^4 c(i,j) (x-c(0,j))^(i-1), j = 1..n-1, n = # of data pts.
   ! dimensions: c(0:4,1:n-1)
real(dp), intent(out):: val         ! value of spline at x
real(dp), intent(out):: der         ! 1st derivative of spline at x
integer n                           ! number of knots
integer i1

! initialize, check input parameters
n=size(xi)
if (size(c,1) /= 5) call stop_error("spline3 error: size(c,1) /= 5.")
if (size(c,2) /= size(xi)-1) call stop_error("spline3 error: size(c,2) /= size(xi)-1.")
! find interval containing x
i1=iix(x,xi)
! return value and derivative
val=poly3(x,c(:,i1))
der=dpoly3(x,c(:,i1))
end subroutine

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

integer function iix(x, xi) result(i1)
! Returns index i of interval [xi(i),xi(i+1)] containing x in mesh xi,
! with intervals indexed by left-most points.
! N.B.: x outside [x1,xn] are indexed to nearest end.
! Uses bisection, except if "x" lies in the first or second elements (which is
! often the case)
real(dp), intent(in) :: x            ! target value
real(dp), intent(in) :: xi(:)        ! mesh, xi(i) < xi(i+1)
integer n                            ! number of mesh points
integer i2, ic

n = size(xi)
i1 = 1
if (n < 2) then
    call stop_error("error in iix: n < 2")
elseif (n == 2) then
    i1 = 1
elseif (n == 3) then
    if (x <= xi(2)) then ! first element
        i1 = 1
    else
        i1 = 2
    end if
elseif (x <= xi(1)) then ! left end
    i1 = 1
elseif (x <= xi(2)) then ! first element
    i1 = 1
elseif (x <= xi(3)) then ! second element
    i1 = 2
elseif (x >= xi(n)) then  ! right end
    i1 = n-1
else
    ! bisection: xi(i1) <= x < xi(i2)
    i1 = 3; i2 = n
    do
        if (i2 - i1 == 1) exit
        ic = i1 + (i2 - i1)/2
        if (x >= xi(ic)) then
            i1 = ic
        else
            i2 = ic
        endif
    end do
end if
end function

integer function iixmin(x, xi, i_min) result(ip)
! Just like iix, but assumes that x >= xi(i_min)
real(dp), intent(in) :: x, xi(:)
integer, intent(in) :: i_min
if (i_min >= 1 .and. i_min <= size(xi)-1) then
    ip = iix(x, xi(i_min:)) + i_min - 1
else
    ip = iix(x, xi)
end if
end function

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

function iixun(x,n,x1,xn)
! Returns index i of interval [x(i),x(i+1)] containing x in uniform mesh defined by
!   x(i) = x1 + (i-1)/(n-1)*(xn-x1), i = 1 .. n,
! with intervals indexed by left-most points.
! N.B.: x outside [x1,xn] are indexed to nearest end.
integer iixun                       ! index i of interval [x(i),x(i+1)] containing x
real(dp), intent(in):: x            ! target value
integer, intent(in):: n             ! number of mesh points
real(dp), intent(in):: x1           ! initial point of mesh
real(dp), intent(in):: xn           ! final point of mesh
integer i

! compute index
i=int((x-x1)/(xn-x1)*(n-1))+1
! reset if ouside 1..n
if (i<1) i=1
if (i>n-1) i=n-1
iixun=i
end function

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

function iixexp(x,n,x1,alpha,beta)
! Returns index i of interval [x(i),x(i+1)] containing x in exponential mesh defined by
!   x(i) = x1 + alpha [ exp(beta(i-1)) - 1 ], i = 1 .. n,
! where alpha = (x(n) - x(1))/[ exp(beta(n-1)) - 1 ],
! beta = log(r)/(n-2), r = (x(n)-x(n-1))/(x(2)-x(1)) = ratio of last to first interval,
! and intervals indexed by left-most points.
! N.B.: x outside [x1,xn] are indexed to nearest end.
integer iixexp                      ! index i of interval [x(i),x(i+1)] containing x
real(dp), intent(in):: x            ! target value
integer, intent(in):: n             ! number of mesh points
real(dp), intent(in):: x1           ! initial point of mesh
real(dp), intent(in):: alpha        ! mesh parameter:
!   x(i) = x1 + alpha [ exp(beta(i-1)) - 1 ], i = 1 .. n,
! where alpha = (x(n) - x(1))/[ exp(beta(n-1)) - 1 ],
! beta = log(r)/(n-2), r = (x(n)-x(n-1))/(x(2)-x(1)) = ratio of last to first interval,
real(dp), intent(in):: beta         ! mesh parameter
integer i

! compute index
i=int(log((x-x1)/alpha + 1)/beta) + 1
! reset if outside 1..n
if (i<1) i=1
if (i>n-1) i=n-1
iixexp=i
end function

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

function poly3(x,c)
! returns value of polynomial \sum_{i=1}^4 c(i) (x-c(0))^(i-1)
real(dp) poly3
real(dp), intent(in):: x      ! point at which to evaluate polynomial
real(dp), intent(in):: c(0:)  ! coefficients: poly = \sum_{i=1}^4 c(i) (x-c(0))^(i-1)
real(dp) dx
dx=x-c(0)
poly3=c(1)+c(2)*dx+c(3)*dx**2+c(4)*dx**3
end function

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

function dpoly3(x,c)
! returns 1st derivative of polynomial \sum_{i=1}^4 c(i) (x-c(0))^(i-1)
real(dp) dpoly3
real(dp), intent(in):: x      ! point at which to evaluate polynomial
real(dp), intent(in):: c(0:)  ! coefficients: poly = \sum_{i=1}^4 c(i) (x-c(0))^(i-1)
real(dp) dx
dx=x-c(0)
dpoly3=c(2)+2*c(3)*dx+3*c(4)*dx**2
end function

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

function d2poly3(x,c)
! returns 2nd derivative of polynomial \sum_{i=1}^4 c(i) (x-c(0))^(i-1)
real(dp) d2poly3
real(dp), intent(in):: x      ! point at which to evaluate polynomial
real(dp), intent(in):: c(0:)  ! coefficients: poly = \sum_{i=1}^4 c(i) (x-c(0))^(i-1)
real(dp) dx
dx=x-c(0)
d2poly3=2*c(3)+6*c(4)*dx
end function

function lagrange3interp(x, y, xnew) result(ynew)
! Takes the function values 'y' on the grid 'x' and returns new values 'ynew'
! at the given grid 'xnew' using cubic Lagrange interpolation through the
! current interval plus one to the left and right (3 intervals and 4 points
! total). The first three intervals are used for interpolation on the first
! interval or to the left of the grid 'x'. The last three intervals are used
! for interpolation at the last interval or to the right of the grid 'x'.
real(dp), intent(in) :: x(:), y(:), xnew(:)
real(dp) :: ynew(size(xnew))
integer :: i, j, ip, idx
idx = 0
do i = 1, size(xnew)
    idx = iixmin(xnew(i), x, idx)
    ! Decide which three intervals to use for interpolation at the point xnew(i)
    ip = idx - 1
    if (ip < 1) ip = 1
    if (ip > size(x)-3) ip = size(x)-3
    ! Interpolate using the three intervals given by the four points x(ip, ip+3)
    ynew(i) = 0
    do j = 1, 4
        ynew(i) = ynew(i) + phih(x(ip:ip+3), j, xnew(i)) * y(ip+j-1)
    end do
end do
end function

function hermite5interp(x, y, yd, extend_right, xnew) result(ynew)
! Takes the function values 'y' and derivatives 'yd' on the grid 'x' and
! returns new values 'ynew' at the given grid 'xnew' using 5th order Hermite
! interpolation. This version uses a Hermite interpolation basis instead of
! solving a 6x6 linear system.
real(dp), intent(in) :: x(:), y(:), yd(:), xnew(:)
logical, intent(in) :: extend_right
real(dp) :: ynew(size(xnew))
integer :: i, j, ip, idx

idx = 0
do i = 1, size(xnew)
    idx = iixmin(xnew(i), x, idx)
    ! Decide which two intervals to use for interpolation at the point xnew(i)
    if (extend_right) then
        ip = idx
        if (ip > size(x)-2) ip = size(x)-2
    else
        ip = idx - 1
        if (ip < 1) ip = 1
    end if
    ! Interpolate using the two intervals ip,ip+1 and ip+1,ip+2. These two
    ! intervals are given by the three points x(ip,ip+2).
    ynew(i) = 0
    do j = 1, 3
        ynew(i) = ynew(i) + hermite_basis_1(x(ip:ip+2), j, xnew(i)) * y (ip+j-1)
        ynew(i) = ynew(i) + hermite_basis_2(x(ip:ip+2), j, xnew(i)) * yd(ip+j-1)
    end do
end do
end function

real(dp) pure function phih(xin, n, xi)
! "phi hat": nth Lagrange polynomial with nodes xin at point xi.
! Value equals to 1 for xi=xin(n) and zero for all other nodes.
real(dp), intent(in) :: xin(:) ! polynomial nodes
integer, intent(in) :: n       ! polynomial index
real(dp), intent(in) :: xi     ! point at which to evaluate phih
integer :: i
! compute nth polynomial: 1 at node n, 0 at all others
phih = 1
do i = 1, size(xin)
    if (i == n) cycle
    phih = phih * (xi-xin(i))/(xin(n)-xin(i))
end do
end function

real(dp) pure function dphih(xin, n, xi)
! "d phi hat": derivative of nth Lagrange polynomial with nodes 'xin' at point
! 'xi'.
real(dp), intent(in) :: xin(:) ! polynomial nodes
integer, intent(in) :: n       ! polynomial index
real(dp), intent(in) :: xi     ! point at which to evaluate dphih
real(dp) :: term
real(dp) :: tmp(size(xin))
integer :: i, j
do i = 1, size(xin)
    if (i==n) cycle
    tmp(i) = (xi-xin(i))/(xin(n)-xin(i))
end do
! compute derivative of nth polynomial
dphih = 0
do j = 1, size(xin)
    if (j == n) cycle
    term = 1 / (xin(n)-xin(j))
    do i = 1, size(xin)
        if (i==n .or. i==j) cycle
        term = term * tmp(i)
    end do
    dphih = dphih + term
end do
end function

real(dp) pure function hermite_basis_1(xin, n, xi) result(h)
! nth Hermite basis polynomial (first kind) with nodes 'xin' at point 'xi'.
! Value equals to 1 for xi=xin(n) and zero for all other nodes. Derivatives are
! zero for all nodes.
real(dp), intent(in) :: xin(:) ! polynomial nodes
integer, intent(in) :: n       ! polynomial index
real(dp), intent(in) :: xi     ! point at which to evaluate phih
h = (1-2*dphih(xin, n, xin(n))*(xi - xin(n))) * phih(xin, n, xi)**2
end function

real(dp) pure function hermite_basis_2(xin, n, xi) result(h)
! nth Hermite basis polynomial (second kind) with nodes 'xin' at point 'xi'.
! Value is zero for all nodes. Derivative equals to 1 for xi=xin(n) and zero
! for all other nodes.
real(dp), intent(in) :: xin(:) ! polynomial nodes
integer, intent(in) :: n       ! polynomial index
real(dp), intent(in) :: xi     ! point at which to evaluate phih
h = (xi - xin(n)) * phih(xin, n, xi)**2
end function

subroutine loadtxt(filename, d)
! Loads a 2D array from a text file.
!
! Arguments
! ---------
!
! Filename to load the array from
character(len=*), intent(in) :: filename
! The array 'd' will be automatically allocated with the correct dimensions
real(dp), allocatable, intent(out) :: d(:, :)
!
! Example
! -------
!
! real(dp), allocatable :: data(:, :)
! call loadtxt("log.txt", data)  ! 'data' will be automatically allocated
!
! Where 'log.txt' contains for example::
!
!     1 2 3
!     2 4 6
!     8 9 10
!     11 12 13
!     ...
!
character :: c
integer :: s, ncol, nrow, ios, i
logical :: lastwhite
real(dp) :: r

open(newunit(s), file=filename, status="old")

! determine number of columns
ncol = 0
lastwhite = .true.
do
   read(s, '(a)', advance='no', iostat=ios) c
   if (ios /= 0) exit
   if (lastwhite .and. .not. white_char(c)) ncol = ncol + 1
   lastwhite = white_char(c)
end do

rewind(s)

! determine number or rows
nrow = 0
do
   read(s, *, iostat=ios) r
   if (ios /= 0) exit
   nrow = nrow + 1
end do

rewind(s)

allocate(d(nrow, ncol))
do i = 1, nrow
    read(s, *) d(i, :)
end do
close(s)
end subroutine

end module


	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program solves heat equation in 1 dimension
	! u_t=\alpha*u_{xx}
	! using a the backward Euler method for x\in[0,2\pi]
	!
	! The boundary conditions are u(0)=u(2\pi)
	! The initial condition is u=sin(x)
	!
	! .. Parameters ..
	!  Nx	= number of modes in x - power of 2 for FFT
	!  Nt	= number of timesteps to take
	!  Tmax	= maximum simulation time
	!  plotgap			= number of timesteps between plots
	!  FFTW_IN_PLACE 	= value for FFTW input
	!  FFTW_MEASURE 	= value for FFTW input
	!  FFTW_EXHAUSTIVE 	= value for FFTW input
	!  FFTW_PATIENT 	= value for FFTW input
	!  FFTW_ESTIMATE 	= value for FFTW input
	!  FFTW_FORWARD     = value for FFTW input
	!  FFTW_BACKWARD	= value for FFTW input
	!  pi = 3.14159265358979323846264338327950288419716939937510d0
	!  L				= width of box
	!  alpha			= heat conductivity
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  n				= loop counter for timesteps direction
	!  allocatestatus	= error indicator during allocation
	!  start			= variable to record start time of program
	!  finish			= variable to record end time of program
	!  count_rate		= variable for clock count rate
	!  planfx			= Forward 1d fft plan in x
	!  planbx			= Backward 1d fft plan in x
	!  dt				= timestep
	! .. Arrays ..
	!  u				= approximate REAL solution
	!  v				= Fourier transform of approximate solution
	!  vna 				= temporary field
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!  x				= x locations
	!  time				= times at which save data
	!  name_config		= array to store filename for data to be saved
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! FFTW3	 -- Fast Fourier Transform in the West Library
	!			(http://www.fftw.org/)

	PROGRAM main

	! Declare variables
	IMPLICIT NONE
	INTEGER(kind=4),	PARAMETER 	::  Nx=64
	INTEGER(kind=4),	PARAMETER	::  Nt=20
	REAL(kind=8),	PARAMETER	&
		::  pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8),	PARAMETER	::  L=5.0d0
	REAL(kind=8),	PARAMETER	::  alpha=0.50d0
	REAL(kind=8)	::  dt=0.2d0/REAL(Nt,kind(0d0))
	COMPLEX(KIND=8), DIMENSION(:),ALLOCATABLE	::  kx
	REAL(kind=8), DIMENSION(:),ALLOCATABLE	::  x
	COMPLEX(KIND=8), DIMENSION(:,:),ALLOCATABLE	::  u,v
	REAL(kind=8), DIMENSION(:),ALLOCATABLE	::  time
	COMPLEX(KIND=8), DIMENSION(:),ALLOCATABLE	::  vna
	INTEGER(kind=4)	::  i,j,k,n
	INTEGER(kind=4)	:: start, finish, count_rate, AllocateStatus
	INTEGER(kind=4), PARAMETER	:: FFTW_IN_PLACE = 8, FFTW_MEASURE = 0, &
		FFTW_EXHAUSTIVE = 8, FFTW_PATIENT = 32, FFTW_ESTIMATE = 64
	INTEGER(kind=4), PARAMETER :: FFTW_FORWARD = -1, FFTW_BACKWARD=1
	COMPLEX(KIND=8), DIMENSION(:),ALLOCATABLE :: fftfx,fftbx
	INTEGER(kind=8)	:: planfx,planbx
	CHARACTER*100	:: name_config

	CALL system_clock(start,count_rate)
	ALLOCATE(kx(1:Nx),x(1:Nx),u(1:Nx,1:1+Nt),v(1:Nx,1:1+Nt),&
   			time(1:1+Nt),vna(1:Nx),fftfx(1:Nx),fftbx(1:Nx),&
   			stat=AllocateStatus)
   	IF (AllocateStatus .ne. 0) STOP

		! set up ffts
	CALL dfftw_plan_dft_1d(planfx,Nx,fftfx(1:Nx),fftbx(1:Nx),&
			FFTW_FORWARD,FFTW_ESTIMATE)
	CALL dfftw_plan_dft_1d(planbx,Nx,fftbx(1:Nx),fftfx(1:Nx),&
			FFTW_BACKWARD,FFTW_ESTIMATE)

	PRINT *,'Setup FFTs'

	! setup fourier frequencies
	DO i=1,1+Nx/2
		kx(i)= cmplx(0.0d0,1.0d0)*REAL(i-1,kind(0d0))/L
	END DO
	kx(1+Nx/2)=0.00d0
	DO i = 1,Nx/2 -1
		kx(i+1+Nx/2)=-kx(1-i+Nx/2)
	END DO
	DO i=1,Nx
		x(i)=(-1.00d0 + 2.00d0*REAL(i-1,kind(0d0))/REAL(Nx,KIND(0d0)))*pi*L
	END DO

	PRINT *,'Setup grid and fourier frequencies and splitting coefficients'

	u(1:Nx,1)=sin(x(1:Nx))
		! transform initial data
	CALL dfftw_execute_dft_(planfx,u(1:Nx,1),v(1:Nx,1))
	PRINT *,'Got initial data, starting timestepping'
	time(1)=0.0d0

	vna(1:Nx)=v(1:Nx,1)
	PRINT *,'Starting timestepping'
	DO n=1,Nt
		DO i=1,Nx
			vna(i)=vna(i)/(1-dt*kx(i)*kx(i))
		END DO
		PRINT *,'storing plot data ',n
		time(n+1)=time(n)+dt
		v(1:Nx,n+1)=vna(1:Nx)
		CALL dfftw_execute_dft_(planbx,v(1:Nx,n+1),u(1:Nx,n+1))
		u(1:Nx,n+1)=u(1:Nx,n+1)/REAL(Nx,KIND(0d0))	! normalize
	END DO
	PRINT *,'Finished time stepping'
	CALL system_clock(finish,count_rate)
	PRINT*,'Program took ',REAL(finish-start)/REAL(count_rate),'for execution'

	! Write data out to disk

	name_config = 'u.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,1+Nt
		DO i=1,Nx
			WRITE(11,*) REAL(u(i,j))
		END DO
	END DO
	CLOSE(11)

	name_config = 'tdata.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,1+Nt
		WRITE(11,*) time(j)
	END DO
	CLOSE(11)

	name_config = 'xcoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO i=1,Nx
		WRITE(11,*) x(i)
	END DO
	CLOSE(11)

	PRINT *,'Saved data'
	DEALLOCATE(kx,x,u,v,&
   			time,vna,fftfx,fftbx,&
   			stat=AllocateStatus)
   	IF (AllocateStatus .ne. 0) STOP

	CALL dfftw_destroy_plan(planbx)
	CALL dfftw_destroy_plan(planfx)
	CALL dfftw_cleanup()
	PRINT *,'Program execution complete'
	END PROGRAM main


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

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

  USE neo_precision

  IMPLICIT NONE

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

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

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

  RETURN
END SUBROUTINE eva2d


      real             function SSINHM (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>>   1998-10-29 SSINHM Krogh  Moved external statement up for mangle.
c>>   1994-10-20 SSINHM Krogh  Changes to use M77CON
c>>   1994-05-22 SSINHM WV Snyder JPL Make SP and DP alike using CHGTYP
c>>   1993-07-21 SSINHM WV Snyder JPL Original code
c
c     Compute SINH(X) - X.
c
c--S replaces "?": ?SINHM
      real             X
      external R1MACH
      real             CUT, R1MACH, E, ROUND, X2
      parameter (CUT = 0.25e0)
      real             SP5, SP4, SP3, SP2, SP1, SQ1
      parameter ( SP5 = .255251817302048E-09)
      parameter ( SP4 = .723809046696880E-07)
      parameter ( SP3 = .109233297700241E-04)
      parameter ( SP2 = .954811583154274E-03)
      parameter ( SP1 = .452867078563929E-01)
      parameter ( SQ1 =-.471329214363072E-02*6.0E0)
      integer M, N
      save M, ROUND
      data M /-1/
c
      if (m .lt. 0) then
         round = r1mach(4)
         if (round .lt. 5.0e-14) then
c           Compute appropriate value of M depending on round-off.
            m = 3
            e = cut/6.0e0
10          if (e .gt. round) then
               m = m + 2
               e = e*cut*cut/(m*(m-1))
               go to 10
            end if
         end if
      end if
c
      if (round .lt. 5.0e-14) then
         n = m
         x2 = x*x
c        We assume m > 1
         ssinhm = 1.0e0 + x2/(n*(n-1))
20       if (n .gt. 5) then
            n = n - 2
            ssinhm = 1.0e0 + ssinhm*x2/(n*(n-1))
            go to 20
         end if
         ssinhm = x * x2 * ssinhm / 6.0e0
         return
      end if
c
c     Use a rational approximation when ABS(X) is less than 1.65,
c     else use the Fortran intrinsic function.
c
      if (x .lt. 1.65e0) then
         x2 = x*x
         ssinhm = ((((((sp5*x2+sp4)*x2+sp3)*x2+sp2)*x2+sp1)*x2+1.0e0)
     *            *x2*x)/(sq1*x2+6.0e0)
      else
         ssinhm = sinh(x) - x
      end if
      return
      end


!	Obtain the frequency distribution of a weighted sum of responses.
!	The weights are integers.
!	maxnw is the array of minimum scores for items.
!	minw is the array of maximum scores for items.
!	numcatobs is the number of observed item categories.
!	weight is the category weights.
!	prob is the vector of observed category probabilities.
!	dist is the probability distribution of the weighted sum.

subroutine distwtsum(maxw,minw,numcatobs,weight,prob,dist)
implicit none
integer,intent(in)::maxw(:),minw(:),numcatobs(:),weight(:)
real(kind=8),intent(in)::prob(:)
real(kind=8),intent(out)::dist(sum(minw):sum(maxw))

!	cat is a category.
!	cat1 is another category.
!	counter provides the probability position.
!	item is an item.
!	nitems is the number of items.
!	top is the maximum value up to item i
integer::cat,cat1,counter,item,nitems,top
!	distnew is the probability distribution for the first i-1 items.
!	distold is the probability distribution for the first i items.

real(kind=8)::distnew(0:sum(maxw)-sum(minw)),distold(0:sum(maxw)-sum(minw))

distnew=0.0_8
dist=0.0_8
distnew(0)=1.0_8

counter=0
top=0
nitems=size(numcatobs)
do item=1,nitems

   if(maxw(item)>minw(item)) then
		distold(0:top)=distnew(0:top)
		distnew(0:top+maxw(item)-minw(item))=0.0_8
		do cat=0,top
			do cat1=1,numcatobs(item)
				distnew(cat+weight(counter+cat1)-minw(item))=distnew(cat+weight(counter+cat1)-minw(item))+distold(cat)*prob(counter+cat1)
			end do
		end do
		top=top+maxw(item)-minw(item)
	end if
	counter=counter+numcatobs(item)
end do
dist(sum(minw):sum(maxw))=distnew

return

end subroutine distwtsum


      FUNCTION julday(mm,id,iyyy)
      INTEGER julday,id,iyyy,mm,IGREG
      PARAMETER (IGREG=15+31*(10+12*1582))
      INTEGER ja,jm,jy
      jy=iyyy
      if (jy.eq.0) pause 'julday: there is no year zero'
      if (jy.lt.0) jy=jy+1
      if (mm.gt.2) then
        jm=mm+1
      else
        jy=jy-1
        jm=mm+13
      endif
      julday=int(365.25*jy)+int(30.6001*jm)+id+1720995
      if (id+31*(mm+12*iyyy).ge.IGREG) then
        ja=int(0.01*jy)
        julday=julday+2-ja+int(0.25*ja)
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/julday.for


      FUNCTION SETSTVEL(D,SSG)
      REAL::SETSTVEL,VISC,GP,SSG,GPD,D,SQGPD,RD,WSET,TMP
C CHANGE RECORD
C
C
C **  NONCOHEASIVE SEDIMENT SETTLING AND SHIELDS CRITERIA
C **  USING VAN RIJN'S EQUATIONS
C
      VISC=1.E-6
      GP=(SSG-1.)*9.82
      GPD=GP*D
      SQGPD=SQRT(GPD)
      RD=SQGPD*D/VISC
C
C **  SETTLING VELOCITY
C
      IF(D.LT.1.0E-4)THEN
        WSET=SQGPD*RD/18.
      ENDIF
      IF(D.GE.1.0E-4.AND.D.LT.1.E-3)THEN
        TMP=SQRT(1.+0.01*RD*RD)-1.
        WSET=10.0*SQGPD*TMP/RD
      ENDIF
      IF(D.GE.1.E-3)THEN
        WSET=1.1*SQGPD
      ENDIF
      SETSTVEL=WSET
      RETURN
      END


      function W4(Z)
c******************************************************************************
c     This routine calculates the complex voigt function using the
c     algorithm of Humlicek 1982.
c******************************************************************************

      COMPLEX W4,Z, T, U
c      REAL*8 X, Y, S
c      z = cmplx(x, y)
      X=REAL(Z)
      Y=AIMAG(Z)
      T=CMPLX(Y,-X)
      S=ABS(X)+Y
      IF (S.LT.15.) GOTO 1
C********  REGION 1
c      write (*,*) "Region 1"
c      write (*,*) Z, X, Y, T
      W4=T*.5641896/(.5+T*T)
      RETURN
1     IF(S.LT.5.5)GOTO 2
C********  REGION 2
c      write (*,*) "Region 2"
      U=T*T
      W4=T*(1.410474+U*.5641896)/(.75+U*(3.+U))
      RETURN
2     IF(Y.LT..195*ABS(X)-.176)GOTO 3
C********  REGION 3
c      write (*,*) "Region 3"
      W4=(16.4955+T*(20.20933+T*(11.96482+T*(3.778987+T*.5642236))))/
     /(16.4955+T*(38.82363+T*(39.27121+T*(21.69274+T*(6.699398+T)))))
      RETURN
C********  REGION 4
3     U=T*T
c      write (*,*) "Region 4"
      W4=CEXP(U)-T*(36183.31-U*(3321.9905-U*(1540.787-U*(219.0313-U*
     *(35.76683-U*(1.320522-U*.56419))))))/(32066.6-U*(24322.84-U*
     *(9022.228-U*(2186.181-U*(364.2191-U*(61.57037-U*(1.841439-U)))))))

      RETURN

      END


!----------------------------------------------------------------------------- best with 100 columns

!> edge-based finite element discretizations
module modEdgeFEM
  public

  integer,parameter,private::DIMS=3

contains

  !> find cell-average curl of vp
  subroutine findCellCurl(grid,vp,rst)
    use modPolyEdgeFeGrid
    use modPolyGrid
    use modSMQ
    class(polyEdgeFeGrid),intent(inout)::grid !< the grid
    double precision,intent(in)::vp(grid%nEdge) !< vector potential
    double precision,allocatable,intent(inout)::rst(:,:) !< curl of vp at cells
    double precision::gradNa(DIMS),gradNb(DIMS),curlNj(DIMS)

    call grid%up()
    if(.not.allocated(rst))then
      allocate(rst(DIMS,grid%nC))
    end if
    rst(:,:)=0d0
    do i=1,grid%nC
      select case(grid%sE(i))
      case(TET)
        do j=1,TET_N_EDGE
          l=1 ! only 1 quadrature point for TET
          gradNa=matmul(grid%invJ(:,:,l,i),TET_GRAD_QP(:,TET_NI_EDGE(1,j),l))
          gradNb=matmul(grid%invJ(:,:,l,i),TET_GRAD_QP(:,TET_NI_EDGE(2,j),l))
          curlNj(1)=2*(gradNa(2)*gradNb(3)-gradNa(3)*gradNb(2))
          curlNj(2)=2*(gradNa(3)*gradNb(1)-gradNa(1)*gradNb(3))
          curlNj(3)=2*(gradNa(1)*gradNb(2)-gradNa(2)*gradNb(1))
          curlNj=curlNj*merge(1,-1,grid%sameDir(j,i))
          rst(:,i)=rst(:,i)+curlNj*vp(grid%iEdgeE(j,i))
        end do
      case default
      end select
    end do
  end subroutine

  !> find curl of curl operator
  !> NOTE: A must be pre-initialized to contain the temporary CSR matrix with duplications
  subroutine findCurlCurl(grid,A,isInactive)
    use modPolyEdgeFeGrid
    use modPolyGrid
    use modSMQ
    use modSparse
    class(polyEdgeFeGrid),intent(inout)::grid !< the grid
    class(linEq),intent(inout)::A !< the discretized linear system
    logical,intent(in),optional::isInactive(grid%nEdge) !< whether inactive (gauged and Dirichlet)
    integer::nnz,maxNNZ
    integer,allocatable::iA(:),jA(:)
    double precision,allocatable::vA(:)
    double precision::curlNj(DIMS),curlNk(DIMS),gradNa(DIMS),gradNb(DIMS)

    call grid%up()
    maxNNZ=size(grid%iEdgeE,1)**2*grid%nC
    allocate(iA(maxNNZ)) ! COO temporary matrix
    allocate(jA(maxNNZ))
    allocate(vA(maxNNZ))
    nnz=0
    do i=1,grid%nC
      select case(grid%sE(i))
      case(TET)
        do j=1,TET_N_EDGE
          if(present(isInactive))then
            if(isInactive(grid%iEdgeE(j,i)))then
              cycle
            end if
          end if
          do k=1,TET_N_EDGE
            nnz=nnz+1
            iA(nnz)=grid%iEdgeE(j,i)
            jA(nnz)=grid%iEdgeE(k,i)
            vA(nnz)=0d0
            do l=1,size(TET_QW)
              gradNa=matmul(grid%invJ(:,:,l,i),TET_GRAD_QP(:,TET_NI_EDGE(1,j),l))
              gradNb=matmul(grid%invJ(:,:,l,i),TET_GRAD_QP(:,TET_NI_EDGE(2,j),l))
              curlNj(1)=2*(gradNa(2)*gradNb(3)-gradNa(3)*gradNb(2))
              curlNj(2)=2*(gradNa(3)*gradNb(1)-gradNa(1)*gradNb(3))
              curlNj(3)=2*(gradNa(1)*gradNb(2)-gradNa(2)*gradNb(1))
              curlNj=curlNj*merge(1,-1,grid%sameDir(j,i))
              gradNa=matmul(grid%invJ(:,:,l,i),TET_GRAD_QP(:,TET_NI_EDGE(1,k),l))
              gradNb=matmul(grid%invJ(:,:,l,i),TET_GRAD_QP(:,TET_NI_EDGE(2,k),l))
              curlNk(1)=2*(gradNa(2)*gradNb(3)-gradNa(3)*gradNb(2))
              curlNk(2)=2*(gradNa(3)*gradNb(1)-gradNa(1)*gradNb(3))
              curlNk(3)=2*(gradNa(1)*gradNb(2)-gradNa(2)*gradNb(1))
              curlNk=curlNk*merge(1,-1,grid%sameDir(k,i))
              vA(nnz)=vA(nnz)+dot_product(curlNj,curlNk)*grid%detJ(l,i)*TET_QW(l)
            end do
          end do
        end do
      case default
      end select
    end do
    if(present(isInactive))then
      do i=1,grid%nEdge
        if(isInactive(i))then
          nnz=nnz+1
          iA(nnz)=i
          jA(nnz)=i
          vA(nnz)=1d0
        end if
      end do
    end if
    call A%setCOO(iA,jA,vA,nnz,job=CSR_CLEAN_SORT)
    deallocate(iA,jA,vA)
  end subroutine

  !> find volumetric source discretization of cell vector v
  subroutine findVolVectSrc(grid,v,rst)
    use modPolyEdgeFeGrid
    use modPolyGrid
    use modSMQ
    class(polyEdgeFeGrid),intent(inout)::grid !< the grid
    double precision,intent(in)::v(DIMS,grid%nC) !< vector in cell (source density)
    double precision,allocatable,intent(inout)::rst(:) !< source discretization on edge
    double precision::Na,Nb,gradNa(DIMS),gradNb(DIMS),Ne(DIMS)

    call grid%up()
    if(.not.allocated(rst))then
      allocate(rst(grid%nEdge))
    end if
    rst(:)=0d0
    do i=1,grid%nC
      select case(grid%sE(i))
      case(TET)
        do j=1,TET_N_EDGE
          do l=1,size(TET_QW)
            gradNa=matmul(grid%invJ(:,:,l,i),TET_GRAD_QP(:,TET_NI_EDGE(1,j),l))
            gradNb=matmul(grid%invJ(:,:,l,i),TET_GRAD_QP(:,TET_NI_EDGE(2,j),l))
            Na=TET_SHAPE_QP(TET_NI_EDGE(1,j),l)
            Nb=TET_SHAPE_QP(TET_NI_EDGE(2,j),l)
            Ne=(Na*gradNb-Nb*gradNa)*merge(1,-1,grid%sameDir(j,i))
            rst(grid%iEdgeE(j,i))=rst(grid%iEdgeE(j,i))&
            &                     +dot_product(Ne,v(:,i))*grid%detJ(l,i)*TET_QW(l)
          end do
        end do
      case default
      end select
    end do
  end subroutine

end module


use plantfem
implicit none

type(IO_) :: f
type(Math_) :: math
type(Random_) :: random
complex(complex64),allocatable :: t(:), Ft(:),Fw(:),Fw_bar(:),Ft_(:),omega(:)
real(real64) :: domega, n
integer(int32) :: i

! Time
t = linspace([0.0d0, 10.0d0],1024)

! Frequency
omega = linspace([0.0d0, 1024.0d0/10.0d0],1024)

Ft = zeros(1024)
!Ft(:) = 1.0d0/2.0d0/Math%PI*domega*(sin( (2.0d0*n + 1)/2.0d0*domega*t ) )/( sin( 1.0d0/2.0d0*domega*t  ))
do i=1,size(Ft)
    Ft(i) = random%gauss(mu=0.0d0,sigma=0.50d0)
enddo
Ft(:) = Ft(:)+5.0d0*sin(2.0d0*Math%PI*t)

Fw = FFT(Ft)

Fw( 516-400:516+400 )=0.0d0

Ft_ = IFFT(Fw)

Fw_bar = Fw
Fw_bar = Fw*Fw

call f%open("Fw.txt","w")
!call f%write(real(t), real(Fw) )
call f%write(real(omega(1:size(t)/2 ) ), real(Fw(1:size(t)/2) ) )
call f%close()

call f%open("Ft.txt","w")
!call f%write(real(t), real(Fw) )
call f%write(real(t), real(Ft) )
call f%close()

call f%open("Ft_.txt","w")
!call f%write(real(t), real(Fw) )
call f%write(real(t), real(Ft_) )
call f%close()

call f%plot("Ft.txt","w l")
call f%plot("Fw.txt","w l")
call f%plot("Ft_.txt","w l")
end


module constants
implicit none

   real, parameter :: pi = 3.1415926536
   real, parameter :: e = 2.7182818285

contains
   subroutine show_consts()
      print*, "Pi = ", pi
      print*,  "e = ", e
   end subroutine show_consts

end module constants


module sum
 contains
	subroutine fortransum(input_array, tsize, result_out) bind(C,name='fortransum')

		integer :: tsize
		integer :: result_out
		integer, dimension(tsize) :: input_array
		result_out = 0
		do i = 1,tsize
			result_out = result_out + input_array(i)
		end do
	end subroutine fortransum

end module sum

! program sum
! 	integer, dimension(size) :: a

! 	integer :: total

! 	do i = 1, size
! 		a(i) = i-1
! 	end do
! 	total = 0
! 	do i = 1, size
! 		total = total + a(i)
! 	end do
! 	a = total

! 	print *, "values: ", size
! 	print *, "total: ", total
! end program sum


! Related to PR 15326.  Try calling string functions whose lengths involve
! some sort of array calculation.
! { dg-do run }
pure elemental function double (x)
  integer, intent (in) :: x
  integer :: double
  double = x * 2
end function double

program main
  implicit none

  interface
    pure elemental function double (x)
      integer, intent (in) :: x
      integer :: double
    end function double
  end interface

  integer, dimension (100:104), target :: a
  integer, dimension (:), pointer :: ap
  integer :: i, lower

  a = (/ (i + 5, i = 0, 4) /)
  ap => a
  lower = 11

  call test (f1 (a), 35)
  call test (f1 (ap), 35)
  call test (f1 ((/ 5, 10, 50 /)), 65)
  call test (f1 (a (101:103)), 21)

  call test (f2 (a), 115)
  call test (f2 (ap), 115)
  call test (f2 ((/ 5, 10, 50 /)), 119)
  call test (f2 (a (101:103)), 116)

  call test (f3 (a), 60)
  call test (f3 (ap), 60)
  call test (f3 ((/ 5, 10, 50 /)), 120)
  call test (f3 (a (101:103)), 30)

  call test (f4 (a, 13, 1), 21)
  call test (f4 (ap, 13, 2), 14)
  call test (f4 ((/ 5, 10, 50 /), 12, 1), 60)
  call test (f4 (a (101:103), 12, 1), 15)
contains
  function f1 (array)
    integer, dimension (10:) :: array
    character (len = sum (array)) :: f1
    f1 = ''
  end function f1

  function f2 (array)
    integer, dimension (10:) :: array
    character (len = array (11) + a (104) + 100) :: f2
    f2 = ''
  end function f2

  function f3 (array)
    integer, dimension (:) :: array
    character (len = sum (double (array (2:)))) :: f3
    f3 = ''
  end function f3

  function f4 (array, upper, stride)
    integer, dimension (10:) :: array
    integer :: upper, stride
    character (len = sum (array (lower:upper:stride))) :: f4
    f4 = ''
  end function f4

  subroutine test (string, length)
    character (len = *) :: string
    integer, intent (in) :: length
    if (len (string) .ne. length) call abort
  end subroutine test
end program main


module matrix_utils

  use iso_fortran_env, only : dp => REAL64

contains

  !===================================================================!
  ! Setup Toepliz matrix with supplied columns
  !===================================================================!

  subroutine toepliz(col, A)

    real(dp), allocatable :: A(:,:)
    real(dp) :: col(:)
    integer :: m, i, j

    m = size(A, 1)
    do j = 1, m
       do i = 1, m
          if (i.eq.j) then
             A(i,j) = col(1)
          else if (i+1.eq.j .or.i-1.eq.j) then
             A(i,j) = col(2)
             A(j,i) = col(2)
          else if (i+2.eq.j .or.i-2.eq.j) then
             A(i,j) = col(3)
             A(j,i) = col(3)
          else if (i+3.eq.j .or.i-3.eq.j) then
             A(i,j) = col(4)
             A(j,i) = col(4)
          else if (i+4.eq.j .or.i-4.eq.j) then
             A(i,j) = col(5)
             A(j,i) = col(5)
          end if
       end do
    end do

  end subroutine toepliz

  subroutine print(matrix)

    real(dp), intent(in) :: matrix(:,:)
    integer :: i, j, m, n

    m = size(matrix, 1)
    n = size(matrix, 2)

    do i = 1, m
       write(*,'(100g15.5)') ( matrix(i,j), j=1,n )
    end do
  end subroutine print

end module matrix_utils


program main

   implicit none

   real, allocatable, dimension(:) :: x
   integer :: rnd_nseed, n
   integer, allocatable, dimension(:) :: rnd_seed

   print *, 'Enter number of elements'
   read *, n

   allocate (x(n))

   call random_seed(size=rnd_nseed)
   print *, 'Random Seed (n)    : ', rnd_nseed
   allocate(rnd_seed(rnd_nseed))
   call random_seed(get=rnd_seed)
   print *, 'Random Seed (array): ', rnd_seed

   call random_number(x)

   print *, 'Number of elements :', size(x)
   print *, 'Sum of values in array : ', sum(x)
   print *, 'Average : ', sum(x)/size(x)

   deallocate (x)

   stop

end program


! Check we do the right thing with extreme values.
! From PR12704
program intrinsic_mmloc_3
  integer, dimension(2) :: d
  integer, dimension(2,2) :: a
  logical, dimension(2) :: k
  logical, dimension(2,2) :: l

  k = .true.
  l = .true.

  d = -huge (d)
  if (maxloc (d, 1) .ne. 1) call abort ()

  d = huge (d)
  if (minloc (d, 1) .ne. 1) call abort ()

  d = -huge (d)
  if (maxloc (d, 1, k) .ne. 1) call abort ()

  d = huge (d)
  if (minloc (d, 1, k) .ne. 1) call abort ()

  a = -huge (a)
  d = maxloc (a)
  if (any (d .ne. 1)) call abort ()

  a = huge (a)
  d = minloc (a)
  if (any (d .ne. 1)) call abort ()

  a = -huge (a)
  d = maxloc (a, l)
  if (any (d .ne. 1)) call abort ()

  a = huge (a)
  d = minloc (a, l)
  if (any (d .ne. 1)) call abort ()

end program


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% main.f %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

! Code converted using TO_F90 by Alan Miller
! Date: 2002-11-09  Time: 22:01:17

PROGRAM Test_uobyqa
!     The Chebyquad test problem (Fletcher, 1965) for N = 2,4,6,8.

USE Powell_Optimize
IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

REAL (dp)  :: rhobeg, rhoend, x(10)
INTEGER    :: i, iprint, maxfun, n

iprint=2
maxfun=5000
rhoend=1.0D-8
DO  n=2,8,2
  DO  i=1,n
    x(i)=REAL(i)/REAL(n+1)
  END DO
  rhobeg=0.2D0*x(1)
  WRITE(*, 20) n
  20 FORMAT (//t6, '******************'/ t6, 'Results with N =', i2 / t6, '******************')
  CALL uobyqa (n, x, rhobeg, rhoend, iprint, maxfun)
END DO
STOP
END PROGRAM Test_uobyqa

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% calfun.f %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

SUBROUTINE calfun(n, x, f)

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

INTEGER, INTENT(IN)     :: n
REAL (dp), INTENT(IN)   :: x(:)
REAL (dp), INTENT(OUT)  :: f

! COMMON a(40,20), b(40,20), e(41)
REAL (dp)  :: sum, y(10,10)
INTEGER    :: i, iw, j, np

DO  j = 1, n
  y(1,j) = 1.0D0
  y(2,j) = 2.0D0 * x(j) - 1.0D0
END DO
DO  i = 2, n
  DO  j = 1, n
    y(i+1,j) = 2.0D0 * y(2,j) * y(i,j) - y(i-1,j)
  END DO
END DO
f = 0.0D0
np = n + 1
iw = 1
DO  i = 1, np
  sum = 0.0D0
  DO  j = 1, n
    sum = sum + y(i,j)
  END DO
  sum = sum / REAL(n)
  IF (iw > 0) sum = sum + 1.0_dp / REAL(i*i - 2*i)
  iw = -iw
  f = f + sum * sum
END DO
RETURN
END SUBROUTINE calfun


subroutine press_calc(m,n,o,p,p0,a,b,orog,ps,temp_ml,press_ml)
implicit none
integer :: m,n,o,p
integer :: x,y,s,t
double precision :: ps(m,n,p),a(o),b(o),p0
double precision ::temp_ml(m,n,o,p),orog(m,n)
double precision, intent(out) :: press_ml(m,n,o,p)
real ::PlanetGrav = 9.80665
real ::PlanetRD = 287.058
real ::height_ml,con
con= PlanetGrav/PlanetRD
do t=1,p
 do s=1,o
  do x=1,m
   do y=1,n
    height_ml =  a(s)  + b(s) * orog (x,y)
    press_ml(x,y,s,t) = ps(m,n,p) * exp(-1*(con/temp_ml(x,y,s,t)*(height_ml&
     - orog(x,y))))
   end do
  end do
 end do
end do
end subroutine press_calc


      subroutine fppocu(idim,k,a,b,ib,db,nb,ie,de,ne,cp,np)
c  subroutine fppocu finds a idim-dimensional polynomial curve p(u) =
c  (p1(u),p2(u),...,pidim(u)) of degree k, satisfying certain derivative
c  constraints at the end points a and b, i.e.
c                  (l)
c    if ib > 0 : pj   (a) = db(idim*l+j), l=0,1,...,ib-1
c                  (l)
c    if ie > 0 : pj   (b) = de(idim*l+j), l=0,1,...,ie-1
c
c  the polynomial curve is returned in its b-spline representation
c  ( coefficients cp(j), j=1,2,...,np )
c  ..
c  ..scalar arguments..
      integer idim,k,ib,nb,ie,ne,np
      real*8 a,b
c  ..array arguments..
      real*8 db(nb),de(ne),cp(np)
c  ..local scalars..
      real*8 ab,aki
      integer i,id,j,jj,l,ll,k1,k2
c  ..local array..
      real*8 work(6,6)
c  ..
      k1 = k+1
      k2 = 2*k1
      ab = b-a
      do 110 id=1,idim
        do 10 j=1,k1
          work(j,1) = 0.
  10    continue
        if(ib.eq.0) go to 50
        l = id
        do 20 i=1,ib
          work(1,i) = db(l)
          l = l+idim
  20    continue
        if(ib.eq.1) go to 50
        ll = ib
        do 40 j=2,ib
          ll =  ll-1
          do 30 i=1,ll
            aki = k1-i
            work(j,i) = ab*work(j-1,i+1)/aki + work(j-1,i)
  30      continue
  40    continue
  50    if(ie.eq.0) go to 90
        l = id
        j = k1
        do 60 i=1,ie
          work(j,i) = de(l)
          l = l+idim
          j = j-1
  60    continue
        if(ie.eq.1) go to 90
        ll = ie
        do 80 jj=2,ie
          ll =  ll-1
          j = k1+1-jj
          do 70 i=1,ll
            aki = k1-i
            work(j,i) = work(j+1,i) - ab*work(j,i+1)/aki
            j = j-1
  70      continue
  80    continue
  90    l = (id-1)*k2
        do 100 j=1,k1
          l = l+1
          cp(l) = work(j,1)
 100    continue
 110  continue
      return
      end


use FEMDomainClass
implicit None

type(FEMDomain_) :: Cube
type(IO_) :: f
real(real64) :: a(3)=0.0d0 ! acceleration
real(real64),allocatable :: some_global_vector(:)

call cube%create(meshtype="Cube3D")
call cube%resize(x=10.0d0)
call cube%resize(y=10.0d0)
call cube%resize(z=10.0d0)

! Mass-Matrix for an Element
call f%open("MassMatrix.txt",'w')
! ElementID=1, Degree of freedom in a node is 3
! 3 unknowns are defined in a node.
call f%write(cube%MassMatrix(ElementID=1, DOF=3))
call f%close()

! Mass-Vector for an Element
! For example, body force N with 3-D space
call f%open("MassVector.txt",'w')
a(3) = -9.80d0
call f%write(cube%MassVector(ElementID=1, DOF=3, Density=1.0d0,Accel=a) )
call f%close()

! Stiffness matrix for an Element
call f%open("StiffnessMatrix.txt",'w')
call f%write(cube%StiffnessMatrix(ElementID=1, E=1000.0d0, v=0.30d0))
call f%close()

! B-matrix (Strain-displacement consistency) for an Element
call f%open("BMatrix.txt",'w')
call f%write(cube%BMatrix(ElementID=1))
call f%close()

! Elastic-Coefficient matrix for an Element
call f%open("DMatrix.txt",'w')
call f%write(cube%DMatrix(E=1000.0d0, v=0.30d0))
call f%close()

! Diffusion matrix for an Element
call f%open("DiffusionMatrix.txt",'w')
call f%write(cube%DiffusionMatrix(ElementID=1,D=1.0d0))
call f%close()

! create sequential vector (0, 1, 2, ...)
some_global_vector = arange(cube%nn())
! Element-wize vector for an Element
! For example, body force N with 3-D space
call f%open("ElementVector.txt",'w')
call f%write(cube%ElementVector(ElementID=1,GlobalVector=some_global_vector,DOF=1))
call f%close()

end


!fortran_free_source

! need a seperate module for these last two functions b/c
! the function F_CC calls both of them, and they cannot be
! in the same module
module pfc1dfuns2
implicit none
contains

!==========================================================================
!function to determine thickness in the pavement at the cell face
FUNCTION F_hp_face(dxin, hin, zin, dxout, hout, zout, b)
implicit none
!INPUTS
REAL :: dxin, dxout  ! size of cells
REAL :: hin, hout    ! thickness at CV center
REAL :: zin, zout    ! elevation at CV center
REAL :: b            ! pavement thickness
REAL :: F_hp_face
!DUMMY
REAL :: head_at_face, Zface !HEAD and ELEVATION at the face
!
head_at_face = ( (hin+zin)*dxin + (hout+zout)*dxout )  &
                        / ( dxin + dxout)
Zface        = ( zin*dxin + zout*dxout ) / ( dxin + dxout)
F_hp_face = MIN ( b, head_at_face - Zface )
END function
!===========================================================================
!function to determine the thickness on the surface at the cell face
FUNCTION F_hs_face(dxin, hin, zin, dxout, hout, zout, b)
implicit none
!INPUTS
REAL :: dxin, dxout  ! size of cells
REAL :: hin, hout    ! thickness at CV center
REAL :: zin, zout    ! elevation at CV center
REAL :: b            ! pavement thickness
REAL :: F_hs_face
!DUMMY
REAL :: head_at_face, Zface !HEAD and ELEVATION at the face
!
head_at_face = ( (hin+zin)*dxin + (hout+zout)*dxout )  &
                        / ( dxin + dxout)
Zface        = ( zin*dxin + zout*dxout ) / ( dxin + dxout)
F_hs_face = MAX ( 0., head_at_face - Zface - b )
END FUNCTION
!=======================================================================

end module pfc1dfuns2


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file shigc.f
c
c     this file contains code and documentation for subroutine shigc
c
c ... files which must be loaded with shigc.f
c
c     sphcom.f, hrfft.f, gaqd.f
c
c     3/6/98
c
c *** shigc is functionally the same as shagci or shsgci.  It
c     it included in spherepack3.0 because legacy codes, using
c     the older version of spherepack call shigc to initialize
c     the saved work space wshigc, for either shagc or shsgc
c
c     subroutine shigc(nlat,nlon,wshigc,lshigc,dwork,ldwork,ierror)
c
c     subroutine shigc initializes the array wshigc which can then
c     be used repeatedly by subroutines shsgc or shagc. it precomputes
c     and stores in wshigc quantities such as gaussian weights,
c     legendre polynomial coefficients, and fft trigonometric tables.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are compu
c            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid poi
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     wshigc an array which must be initialized by subroutine shigc.
c            once initialized, wshigc can be used repeatedly by shsgc
c            or shagc as long as nlat and nlon remain unchanged.  wshigc
c            must not be altered between calls of shsgc or shagc.
c
c     lshigc the dimension of the array wshigc as it appears in the
c            program that calls shsgc or shagc. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshigc must be at least
c
c                  nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
c
C*PL*ERROR* Comment line too long
c     dwork  a double precision work array that does not have to be saved.
c
c     ldwork the dimension of the array dwork as it appears in the
c            program that calls shigc. ldwork must be at least
c
c               nlat*(nlat+4)
c
c     output parameter
c
C*PL*ERROR* Comment line too long
c     wshigc an array which must be initialized before calling shsgc or shagc.
C*PL*ERROR* Comment line too long
c            once initialized, wshigc can be used repeatedly by shsgc or shagc
c            as long as nlat and nlon remain unchanged.  wshigc must not
c            altered between calls of shsgc or shagc
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lshigc
c            = 4  error in the specification of ldwork
c            = 5  failure in gaqd to compute gaussian points
c                 (due to failure in eigenvalue routine)
c
c
c ****************************************************************
      SUBROUTINE DSHIGC(NLAT,NLON,WSHIGC,LSHIGC,DWORK,LDWORK,IERROR)
      DOUBLE PRECISION WSHIGC
c     this subroutine must be called before calling shsgc/shagc with
c     fixed nlat,nlon. it precomputes quantites such as the gaussian
c     points and weights, m=0,m=1 legendre polynomials, recursion
c     recursion coefficients.
      DIMENSION WSHIGC(LSHIGC)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
c     set triangular truncation limit for spherical harmonic basis
      L = MIN0((NLON+2)/2,NLAT)
c     set equator or nearest point (if excluded) pointer
      LATE = (NLAT+MOD(NLAT,2))/2
      L1 = L
      L2 = LATE
      IERROR = 3
c     check permanent work space length
      IF (LSHIGC.LT.NLAT* (2*L2+3*L1-2)+3*L1* (1-L1)/2+NLON+15) RETURN
      IERROR = 4
c     if (lwork.lt.4*nlat*(nlat+2)+2) return
      IF (LDWORK.LT.NLAT* (NLAT+4)) RETURN
      IERROR = 0
c     set pointers
      I1 = 1
      I2 = I1 + NLAT
      I3 = I2 + NLAT*LATE
      I4 = I3 + NLAT*LATE
      I5 = I4 + L* (L-1)/2 + (NLAT-L)* (L-1)
      I6 = I5 + L* (L-1)/2 + (NLAT-L)* (L-1)
      I7 = I6 + L* (L-1)/2 + (NLAT-L)* (L-1)
c     set indices in temp work for double precision gaussian wts and pts
      IDTH = 1
c     idwts = idth+2*nlat
c     iw = idwts+2*nlat
      IDWTS = IDTH + NLAT
      IW = IDWTS + NLAT
      CALL DSHIGC1(NLAT,NLON,L,LATE,WSHIGC(I1),WSHIGC(I2),WSHIGC(I3),
     +            WSHIGC(I4),WSHIGC(I5),WSHIGC(I6),WSHIGC(I7),
     +            DWORK(IDTH),DWORK(IDWTS),DWORK(IW),IERROR)
      IF (IERROR.NE.0) IERROR = 5
      RETURN
      END
      SUBROUTINE DSHIGC1(NLAT,NLON,L,LATE,WTS,P0N,P1N,ABEL,BBEL,CBEL,
     +                   WFFT,DTHETA,DWTS,WORK,IER)
      DOUBLE PRECISION WTS
      DOUBLE PRECISION P0N
      DOUBLE PRECISION P1N
      DOUBLE PRECISION ABEL
      DOUBLE PRECISION BBEL
      DOUBLE PRECISION CBEL
      DOUBLE PRECISION WFFT
      DOUBLE PRECISION FN
      DOUBLE PRECISION FM
      DIMENSION WTS(NLAT),P0N(NLAT,LATE),P1N(NLAT,LATE),ABEL(1),BBEL(1),
     +          CBEL(1),WFFT(1),DTHETA(NLAT),DWTS(NLAT)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION PB,DTHETA,DWTS,WORK(*)
c     compute the nlat  gaussian points and weights, the
c     m=0,1 legendre polys for gaussian points and all n,
c     and the legendre recursion coefficients
c     define index function used in storing
c     arrays for recursion coefficients (functions of (m,n))
c     the index function indx(m,n) is defined so that
c     the pairs (m,n) map to [1,2,...,indx(l-1,l-1)] with no
c     "holes" as m varies from 2 to n and n varies from 2 to l-1.
c     (m=0,1 are set from p0n,p1n for all n)
c     define for 2.le.n.le.l-1
      INDX(M,N) = (N-1)* (N-2)/2 + M - 1
c     define index function for l.le.n.le.nlat
      IMNDX(M,N) = L* (L-1)/2 + (N-L-1)* (L-1) + M - 1
c     preset quantites for fourier transform
      CALL DHRFFTI(NLON,WFFT)
c     compute double precision gaussian points and weights
c     lw = 4*nlat*(nlat+1)+2
      LW = NLAT* (NLAT+2)
      CALL DGAQD(NLAT,DTHETA,DWTS,WORK,LW,IER)
      IF (IER.NE.0) RETURN
c     store gaussian weights single precision to save computation
c     in inner loops in analysis
      DO 100 I = 1,NLAT
          WTS(I) = DWTS(I)
  100 CONTINUE
c     initialize p0n,p1n using double precision dnlfk,dnlft
      DO 101 NP1 = 1,NLAT
          DO 101 I = 1,LATE
              P0N(NP1,I) = 0.0D0
              P1N(NP1,I) = 0.0D0
  101 CONTINUE
c     compute m=n=0 legendre polynomials for all theta(i)
      NP1 = 1
      N = 0
      M = 0
      CALL DDNLFK(M,N,WORK)
      DO 103 I = 1,LATE
          CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
          P0N(1,I) = PB
  103 CONTINUE
c     compute p0n,p1n for all theta(i) when n.gt.0
      DO 104 NP1 = 2,NLAT
          N = NP1 - 1
          M = 0
          CALL DDNLFK(M,N,WORK)
          DO 105 I = 1,LATE
              CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
              P0N(NP1,I) = PB
  105     CONTINUE
c     compute m=1 legendre polynomials for all n and theta(i)
          M = 1
          CALL DDNLFK(M,N,WORK)
          DO 106 I = 1,LATE
              CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
              P1N(NP1,I) = PB
  106     CONTINUE
  104 CONTINUE
c     compute and store swarztrauber recursion coefficients
c     for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel
      DO 107 N = 2,NLAT
          FN = DBLE(N)
          MLIM = MIN0(N,L)
          DO 107 M = 2,MLIM
              FM = DBLE(M)
              IMN = INDX(M,N)
              IF (N.GE.L) IMN = IMNDX(M,N)
              ABEL(IMN) = SQRT(((2*FN+1)* (FM+FN-2)* (FM+FN-3))/
     +                    (((2*FN-3)* (FM+FN-1)* (FM+FN))))
              BBEL(IMN) = SQRT(((2*FN+1)* (FN-FM-1)* (FN-FM))/
     +                    (((2*FN-3)* (FM+FN-1)* (FM+FN))))
              CBEL(IMN) = SQRT(((FN-FM+1)* (FN-FM+2))/
     +                    (((FN+FM-1)* (FN+FM))))
  107 CONTINUE
      RETURN
      END


Module Phys_constants
! Physical and Mathematical constants
! Solar constants
! c.g.s. units
  Real :: Gravity=2.7414e+4 ! cm/s^2 ! Default. Solar surface gravity
  Real, Parameter :: Solar_Gravity = 2.7414e+4 ! Surface gravity (cm/s^2)
! Physical constants
! c.g.s. units
  Real, Parameter :: cc = 2.99792458D10, hh = 6.62618D-27, ee = 1.602189D-12
  Real, Parameter :: mass_el = 9.10953D-28, mass_pr = 1.672648D-24
  Real, Parameter :: bk = 1.38066D-16, Avog=6.022045D23
! Conversion factor: eV to erg (g cm^2 / s^2).
! Note that 1 V = 10^7 (g cm^2)/(C s^2)
  Real, Parameter :: eV_to_cgs = ee
! Mathematical constants
  Real, Parameter :: Pi = 3.14159265389793D0
  Real, Parameter :: SqrtPi = 1.77245390415191650391 ! Sqrt(Pi)
  Real, Parameter :: Piis = 0.56418956659890107D0 ! Inverse of the Sqrt of Pi
End Module Phys_constants


c
c	transformation matrix t5=<phi-90,Y>*<lamda,Z>
c
c	iverse = 1 forward transform
c	       =-1 inverse transform
c
	subroutine t5 (itime,x_in,x_out,iverse)
	real x_in(3),x_out(3),phi,lamda,rmjd,ut
	real temp(3),fracday
	integer*4 itime(2),iverse,iyr,iday
	parameter (pid2=3.1415927/2.0,degrad=3.1415927/180.0)
c
	IYR=itime(1)/1000
	IDAY=itime(1)-IYR*1000
	ut=itime(2)/3600000.0
	fracday=ut/24.0
c
c	RMJD=44238.0+FLOAT(IYR-1980)*365.+
c     &		FLOAT((IYR-1977)/4)+FLOAT(IDAY)
c  rmjd = modified Julian day = time measured in days from 00:00UT November 17, 1858
	rmjd=45.0+float(iyr-1859)*365.0 + (float((iyr-1861)/4)+1.0)
     &		+ float(iday) -1.0 + fracday
c
	factor=(rmjd-46066.0)/365.25
	phi=(78.8+4.283e-2*factor)*degrad
	lamda=(289.1-1.413e-2*factor)*degrad
c
	if (iverse.eq.1) then
	  call rotate_z(lamda,x_in,temp)
	  call rotate_y(phi-pid2,temp,x_out)
	else
	  call rotate_y(iverse*(phi-pid2),x_in,temp)
	  call rotate_z(iverse*lamda,temp,x_out)
	end if
c
	return
	end


!derivmodule.f90 - equations of motion for integrator
module derivmodule

    use kindmodule

    implicit none

    complex(wp) :: mu=1.0              ! Gravitational parameter
    complex(wp) :: mustar=0.0121505856 ! Mass ratio for three body problem

    public :: dkep, dcrtbp, setmu, setmustar, getmu, getmustar
    private :: mu, mustar

contains

    ! Equations of motion for Keplerian dynamics
    subroutine dkep(t, x, xdot)

        use kindmodule
        use mathmodule

        ! DECLARATION
        implicit none

        ! Input/output
        complex(wp),intent(in) :: t
        complex(wp),intent(in),dimension(:) :: x
        complex(wp),intent(out),dimension(:) :: xdot
        ! Local
        complex(wp) :: rmag3

        ! EXECUTION
        xdot(1:3) = x(4:6)

        rmag3 = astnorm(x(1:3))**3
        xdot(4) = -mu*x(1)/rmag3
        xdot(5) = -mu*x(2)/rmag3
        xdot(6) = -mu*x(3)/rmag3

    end subroutine dkep

    ! Equations of motion for CRTBP
    subroutine dcrtbp(t, x, xdot)

        use kindmodule
        use mathmodule

        ! DECLARATION
        implicit none

        ! Input/output
        complex(wp),intent(in) :: t
        complex(wp),intent(in),dimension(:) :: x
        complex(wp),intent(out),dimension(:) :: xdot
        ! Local
        complex(wp),dimension(3) :: r1, r2
        complex(wp) :: r1mag3, r2mag3

        ! EXECUTION
        xdot(1:3) = x(4:6)

        r1(1) = x(1) + mustar
        r1(2) = x(2)
        r1(3) = x(3)

        r2(1) = x(1) - 1 + mustar
        r2(2) = x(2)
        r2(3) = x(3)

        r1mag3 = astnorm(r1)**3
        r2mag3 = astnorm(r2)**3

        xdot(4) = 2*x(5) + x(1) - (1-mustar)*(x(1)+mustar)/r1mag3 - mustar*(x(1)-1+mustar)/r2mag3
        xdot(5) = -2*x(4) + x(2) - (1-mustar)*x(2)/r1mag3 - mustar*x(2)/r2mag3
        xdot(6) = -(1-mustar)*x(3)/r1mag3 - mustar*x(3)/r2mag3

    end subroutine dcrtbp

    ! Sets mass ratio module variable
    subroutine setmustar(mustarin)
        use kindmodule
        implicit none
        complex(wp),intent(in) :: mustarin
        mustar = mustarin
    end subroutine setmustar

    ! Reports mass ratio module variable
    function getmustar()
        use kindmodule
        implicit none
        complex(wp) :: getmustar
        getmustar = mustar
    end function getmustar

    ! Sets gravitational parameter module variable
    subroutine setmu(muin)
        use kindmodule
        implicit none
        complex(wp),intent(in) :: muin
        mu = muin
    end subroutine setmu

    ! Reports gravitational parameter module variable
    function getmu()
        use kindmodule
        implicit none
        complex(wp) :: getmu
        getmu = mu
    end function getmu

end module derivmodule


subroutine apply_2ndbc_solid(x_solid,nsd,nn_solid,ien_sbc,ne_sbc,nen_solid,&
                        ien_solid,ne_solid,solid_bcforce,solid_stress)
!---------------------------------
! Calculate solid surface normal integral for 3-D cases
! 1 find the points on the boundary surface
! 2 use two vector cross to find the norm of the norm of the surface
! 3 take one interial point and take the dot between this vector and norm
!   if dot < 0 it is the outward norm and then normalize the norm
! 4 calculate the area of boundary surface: (1) tet, area of triangle; (2) hex, 2 triangles
! 5 take norm*area and distribute it equaly to the each node

implicit none

real(8) x_solid(nsd,nn_solid)
integer nsd
integer nn_solid
integer ien_sbc(ne_sbc,nen_solid+2)
integer ne_sbc
integer nen_solid
integer ien_solid(ne_solid,nen_solid)
integer ne_solid
real(8) solid_bcforce(nsd,nn_solid)
real(8) solid_stress(nsd*2,nn_solid)
!------------------------------------
integer count
integer ibs
integer ine
integer ntem
integer nos
real(8), allocatable, dimension(:,:) :: x
real(8) p(nsd)
real(8) w
real(8) norm(nsd)
real(8) area
integer isd
integer jsd
real(8) stress_tmp(nsd,nsd)
integer error_id

solid_bcforce(:,:)=0.0d0

if (nen_solid == 4) then
allocate (x(nsd,3))
w=1.0/3.0
end if

if (nen_solid == 8) then
allocate (x(nsd,4))
w=1.0/4.0
end if

do ibs=1,ne_sbc

	ine=ien_sbc(ibs,1)
	count=1
		do nos=1,nen_solid
		ntem=ien_solid(ine,nos)
		if (ien_sbc(ibs,nos+1) == 1) then
		x(1:nsd,count)=x_solid(1:nsd,ntem)
		count=count+1
		else
		p(1:nsd)=x_solid(1:nsd,ntem)
		end if
		end do
		! find the local nodes on the 2nd type BC surface
        if (count .ne. 4) write(*,*) 'Wrong !!!!!',ibs
            if (nen_solid == 4) then
                call outnormal_tet(x,nsd,p,norm,area)
            elseif (nen_solid == 8) then
                call outnormal_hex(x,nsd,p,norm,area)
            endif
		! get the ourward norm

                do nos=1,nen_solid
                ntem=ien_solid(ine,nos)

                if (ien_sbc(ibs,nos+1) == 1 .and. ien_sbc(ibs,nen_solid+2) == -999) then
                stress_tmp(1,1)=solid_stress(1,ntem)
                stress_tmp(2,2)=solid_stress(2,ntem)
                stress_tmp(3,3)=solid_stress(3,ntem)
                stress_tmp(2,3)=solid_stress(4,ntem)
                stress_tmp(3,2)=solid_stress(4,ntem)
                stress_tmp(1,3)=solid_stress(5,ntem)
                stress_tmp(3,1)=solid_stress(5,ntem)
                stress_tmp(1,2)=solid_stress(6,ntem)
                stress_tmp(2,1)=solid_stress(6,ntem)

			do isd=1,nsd
				do jsd=1,nsd
				solid_bcforce(isd,ntem)=solid_bcforce(isd,ntem)+&
				area*stress_tmp(isd,jsd)*norm(jsd)*w
				end do
			end do

		end if
		end do
		! integrate over 2nd BC surface \sigma_{ij} n_{j} w
continue

end do

deallocate(x)

continue
return
end


	SUBROUTINE DP_UNMC  ( idata, kxky, nbits, ref, scale,
     +			      grid, iret )
C************************************************************************
C* DP_UNMC								*
C*									*
C* This subroutine unpacks a grid in the NMC format.  The unpacking	*
C* equation is:								*
C*									*
C*	GRID   =  REF  +  IDATA * SCALE					*
C*									*
C* Each grid point must be packed into 16 bits which can be treated	*
C* as an INTEGER*2 word.  The scaling factor is a multiplier for the	*
C* data.  It must be set to  1 / 2 ** (15-N) where N is the exponent	*
C* with the original NMC grid.  This subroutine assumes there is no	*
C* missing data.							*
C*									*
C* DP_UNMC  ( IDATA, KXKY, NBITS, REF, SCALE, GRID, IRET )		*
C*									*
C* Input parameters:							*
C*	IDATA (KXKY)	INTEGER*2	Packed data			*
C*	KXKY		INTEGER		Number of grid points		*
C*	NBITS		INTEGER		Number of bits			*
C*	REF		REAL		Reference value of grid		*
C*	SCALE		REAL		Scaling factor			*
C*									*
C* Output parameters:							*
C*	GRID (KXKY)	REAL		Grid data			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					-10 = NBITS invalid		*
C*					-12 = invalid scale		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 3/89						*
C* M. desJardins/GSFC	 2/91	Rewrite using INTEGER*2 words		*
C* K. Brill/NMC		 5/91   Added MV_SW42				*
C* S. Jacobs/EAI	 8/92	Added check for ULTRIX machine		*
C* S. Jacobs/EAI	10/93	Added check for ALPHA machine		*
C* T. Piper/GSC		11/98	Updated prolog				*
C* T. Piper/GSC		 3/99	Corrected prolog			*
C* S. Jacobs/NCEP	 2/01	Added check for LINUX machine		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		grid  (*)
	INTEGER*2	idata (*)
C------------------------------------------------------------------------
	iret = 0
C
C*	Check for valid input.
C
	IF  ( nbits .ne. 16 )  THEN
	    iret = -10
	    RETURN
	END IF
	IF  ( scale .eq. 0. )  THEN
	    iret = -12
	    RETURN
	END IF
C
C*	If the machine is a VAX, swap the 16-bit words.
C
	IF ( ( MTMACH .eq. MTVAX  ) .or.
     +	     ( MTMACH .eq. MTIGPH ) .or.
     +	     ( MTMACH .eq. MTALPH ) .or.
     +	     ( MTMACH .eq. MTLNUX ) .or.
     +	     ( MTMACH .eq. MTULTX ) ) THEN
	    nwords = kxky / 2
	    IF ( MOD ( kxky, 2 ) .ne. 0 ) nwords = nwords + 1
	    ier = MV_SW42 ( nwords, idata, idata )
	END IF
C
C*	Loop through all the grid points.
C
	DO  i = 1, kxky
	    grid (i) = ref + idata (i) * scale
	END DO
C*
	RETURN
	END


      subroutine aratio_element_edge(ielmtyp,
     *                               x,y,z,
     *                               id_edge_min, id_edge_max,
     *                               edge_min, edge_max,
     *                               edge_min_edge_max_ratio)
C
C
C #####################################################################
C
C     PURPOSE -
C
C        For a single element finds the ratio:
C                (shortest element edge/longest element edge)
C
C     INPUT ARGUMENTS -
C
C        ielmtyp            : The element type.
C        (x(),y(),z()       : The coordinates of the element.
C
C     OUTPUT ARGUMENTS -
C
C        id_edge_min             : The local edge number of the shortest edge
C        id_edge_max             : The local edge number of the longest edge
C        edge_min                : The length of the longest edge
C        edge_max                : The length of the shortest edge
C        edge_min_edge_max_ratio : The computed edge min to edge max ratio.
C
C     CHANGE HISTORY -
C
C $Log: aratio_element_edge.f,v $
C Revision 2.00  2007/11/05 19:45:46  spchu
C Import to CVS
C
CPVCS
CPVCS       Rev 1.0   20 Jun 2006 18:25:14   gable
CPVCS    Initial revision.
C
C ######################################################################
C
C
      implicit none
C
      include "local_element.h"
C
      real*8 edge_min_edge_max_ratio, dist, edge_min, edge_max
      real*8 x(1000000), y(1000000), z(1000000)
      integer i, i1, i2, ielmtyp
      integer id_edge_min, id_edge_max
C
C ######################################################################
C
C
C   Find min and max edge length. Save the square root calculation
C   until the min/max have been found.
C
      edge_max = -1.e20
      edge_min =  1.e20
      do i=1,nelmnee(ielmtyp)
         i1 = ielmedge1(1,i,ielmtyp)
         i2 = ielmedge1(2,i,ielmtyp)
         dist = (x(i2)-x(i1))**2 +
     1          (y(i2)-y(i1))**2 +
     2          (z(i2)-z(i1))**2

         if(dist .gt. edge_max)then
            edge_max = dist
            id_edge_max = i
         endif
         if(dist .lt. edge_min)then
            edge_min = dist
            id_edge_min = i
         endif
      enddo

      edge_max = sqrt(edge_max)
      edge_min = sqrt(edge_min)
      edge_min_edge_max_ratio = edge_min/edge_max

      return
      end


CNNNNXB----------------------------------------------------------------E
      SUBROUTINE CALVIS(QV,QC,QR,CRAIN,CFRZR,CICEP,CSNOW,TA,PP,VIS)
C$$$  SUBPROGRAM DOCUMENTATION  BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    CALVIS      COMPUTES VISUAL RANGE IN KM FROM GFS
C   PRGMMR: L. D. BURROUGHS  ORG: W/NMC21    DATE: 03-03-09
C
C ABSTRACT: COMPUTES HORIZONTAL VISIBILITY AT THE 1000 HPA LAYER FROM
c   QV, QC, QR, CRAIN, CFRZR, CICEP,CSNOW, AIR TEMP AND PRESSURE.
C
C PROGRAM HISTORY LOG:
C   03-02-03  L. D. BURROUGHS
C
C USAGE:    CALL CALVIS(QV,QC,QR,CRAIN,CFRZR,CICEP,CSNOW,TA,PP,VIS)
C
C   INPUT ARGUMENT LIST:
c      qv      - water vapor mixing ratio (kg/kg)
c      qc      - cloud water mixing ratio (kg/kg)
c      qr      - rain water mixing ratio  (kg/kg)
c      ta      - air temperature          (k)
c      pp      - pressure                 (hPa)
c      crain   - categorical rain         (y=1,n=0)
c      cfrzr   - categorical freezing rain(y=1,n=0)
c      cicep   - categorical ice pellets  (y=1.n=0)
c      csnow   - categorical snow         (y=1,n=0)
c
C
C   OUTPUT ARGUMENT LIST:
C     vis      - visual range in km
C
C   INPUT FILES:
C     NONE
C
C   OUTPUT FILES:
C     NONE
C
C   SUBPROGRAMS CALLED:
C
C     UNIQUE:    - NONE
C
C     LIBRARY:
C       W3LIB    - NONE
C
C       IMSL     - NONE
C
C       SPECIAL  - LOG
C
C REMARKS:
c   If crain and cfrzr = 0 and cicep and csnow = 0; then qc determines
c                  vis alone;
c   if crain or cfrzr =1 and cicep and csnow = 0; then qc and qr deter-
c           mine   vis;
c   if crain or cfrzr =1 and cicep or csnow =1; then qc and a combo of
c           50 percent rain and snow is used to determine vis;
c   if crain or cfrzr =0 and cicep or csnow =1; then qc and qs deter-
c           nine   vis;
C
c   The routine uses the following
c   expressions for extinction coefficient, beta (in km**-1),
c   with C being the mass concentration (in g/m**3):
c
c      cloud water:  beta = 144.7 * C ** (0.8800)
c      rain water:   beta =  2.24 * C ** (0.7500)
c      cloud ice:    beta = 327.8 * C ** (1.0000)
c      snow:         beta = 10.36 * C ** (0.7776)
c
c   These expressions were obtained from the following sources:
c
c      for cloud water: from Kunkel (1984)
c      for rainwater: from M-P dist'n, with No=8e6 m**-4 and
c         rho_w=1000 kg/m**3
c      for cloud ice: assume randomly oriented plates which follow
c         mass-diameter relationship from Rutledge and Hobbs (1983)
c      for snow: from Stallabrass (1985), assuming beta = -ln(.02)/vis
c
c   The extinction coefficient for each water species present is
c   calculated, and then all applicable betas are summed to yield
c   a single beta. Then the following relationship is used to
c   determine visibility (in km), where epsilon is the threshhold
c   of contrast, usually taken to be .02:
c
c      vis = -ln(epsilon)/beta      [found in Kunkel (1984)]
c
c   This procedure was first developed by Stoelinga and Warner, adapted to the
c   eta model postprocessor by Geoff Manikin, and adapted by Larry Burroughs for
c   use with the GFS to replace the statistical open ocean fog and visibility	c   system.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN90
C   MACHINE:  IBM SP
C
C$$$
C
      IMPLICIT none
CNNNNX------------------------------------------------------------------
      SAVE
      REAL rdc, coeflc, coeflp, coeffc, coeffp
      REAL exponlc, exponlp, exponfc, exponfp, rhoice, rhowat

      PARAMETER(RDC=0.34838,COEFLC=144.7,COEFLP=2.24,COEFFC=327.8,
     1          COEFFP=10.36,EXPONLC=0.8800,EXPONLP=0.7500,
     2          EXPONFC=1.0000,EXPONFP=0.7776,RHOICE=916.8,
     3          RHOWAT=997.37)

! Arguments
      REAL qv, qc, qr, crain, cfrzr, cicep, csnow, ta, pp, vis
! Local
      REAL const1, sh, tv, rhoair, qcld, vovermd, concfp
      REAL conclc, conclp, concfc, qprr, qprs, qcldi
      REAL betav
CNNNNX------------------------------------------------------------------
      CONST1=-LOG(0.02)
      SH=QV/(1+QV)
      TV=TA*(1.0+0.608*SH)
      RHOAIR=RDC*PP/TV
C
C        Determine precipitation type and mixing ratio values
C
      IF(CRAIN.EQ.0..AND.CFRZR.EQ.0..AND.CICEP.EQ.0..AND.CSNOW.EQ.0.)
     1   THEN
         QCLD=QC
         VOVERMD=(1.+QV)/RHOAIR+QCLD/RHOWAT
         CONCLC = QCLD/VOVERMD*1000.
         CONCLP = 0.
         CONCFC = 0.
         CONCFP = 0.
      ELSEIF((CRAIN.EQ.1..OR.CFRZR.EQ.1.).AND.CICEP.EQ.0..AND.
     1   CSNOW.EQ.0.)THEN
         QPRR=QR
         QCLD=QC
         VOVERMD=(1.+QV)/RHOAIR+(QPRR+QCLD)/RHOWAT
         CONCLC = QCLD/VOVERMD*1000.
         CONCLP = QPRR/VOVERMD*1000.
         CONCFC = 0.
         CONCFP = 0.
      ELSEIF((CRAIN.EQ.1..OR.CFRZR.EQ.1.).AND.(CICEP.EQ.1..OR.
     1   CSNOW.EQ.1.))THEN
         QPRR=0.5*QR
         QPRS=0.5*QR
         QCLD=0.5*QC
         QCLDI=0.5*QC
         VOVERMD=(1.+QV)/RHOAIR+(QPRR+QCLD)/RHOWAT+(QPRS+QCLDI)/RHOICE
         CONCLC = QCLD/VOVERMD*1000.
         CONCLP = QPRR/VOVERMD*1000.
         CONCFC = QCLDI/VOVERMD*1000.
         CONCFP = QPRS/VOVERMD*1000.
      ELSEIF(CRAIN.EQ.0..AND.CFRZR.EQ.0..AND.(CICEP.EQ.1..OR.
     1   CSNOW.EQ.1.))THEN
         QPRS=QR
         QCLDI=QC
         IF(TA.LE.263.)THEN
            VOVERMD=(1.+QV)/RHOAIR+(QPRS+QCLDI)/RHOICE
            CONCLC = 0.
            CONCLP = 0.
            CONCFC = QCLDI/VOVERMD*1000.
            CONCFP = QPRS/VOVERMD*1000.
         ELSE
            VOVERMD=(1.+QV)/RHOAIR+QCLDI/RHOWAT+QPRS/RHOICE
            CONCLC = QCLDI/VOVERMD*1000.
            CONCLP = 0.
            CONCFC = 0.
            CONCFP = QPRS/VOVERMD*1000.
         ENDIF
      ENDIF
      BETAV=COEFFC*CONCFC**EXPONFC+COEFFP*CONCFP**EXPONFP
     1     +COEFLC*CONCLC**EXPONLC+COEFLP*CONCLP**EXPONLP
     2     +1.E-10
c CHANGED GSM 3-10-00 -->  no point in distinguishing values
c       above 20 km, so make that value the max (prev max was 80)
        VIS=1.E3*MIN(20.,CONST1/BETAV)
C
      RETURN
      END


      SUBROUTINE HLUGPROJ(PHI0, LAMBDA0, PHI, LAMBDA, X, Y)
C
C  Find the projection onto the plane tangent to the globe at
C  (PHI0,LAMBDA0) of the point on the globe (PHI,LAMBDA).
C  The projected point is returned in Cartesian coordinate
C  (X,Y).
C
      DOUBLE PRECISION PHI0, LAMBDA0, PHI, LAMBDA, X, Y
      DOUBLE PRECISION SIN0, COS0, SINP, COSP, SIND, COSD, DENOM
      DOUBLE PRECISION D2R
      PARAMETER (D2R = 0.017453292519943D0)
C
      SIN0 = SIN(D2R*PHI0)
      COS0 = COS(D2R*PHI0)
      SINP = SIN(D2R*PHI)
      COSP = COS(D2R*PHI)
      SIND = SIN(D2R*(LAMBDA-LAMBDA0))
      COSD = COS(D2R*(LAMBDA-LAMBDA0))
      DENOM = SIN0*SINP + COS0*COSP*COSD
      X = (COSP*SIND)/DENOM
      Y = (COS0*SINP - SIN0*COSP*COSD)/DENOM
C
      RETURN
      END


! $UWHPSC/codes/openmp/normalize2.f90

! Example of normalizing a vector using coarse-grain parallelism.

program main

    use omp_lib
    implicit none
    integer, parameter :: n = 1000
    real(kind=8), dimension(n) :: x,y
    real(kind=8) :: norm,norm_thread,ynorm,ynorm_thread
    integer :: nthreads, points_per_thread,thread_num
    integer :: i,istart,iend

    ! Specify number of threads to use:
    nthreads = 1       ! need this value in serial mode
    !$ nthreads = 4
    !$ call omp_set_num_threads(nthreads)
    !$ print "('Using OpenMP with ',i3,' threads')", nthreads

    ! Determine how many points to handle with each thread.
    ! Note that dividing two integers and assigning to an integer will
    ! round down if the result is not an integer.
    ! This, together with the min(...) in the definition of iend below,
    ! insures that all points will get distributed to some thread.
    points_per_thread = (n + nthreads - 1) / nthreads
    print *, "points_per_thread = ",points_per_thread

    ! initialize x:
    do i=1,n
        x(i) = dble(i)  ! convert to double float
        enddo

    norm = 0.d0
    ynorm = 0.d0

    !$omp parallel private(i,norm_thread, &
    !$omp                  istart,iend,thread_num,ynorm_thread)

    thread_num = 0     ! needed in serial mode
    !$ thread_num = omp_get_thread_num()    ! unique for each thread

    ! Determine start and end index for the set of points to be
    ! handled by this thread:
    istart = thread_num * points_per_thread + 1
    iend = min((thread_num+1) * points_per_thread, n)

    !$omp critical
    print 201, thread_num, istart, iend
    !$omp end critical
201 format("Thread ",i2," will take i = ",i6," through i = ",i6)

    norm_thread = 0.d0
    do i=istart,iend
        norm_thread = norm_thread + abs(x(i))
        enddo

    ! update global norm with value from each thread:
    !$omp critical
      norm = norm + norm_thread
      print *, "norm updated to: ",norm
    !$omp end critical

    ! make sure all have updated norm before proceeding:
    !$omp barrier

    ynorm_thread = 0.d0
    do i=istart,iend
        y(i) = x(i) / norm
        ynorm_thread = ynorm_thread + abs(y(i))
        enddo

    ! update global ynorm with value from each thread:
    !$omp critical
      ynorm = ynorm + ynorm_thread
      print *, "ynorm updated to: ",ynorm
    !$omp end critical
    !$omp barrier

    !$omp end parallel

    print *, "norm of x = ",norm, "  n(n+1)/2 = ",n*(n+1)/2
    print *, 'ynorm should be 1.0:   ynorm = ', ynorm

end program main


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
!  Module defining a user generic which resolves to a function returning
!  an array whose size is the SIZE of an array argument.
!
module square
interface square
    function square_s(x)		!"scalar" version
    integer, intent(in) :: x
    integer :: square_s
    end function square_s
    function square_v(x)		!"vector" version
    integer, dimension(:), intent(in) :: x
    integer, dimension(size(x)) :: square_v
    end function square_v
endinterface
integer result(10)
common/result/result
endmodule square

function square_s(x)		!"scalar" version
    integer, intent(in) :: x
    integer :: square_s
    square_s = x * x
end function square_s

function square_v(x)		!"vector" version
    integer, dimension(:), intent(in) :: x
    integer, dimension(size(x)) :: square_v
    square_v = x * x
end function square_v

subroutine test_v(x)
    use square
    implicit none
    integer, dimension(:), intent(in) :: x
    integer, dimension(size(x)) :: gam1
    gam1=square(x)
!    print *, gam1
    result(1:3) = gam1(1:3)
end subroutine test_v

subroutine test_s(x)
    use square
    implicit none
    integer :: x, gam1
    result(4) = square(x)
end subroutine test_s

program test
    interface
	subroutine test_v(x)
	integer, dimension(:), intent(in) :: x
	endsubroutine
    endinterface
    integer, dimension(3) :: inp = (/2,-3,4/)
    integer, dimension(4) :: expect = (/4,9,16,25/)
    integer result(10)
    common/result/result
    call test_v(inp)
    call test_s(-5)
!    print *, result(1:3), result(4)
    call check(result, expect, 4)
end


subroutine check()
    use mpi
    use commondata
    implicit none
    integer :: i, j, k
    real(8) :: error1, error2
    real(8) :: total_error1, total_error2

    error1 = 0.0d0
    error2 = 0.0d0

    do k = 1, nz
        do j = 1, ny
            do i = 1, nx
                error1 = error1 + (u(i,j,k)-up(i,j,k))*(u(i,j,k)-up(i,j,k))+(v(i,j,k)-vp(i,j,k))*(v(i,j,k)-vp(i,j,k))
                error2 = error2 + u(i,j,k)*u(i,j,k)+v(i,j,k)*v(i,j,k) + w(i,j,k)*w(i,j,k)
            enddo
        enddo
    enddo

    up = u
    vp = v
    wp = w

    call MPI_Barrier(comm3d, rc)

    call MPI_ALLreduce(error1, total_error1, 1, MPI_REAL8, MPI_SUM, comm3d, rc)
    call MPI_ALLreduce(error2, total_error2, 1, MPI_REAL8, MPI_SUM, comm3d, rc)

    errorU = sqrt(total_error1)/sqrt(total_error2)

    if (rank3d == 0) then
        write(*,*) itc,' ',errorU
    endif

    return
end subroutine check


SUBROUTINE PreProcessDiffStencilsZ(FineGrid,DiffStencils,GhostGridZ,gamma)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
TYPE (Diff_def), INTENT(OUT) :: DiffStencils
TYPE (Level_def), INTENT(IN) :: FineGrid
INTEGER :: GhostGridZ,STAT
INTEGER :: rank, Nz, order, Nzp, Diff, gamma, i
REAL(KIND=long), DIMENSION(:), ALLOCATABLE :: Stencil
INTEGER, DIMENSION(:), ALLOCATABLE :: idx

! TEMPORARY POINTERS/VARIABLES
Nz = FineGrid%Nz
! Derivatives in z-direction
!    One-sided stencils near free surface.
!    One-side stencils near bottom, and if ghost points
!    are supported then the directional ghost point
!    is included in stencil.
IF (GhostGridZ==0) THEN; Nzp = Nz; ELSE; Nzp = Nz+1; ENDIF
ALLOCATE( DiffStencils%StencilZ(Nzp,2*gamma+1,2),STAT=STAT)
IF (STAT/=0) THEN
	PRINT*,'Error: Could not allocate memory for differentiation stencil (Z).'
	STOP
ENDIF
ALLOCATE( Stencil(2*gamma+1) )
ALLOCATE( idx(2*gamma+1) )
DO i=-gamma,gamma,1
	idx(i+gamma+1) = i
END DO
DO order=1,2
  DO i = 1, Nzp
	IF (i-1<gamma) THEN
		Diff = gamma-i+1
		CALL TaylorFDStencils1DArbitrary(gamma-Diff,gamma+Diff,order,Stencil,FineGrid%z(i+idx+Diff))
	ELSEIF (i>=Nz-gamma+1) THEN
		Diff = i-(Nzp-gamma)
		CALL TaylorFDStencils1DArbitrary(gamma+Diff,gamma-Diff,order,Stencil,FineGrid%z(i+idx-Diff))
	ELSE
		CALL TaylorFDStencils1DArbitrary(gamma,gamma,order,Stencil,FineGrid%z(i+idx))
	ENDIF
	DiffStencils%StencilZ(i,:,order) = Stencil
  END DO
END DO
DEALLOCATE(Stencil,idx)
END SUBROUTINE PreProcessDiffStencilsZ


C
C     MATRIX MULTIPLICATION - VERSION WITH CALL TO SAXPY
C
C     DATA FLOW INTERPROCEDURAL ANALYSIS
C     SUMMARY OF EFFECTS ON A PROCEDURE
C     PARALLELIZATION OF LOOPS INCLUDING CALLS TO PROCEDURE
C
      SUBROUTINE MM(N, A, B, C)
C
      REAL*8 A(N,N), B(N,N), C(N,N), XAUX(0:127)
C
      DO I = 1,N
         DO J = 1,N
            C(I,J) = 0.0
         ENDDO
      ENDDO
C
      DO J = 1,N
         DO K = 1,N
            CALL SAXPY(N, C(1,J), A(1,K), B(K,J))
         ENDDO
      ENDDO
C
      RETURN
      END
C
C     COMPUTATION OF X = X + S*Y
C
C     SUMMARY OF EFFECTS ON A PROCEDURE
C
      SUBROUTINE SAXPY(N, X, Y, S)
C
      INTEGER N
      REAL*8 X(N), Y(N), S
C
      DO 10 I = 1, N
         X(I) = X(I) + S*Y(I)
 10   CONTINUE
C
      END