! { dg-do compile }
! PR fortran/36316
!
! gfortran generated a mismatching tree ("type mismatch in binary expression")
! for array bounds (mixing integer kind=4/kind=8 without fold_convert).
!
MODULE YOMCAIN

IMPLICIT NONE
SAVE

TYPE distributed_vector
REAL, pointer :: local(:)
INTEGER(4)       :: global_length,local_start
INTEGER(8)       :: local_end
END TYPE distributed_vector

INTERFACE ASSIGNMENT (=)
MODULE PROCEDURE assign_ar_dv
END INTERFACE

INTERFACE OPERATOR (*)
MODULE PROCEDURE multiply_dv_dv
END INTERFACE

CONTAINS

SUBROUTINE assign_ar_dv (handle,pvec)

!         copy array to the distributed_vector

REAL,                      INTENT(IN)    :: pvec(:)
TYPE (distributed_vector), INTENT(INOUT) :: handle

handle%local(:) = pvec(:)

RETURN
END SUBROUTINE assign_ar_dv

FUNCTION multiply_dv_dv (handle1,handle2)

!         multiply two distributed_vectors

TYPE (distributed_vector), INTENT(IN) :: handle2
TYPE (distributed_vector), INTENT(IN) :: handle1
REAL :: multiply_dv_dv(handle1%local_start:handle1%local_end)

multiply_dv_dv = handle1%local(:) * handle2%local(:)

RETURN
END FUNCTION multiply_dv_dv

SUBROUTINE CAININAD_SCALE_DISTVEC ()
TYPE (distributed_vector) :: PVAZG
TYPE (distributed_vector) :: ZTEMP
TYPE (distributed_vector) :: SCALP_DV

ZTEMP = PVAZG * SCALP_DV
END SUBROUTINE CAININAD_SCALE_DISTVEC
END MODULE YOMCAIN


subroutine vector_dot_pa(x,y,ndf,nn,nn_local,node_local,z)
! calculate vector dot z=x*y
use mpi_variables
implicit none
include 'mpif.h'

real(8) x(ndf,nn)
real(8) y(ndf,nn)
integer ndf
integer nn
real(8) z
integer nn_local
integer node_local(nn_local)

integer i
real(8) tmp
integer j
integer node

z=0.0d0
tmp=0.0d0
do i=1,nn_local
	node=node_local(i)
	do j=1,ndf
		tmp=tmp+x(j,node)*y(j,node)
	end do
end do
	   z=tmp
!           call mpi_barrier(mpi_comm_world,ierror)
!           call mpi_reduce(tmp,z,1,mpi_double_precision,mpi_sum,0,mpi_comm_world,ierror)
!           call mpi_bcast(z,1,mpi_double_precision,0,mpi_comm_world,ierror)
end subroutine vector_dot_pa


C FILE: SPL_INT.F
C f2py -c -m spl_int  spl_int.f
C import spl_int
C print spl_int.spl_evf.__doc__
      SUBROUTINE SPL_INT(xi,yi,n,k)
C
C     CALCULATE THE CURVATURE
C     Cubic spline representation for arbitary knot spacing.
C
      INTEGER N
      DOUBLE PRECISION x(N),y(N),k(N),u(N-2),v(N-2),xi(N),yi(N)
Cf2py intent(in) xi,yi,n,
Cf2py intent(out) xi,yi,k
Cf2py depend(n) xi,yi,k
      do 100 i=1,N-1
         x(i) = xi(i+1) - xi(i)
         y(i) = (yi(i+1) - yi(i))/x(i)
 100  enddo
c     # Gaussian Elimination
      u(1) = 2 * (x(2) + x(1))
      v(1) = 6 * (y(2) - y(1))
      do 200 i=2,N-2
         u(i) = 2 * (x(i) + x(i+1)) - x(i)**2/u(i-1)
         v(i) = 6 * (y(i+1) - y(i)) - x(i)*v(i-1)/u(i-1)
 200  enddo
c     # Back-substitution
c     Natural spline
      k(N) = 0
      k(1) = 0
      do 300 i=N-2,1,-1
         k(i+1) = (v(i)-x(i+1)*k(i+2)) / u(i)
 300  enddo
      END

      SUBROUTINE SPL_INTf(xi,yi,n,b,k,d)
C
C     CALCULATE THE CURVATURE fast
C     Returns all coefficients for each interval
C
      INTEGER N
      DOUBLE PRECISION xi(N),yi(N)
      DOUBLE PRECISION h(N),dy(N),b(N-1),k(N),d(N-1),u(N-2),v(N-2)
Cf2py intent(in) xi,yi,n
Cf2py intent(out) xi,yi,b,k,d
Cf2py depend(n) xi,yi,k
Cf2py depend(n-1) b,d
      do 100 i=1,N-1
         h(i) = xi(i+1) - xi(i)
         dy(i) = (yi(i+1) - yi(i))/h(i)
 100  enddo
c     # Gaussian Elimination
      u(1) = 2 * (h(2) + h(1))
      v(1) = 6 * (dy(2) - dy(1))
      do 200 i=2,N-2
         u(i) = 2 * (h(i) + h(i+1)) - h(i)**2/u(i-1)
         v(i) = 6 * (dy(i+1) - dy(i)) - h(i)*v(i-1)/u(i-1)
 200  enddo
c     # Back-substitution
      k(N) = 0
      do 300 i=N-2,1,-1
         k(i+1) = (v(i)-h(i+1)*k(i+2))/u(i)
         b(i+1) = -k(i+2)*h(i+1)/6. - k(i+1)*h(i+1)/3 + dy(i+1)
C         b(i+1) = dy(i+1)
         d(i+1) = (k(i+2)-k(i+1))/6/h(i+1)
 300  enddo
      k(1) = 0
c      b(1) = -k(2)*h(1)/6. - k(1)*h(1)/3 + dy(1)/h(1)
      b(1) = dy(1)
      d(1) = (k(2)-k(1))/6/h(1)
C     y'(x) = b + 2cx + 3dx**2
C     b(N) = b(N-1) + k(N-1)*h(N-1) + 3*d(N-1)*h(N-1)**2
      END

      SUBROUTINE SPL_EQ_INT(xi,yi,n,k)
C
C     CALCULATE THE CURVATURE
C     Uniform knot spacing
C
      INTEGER N
      DOUBLE PRECISION x(N),y(N),k(N),u(N-2),v(N-2),xi(N),yi(N)
Cf2py intent(in) xi,yi,n,
Cf2py intent(out) xi,yi,k
Cf2py depend(n) xi,yi,k

      do 100 i=1,N-1
C         x(i) = 1 ! unit grid xi(i+1) - xi(i)
         y(i) = yi(i+1) - yi(i)
 100  enddo
c     # Gaussian Elimination
      u(1) = 4     !2 * (x(2) + x(1))
      v(1) = 6 * (y(2) - y(1))
      do 200 i=2,N-2
         u(i) = 4 - 1. /u(i-1) ! 2 * (x(i) + x(i+1)) - x(i)**2/u(i-1)
         v(i) = 6 * (y(i+1) - y(i)) - v(i-1)/u(i-1)
 200  enddo
c     # Back-substitution
      k(N) = 0
      k(1) = 0
      do 300 i=N-2,1,-1
c         k(i+1) = (v(i)-x(i+1)*k(i+2))/u(i)
         k(i+1) = (v(i)-k(i+2))/u(i)
 300  enddo
      END

      SUBROUTINE SPL_EV(x,y,k,n,xx,nn,yy)
C
C     CALCULATE THE SPLINE for equidistant grid
C
C     must be sorted
      INTEGER N,nn
      DOUBLE PRECISION x(N),y(N),k(N),xx(nn),yy(nn),h,dx
Cf2py intent(in) x,y,n,k
Cf2py intent(out) yy
Cf2py depend(n) x,y,k
Cf2py depend(nn) xx,yy
      m=1
c      write(6,*) xx(m), x(1)
      do 100 i=1,nn
         ! find the left knot x
         do while (x(m) .le. xx(i) .and. m .lt. N)
            m=m+1
         enddo
         m=m-1
         h = x(m+1) - x(m) !x(i+1)-x(i)
         dx = (xx(i)-x(m))
         yy(i) = y(m) + dx* (-k(m+1)*h/6. - k(m)*h/3 + (y(m+1)-y(m))/h
     1                       + dx * (k(m)/2 + dx * (k(m+1)-k(m))/6/h))
c         if (i .lt. 10) write(6,*) m,yy(i),xx(i),k(m),dx
 100  enddo
      END

      SUBROUTINE SPL_EVf(x,y,b,k,d,n,xx,nn,yy)
C
C     CALCULATE THE SPLINE
C
C     must be sorted
      INTEGER N,nn
      DOUBLE PRECISION x(N),y(N),b(N-1),k(N),d(N-1),xx(nn),yy(nn)
      DOUBLE PRECISION dx
Cf2py intent(in) x,y,b,k,d,n,xx,nn
Cf2py intent(out) yy
Cf2py depend(n) x,y,k, b,d
Cf2py depend(nn) xx,yy
      m = 1
c      write(6,*) xx(m), x(1)
      do 100 i=1,nn
         ! find the left knot x
         do while (x(m+1) .lt. xx(i) .and. m .lt. N-1)
            m = m + 1
         enddo
c         m = m - 1
c         h = x(m+1) - x(m) !x(i+1)-x(i)
         dx = xx(i) - x(m)
         yy(i) = y(m) + dx * (b(m) + dx * (k(m)/2 + dx * d(m)))
c         if (i .lt. 10) write(6,*) 'ok',m,yy(i),b(m),
c     1   (y(m+1)-y(m))/h

c         if (i .lt. 10) write(6,*) m,yy(i),xx(i),k(m),dx
 100  enddo
      END

      SUBROUTINE SPL_EQ_EV(x,y,k,n,xx,nn,yy)
C
C     CALCULATE THE SPLINE for equidistant grid
C
C     must be sorted
      INTEGER N,nn
      DOUBLE PRECISION x(N),y(N),k(N),xx(nn),yy(nn),h,dx
Cf2py intent(in) x,y,n,k
Cf2py intent(out) yy
Cf2py depend(n) x,y,k
Cf2py depend(nn) xx,yy
      h = x(2) - x(1) !x(i+1)-x(i)
      do 100 i=1,nn
         dx = (xx(i)/h-i+1)
         yy(i) = y(i) + dx* (-k(i+1)/6. - k(i)/3 + (y(i+1)-y(i)) +
     1                        dx * (k(i)/2 + dx * (k(i+1)-k(i))/6))
 100  enddo
      END
C END FILE SPL_INT.F


function MakeGridPointC(cilm, lmax, lat, longitude, norm, &
                        csphase, dealloc)
!------------------------------------------------------------------------------
!
!   This function will determine the value at a given latitude and
!   longitude corresponding to the given set of complex spherical harmonics.
!   Latitude and Longitude are assumed to be in DEGREES!
!
!   Calling Parameters
!
!       IN
!           cilm        Complex spherical harmonic coefficients, with
!                       dimensions (2, lmax+1, lmax+1).
!           lmax        Maximum degree used in the expansion.
!           lat         latitude (degrees).
!           long        longitude (degrees).
!
!       OPTIONAL (IN)
!           norm        Spherical harmonic normalization:
!                           (1) "geodesy" (default)
!                           (2) Schmidt
!                           (3) unnormalized
!                           (4) orthonormalized
!           csphase     1: Do not include the phase factor of (-1)^m
!                       -1: Apply the phase factor of (-1)^m.
!           dealloc     If (1) Deallocate saved memory in Legendre function
!                       routines. Default (0) is not to deallocate memory.
!
!   Notes:
!       1.  If lmax is greater than the the maximum spherical harmonic
!           degree of the input file, then this file will be ZERO PADDED!
!           (i.e., those degrees after lmax are assumed to be zero).
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS, only: PlmBar, PLegendreA, PlmSchmidt, PlmON, CSPHASE_DEFAULT
    use ftypes

    implicit none

    complex(dp) :: MakeGridPointC
    complex(dp), intent(in):: cilm(:,:,:)
    real(dp), intent(in) :: lat, longitude
    integer, intent(in) :: lmax
    integer, intent(in), optional :: norm, csphase, dealloc
    real(dp) :: pi, x, lon
    complex(dp) :: expand, i_imag
    integer :: index, l, m, l1, m1, lmax_comp, phase, astat(4)
    real(dp), allocatable :: pl(:), cosm(:), sinm(:), onem(:)

    i_imag = cmplx(0.0_dp, 1.0_dp, dp)

    if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax+1 .or. &
            size(cilm(1,1,:)) < lmax+1) then
        print*, "Error --- MakeGridPointC"
        print*, "CILM must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax
        print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), &
                size(cilm(1,1,:))
        stop
    end if

    if (present(norm)) then
        if (norm >4 .or. norm < 1) then
            print*, "Error - MakeGridPointC"
            print*, "Parameter NORM must be 1, 2, 3, or 4"
            stop
        end if
    end if

    if (present(csphase)) then
        if (csphase == -1) then
             phase = -1
        else if (csphase == 1) then
                phase = 1
        else
            print*, "Error --- MakeGridPointC"
            print*, "CSPHASE must be 1 (exclude) or -1 (include)."
            print*, "Input value is ", csphase
            stop
        end if

    else
        phase = CSPHASE_DEFAULT

    end if

    allocate (pl(((lmax+1) * (lmax+2)) / 2), stat = astat(1))
    allocate (cosm(lmax+1), stat = astat(2))
    allocate (sinm(lmax+1), stat = astat(3))
    allocate (onem(lmax+1), stat = astat(4))

    if (sum(abs(astat(1:4))) /= 0) then
        print*, "Error --- MakeGridPointC"
        print*, "Cannot allocate memory for arrays PL, COSM, SINM and ONEM", &
                astat(1), astat(2), astat(3), astat(4)
        stop
    end if

    pi = acos(-1.0_dp)
    x = sin(lat * pi / 180.0_dp)
    lon = longitude * pi / 180.0_dp

    lmax_comp = min(lmax, size(cilm(1,1,:)) - 1)

    if (present(norm)) then
        if (norm == 1) call PlmBar(pl, lmax_comp, x, csphase = phase, &
                                   cnorm = 1)
        if (norm == 2) call PlmSchmidt(pl, lmax_comp, x, csphase = phase, &
                                       cnorm = 1)
        if (norm == 3) call PLegendreA(pl, lmax_comp, x, csphase = phase)
        if (norm == 4) call PlmON(pl, lmax_comp, x, csphase = phase, &
                                  cnorm = 1)

    else
        call PlmBar(pl, lmax_comp, x, csphase = phase, cnorm = 1)

    end if

    expand = cmplx(0.0_dp, 0.0_dp, dp)

    do m = 0, lmax
        m1 = m + 1
        onem(m1) = (-1)**m
    end do

    ! Precompute sines and cosines. Use multiple angle identity to minimize
    ! number of calls to SIN and COS.
    sinm(1) = 0.0_dp
    cosm(1) = 1.0_dp

    if (lmax_comp > 0) then
        sinm(2) = sin(lon)
        cosm(2) = cos(lon)
    end if

    do m = 2, lmax_comp, 1
        m1 = m + 1
        sinm(m1) = 2 * sinm(m) * cosm(2) - sinm(m-1)
        cosm(m1) = 2 * cosm(m) * cosm(2) - cosm(m-1)
    end do

    do l = lmax_comp, 0, -1
        l1 = l + 1
        index = (l+1) * l / 2 + 1
        expand = expand + cilm(1,l1,1) * pl(index)

        do m = 1, l, 1
            m1 = m + 1
            index = index + 1
            expand = expand + pl(index) * &
                ( cosm(m1) * (cilm(1,l1,m1) + cilm(2,l1,m1) * onem(m1)) &
                  + i_imag * sinm(m1) * (cilm(1,l1,m1) - cilm(2,l1,m1) &
                                                         * onem(m1)) )

        end do

    end do

    MakeGridPointC = expand

    ! deallocate memory
    if (present(dealloc)) then
        if (dealloc == 1) then
            if (present(norm)) then
                if (norm == 1) call PlmBar(pl, -1, x, csphase = phase)
                if (norm == 2) call PlmSchmidt(pl, -1, x, csphase = phase)
                if (norm == 4) call PlmON(pl, -1, x, csphase = phase)
            else
                call PlmBar(pl, -1, x, csphase = phase)
            end if
        end if
    end if

    deallocate (pl)
    deallocate (cosm)
    deallocate (sinm)
    deallocate (onem)

end function MakeGridPointC


C NCLFORTSTART
      subroutine polft(n,x,y,w,maxdeg,ndeg,eps,r,ierr
     +                ,work,coef,maxdeg1,lwork,cmsg)
      implicit none
c                                                     ; INPUT
      integer n, maxdeg, maxdeg1, lwork
ccccc double precision x(n), y(n),w(n),work(3*n+3*maxdeg+3),eps
      double precision x(n), y(n),w(n),work(lwork),eps,cmsg
c                                                     ; OUTPUT
      integer ndeg, ierr
      double precision r(n), coef(maxdeg1)
C NCLEND
C                                                     ; LOCAL
      integer i
      double precision c0

      c0 = 0.0
      if (n.gt.maxdeg) then
          call dpolft (n, x,y, w, maxdeg, ndeg, eps, r, ierr
     *                ,work,lwork)
          call dpcoef (maxdeg, c0, coef, work, lwork, maxdeg1)
      else
          do i=1,maxdeg1
             coef(i) = cmsg
          end do
      end if

      return
      end

C NCLFORTSTART
      subroutine polftmsg(n,x,y,w,xmsg,ymsg,maxdeg,ndeg,eps,r,ierr
     +                    ,work,coef,maxdeg1,lwork,cmsg,xx,yy,ww)
      implicit none
c                                                     ; INPUT
      integer n, maxdeg, maxdeg1, lwork
ccccc double precision x(n), y(n),w(n),work(3*n+3*maxdeg+3),eps
      double precision x(n), y(n),w(n),work(lwork),eps
      double precision xmsg,ymsg,cmsg
c                                                     ; temp work
      double precision xx(n), yy(n), ww(n)
c                                                     ; OUTPUT
      integer ndeg, ierr
      double precision r(n), coef(maxdeg1)
C NCLEND
C                                                     ; LOCAL
      integer i, nn
      double precision c0

c xx, yy, ww will hold non-missing values

      nn = 0
      do i=1,n
         if (x(i).ne.xmsg .and. y(i).ne.ymsg) then
             nn = nn+1
             xx(nn) = x(i)
             yy(nn) = y(i)
             ww(nn) = w(i)
         end if
      end do

      c0 = 0.0
      if (nn.gt.maxdeg) then
          call dpolft (nn, xx, yy, ww, maxdeg, ndeg, eps, r, ierr
     *                ,work,lwork)
          call dpcoef (maxdeg, c0, coef, work, lwork, maxdeg1)
      else
          do i=1,maxdeg1
             coef(i) = cmsg
          end do
      end if

      return
      end
c ---------------------- SLATEC ----------------------------------
      SUBROUTINE DPOLFT (N, X, Y, W, MAXDEG, NDEG, EPS, R, IERR, A, LA)
cDJS  SUBROUTINE DPOLFT (N, X, Y, W, MAXDEG, NDEG, EPS, R, IERR, A)
C***BEGIN PROLOGUE  DPOLFT
C***PURPOSE  Fit discrete data in a least squares sense by polynomials
C            in one variable.
C***LIBRARY   SLATEC
C***CATEGORY  K1A1A2
C***TYPE      DOUBLE PRECISION (POLFIT-S, DPOLFT-D)
C***KEYWORDS  CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT
C***AUTHOR  Shampine, L. F., (SNLA)
C           Davenport, S. M., (SNLA)
C           Huddleston, R. E., (SNLL)
C***DESCRIPTION
C
C     Abstract
C
C     Given a collection of points X(I) and a set of values Y(I) which
C     correspond to some function or measurement at each of the X(I),
C     subroutine  DPOLFT  computes the weighted least-squares polynomial
C     fits of all degrees up to some degree either specified by the user
C     or determined by the routine.  The fits thus obtained are in
C     orthogonal polynomial form.  Subroutine  DP1VLU  may then be
C     called to evaluate the fitted polynomials and any of their
C     derivatives at any point.  The subroutine  DPCOEF  may be used to
C     express the polynomial fits as powers of (X-C) for any specified
C     point C.
C
C     The parameters for  DPOLFT  are
C
C     Input -- All TYPE REAL variables are DOUBLE PRECISION
C         N -      the number of data points.  The arrays X, Y and W
C                  must be dimensioned at least  N  (N .GE. 1).
C         X -      array of values of the independent variable.  These
C                  values may appear in any order and need not all be
C                  distinct.
C         Y -      array of corresponding function values.
C         W -      array of positive values to be used as weights.  If
C                  W(1) is negative,  DPOLFT  will set all the weights
C                  to 1.0, which means unweighted least squares error
C                  will be minimized.  To minimize relative error, the
C                  user should set the weights to:  W(I) = 1.0/Y(I)**2,
C                  I = 1,...,N .
C         MAXDEG - maximum degree to be allowed for polynomial fit.
C                  MAXDEG  may be any non-negative integer less than  N.
C                  Note -- MAXDEG  cannot be equal to  N-1  when a
C                  statistical test is to be used for degree selection,
C                  i.e., when input value of  EPS  is negative.
C         EPS -    specifies the criterion to be used in determining
C                  the degree of fit to be computed.
C                  (1)  If  EPS  is input negative,  DPOLFT  chooses the
C                       degree based on a statistical F test of
C                       significance.  One of three possible
C                       significance levels will be used:  .01, .05 or
C                       .10.  If  EPS=-1.0 , the routine will
C                       automatically select one of these levels based
C                       on the number of data points and the maximum
C                       degree to be considered.  If  EPS  is input as
C                       -.01, -.05, or -.10, a significance level of
C                       .01, .05, or .10, respectively, will be used.
C                  (2)  If  EPS  is set to 0.,  DPOLFT  computes the
C                       polynomials of degrees 0 through  MAXDEG .
C                  (3)  If  EPS  is input positive,  EPS  is the RMS
C                       error tolerance which must be satisfied by the
C                       fitted polynomial.  DPOLFT  will increase the
C                       degree of fit until this criterion is met or
C                       until the maximum degree is reached.
C
C     Output -- All TYPE REAL variables are DOUBLE PRECISION
C         NDEG -   degree of the highest degree fit computed.
C         EPS -    RMS error of the polynomial of degree  NDEG .
C         R -      vector of dimension at least NDEG containing values
C                  of the fit of degree  NDEG  at each of the  X(I) .
C                  Except when the statistical test is used, these
C                  values are more accurate than results from subroutine
C                  DP1VLU  normally are.
C         IERR -   error flag with the following possible values.
C             1 -- indicates normal execution, i.e., either
C                  (1)  the input value of  EPS  was negative, and the
C                       computed polynomial fit of degree  NDEG
C                       satisfies the specified F test, or
C                  (2)  the input value of  EPS  was 0., and the fits of
C                       all degrees up to  MAXDEG  are complete, or
C                  (3)  the input value of  EPS  was positive, and the
C                       polynomial of degree  NDEG  satisfies the RMS
C                       error requirement.
C             2 -- invalid input parameter.  At least one of the input
C                  parameters has an illegal value and must be corrected
C                  before  DPOLFT  can proceed.  Valid input results
C                  when the following restrictions are observed
C                       N .GE. 1
C                       0 .LE. MAXDEG .LE. N-1  for  EPS .GE. 0.
C                       0 .LE. MAXDEG .LE. N-2  for  EPS .LT. 0.
C                       W(1)=-1.0  or  W(I) .GT. 0., I=1,...,N .
C             3 -- cannot satisfy the RMS error requirement with a
C                  polynomial of degree no greater than  MAXDEG .  Best
C                  fit found is of degree  MAXDEG .
C             4 -- cannot satisfy the test for significance using
C                  current value of  MAXDEG .  Statistically, the
C                  best fit found is of order  NORD .  (In this case,
C                  NDEG will have one of the values:  MAXDEG-2,
C                  MAXDEG-1, or MAXDEG).  Using a higher value of
C                  MAXDEG  may result in passing the test.
C         A -      work and output array having at least 3N+3MAXDEG+3
C                  locations
C
C     Note - DPOLFT  calculates all fits of degrees up to and including
C            NDEG .  Any or all of these fits can be evaluated or
C            expressed as powers of (X-C) using  DP1VLU  and  DPCOEF
C            after just one call to  DPOLFT .
C
C***REFERENCES  L. F. Shampine, S. M. Davenport and R. E. Huddleston,
C                 Curve fitting by polynomials in one variable, Report
C                 SLA-74-0270, Sandia Laboratories, June 1974.
C***ROUTINES CALLED  DP1VLU, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   740601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900911  Added variable YP to DOUBLE PRECISION declaration.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C   920527  Corrected erroneous statements in DESCRIPTION.  (WRB)
C***END PROLOGUE  DPOLFT
      INTEGER I,IDEGF,IERR,J,JP1,JPAS,K1,K1PJ,K2,K2PJ,K3,K3PI,K4,
     * K4PI,K5,K5PI,KSIG,M,MAXDEG,MOP1,NDEG,NDER,NFAIL
      INTEGER LA
      DOUBLE PRECISION TEMD1,TEMD2
      DOUBLE PRECISION A(LA),DEGF,DEN,EPS,ETST,F,FCRIT,R(N),SIG,SIGJ,
     * SIGJM1,SIGPAS,TEMP,X(N),XM,Y(N),YP(1),W(N),W1,W11
cDJS  DOUBLE PRECISION A(*),DEGF,DEN,EPS,ETST,F,FCRIT,R(*),SIG,SIGJ,
cDJS * SIGJM1,SIGPAS,TEMP,X(*),XM,Y(*),YP,W(*),W1,W11
      DOUBLE PRECISION CO(4,3)
      SAVE CO
      DATA  CO(1,1), CO(2,1), CO(3,1), CO(4,1), CO(1,2), CO(2,2),
     1      CO(3,2), CO(4,2), CO(1,3), CO(2,3), CO(3,3),
     2  CO(4,3)/-13.086850D0,-2.4648165D0,-3.3846535D0,-1.2973162D0,
     3          -3.3381146D0,-1.7812271D0,-3.2578406D0,-1.6589279D0,
     4          -1.6282703D0,-1.3152745D0,-3.2640179D0,-1.9829776D0/
C***FIRST EXECUTABLE STATEMENT  DPOLFT
      M = ABS(N)
      IF (M .EQ. 0) GO TO 30
      IF (MAXDEG .LT. 0) GO TO 30
      A(1) = MAXDEG
      MOP1 = MAXDEG + 1
      IF (M .LT. MOP1) GO TO 30
      IF (EPS .LT. 0.0D0 .AND.  M .EQ. MOP1) GO TO 30
      XM = M
      ETST = EPS*EPS*XM
      IF (W(1) .LT. 0.0D0) GO TO 2
      DO 1 I = 1,M
        IF (W(I) .LE. 0.0D0) GO TO 30
 1      CONTINUE
      GO TO 4
 2    DO 3 I = 1,M
 3      W(I) = 1.0D0
 4    IF (EPS .GE. 0.0D0) GO TO 8
C
C DETERMINE SIGNIFICANCE LEVEL INDEX TO BE USED IN STATISTICAL TEST FOR
C CHOOSING DEGREE OF POLYNOMIAL FIT
C
      IF (EPS .GT. (-.55D0)) GO TO 5
      IDEGF = M - MAXDEG - 1
      KSIG = 1
      IF (IDEGF .LT. 10) KSIG = 2
      IF (IDEGF .LT. 5) KSIG = 3
      GO TO 8
 5    KSIG = 1
      IF (EPS .LT. (-.03D0)) KSIG = 2
      IF (EPS .LT. (-.07D0)) KSIG = 3
C
C INITIALIZE INDEXES AND COEFFICIENTS FOR FITTING
C
 8    K1 = MAXDEG + 1
      K2 = K1 + MAXDEG
      K3 = K2 + MAXDEG + 2
      K4 = K3 + M
      K5 = K4 + M
      DO 9 I = 2,K4
 9      A(I) = 0.0D0
      W11 = 0.0D0
      IF (N .LT. 0) GO TO 11
C
C UNCONSTRAINED CASE
C
      DO 10 I = 1,M
        K4PI = K4 + I
        A(K4PI) = 1.0D0
 10     W11 = W11 + W(I)
      GO TO 13
C
C CONSTRAINED CASE
C
 11   DO 12 I = 1,M
        K4PI = K4 + I
 12     W11 = W11 + W(I)*A(K4PI)**2
C
C COMPUTE FIT OF DEGREE ZERO
C
 13   TEMD1 = 0.0D0
      DO 14 I = 1,M
        K4PI = K4 + I
        TEMD1 = TEMD1 + W(I)*Y(I)*A(K4PI)
 14     CONTINUE
      TEMD1 = TEMD1/W11
      A(K2+1) = TEMD1
      SIGJ = 0.0D0
      DO 15 I = 1,M
        K4PI = K4 + I
        K5PI = K5 + I
        TEMD2 = TEMD1*A(K4PI)
        R(I) = TEMD2
        A(K5PI) = TEMD2 - R(I)
 15     SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2
      J = 0
C
C SEE IF POLYNOMIAL OF DEGREE 0 SATISFIES THE DEGREE SELECTION CRITERION
C
      IF (EPS) 24,26,27
C
C INCREMENT DEGREE
C
 16   J = J + 1
      JP1 = J + 1
      K1PJ = K1 + J
      K2PJ = K2 + J
      SIGJM1 = SIGJ
C
C COMPUTE NEW B COEFFICIENT EXCEPT WHEN J = 1
C
      IF (J .GT. 1) A(K1PJ) = W11/W1
C
C COMPUTE NEW A COEFFICIENT
C
      TEMD1 = 0.0D0
      DO 18 I = 1,M
        K4PI = K4 + I
        TEMD2 = A(K4PI)
        TEMD1 = TEMD1 + X(I)*W(I)*TEMD2*TEMD2
 18     CONTINUE
      A(JP1) = TEMD1/W11
C
C EVALUATE ORTHOGONAL POLYNOMIAL AT DATA POINTS
C
      W1 = W11
      W11 = 0.0D0
      DO 19 I = 1,M
        K3PI = K3 + I
        K4PI = K4 + I
        TEMP = A(K3PI)
        A(K3PI) = A(K4PI)
        A(K4PI) = (X(I)-A(JP1))*A(K3PI) - A(K1PJ)*TEMP
 19     W11 = W11 + W(I)*A(K4PI)**2
C
C GET NEW ORTHOGONAL POLYNOMIAL COEFFICIENT USING PARTIAL DOUBLE
C PRECISION
C
      TEMD1 = 0.0D0
      DO 20 I = 1,M
        K4PI = K4 + I
        K5PI = K5 + I
        TEMD2 = W(I)*((Y(I)-R(I))-A(K5PI))*A(K4PI)
 20     TEMD1 = TEMD1 + TEMD2
      TEMD1 = TEMD1/W11
      A(K2PJ+1) = TEMD1
C
C UPDATE POLYNOMIAL EVALUATIONS AT EACH OF THE DATA POINTS, AND
C ACCUMULATE SUM OF SQUARES OF ERRORS.  THE POLYNOMIAL EVALUATIONS ARE
C COMPUTED AND STORED IN EXTENDED PRECISION.  FOR THE I-TH DATA POINT,
C THE MOST SIGNIFICANT BITS ARE STORED IN  R(I) , AND THE LEAST
C SIGNIFICANT BITS ARE IN  A(K5PI) .
C
      SIGJ = 0.0D0
      DO 21 I = 1,M
        K4PI = K4 + I
        K5PI = K5 + I
        TEMD2 = R(I) + A(K5PI) + TEMD1*A(K4PI)
        R(I) = TEMD2
        A(K5PI) = TEMD2 - R(I)
 21     SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2
C
C SEE IF DEGREE SELECTION CRITERION HAS BEEN SATISFIED OR IF DEGREE
C MAXDEG  HAS BEEN REACHED
C
      IF (EPS) 23,26,27
C
C COMPUTE F STATISTICS  (INPUT EPS .LT. 0.)
C
 23   IF (SIGJ .EQ. 0.0D0) GO TO 29
      DEGF = M - J - 1
      DEN = (CO(4,KSIG)*DEGF + 1.0D0)*DEGF
      FCRIT = (((CO(3,KSIG)*DEGF) + CO(2,KSIG))*DEGF + CO(1,KSIG))/DEN
      FCRIT = FCRIT*FCRIT
      F = (SIGJM1 - SIGJ)*DEGF/SIGJ
      IF (F .LT. FCRIT) GO TO 25
C
C POLYNOMIAL OF DEGREE J SATISFIES F TEST
C
 24   SIGPAS = SIGJ
      JPAS = J
      NFAIL = 0
      IF (MAXDEG .EQ. J) GO TO 32
      GO TO 16
C
C POLYNOMIAL OF DEGREE J FAILS F TEST.  IF THERE HAVE BEEN THREE
C SUCCESSIVE FAILURES, A STATISTICALLY BEST DEGREE HAS BEEN FOUND.
C
 25   NFAIL = NFAIL + 1
      IF (NFAIL .GE. 3) GO TO 29
      IF (MAXDEG .EQ. J) GO TO 32
      GO TO 16
C
C RAISE THE DEGREE IF DEGREE  MAXDEG  HAS NOT YET BEEN REACHED  (INPUT
C EPS = 0.)
C
 26   IF (MAXDEG .EQ. J) GO TO 28
      GO TO 16
C
C SEE IF RMS ERROR CRITERION IS SATISFIED  (INPUT EPS .GT. 0.)
C
 27   IF (SIGJ .LE. ETST) GO TO 28
      IF (MAXDEG .EQ. J) GO TO 31
      GO TO 16
C
C RETURNS
C
 28   IERR = 1
      NDEG = J
      SIG = SIGJ
      GO TO 33
 29   IERR = 1
      NDEG = JPAS
      SIG = SIGPAS
      GO TO 33
 30   IERR = 2
c c c CALL XERMSG ('SLATEC', 'DPOLFT', 'INVALID INPUT PARAMETER.', 2,
c c c+   1)
      GO TO 37
 31   IERR = 3
      NDEG = MAXDEG
      SIG = SIGJ
      GO TO 33
 32   IERR = 4
      NDEG = JPAS
      SIG = SIGPAS
C
 33   A(K3) = NDEG
C
C WHEN STATISTICAL TEST HAS BEEN USED, EVALUATE THE BEST POLYNOMIAL AT
C ALL THE DATA POINTS IF  R  DOES NOT ALREADY CONTAIN THESE VALUES
C
      IF(EPS .GE. 0.0  .OR.  NDEG .EQ. MAXDEG) GO TO 36
      NDER = 0
      DO 35 I = 1,M
        CALL DP1VLU (NDEG,NDER,X(I),R(I),YP,A)
 35     CONTINUE
 36   EPS = SQRT(SIG/XM)
 37   RETURN
      END
c--------------------------------------------------------------
      SUBROUTINE DP1VLU (L, NDER, X, YFIT, YP, A)
C***BEGIN PROLOGUE  DP1VLU
C***PURPOSE  Use the coefficients generated by DPOLFT to evaluate the
C            polynomial fit of degree L, along with the first NDER of
C            its derivatives, at a specified point.
C***LIBRARY   SLATEC
C***CATEGORY  K6
C***TYPE      DOUBLE PRECISION (PVALUE-S, DP1VLU-D)
C***KEYWORDS  CURVE FITTING, LEAST SQUARES, POLYNOMIAL APPROXIMATION
C***AUTHOR  Shampine, L. F., (SNLA)
C           Davenport, S. M., (SNLA)
C***DESCRIPTION
C
C     Abstract
C
C     The subroutine  DP1VLU  uses the coefficients generated by  DPOLFT
C     to evaluate the polynomial fit of degree  L , along with the first
C     NDER  of its derivatives, at a specified point.  Computationally
C     stable recurrence relations are used to perform this task.
C
C     The parameters for  DP1VLU  are
C
C     Input -- ALL TYPE REAL variables are DOUBLE PRECISION
C         L -      the degree of polynomial to be evaluated.  L  may be
C                  any non-negative integer which is less than or equal
C                  to  NDEG , the highest degree polynomial provided
C                  by  DPOLFT .
C         NDER -   the number of derivatives to be evaluated.  NDER
C                  may be 0 or any positive value.  If NDER is less
C                  than 0, it will be treated as 0.
C         X -      the argument at which the polynomial and its
C                  derivatives are to be evaluated.
C         A -      work and output array containing values from last
C                  call to  DPOLFT .
C
C     Output -- ALL TYPE REAL variables are DOUBLE PRECISION
C         YFIT -   value of the fitting polynomial of degree  L  at  X
C         YP -     array containing the first through  NDER  derivatives
C                  of the polynomial of degree  L .  YP  must be
C                  dimensioned at least  NDER  in the calling program.
C
C***REFERENCES  L. F. Shampine, S. M. Davenport and R. E. Huddleston,
C                 Curve fitting by polynomials in one variable, Report
C                 SLA-74-0270, Sandia Laboratories, June 1974.
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   740601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DP1VLU
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER I,IC,ILO,IN,INP1,IUP,K1,K1I,K2,K3,K3P1,K3PN,K4,K4P1,K4PN,
     * KC,L,LM1,LP1,MAXORD,N,NDER,NDO,NDP1,NORD
cDJS  DOUBLE PRECISION A(*),CC,DIF,VAL,X,YFIT,YP(*)
      DOUBLE PRECISION A(*),CC,DIF,VAL,X,YFIT,YP(1)
      CHARACTER*8 XERN1, XERN2
C***FIRST EXECUTABLE STATEMENT  DP1VLU
      IF (L .LT. 0) GO TO 12
      NDO = MAX(NDER,0)
      NDO = MIN(NDO,L)
      MAXORD = A(1) + 0.5D0
      K1 = MAXORD + 1
      K2 = K1 + MAXORD
      K3 = K2 + MAXORD + 2
      NORD = A(K3) + 0.5D0
      IF (L .GT. NORD) GO TO 11
      K4 = K3 + L + 1
      IF (NDER .LT. 1) GO TO 2
      DO 1 I = 1,NDER
 1      YP(I) = 0.0D0
 2    IF (L .GE. 2) GO TO 4
      IF (L .EQ. 1) GO TO 3
C
C L IS 0
C
      VAL = A(K2+1)
      GO TO 10
C
C L IS 1
C
 3    CC = A(K2+2)
      VAL = A(K2+1) + (X-A(2))*CC
      IF (NDER .GE. 1) YP(1) = CC
      GO TO 10
C
C L IS GREATER THAN 1
C
 4    NDP1 = NDO + 1
      K3P1 = K3 + 1
      K4P1 = K4 + 1
      LP1 = L + 1
      LM1 = L - 1
      ILO = K3 + 3
      IUP = K4 + NDP1
      DO 5 I = ILO,IUP
 5      A(I) = 0.0D0
      DIF = X - A(LP1)
      KC = K2 + LP1
      A(K4P1) = A(KC)
      A(K3P1) = A(KC-1) + DIF*A(K4P1)
      A(K3+2) = A(K4P1)
C
C EVALUATE RECURRENCE RELATIONS FOR FUNCTION VALUE AND DERIVATIVES
C
      DO 9 I = 1,LM1
        IN = L - I
        INP1 = IN + 1
        K1I = K1 + INP1
        IC = K2 + IN
        DIF = X - A(INP1)
        VAL = A(IC) + DIF*A(K3P1) - A(K1I)*A(K4P1)
        IF (NDO .LE. 0) GO TO 8
        DO 6 N = 1,NDO
          K3PN = K3P1 + N
          K4PN = K4P1 + N
 6        YP(N) = DIF*A(K3PN) + N*A(K3PN-1) - A(K1I)*A(K4PN)
C
C SAVE VALUES NEEDED FOR NEXT EVALUATION OF RECURRENCE RELATIONS
C
        DO 7 N = 1,NDO
          K3PN = K3P1 + N
          K4PN = K4P1 + N
          A(K4PN) = A(K3PN)
 7        A(K3PN) = YP(N)
 8      A(K4P1) = A(K3P1)
 9      A(K3P1) = VAL
C
C NORMAL RETURN OR ABORT DUE TO ERROR
C
 10   YFIT = VAL
      RETURN
C
   11 WRITE (XERN1, '(I8)') L
      WRITE (XERN2, '(I8)') NORD
ccccc CALL XERMSG ('SLATEC', 'DP1VLU',
ccccc*   'THE ORDER OF POLYNOMIAL EVALUATION, L = ' // XERN1 //
ccccc*   ' REQUESTED EXCEEDS THE HIGHEST ORDER FIT, NORD = ' // XERN2 //
ccccc*   ', COMPUTED BY DPOLFT -- EXECUTION TERMINATED.', 8, 2)
      RETURN
C
   12 continue
cc 12 CALL XERMSG ('SLATEC', 'DP1VLU',
cc   +   'INVALID INPUT PARAMETER.  ORDER OF POLYNOMIAL EVALUATION ' //
cc   +   'REQUESTED IS NEGATIVE.', 2, 2)
      RETURN
      END
C--------------------------------------------------------------------------
cDJS  SUBROUTINE DPCOEF (L, C, TC, A)
      SUBROUTINE DPCOEF (L, C, TC, A, LA, LTC)
C***BEGIN PROLOGUE  DPCOEF
C***PURPOSE  Convert the DPOLFT coefficients to Taylor series form.
C***LIBRARY   SLATEC
C***CATEGORY  K1A1A2
C***TYPE      DOUBLE PRECISION (PCOEF-S, DPCOEF-D)
C***KEYWORDS  CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT
C***AUTHOR  Shampine, L. F., (SNLA)
C           Davenport, S. M., (SNLA)
C***DESCRIPTION
C
C     Abstract
C
C     DPOLFT  computes the least squares polynomial fit of degree  L  as
C     a sum of orthogonal polynomials.  DPCOEF  changes this fit to its
C     Taylor expansion about any point  C , i.e. writes the polynomial
C     as a sum of powers of (X-C).  Taking  C=0.  gives the polynomial
C     in powers of X, but a suitable non-zero  C  often leads to
C     polynomials which are better scaled and more accurately evaluated.
C
C     The parameters for  DPCOEF  are
C
C     INPUT -- All TYPE REAL variables are DOUBLE PRECISION
C         L -      Indicates the degree of polynomial to be changed to
C                  its Taylor expansion.  To obtain the Taylor
C                  coefficients in reverse order, input  L  as the
C                  negative of the degree desired.  The absolute value
C                  of L  must be less than or equal to NDEG, the highest
C                  degree polynomial fitted by  DPOLFT .
C         C -      The point about which the Taylor expansion is to be
C                  made.
C         A -      Work and output array containing values from last
C                  call to  DPOLFT .
C
C     OUTPUT -- All TYPE REAL variables are DOUBLE PRECISION
C         TC -     Vector containing the first LL+1 Taylor coefficients
C                  where LL=ABS(L).  If  L.GT.0 , the coefficients are
C                  in the usual Taylor series order, i.e.
C                    P(X) = TC(1) + TC(2)*(X-C) + ... + TC(N+1)*(X-C)**N
C                  If L .LT. 0, the coefficients are in reverse order,
C                  i.e.
C                    P(X) = TC(1)*(X-C)**N + ... + TC(N)*(X-C) + TC(N+1)
C
C***REFERENCES  L. F. Shampine, S. M. Davenport and R. E. Huddleston,
C                 Curve fitting by polynomials in one variable, Report
C                 SLA-74-0270, Sandia Laboratories, June 1974.
C***ROUTINES CALLED  DP1VLU
C***REVISION HISTORY  (YYMMDD)
C   740601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPCOEF
C
      INTEGER I,L,LL,LLP1,LLP2,NEW,NR
cDJS  DOUBLE PRECISION A(*),C,FAC,SAVE,TC(*)
      DOUBLE PRECISION A(LA),C,FAC,SAVE,TC(LTC)

C***FIRST EXECUTABLE STATEMENT  DPCOEF
      LL = ABS(L)
      LLP1 = LL + 1
      CALL DP1VLU (LL,LL,C,TC(1),TC(2),A)
      IF (LL .LT. 2) GO TO 2
      FAC = 1.0D0
      DO 1 I = 3,LLP1
        FAC = FAC*(I-1)
 1      TC(I) = TC(I)/FAC
 2    IF (L .GE. 0) GO TO 4
      NR = LLP1/2
      LLP2 = LL + 2
      DO 3 I = 1,NR
        SAVE = TC(I)
        NEW = LLP2 - I
        TC(I) = TC(NEW)
 3      TC(NEW) = SAVE
 4    RETURN
      END


program main
    use PreprocessingClass

    type(Preprocessing_)::omega
    type(MPI_)::mpidata
    real(8),allocatable :: nod_coord(:,:)

    call mpidata%start()
    call omega%Init(Default=.true.)  ! Constractor
    call omega%ImportPictureName(Name="debug/scandata/case1GM.png")
    call omega%ImportPictureName(Name="EXAMPLES/green.png")
    call omega%GetPixcelSize(MPIData)

    call omega%SetColor(28,255,255)
    call omega%SetColor(0,255,0)
    call omega%GetPixcelByRGB(MPIData,err=10,onlycoord=.true.)
    call omega%importPixcelAsNode(interval=100)

    call showArray(omega%FEMDomain%Mesh%NodCoord,Name="test.txt")
    call omega%Meshing()
    call mpidata%end()

end program main


    !use crop2mlModules

        IF (latitude < 0) THEN
            IF (sowingDay > sDsa_sh) THEN
                fixPhyll = p * (1 - rp * MIN(sowingDay - sDsa_sh, sDws))
            ELSE
                fixPhyll = p
            END IF
        ELSE
            IF (sowingDay < sDsa_nh) THEN
                fixPhyll = p * (1 - rp * MIN(sowingDay, sDws))
            ELSE
                fixPhyll = p
            END IF
        END IF


*       This program calculate the solution for the
*       diferintial equation:
*       dy/dx=-xy<    y(x=0)=1
*       the solution is : y= exp(-x^2/2)

        ax(Vx,Vy)=-0.5*p*Cd*A*sqrt((Vx**2+Vy**2))*Vx/bm
        ay(Vx,Vy)=-0.5*p*Cd*A*sqrt((Vx**2+Vy**2))*Vy/bm-g

20      write(*,*)'Enter step size (.le.0 to stop )'
        Read(*,*)H
        if(H.LE.0)stop
*        Nstep=5000/H

        write(*,*)'Enter the ball mass Kg'
        Read(*,*)bm
        write(*,*)'Enter the initial velocity Vx,Vy'
        Read(*,*)Vx,Vy
        write(*,*)'Enter the air resistance'
        Read(*,*)p
        write(*,*)'Enter the drag coefficient'
        Read(*,*)Cd
        write(*,*)'Enter the cross section area'
        Read(*,*)A
         Nstep=4
        x=0
        y=0

        do 10 it=0,Nstep-1
        Vxh=h*ax(Vx,Vy)+Vx
        Vyh=h*ay(Vx,Vy)+Vy
        Xh=x+Vx*h-0.5*ax(Vx,Vy)*h**2
        yh=y+Vy*h-0.5*ay(Vx,Vy)*h**2

        Vx=Vxh
        Vy=Vyh

*        Diff=exp(-0.5*(x+H)**2)-y
        Write(*,*)it,VXh,Vyh,Xh,Yh
10      continue
        go to 20
        End


    subroutine phfunc(xo,fsoil,dfsoil,temper)
!   -----------------------------------------
!   This routine calculate pH for a solution at equilibrium with
!   soil PCO2 and carbonate rock. Used to estimate carbonate weathering

    !use constante, only: deltah0, xloak25
    implicit none

    include 'combine_foam.inc'

    salsoil=0.
    prsoil=0.

    call eqcte(temper,salsoil,prsoil,betasoil,ak1soil &
               ,ak2soil,akbsoil,akcsoil)

!   ak25=10**xloak25

!   aksp=ak25*exp(-deltah0/8.314*(1/temper-1/298))
!   aksp=akcsoil
    aksp=-0.38031396+0.0037566543*temper &
         -1.2063922d-5*temper*temper &
         +1.2696055d-8*temper*temper*temper
    if (temper.lt.278.15) then
        aksp=0.004460795   !to maintain aksp constant below 278.15 K
    endif

    Hsoil=xo

    fsoil=2.*aksp*xo*xo*xo*xo/(ak1soil*ak2soil*betasoil*pco2soil) &
          -ak1soil*betasoil*pco2soil*xo &
          -2*ak1soil*ak2soil*betasoil*pco2soil &
          -2.*SO4soil*xo*xo
    dfsoil=2.*4*aksp*xo*xo*xo/(ak1soil*ak2soil*betasoil*pco2soil)- &
           ak1soil*betasoil*pco2soil-4*SO4soil*xo

    return
    end


      subroutine growthrate(timestep,t,p,ph2o,psat,seq,r,Cste)

!     Legacy Mars GCM v24
!     Mars Climate Modeling Center
!     NASA Ames Research Center

      use constants_h, only: PI

      IMPLICIT NONE

c=======================================================================
c
c     Determination of the water ice crystal growth rate
c
c=======================================================================

c-----------------------------------------------------------------------
c   declarations:
c   -------------

c
c   arguments:
c   ----------

      REAL*8 timestep
      REAL*8 t    ! temperature in the middle of the layer (K)
      REAL*8 p    ! pressure in the middle of the layer (K)
      REAL*8 ph2o ! water vapor partial pressure (Pa)
      REAL*8 psat ! water vapor saturation pressure (Pa)
      REAL*8 r    ! crystal radius before condensation (m)
      REAL*8 seq  ! Equilibrium saturation ratio
      REAL*8 dr   ! crystal radius variation (m)

c   local:
c   ------

c     Effective gas molecular radius (m)
      real*8 :: molco2 = 2.2e-10    ! CO2
c     Effective gas molecular radius (m)
      real*8 :: molh2o = 1.2e-10    ! H2O
c     Molecular weight of CO2
      real*8 :: Mco2 = 44.e-3       ! kg.mol-1
c     Molecular weight of H2O
      real*8 :: Mh2o = 18.e-3       ! kg.mol-1
c     surface tension of ice/vapor
      real*8 :: sigh2o = 0.12       ! N.m
c     Ice density
      real*8 :: rho_i = 917.        ! kg.m-3 also defined in initcld.f
c     Avogadro number
      real*8 :: nav = 6.023e23
c     Perfect gas constant
      real*8 :: rgp = 8.3143
c     Boltzman constant
      real*8 :: kbz = 1.381e-23
c     Reference temperature, T=273,15 K
      real*8 :: To = 273.15

      REAL*8 k,Lv
      REAL*8 knudsen           ! Knudsen number (gas mean free path/particle radius)
      REAL*8 a,Dv,lambda,Rk,Rd ! Intermediate computations for growth rate
      REAL*8 Cste, rf

c-----------------------------------------------------------------------
c      Ice particle growth rate by diffusion/impegement of water molecules
c                r.dr/dt = (S-Seq) / (Seq*Rk+Rd)
c        with r the crystal radius, Rk and Rd the resistances due to
c        latent heat release and to vapor diffusion respectively
c-----------------------------------------------------------------------

c     - Equilibrium saturation accounting for KeLvin Effect
c       seq=exp(2*sigh2o*Mh2o/(rho_i*rgp*t*r))

c     - Thermal conductibility of CO2
      k  = (0.17913 * t - 13.9789) * 4.184e-4
c     - Latent heat of h2o (J.kg-1)
      Lv = (2834.3 - 0.28 * (t-To) - 0.004 * (t-To)**2 ) * 1.e+3

c     - Constant to compute gas mean free path
c     l= (T/P)*a, with a = (  0.707*8.31/(4*pi*molrad**2 * avogadro))
      a = 0.707*rgp/(4 * pi* molco2**2  * nav)

c     - Compute Dv, water vapor diffusion coefficient
c       accounting for both kinetic and continuum regime of diffusion,
c       the nature of which depending on the Knudsen number.

      Dv = 1./3. * sqrt( 8*kbz*t/(pi*Mh2o/nav) )* kbz * t /
     &   ( pi * p * 100. * (molco2+molh2o)**2 * sqrt(1.+Mh2o/Mco2) )

      knudsen = t / (p*100.) * a / r
      lambda  = (1.333+0.71/knudsen) / (1.+1./knudsen)
      Dv      = Dv / (1. + lambda * knudsen)

c     - Compute Rk
      Rk = Lv**2 * rho_i * Mh2o / (k*rgp*t**2.)
c     - Compute Rd
      Rd = rgp * t *rho_i / (Dv*psat*Mh2o)

c     - Compute Cste=rdr/dt, then r(t+1)= sqrt(r(t)**2.+2.*Cste*dt)
      Cste = 1. / (seq*Rk+Rd)

      RETURN
      END


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!> @brief A Fortran 2003 module defining "circles" and "cylinders" for use in
!> geometry.
!>
!> This module provides a derived data types for a "circle" which must exist in
!> 2-D space and a "cylinder" which must exist in 3-D space. The circle is
!> defined by a point for the center of rotation and a radius. The cylinder is
!> defined by two points for the central axis of rotation and its total extent
!> (if it is to be finite) and a radius. The cylinder is assumed to be a right
!> cylinder. The module also provides methods for constructing and destructing
!> these types and routines for intersecting lines with their bodies.
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
MODULE Geom_CircCyl
USE IntrType
USE Constants_Conversion
USE ExtendedMath
USE Geom_Points
USE Geom_Line

IMPLICIT NONE
PRIVATE !Default contents of module to private
!
! List of Public items
PUBLIC :: CircleType
PUBLIC :: CylinderType
PUBLIC :: OPERATOR(==)

!> @brief Type for a circle
TYPE :: CircleType
  !> The point that defines the center of rotation of the circle.
  TYPE(PointType) :: c
  !> The radius of the circle
  REAL(SRK) :: r=0.0_SRK
  !> The starting theta angle
  REAL(SRK) :: thetastt=0.0_SRK
  !> The stopping theta angle
  REAL(SRK) :: thetastp=0.0_SRK
!
!List of type bound procedures
  CONTAINS
    !> @copybrief Geom_CircCyl::set_CircleType
    !> @copydetails Geom_CircCyl::set_CircleType
    PROCEDURE,PASS :: set => set_CircleType
    !> @copybrief Geom_CircCyl::clear_CircleType
    !> @copydetails Geom_CircCyl::clear_CircleType
    PROCEDURE,PASS :: clear => clear_CircleType
    !> @copybrief Geom_CircCyl::intersect_CircleType_and_LineType
    !> @copydetails Geom_CircCyl::intersect_CircleType_and_LineType
    PROCEDURE,PASS :: intersectLine => intersect_CircleType_and_LineType
    !> @copybrief Geom_CircCyl::intersect_CircleType_and_CircleType
    !> @copydetails Geom_CircCyl::intersect_CircleType_and_CircleType
    PROCEDURE,PASS :: intersectCircle => intersect_CircleType_and_CircleType
    !> @copybrief Geom_CircCyl::intersect_ArcCircleType_and_LineType
    !> @copydetails Geom_CircCyl::intersect_ArcCircleType_and_LineType
    PROCEDURE,PASS :: intersectArcLine => intersect_ArcCircleType_and_LineType
    !> @copybrief Geom_CircCyl::inside_CircleType
    !> @copydetails Geom_CircCyl::inside_CircleType
    PROCEDURE,PASS :: inside => inside_CircleType
    !> @copybrief Geom_CircCyl::onSurface_CircleType
    !> @copydetails Geom_CircCyl::onSurface_CircleType
    PROCEDURE,PASS :: onSurface => onSurface_CircleType
ENDTYPE CircleType

!> @brief Type for a cylinder
TYPE :: CylinderType
  !> The line segment that defines the center of rotation of the cylinder and
  !> its extents (if finite).
  TYPE(LineType) :: axis
  !> The radius of the circle
  REAL(SRK) :: r=0.0_SRK
  !> The starting theta angle
  REAL(SRK) :: thetastt=0.0_SRK
  !> The stopping theta angle
  REAL(SRK) :: thetastp=0.0_SRK
!
!List of type bound procedures
  CONTAINS
    !> @copybrief Geom_CircCyl::set_CylinderType
    !> @copydetails Geom_CircCyl::set_CylinderType
    PROCEDURE,PASS :: set => set_CylinderType
    !> @copybrief Geom_CircCyl::clear_CylinderType
    !> @copydetails Geom_CircCyl::clear_CylinderType
    PROCEDURE,PASS :: clear => clear_CylinderType
    !> @copybrief Geom_CircCyl::intersect_CylinderType_and_LineType
    !> @copydetails Geom_CircCyl::intersect_CylinderType_and_LineType
    PROCEDURE,PASS :: intersectLine => intersect_CylinderType_and_LineType
ENDTYPE CylinderType

!> @brief Generic interface for 'is equal to' operator (==)
!>
!> Adds 'is equal to' capability for Circle types
INTERFACE OPERATOR(==)
  !> @copybrief Geom_CircCyl::isequal_CircleType
  !> @copydetails Geom_CircCyl::isequal_CircleType
  MODULE PROCEDURE isequal_CircleType
  !> @copybrief Geom_CircCyl::isequal_CylinderType
  !> @copydetails Geom_CircCyl::isequal_CylinderType
  MODULE PROCEDURE isequal_CylinderType
ENDINTERFACE
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
!> @brief Sets the values for the CircleType object attributes
!> @param circ the CircleType object to set
!> @param p a point for the center of rotation (must be 2-D)
!> @param r the radius of the circle
ELEMENTAL SUBROUTINE set_CircleType(circ,p,r,angstt,angstp)
  CLASS(CircleType),INTENT(INOUT) :: circ
  TYPE(PointType),INTENT(IN) :: p
  REAL(SRK),INTENT(IN) :: r
  REAL(SRK),INTENT(IN),OPTIONAL :: angstt
  REAL(SRK),INTENT(IN),OPTIONAL :: angstp
  REAL(SRK) :: dtheta
  CALL circ%clear()
  IF(p%dim == 2 .AND. r > ZERO) THEN
    circ%c=p
    circ%r=r
    circ%thetastt=ZERO
    circ%thetastp=TWOPI
    IF(PRESENT(angstt)) circ%thetastt=angstt
    IF(PRESENT(angstp)) circ%thetastp=angstp
    dtheta=circ%thetastp-circ%thetastt
    IF(dtheta .APPROXGE. TWOPI) THEN
      circ%thetastt=ZERO
      circ%thetastp=TWOPI
    ENDIF
    !circ%cosstt=COS(circ%thetastt)
    !circ%sinstt=SIN(circ%thetastt)
    !circ%cosstp=COS(circ%thetastp)
    !circ%sinstp=SIN(circ%thetastp)
  ENDIF
ENDSUBROUTINE set_CircleType
!
!-------------------------------------------------------------------------------
!> @brief Clears a CircleType object's attributes
!> @param circ the CircleType object to clear
ELEMENTAL SUBROUTINE clear_CircleType(circ)
  CLASS(CircleType),INTENT(INOUT) :: circ
  CALL circ%c%clear()
  circ%r=ZERO
  circ%thetastt=ZERO
  circ%thetastp=ZERO
ENDSUBROUTINE clear_CircleType
!
!-------------------------------------------------------------------------------
!> @brief Sets the values for the CylinderType object attributes
!> @param cyl the CylinderType object to set
!> @param p a point for the "bottom" of the central axis of rotation
!>        (must be 3-D)
!> @param q a point for the "top" of the central axis of rotation (must be 3-D)
!> @param r the radius of the cylinder
ELEMENTAL SUBROUTINE set_CylinderType(cyl,p,q,r,angstt,angstp)
  CLASS(CylinderType),INTENT(INOUT) :: cyl
  TYPE(PointType),INTENT(IN) :: p
  TYPE(PointType),INTENT(IN) :: q
  REAL(SRK),INTENT(IN) :: r
  REAL(SRK),INTENT(IN),OPTIONAL :: angstt
  REAL(SRK),INTENT(IN),OPTIONAL :: angstp
  REAL(SRK) :: dtheta
  CALL cyl%clear()
  IF(p%dim == 3 .AND. .NOT.(p .APPROXEQA. q)  .AND. r > ZERO) THEN
    CALL cyl%axis%set(p,q)
    cyl%r=r
    cyl%thetastt=ZERO
    cyl%thetastp=TWOPI
    IF(PRESENT(angstt)) cyl%thetastt=angstt
    IF(PRESENT(angstp)) cyl%thetastp=angstp
    dtheta=cyl%thetastp-cyl%thetastt
    IF(dtheta .APPROXGE. TWOPI) THEN
      cyl%thetastt=ZERO
      cyl%thetastp=TWOPI
    ENDIF
  ENDIF
ENDSUBROUTINE set_CylinderType
!
!-------------------------------------------------------------------------------
!> @brief Clears a CylinderType object's attributes
!> @param circ the CylinderType object to clear
ELEMENTAL SUBROUTINE clear_CylinderType(cyl)
  CLASS(CylinderType),INTENT(INOUT) :: cyl
  CALL cyl%axis%clear()
  cyl%r=ZERO
  cyl%thetastt=ZERO
  cyl%thetastp=ZERO
ENDSUBROUTINE clear_CylinderType
!
!-------------------------------------------------------------------------------
!> @brief Determines point(s) of intersection between a line and circle (if any)
!> @param circle the circle type to test for intersection
!> @param line the line type thats being tested against the circle
!> @param p1 the first point of intersection (if it exists)
!> @param p2 the second point of intersection (if it exists)
!> @note a return code is assigned to @c p1%dim and @c p2%dim indicating the type of
!> intersection. @n
!>  > 0: success; an intersection point was found @n
!> == 0: no intersection was found (intersection outside segment) @n
!>   -1: problem with dummy arguments passed to routine @n
!>   -2: line is not directed toward circle (disjoint) @n
!>   -3: line segment is tangent @n
ELEMENTAL SUBROUTINE intersect_CircleType_and_LineType(circle,line,p1,p2)
  CLASS(CircleType),INTENT(IN) :: circle
  TYPE(LineType),INTENT(IN) :: line
  TYPE(PointType),INTENT(INOUT) :: p1
  TYPE(PointType),INTENT(INOUT) :: p2
  REAL(SRK) :: a,b,c,t1,t2,u(2),w(2),ra,discr

  CALL p1%clear()
  CALL p2%clear()
  p1%dim=-1
  p2%dim=-1
  IF(circle%c%dim == 2 .AND. line%p1%dim == 2 .AND. &
      line%p2%dim == 2 .AND. circle%r > 0.0_SRK) THEN
    u(1)=line%p2%coord(1)-line%p1%coord(1)  !dx
    u(2)=line%p2%coord(2)-line%p1%coord(2)  !dy
    w(1)=line%p1%coord(1)-circle%c%coord(1)
    w(2)=line%p1%coord(2)-circle%c%coord(2)
    b=w(1)*u(1)+w(2)*u(2)
    c=w(1)*w(1)+w(2)*w(2)-circle%r*circle%r

    IF(c > zero .AND. b > zero) THEN
      p1%dim=-2
      p2%dim=-2
    ELSE
      a=u(1)*u(1)+u(2)*u(2) !dr^2
      discr=b*b-a*c
      IF(discr < -EPSREAL) THEN
        !Disjoint
        p1%dim=-2
        p2%dim=-2
      ELSEIF(discr .APPROXEQA. zero) THEN
        !Tangent

        ra=one/a
        t1=-ra*b
        IF(t1<ZERO .OR. t1 > ONE ) THEN
          p1%dim=-2
          p2%dim=-2
        ELSE
          p1=line%p1
          p1%coord(1)=p1%coord(1)+u(1)*t1
          p1%coord(2)=p1%coord(2)+u(2)*t1
          p1%dim=-3
          p2%dim=-3
        ENDIF
      ELSE
        p1%dim=0
        p2%dim=0
        ra=one/a
        discr=SQRT(discr)
        t1=(-b-discr)*ra
        t2=(-b+discr)*ra
        IF(ZERO < t1 .AND. t1 < ONE) THEN
          p1=line%p1
          p1%coord(1)=p1%coord(1)+u(1)*t1
          p1%coord(2)=p1%coord(2)+u(2)*t1
        ENDIF
        IF(ZERO < t2 .AND. t2 < ONE) THEN
          p2=line%p1
          p2%coord(1)=p2%coord(1)+u(1)*t2
          p2%coord(2)=p2%coord(2)+u(2)*t2
        ENDIF
      ENDIF
    ENDIF
  ENDIF
ENDSUBROUTINE intersect_CircleType_and_LineType
!
!-------------------------------------------------------------------------------
!> @brief Determines point(s) of intersection between two circles (if any)
!> @param c1 first circle type to test for intersection
!> @param c2 second circle type to test for intersection
!> @param p1 first point of intersection if it exists
!> @param p2 second point of intersection if it exists
!> @note a return code is assigned to @c p1%dim and @c p2%dim indicating the type of
!> intersection. @n
!> ==  2: success; Two points of intersection  found @n
!> == -1: uninitialized circle
!> == -2: no intersection points found (disjoint) @n
!> == -3: The circles are tangent @n
!> == -4: The circles are overlapped @n
ELEMENTAL SUBROUTINE intersect_CircleType_and_CircleType(c1,c2,p1,p2)
  CLASS(CircleType),INTENT(IN)  :: c1,c2
  TYPE(PointType),INTENT(INOUT) :: p1,p2
  TYPE(PointType)               :: v1
  REAL(SRK)                     :: d,s,m
  REAL(SRK)                     :: dx,dy,dx2,dy2,dr2
  REAL(SRK)                     :: t1,t2,a,b,c

  CALL p1%clear()
  CALL p1%clear()
  p1%dim=-1
  p2%dim=-1

  IF(c1%c%dim==2 .AND. c2%c%dim==2 .AND. &
      c1%r > 0.0_SRK .AND. c2%r > 0.0_SRK) THEN
    d=Distance(c1%c,c2%c)
    s=c1%r+c2%r
    IF(d > s) THEN
      p1%dim=-2
      p2%dim=-2
    ELSEIF(d .APPROXEQ. s) THEN
      !Tangent
      v1=c2%c-c1%c
      m=SQRT(v1%coord(1)*v1%coord(1)+v1%coord(2)*v1%coord(2))
      v1%coord(1)=v1%coord(1)/m
      v1%coord(2)=v1%coord(2)/m
      CALL p1%init(DIM=2,X=ZERO,Y=ZERO)
      p1%coord(1)=c1%c%coord(1)+v1%coord(1)*c1%r
      p1%coord(2)=c1%c%coord(2)+v1%coord(2)*c1%r
      p1%dim=-3
      p2=p1
    ELSE
      IF(c1%c == c2%c) THEN
        p1%dim=-4
        p2%dim=-4
      ELSE
        dx=c2%c%coord(1)-c1%c%coord(1)
        dy=c2%c%coord(2)-c1%c%coord(2)
        dr2=(c1%r*c1%r-c2%r*c2%r)
        dx2=(c1%c%coord(1)*c1%c%coord(1)-c2%c%coord(1)*c2%c%coord(1))
        dy2=(c1%c%coord(2)*c1%c%coord(2)-c2%c%coord(2)*c2%c%coord(2))
        IF(c1%c%coord(1) == c2%c%coord(1)) THEN
          t1=(dr2-dx2-dy2)/(2.0_SRK*dy)
          t2=dx/dy
          !Set up quadratic equation
          a=(1.0_SRK+t2*t2)
          b=(2.0_SRK*t2*c1%c%coord(2)-2.0_SRK*c1%c%coord(1)-2.0_SRK*t1*t2)
          c=(t1*t1+c1%c%coord(1)*c1%c%coord(1)+c1%c%coord(2)*c1%c%coord(2))
          c=c-2.0_SRK*t1*c1%c%coord(2)-c1%r*c1%r
          IF(4.0_SRK*a*c > b*b) THEN
            p1%dim=-4
            p2%dim=-4
          ELSE
            CALL p1%init(DIM=2,X=ZERO,Y=ZERO)
            p2=p1
            p1%coord(1)=(-b+SQRT(b*b-4.0_SRK*a*c))/(2.0_SRK*a)
            p1%coord(2)=t1-p1%coord(1)*t2
            p2%coord(1)=(-b-SQRT(b*b-4.0_SRK*a*c))/(2.0_SRK*a)
            p2%coord(2)=t1-p2%coord(1)*t2
          ENDIF
        ELSE
          t1=(dr2-dx2-dy2)/(2.0_SRK*dx)
          t2=dy/dx

          !Set up quadratic equation
          a=(1.0_SRK+t2*t2)
          b=(2.0_SRK*t2*c1%c%coord(1)-2.0_SRK*c1%c%coord(2)-2.0_SRK*t1*t2)
          c=(t1*t1+c1%c%coord(1)*c1%c%coord(1)+c1%c%coord(2)*c1%c%coord(2))
          c=c-2.0_SRK*t1*c1%c%coord(1)-c1%r*c1%r
          IF(4.0_SRK*a*c > b*b) THEN
            p1%dim=-4
            p2%dim=-4
          ELSE
            CALL p1%init(DIM=2,X=ZERO,Y=ZERO)
            p2=p1
            p1%coord(2)=(-b+SQRT(b*b-4.0_SRK*a*c))/(2.0_SRK*a)
            p1%coord(1)=t1-p1%coord(2)*t2
            p2%coord(2)=(-b-SQRT(b*b-4.0_SRK*a*c))/(2.0_SRK*a)
            p2%coord(1)=t1-p2%coord(2)*t2
          ENDIF
        ENDIF
      ENDIF
    ENDIF
  ENDIF
ENDSUBROUTINE intersect_CircleType_and_CircleType
!
!-------------------------------------------------------------------------------
!> @brief Determines point(s) of intersection between a line and circle (if any)
!> @param circle the circle type to test for intersection
!> @param line the line type thats being tested against the circle
!> @param p1 the first point of intersection (if it exists)
!> @param p2 the second point of intersection (if it exists)
!> @note a return code is assigned to @c p1%dim and @c p2%dim indicating the type of
!> intersection. @n
!>  > 0: success; an intersection point was found @n
!> == 0: no intersection was found (intersection outside segment) @n
!>   -1: problem with dummy arguments passed to routine @n
!>   -2: line is not directed toward circle (disjoint) @n
!>   -3: line segment is tangent @n
ELEMENTAL SUBROUTINE intersect_ArcCircleType_and_LineType(circle,line,p1,p2,p3,p4)
  CLASS(CircleType),INTENT(IN) :: circle
  TYPE(LineType),INTENT(IN) :: line
  TYPE(PointType),INTENT(INOUT) :: p1
  TYPE(PointType),INTENT(INOUT) :: p2
  TYPE(PointType),INTENT(INOUT) :: p3
  TYPE(PointType),INTENT(INOUT) :: p4
  LOGICAL(SBK) :: arcTest
  REAL(SRK) :: a,b,c,t1,t2,u(2),w(2),ra,discr,theta,theta_shift,c0(2),c1(2),c2(2)
  TYPE(LineType) :: arcLine

  CALL p1%clear()
  CALL p2%clear()
  CALL p3%clear()
  CALL p4%clear()
  p1%dim=-1
  p2%dim=-1
  p3%dim=-1
  p4%dim=-1
  IF(circle%c%dim == 2 .AND. line%p1%dim == 2 .AND. &
      line%p2%dim == 2 .AND. circle%r > 0.0_SRK) THEN
    u(1)=line%p2%coord(1)-line%p1%coord(1)  !dx
    u(2)=line%p2%coord(2)-line%p1%coord(2)  !dy
    w(1)=line%p1%coord(1)-circle%c%coord(1)
    w(2)=line%p1%coord(2)-circle%c%coord(2)
    b=w(1)*u(1)+w(2)*u(2)
    c=w(1)*w(1)+w(2)*w(2)-circle%r*circle%r
    IF(c > zero .AND. b > zero) THEN
      p1%dim=-2
      p2%dim=-2
    ELSE
      a=u(1)*u(1)+u(2)*u(2) !dr^2
      discr=b*b-a*c
      arcTest=(circle%thetastt /= ZERO .OR. circle%thetastp /= TWOPI)
      IF(discr < -EPSREAL) THEN
        !Disjoint
        p1%dim=-2
        p2%dim=-2
      ELSEIF(discr .APPROXEQA. zero) THEN
        !Tangent
        p1%dim=-3
        p2%dim=-3
      ELSE
        p1%dim=0
        p2%dim=0
        ra=one/a
        discr=SQRT(discr)
        t1=(-b-discr)*ra
        t2=(-b+discr)*ra
        IF(ZERO < t1 .AND. t1 < ONE) THEN
          p1=line%p1
          p1%coord(1)=p1%coord(1)+u(1)*t1
          p1%coord(2)=p1%coord(2)+u(2)*t1
          IF(arcTest) THEN
            theta_shift=0.0_SRK
            theta=ATAN2PI((p1%coord(1)-circle%c%coord(1)),(p1%coord(2)-circle%c%coord(2)))
            IF(circle%thetastt > circle%thetastp) THEN
              theta_shift=TWOPI
              IF(p1%coord(2)-circle%c%coord(2) > 0.0_SRK) theta=theta+TWOPI
            ENDIF
            IF((theta .APPROXLE. circle%thetastt) .OR. &
                (circle%thetastp+theta_shift .APPROXLE. theta)) CALL p1%clear()
          ENDIF
        ENDIF
        IF(ZERO < t2 .AND. t2 < ONE) THEN
          p2=line%p1
          p2%coord(1)=p2%coord(1)+u(1)*t2
          p2%coord(2)=p2%coord(2)+u(2)*t2
          IF(arcTest) THEN
            theta_shift=0.0_SRK
            theta=ATAN2PI((p2%coord(1)-circle%c%coord(1)),(p2%coord(2)-circle%c%coord(2)))
            IF(circle%thetastt > circle%thetastp) THEN
              theta_shift=TWOPI
              IF(p2%coord(2)-circle%c%coord(2) > 0.0_SRK) theta=theta+TWOPI
            ENDIF
            IF((theta .APPROXLE. circle%thetastt) .OR. &
                (circle%thetastp+theta_shift .APPROXLE. theta)) CALL p2%clear()
          ENDIF
        ENDIF
      ENDIF
      IF(arcTest) THEN
        !Test for intersection with segments between center of rotation
        !and ends of arc
        arcLine%p1=circle%c
        c0=circle%c%coord
        c1(1)=c0(1)+circle%r*COS(circle%thetastt)
        c1(2)=c0(2)+circle%r*SIN(circle%thetastt)
        c2(1)=c0(1)+circle%r*COS(circle%thetastp)
        c2(2)=c0(2)+circle%r*SIN(circle%thetastp)
        CALL arcLine%p2%init(DIM=2,X=c1(1),Y=c1(2))
        p3=arcLine%intersect(line)
        arcLine%p2%coord=c2
        p4=arcLine%intersect(line)

        IF(p1%dim /= 2 .AND. p2%dim /= 2) THEN
          !No other intersections, therefore we check p3 and p4
          !to find out if either lies on a corner of the wedge
          IF(p3%dim == 2) THEN
            IF(p4%dim < 0) THEN
              !The other surface is co-linear or disjoint
              !so we mark this as co-linear or disjoint
              IF(ALL(p3%coord .APPROXEQA. c0) .OR. &
                  ALL(p3%coord .APPROXEQA. c1) .OR. &
                  ALL(p3%coord .APPROXEQA. c2)) p3%dim=p4%dim
            ELSEIF(p4%dim == 2) THEN
              IF(ALL(p3%coord .APPROXEQA. p4%coord)) THEN
                p3%dim=-3
                p4%dim=-3
              ENDIF
            ENDIF
          ELSEIF(p3%dim < 0 .AND. p4%dim > 0) THEN
            !The other surface is co-linear or disjoint
            !so we mark this as co-linear or disjoint
            IF(ALL(p4%coord .APPROXEQA. c0) .OR. &
                ALL(p4%coord .APPROXEQA. c1) .OR. &
                ALL(p4%coord .APPROXEQA. c2)) p4%dim=p3%dim
          ENDIF
        ELSE
          IF(p3%dim == 2 .AND. p4%dim == 2) THEN
            IF(ALL(p3%coord .APPROXEQA. p4%coord)) p4%dim=-3
          ENDIF
        ENDIF
      ENDIF
    ENDIF
  ENDIF
ENDSUBROUTINE intersect_ArcCircleType_and_LineType
!
!-------------------------------------------------------------------------------
!> @brief Determines the points of intersection between a line and a cylinder
!> (if any).
!> @param cyl the cylinder object to test for intersection
!> @param line the line segment to test for intersection
!> @param p1 the first point of intersection (if it exists)
!> @param p2 the second point of intersection (if it exists)
!> @note a return code is assigned to @c p1%dim and @c p2%dim indicating the type of
!> intersection. @n
!>  > 0: success; an intersection point was found @n
!> == 0: no intersection was found @n
!>   -1: problem with dummy arguments passed to routine @n
!>   -2: the line segment lies totally outside the cylinders P-surface @n
!>   -3: the line segment lies totally outside the cylinders Q-surface @n
!>   -4: the segment lies on the cylinder's surface @n
!>   -5: the segment is parallel to the cylinder's axis and outisde it's radius @n
!>   -6: the segment is parallel to the cylinder's axis and totally inside it @n
!>   -7: the segment is tangent to the cylinder @n
!>   -8: the segment does not intersect the cylinder @n
!>
!> The algorithm for finding the intersection is similar to that outlined
!> in section 5.3.7 of "Real-Time Collision Detection" by Christer Ericson.
!> The problem for the intersection is stated as a quadratic equation which is
!> obtained by substituting the parametric equation of a line into the
!> parametric equation for a cylinder.
!>
!> For a segment defined by points A and B with orientation A->B, and a finite
!> cylinder defined by a central axis of rotation P->Q and radius R, the
!> equation is given as:
!>
!>  \f[ a t^2 + 2b t + c = 0 \f]
!>
!> with
!>
!>  \f[ a = \left(\vec{d}\cdot\vec{d}\right) \left(\vec{u}\cdot\vec{u}\right) - \left(\vec{u}\cdot\vec{d}\right)^2 \f]
!>  \f[ b = \left(\vec{d}\cdot\vec{d}\right) \left(\vec{w}\cdot\vec{u}\right) - \left(\vec{u}\cdot\vec{d}\right) \left(\vec{w}\cdot\vec{d}\right) \f]
!>  \f[ c = \left(\vec{d}\cdot\vec{d}\right) \left(\vec{w}\cdot\vec{w} - R^2\right) - \left(\vec{w}\cdot\vec{d}\right)^2 \f]
!>
!> and
!>
!>  \f[ \vec{u} = \vec{B}-\vec{A} \f]
!>  \f[ \vec{d} = \vec{Q}-\vec{P} \f]
!>  \f[ \vec{w} = \vec{A}-\vec{P} \f]
!>
!> One then solves the quadratic equation for the roots of \f$ t \f$
!> (where \f$ 0 <= t <= 1 \f$) and obtains the coordinates of the points as:
!>
!> \f[ \vec{L}(t)=\vec{A}+\vec{u} t \f]
!>
!> Intersections at the end-caps of the cylinder (called the P-surface and
!> Q-surface) have the values of t as:
!>
!> \f[ t_P = -\left(\vec{w}\cdot\vec{d}\right)/\left(\vec{u}\cdot\vec{d}\right) \f]
!> \f[ t_Q = \left(\vec{d}\cdot\vec{d}-\vec{w}\cdot\vec{d}\right)/\left(\vec{u}\cdot\vec{d}\right) \f]
!>
!> @TODO: Create sister routine to work with partial cylinders
!>
ELEMENTAL SUBROUTINE intersect_CylinderType_and_LineType(cyl,line,p1,p2)
  CLASS(CylinderType),INTENT(IN) :: cyl
  TYPE(LineType),INTENT(IN) :: line
  TYPE(PointType),INTENT(INOUT) :: p1
  TYPE(PointType),INTENT(INOUT) :: p2
  LOGICAL(SBK) :: arcTest
  REAL(SRK) :: u(3),w(3),d(3)
  REAL(SRK) :: ud,uw,uu,wd,dd,t1,t2,tp,tq,a,b,c,k,g1,g2,ra,discr
  !REAL(SRK) :: x(2),theta

  CALL p1%clear()
  CALL p2%clear()
  p1%dim=-1
  p2%dim=-1
  !Check for valid input
  IF(cyl%axis%p1%dim == 3 .AND. cyl%axis%p2%dim == 3 .AND. &
      line%p1%dim == 3 .AND. line%p2%dim == 3 .AND. cyl%r > zero) THEN
    p1%dim=0
    p2%dim=0

    !For a line defined by A->B compute B-A as slope for parametric eqn's
    !P(t)=A+u*t for a point on segment A->B.
    u(1)=line%p2%coord(1)-line%p1%coord(1)
    u(2)=line%p2%coord(2)-line%p1%coord(2)
    u(3)=line%p2%coord(3)-line%p1%coord(3)

    !For a central axis of rotation defined by P->Q compute Q-P
    d(1)=cyl%axis%p2%coord(1)-cyl%axis%p1%coord(1)
    d(2)=cyl%axis%p2%coord(2)-cyl%axis%p1%coord(2)
    d(3)=cyl%axis%p2%coord(3)-cyl%axis%p1%coord(3)

    !Vector of P->A, used to project A->B onto cylinder-local coordinate
    w(1)=line%p1%coord(1)-cyl%axis%p1%coord(1)
    w(2)=line%p1%coord(2)-cyl%axis%p1%coord(2)
    w(3)=line%p1%coord(3)-cyl%axis%p1%coord(3)

    !Dot(u,d), length of A->B projected onto P->Q
    ud=u(1)*d(1)+u(2)*d(2)+u(3)*d(3)
    !Dot(w,d), length of P->A projected onto P->Q
    wd=w(1)*d(1)+w(2)*d(2)+w(3)*d(3)
    !Dot(d,d), length of P->Q
    dd=d(1)*d(1)+d(2)*d(2)+d(3)*d(3)

    IF(wd < -EPSREAL .AND. wd+ud < -EPSREAL) THEN
      !The line segment is totally outside the P-surface
      p1%dim=-2
      p2%dim=-2
    ELSEIF(wd > dd .AND. wd+ud > dd) THEN
      !The line segment is totally outside the Q-surface
      p1%dim=-3
      p2%dim=-3
    ELSE
      !At least one of the segment end points lies within interval spanned
      !by P->Q, or on opposite ends of P and Q

      !Dot(u,u), length of A->B
      uu=u(1)*u(1)+u(2)*u(2)+u(3)*u(3)
      !Dot(u,w), projection of A->B into direction perpendicular to P->Q
      uw=u(1)*w(1)+u(2)*w(2)+u(3)*w(3)

      a=dd*uu-ud*ud
      k=w(1)*w(1)+w(2)*w(2)+w(3)*w(3)-cyl%r*cyl%r
      c=dd*k-wd*wd

      IF(ABS(a) < EPSREAL) THEN
!Segment A->B is parallel to P->Q
        IF(c .APPROXEQA. zero) THEN
          !Segment is on the cylinder surface
          p1%dim=-4
          p2%dim=-4
        ELSEIF(c > zero) THEN
          !Segment is outside cylinder radius
          p1%dim=-5
          p2%dim=-5
        ELSE
          !Segment is inside cylinder, check end-caps
          IF(wd < zero .OR. wd+ud < zero) THEN !segment intersects P-surface
            tp=-wd/ud
            p1=line%p1
            p1%coord(1)=p1%coord(1)+tp*u(1)
            p1%coord(2)=p1%coord(2)+tp*u(2)
            p1%coord(3)=p1%coord(3)+tp*u(3)
          ENDIF
          IF(wd > dd .OR. wd+ud > dd) THEN !segment intersects Q-surface
            tq=(dd-wd)/ud
            p2=line%p1
            p2%coord(1)=p2%coord(1)+tq*u(1)
            p2%coord(2)=p2%coord(2)+tq*u(2)
            p2%coord(3)=p2%coord(3)+tq*u(3)
          ENDIF
          IF((zero < wd .AND. wd < dd) .AND. &
              (zero < wd+ud .AND. wd+ud < dd)) THEN
            !Segment is totally inside cylinder and parallel to P->Q
            p1%dim=-6
            p2%dim=-6
          ENDIF
        ENDIF
      ELSE
!Segment A->B is not parallel to P->Q
        b=dd*uw-ud*wd
        discr=b*b-a*c
        IF(discr .APPROXEQA. zero) THEN
          !Line is tangent
          p1%dim=-7
          p2%dim=-7
        ELSEIF(discr < zero) THEN
          !No real roots, no intersection
          p1%dim=-8
          p2%dim=-8
        ELSE
          !Solution to quadratic formula
          ra=1.0_SRK/a
          g1=-b*ra
          g2=SQRT(discr)*ra
          t1=g1-g2
          t2=g1+g2

          arcTest=(cyl%thetastt /= ZERO .OR. cyl%thetastp /= TWOPI)
          IF(zero < t1 .AND. t1 < one) THEN
            !Intersection with the side of a cylinder
            p1=line%p1
            p1%coord(1)=p1%coord(1)+t1*u(1)
            p1%coord(2)=p1%coord(2)+t1*u(2)
            p1%coord(3)=p1%coord(3)+t1*u(3)
          ELSE
            IF(wd+t1*ud < zero) THEN
              tp=-wd/ud
              IF(((k+tp*(2._SRK*uw+tp*uu)) < zero) .AND.  &
                  (zero < tp .AND. tp < one)) THEN
                !Intersection with P-surface
                p1=line%p1
                p1%coord(1)=p1%coord(1)+tp*u(1)
                p1%coord(2)=p1%coord(2)+tp*u(2)
                p1%coord(3)=p1%coord(3)+tp*u(3)
              ENDIF
            ELSEIF(wd+t1*ud > dd) THEN
              tq=(dd-wd)/ud
              IF(((k+dd-2._SRK*wd+tq*(2._SRK*(uw-ud)+tq*uu)) < zero) .AND. &
                  (zero < tq .AND. tq < one)) THEN
                !Intersection with Q-surface
                p1=line%p1
                p1%coord(1)=p1%coord(1)+tq*u(1)
                p1%coord(2)=p1%coord(2)+tq*u(2)
                p1%coord(3)=p1%coord(3)+tq*u(3)
              ENDIF
            ENDIF
          ENDIF

          IF(zero < t2 .AND. t2 < one) THEN
            !Intersection with the side of a cylinder
            p2=line%p1
            p2%coord(1)=p2%coord(1)+t2*u(1)
            p2%coord(2)=p2%coord(2)+t2*u(2)
            p2%coord(3)=p2%coord(3)+t2*u(3)
          ELSE
            IF(wd+t2*ud < zero) THEN
              tp=-wd/ud
              IF(((k+tp*(2._SRK*uw+tp*uu)) < zero) .AND.  &
                  (zero < tp .AND. tp < one)) THEN
                !Intersection with P-surface
                p2=line%p1
                p2%coord(1)=p2%coord(1)+tp*u(1)
                p2%coord(2)=p2%coord(2)+tp*u(2)
                p2%coord(3)=p2%coord(3)+tp*u(3)
              ENDIF
            ELSEIF(wd+t2*ud > dd) THEN
              tq=(dd-wd)/ud
              IF(((k+dd-2._SRK*wd+tq*(2._SRK*(uw-ud)+tq*uu)) < zero) .AND. &
                  (zero < tq .AND. tq < one)) THEN
                !Intersection with Q-surface
                p2=line%p1
                p2%coord(1)=p2%coord(1)+tq*u(1)
                p2%coord(2)=p2%coord(2)+tq*u(2)
                p2%coord(3)=p2%coord(3)+tq*u(3)
              ENDIF
            ENDIF
          ENDIF
        ENDIF
      ENDIF
    ENDIF
  ENDIF
ENDSUBROUTINE intersect_CylinderType_and_LineType
!
!-------------------------------------------------------------------------------
!> @brief Determines whether a point lies within a circle type.
!> @param circle the circle type to test for intersection
!> @param point the first to query
ELEMENTAL FUNCTION inside_CircleType(circle,point) RESULT(bool)
  CLASS(CircleType),INTENT(IN) :: circle
  TYPE(PointType),INTENT(IN) :: point
  LOGICAL(SBK) :: bool
  REAL(SRK) :: x,y,dtheta ,cosstt,cosstp,sinstt,sinstp
  bool=.FALSE.
  x=point%coord(1)-circle%c%coord(1)
  y=point%coord(2)-circle%c%coord(2)
  dtheta=circle%thetastp-circle%thetastt
  IF((x*x+y*y) .APPROXLE. circle%r*circle%r) THEN
    IF(dtheta .APPROXLE. PI)THEN
      cosstt=COS(circle%thetastt)
      cosstp=COS(circle%thetastp)
      sinstt=SIN(circle%thetastt)
      sinstp=SIN(circle%thetastp)
      IF(COS(circle%thetastt)*y .APPROXGE. SIN(circle%thetastt)*x) &
          bool=COS(circle%thetastp)*y .APPROXLE. SIN(circle%thetastp)*x
    ELSEIF(dtheta < TWOPI) THEN
      cosstt=COS(circle%thetastt)
      cosstp=COS(circle%thetastp)
      sinstt=SIN(circle%thetastt)
      sinstp=SIN(circle%thetastp)
      bool=(COS(circle%thetastt)*y .APPROXGE. SIN(circle%thetastt)*x) &
          .OR. (COS(circle%thetastp)*y .APPROXLE. SIN(circle%thetastp)*x)
    ELSE
      bool=.TRUE.
    ENDIF
  ENDIF
ENDFUNCTION inside_CircleType
!
!-------------------------------------------------------------------------------
!> @brief Determines whether a point lies within a circle type.
!> @param circle the circle type to test for intersection
!> @param point the first to query
ELEMENTAL FUNCTION onSurface_CircleType(circle,point) RESULT(bool)
  CLASS(CircleType),INTENT(IN) :: circle
  TYPE(PointType),INTENT(IN) :: point
  LOGICAL(SBK) :: bool
  REAL(SRK) :: x,y,theta,theta_shift
  bool=.FALSE.
  IF(point%dim == 2 .AND. circle%r > 0.0_SRK) THEN
    x=point%coord(1)-circle%c%coord(1)
    y=point%coord(2)-circle%c%coord(2)
    IF((x*x+y*y) .APPROXEQA. circle%r*circle%r) THEN
      theta=ATAN2PI(x,y)
      theta_shift=0.0_SRK
      IF(circle%thetastt > circle%thetastp) theta_shift=TWOPI
      IF(y > 0.0_SRK .OR. ((y .APPROXEQA. 0.0_SRK) .AND. &
          (x .APPROXGE. 0.0_SRK))) theta=theta+theta_shift
      bool=(circle%thetastt .APPROXLE. theta) .AND. &
          (theta .APPROXLE. circle%thetastp+theta_shift)
    ENDIF
  ENDIF
ENDFUNCTION onSurface_CircleType
!
!-------------------------------------------------------------------------------
!> @brief Defines the 'is equal to' operation between two circles e.g. @c
!>        circ1 == circ2
!> @param p0 the first circle
!> @param p1 the second circle
!> @returns @c bool the boolean result of the operation
!>
!> Function is elemental so it can be used on an array of circles.
ELEMENTAL FUNCTION isequal_CircleType(c0,c1) RESULT(bool)
  TYPE(CircleType),INTENT(IN) :: c0,c1
  LOGICAL(SBK) :: bool
  bool=.FALSE.
  IF((c0%r .APPROXEQA. c1%r) .AND. (c0%thetastt .APPROXEQA. c1%thetastt) .AND. &
      (c0%thetastp .APPROXEQA. c1%thetastp)) bool=(c0%c == c1%c)
ENDFUNCTION isequal_CircleType
!
!-------------------------------------------------------------------------------
!> @brief Defines the 'is equal to' operation between two cylinders e.g. @c
!>        cyl1 == cyl2
!> @param p0 the first cylinder
!> @param p1 the second cylinder
!> @returns @c bool the boolean result of the operation
!>
!> Function is elemental so it can be used on an array of cylinders.
ELEMENTAL FUNCTION isequal_CylinderType(c0,c1) RESULT(bool)
  TYPE(CylinderType),INTENT(IN) :: c0,c1
  LOGICAL(SBK) :: bool
  bool=.FALSE.
  IF((c0%r .APPROXEQA. c1%r) .AND. (c0%thetastt .APPROXEQA. c1%thetastt) .AND. &
      (c0%thetastp .APPROXEQA. c1%thetastp)) bool=(c0%axis == c1%axis)
ENDFUNCTION isequal_CylinderType
!
ENDMODULE Geom_CircCyl


!
! wavy - A spectral ocean wave modeling and development framework
! Copyright (c) 2017, Wavebit Scientific LLC
! All rights reserved.
!
! Licensed under the BSD-3 clause license. See LICENSE for details.

module mod_nondimensional

use mod_precision,only:realkind

implicit none

private

public :: nondimensionalDepth
public :: nondimensionalEnergy
public :: nondimensionalFetch
public :: nondimensionalFrequency
public :: nondimensionalRoughness_S1974
public :: nondimensionalRoughness_H1986
public :: nondimensionalTime
public :: waveAge

contains

!-------------------------------------------------------------------------------
pure elemental real(kind=realkind) function waveAge(cp,u)
  !! Returns wave age, the ratio of phase speed and friction velocity or wind
  !! speed, depending on the caller's definition of wave age.
  real(kind=realkind),intent(in) :: cp
    !! Phase speed [m/s]
  real(kind=realkind),intent(in) :: u
    !! Friction velocity or wind speed [m/s]
  waveAge = cp / u
endfunction waveAge
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental real(kind=realkind) function nondimensionalDepth(wspd,depth,grav)
  !! Returns nondimensional depth based on input wind speed [m/s], mean water
  !! depth [m], and gravitational acceleration [m/s^2].
  real(kind=realkind),intent(in) :: wspd
    !! Wind speed at reference height [m/s]
  real(kind=realkind),intent(in) :: depth
    !! Mean water depth [m]
  real(kind=realkind),intent(in) :: grav
    !! Gravitational acceleration [m/s^2]
  nondimensionalDepth = grav*depth/wspd**2
endfunction nondimensionalDepth
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental real(kind=realkind) function nondimensionalEnergy(wspd,sigma,&
  grav)
  !! Returns nondimensional energy based on input wind speed, RMS of wave
  !! variance, and gravitational acceleration.
  real(kind=realkind),intent(in) :: wspd
    !! Wind speed at reference height [m/s]
  real(kind=realkind),intent(in) :: sigma
    !! Root mean square of wave variance
  real(kind=realkind),intent(in) :: grav
    !! Gravitational acceleration [m/s^2]
  nondimensionalEnergy = sigma**2*grav**2/wspd**4
endfunction nondimensionalEnergy
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental real(kind=realkind) function nondimensionalFetch(wspd,fetch,grav)
  !! Returns nondimensional energy based on input wind speed, RMS of wave
  !! variance, and gravitational acceleration.
  real(kind=realkind),intent(in) :: wspd
    !! Wind speed at reference height [m/s]
  real(kind=realkind),intent(in) :: fetch
    !! Fetch [m]
  real(kind=realkind),intent(in) :: grav
    !! Gravitational acceleration [m/s^2]
  nondimensionalFetch = grav*fetch/wspd**2
endfunction nondimensionalFetch
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental real(kind=realkind) function nondimensionalFrequency(wspd,fpeak,&
  grav)
  !! Returns nondimensional frequency based on input wind speed, peak frequency,
  !! and gravitational acceleration.
  real(kind=realkind),intent(in) :: wspd
    !! Wind speed at reference height [m/s]
  real(kind=realkind),intent(in) :: fpeak
    !! Peak frequency [Hz]
  real(kind=realkind),intent(in) :: grav
    !! Gravitational acceleration [m/s^2]
  nondimensionalFrequency = fpeak*wspd/grav
endfunction nondimensionalFrequency
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental real(kind=realkind) function nondimensionalRoughness_S1974(z0,&
  ustar,grav)
  !! Returns the aerodynamic roughness length scaled by friction velocity
  !! squared and gravitational acceleration, after Stewart (1974).
  !!
  !! References:
  !!
  !! TODO reference
  real(kind=realkind),intent(in) :: z0
    !! Roughness length [m]
  real(kind=realkind),intent(in) :: ustar
    !! Friction velocity [m/s]
  real(kind=realkind),intent(in) :: grav
    !! Gravitational acceleration [m/s^2]
  nondimensionalRoughness_S1974 = grav*z0/ustar**2
endfunction nondimensionalRoughness_S1974
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental real(kind=realkind) function nondimensionalRoughness_H1986(z0,hs)
  !! Returns the aerodynamic roughness length scaled by significant wave height,
  !! after Huang (1986).
  !!
  !! TODO reference
  real(kind=realkind),intent(in) :: z0
    !! Roughness length [m]
  real(kind=realkind),intent(in) :: hs
    !! Significant wave height [m]
  nondimensionalRoughness_H1986 = z0 / hs
endfunction nondimensionalRoughness_H1986
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure elemental real(kind=realkind) function nondimensionalTime(wspd,time,grav)
  !! Returns nondimensional time (duration) based on input wind speed, duration,
  !! and gravitational acceleration.
  real(kind=realkind),intent(in) :: wspd
    !! Wind speed at reference height [m/s]
  real(kind=realkind),intent(in) :: time
    !! Time [s]
  real(kind=realkind),intent(in) :: grav
    !! Gravitational acceleration [m/s^2]
  nondimensionalTime = grav*time/wspd
endfunction nondimensionalTime
!-------------------------------------------------------------------------------
endmodule mod_nondimensional


!------------------------------------------------------------------------------
!!  module: compute sub grid stress
!------------------------------------------------------------------------------
!!
!! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 09/06/2014
!!
!! - description:
!!  - this module contains all the routines used for computing sgs
!!  - cs_opt2 & nu_t are definded on w-nodes
!!
!------------------------------------------------------------------------------

module compute_dns_stress

  use decomp_2d
  use parameters_IO, only : rprec

  !! - global variables
  use system_variables, only : dudx,dudy,dudz,dvdx,dvdy,dvdz,dwdx,dwdy,dwdz,&
       txx,tyy,tzz,txy,txz,tyz

  implicit none

  private

  public :: dns_stress

contains !=======================================================================

  !!--------------------------------------------------------------------------------
  !! subroutine: dns_stress
  !!--------------------------------------------------------------------------------
  !!
  !!  last checked/modified: marco giometto ( mgiometto@gmail.com ) on 26/03/2013
  !!
  !!--------------------------------------------------------------------------------
  subroutine dns_stress (dcp,Re,lbc_special)
    implicit none

    TYPE(DECOMP_INFO),intent(in) :: dcp
    real(rprec),intent(in) :: Re
    character(*),intent(in) :: lbc_special

    integer :: i,j,k,k_min

    ! txx,tyy,tzz,txy on uvp-nodes & txz,tyz on w-nodes
    if((dcp%xst(3)==1).and.(lbc_special.eq.'wall_law'))then
       do j=1,dcp%xsz(2)
          do i=1,dcp%xsz(1)
             txx(i,j,1)=2.0_rprec*dudx(i,j,1)/Re
             tyy(i,j,1)=2.0_rprec*dvdy(i,j,1)/Re
             tzz(i,j,1)=2.0_rprec*dwdz(i,j,1)/Re
             txy(i,j,1)=(dudy(i,j,k)+dvdx(i,j,1))/Re
          enddo
       enddo
       k_min=2
    else
       k_min=1
    end if

    !$omp parallel do
    do k=k_min,dcp%xsz(3)
       do j=1,dcp%xsz(2)
          do i=1,dcp%xsz(1)
             txx(i,j,k)=2.0_rprec*dudx(i,j,k)/Re
             tyy(i,j,k)=2.0_rprec*dvdy(i,j,k)/Re
             tzz(i,j,k)=2.0_rprec*dwdz(i,j,k)/Re
             txy(i,j,k)=(dudy(i,j,k)+dvdx(i,j,k))/Re
             txz(i,j,k)=(dudz(i,j,k)+dwdx(i,j,k))/Re
             tyz(i,j,k)=(dvdz(i,j,k)+dwdy(i,j,k))/Re
          enddo
       enddo
    enddo
   !$omp end parallel do

    return
  end subroutine dns_stress

end module compute_dns_stress