!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Spherepack                            *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(gradient_routines) gradient_regular_grid_saved

contains

    !     subroutine grades(nlat, nlon, isym, nt, v, w, idvw, jdvw, a, b, mdab, ndab, &
    !                       wvhses, ierror)
    !
    !     given the scalar spherical harmonic coefficients a and b, precomputed
    !     by subroutine shaes for a scalar field sf, subroutine grades computes
    !     an irrotational vector field (v, w) such that
    !
    !           gradient(sf) = (v, w).
    !
    !     v is the colatitudinal and w is the east longitudinal component
    !     of the gradient.  i.e.,
    !
    !            v(i, j) = d(sf(i, j))/dtheta
    !
    !     and
    !
    !            w(i, j) = 1/sint*d(sf(i, j))/dlambda
    !
    !     at colatitude
    !
    !            theta(i) = (i-1)*pi/(nlat-1)
    !
    !     and longitude
    !
    !            lambda(j) = (j-1)*2*pi/nlon.
    !
    !     where sint = sin(theta(i)).  required associated legendre polynomials
    !     are stored rather than recomputed as they are in subroutine gradec
    !
    !
    !     input parameters
    !
    !
    !     nlat   the number of colatitudes on the full sphere including the
    !            poles. for example, nlat = 37 for a five degree grid.
    !            nlat determines the grid increment in colatitude as
    !            pi/(nlat-1).  if nlat is odd the equator is located at
    !            grid point i=(nlat + 1)/2. if nlat is even the equator is
    !            located half way between points i=nlat/2 and i=nlat/2+1.
    !            nlat must be at least 3. note: on the half sphere, the
    !            number of grid points in the colatitudinal direction is
    !            nlat/2 if nlat is even or (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater than
    !            3.  the efficiency of the computation is improved when nlon
    !            is a product of small prime numbers.
    !
    !
    !     isym   this has the same value as the isym that was input to
    !            subroutine shaes to compute the arrays a and b from the
    !            scalar field sf.  isym determines whether (v, w) are
    !            computed on the full or half sphere as follows:
    !
    !      = 0
    !
    !           sf is not symmetric about the equator. in this case
    !           the vector field (v, w) is computed on the entire sphere.
    !           i.e., in the arrays  v(i, j), w(i, j) for i=1, ..., nlat and
    !           j=1, ..., nlon.
    !
    !      = 1
    !
    !           sf is antisymmetric about the equator. in this case w is
    !           antisymmetric and v is symmetric about the equator. w
    !           and v are computed on the northern hemisphere only.  i.e.,
    !           if nlat is odd they are computed for i=1, ..., (nlat + 1)/2
    !           and j=1, ..., nlon.  if nlat is even they are computed for
    !           i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !      = 2
    !
    !           sf is symmetric about the equator. in this case w is
    !           symmetric and v is antisymmetric about the equator. w
    !           and v are computed on the northern hemisphere only.  i.e.,
    !           if nlat is odd they are computed for i=1, ..., (nlat + 1)/2
    !           and j=1, ..., nlon.  if nlat is even they are computed for
    !           i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !
    !     nt     nt is the number of scalar and vector fields.  some
    !            computational efficiency is obtained for multiple fields.
    !            the arrays a, b, v, and w can be three dimensional corresponding
    !            to an indexed multiple array sf.  in this case, multiple
    !            vector synthesis will be performed to compute each vector
    !            field.  the third index for a, b, v, and w is the synthesis
    !            index which assumes the values k = 1, ..., nt.  for a single
    !            synthesis set nt = 1.  the description of the remaining
    !            parameters is simplified by assuming that nt=1 or that a, b, v,
    !            and w are two dimensional arrays.
    !
    !     idvw   the first dimension of the arrays v, w as it appears in
    !            the program that calls grades. if isym = 0 then idvw
    !            must be at least nlat.  if isym = 1 or 2 and nlat is
    !            even then idvw must be at least nlat/2. if isym = 1 or 2
    !            and nlat is odd then idvw must be at least (nlat + 1)/2.
    !
    !     jdvw   the second dimension of the arrays v, w as it appears in
    !            the program that calls grades. jdvw must be at least nlon.
    !
    !     a, b    two or three dimensional arrays (see input parameter nt)
    !            that contain scalar spherical harmonic coefficients
    !            of the scalar field array sf as computed by subroutine shaes.
    !     ***    a, b must be computed by shaes prior to calling grades.
    !
    !     mdab   the first dimension of the arrays a and b as it appears in
    !            the program that calls grades (and shaes). mdab must be at
    !            least min(nlat, (nlon+2)/2) if nlon is even or at least
    !            min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     ndab   the second dimension of the arrays a and b as it appears in
    !            the program that calls grades (and shaes). ndab must be at
    !            least nlat.
    !
    !
    !   wvhses   an array which must be initialized by subroutine gradesi
    !            (or equivalently by subroutine vhsesi).  once initialized,
    !            wsav can be used repeatedly by grades as long as nlon
    !            and nlat remain unchanged.  wvhses must not be altered
    !            between calls of grades.
    !
    !
    !  lvhses    the dimension of the array wvhses as it appears in the
    !            program that calls grades. define
    !
    !               l1 = min(nlat, nlon/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd.
    !
    !            then lvhses must be greater than or equal to
    !
    !               (l1*l2*(2*nlat-l1+1))/2+nlon+15
    !
    !     output parameters
    !
    !
    !     v, w   two or three dimensional arrays (see input parameter nt) that
    !           contain an irrotational vector field such that the gradient of
    !           the scalar field sf is (v, w).  w(i, j) is the east longitude
    !           component and v(i, j) is the colatitudinal component of velocity
    !           at colatitude theta(i) = (i-1)*pi/(nlat-1) and longitude
    !           lambda(j) = (j-1)*2*pi/nlon. the indices for v and w are defined
    !           at the input parameter isym.  the vorticity of (v, w) is zero.
    !           note that any nonzero vector field on the sphere will be
    !           multiple valued at the poles [reference swarztrauber].
    !
    !
    !  ierror   = 0  no errors
    !           = 1  error in the specification of nlat
    !           = 2  error in the specification of nlon
    !           = 3  error in the specification of isym
    !           = 4  error in the specification of nt
    !           = 5  error in the specification of idvw
    !           = 6  error in the specification of jdvw
    !           = 7  error in the specification of mdab
    !           = 8  error in the specification of ndab
    !           = 9  error in the specification of lvhses
    !
    module subroutine grades(nlat, nlon, isym, nt, v, w, idvw, jdvw, a, b, mdab, ndab, &
        wvhses, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: isym
        integer(ip), intent(in)  :: nt
        real(wp),    intent(out) :: v(idvw, jdvw, nt)
        real(wp),    intent(out) :: w(idvw, jdvw, nt)
        integer(ip), intent(in)  :: idvw
        integer(ip), intent(in)  :: jdvw
        real(wp),    intent(in)  :: a(mdab, ndab, nt)
        real(wp),    intent(in)  :: b(mdab, ndab, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(in)  :: wvhses(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip) :: idz, imid
        integer(ip) :: required_wavetable_size
        integer(ip) :: lzimn, mmax

        ! Check calling arguments
        ierror = 1
        if (nlat < 3) return
        ierror = 2
        if (nlon < 4) return
        ierror = 3
        if (isym < 0 .or. isym > 2) return
        ierror = 4
        if (nt < 0) return
        ierror = 5
        imid = (nlat + 1)/2
        if ((isym == 0 .and. idvw<nlat) .or. &
            (isym /= 0 .and. idvw<imid)) return
        ierror = 6
        if (jdvw < nlon) return
        ierror = 7
        mmax = min(nlat, (nlon + 1)/2)
        if (mdab < min(nlat, (nlon+2)/2)) return
        ierror = 8
        if (ndab < nlat) return
        ierror = 9
        !
        !     verify minimum saved workspace length
        !
        idz = (mmax*(2*nlat-mmax+1))/2
        lzimn = idz*imid
        required_wavetable_size = 2*lzimn+nlon+15
        if (size(wvhses) < required_wavetable_size) return
        ierror = 0

        call gradient_lower_utility_routine(nlat, nlon, isym, nt, v, w, idvw, jdvw, a, b, &
            wvhses, vhses, ierror)

    end subroutine grades

end submodule gradient_regular_grid_saved


FUNCTION MULTINT(X,Y)
INTEGER MULTINT, X, Y
MULTINT = X * Y
END


PROGRAM carre_magique
	USE matrices
	IMPLICIT NONE

	INTEGER, DIMENSION(:,:), ALLOCATABLE :: mat
	INTEGER :: n, ok, il, ic, k

	PRINT*, 'Saisie de la matrice:'
	CALL saisit_impair(n)

	ALLOCATE(mat(n,n), STAT=ok)
	IF(ok/=0)STOP "L'allocation a echoue"
	mat=0

	il=n
	ic=n/2+1
	mat(il, ic)=1

	DO k=2,n**2
		IF(mat(plus_un(il,n), plus_un(ic,n))==0)THEN
			il=plus_un(il,n)
			ic=plus_un(ic,n)
		ELSE
			il=moins_un(il,n)
		END IF
		mat(il,ic)=k
	END DO

	PRINT*, 'Affichage de la matrice:'
	CALL affiche(mat)

DEALLOCATE(mat)
END PROGRAM carre_magique


module sort_data_module
    interface sort_data
        ! We use only two types for example
        module procedure sort_real_dp
        module procedure sort_integer_32
    end interface

    contains
    subroutine sort_real_dp(raw_data, how_many)
        use iso_fortran_env, wp => real64
        implicit none

        integer, intent(in) :: how_many
        real(wp), dimension(:), intent(inout) :: raw_data

        call quicksort(1,how_many)

        contains
        recursive subroutine quicksort(l, r)
            implicit none

            integer, intent(in) :: l, r
            integer :: i, j
            real(wp) :: v, t

            include 'quicksort_include_code.f90'
        end subroutine
    end subroutine sort_real_dp

    subroutine sort_integer_32(raw_data, how_many)
        use iso_fortran_env, wp => int32
        implicit none

        integer, intent(in) :: how_many
        integer(wp), dimension(:), intent(inout) :: raw_data

        call quicksort(1,how_many)

        contains
        recursive subroutine quicksort(l, r)
            implicit none

            integer, intent(in) :: l, r
            integer :: i, j
            integer(wp) :: v, t

            include 'quicksort_include_code.f90'
        end subroutine
    end subroutine sort_integer_32
end module


# include "define.inc"

!> A module which defines a variety of constants, for example,
!! mathematical constants like pi, dimensions of arrays whose sizes are
!! set at compile time, and kind parameters.
!!
!! This module must not be compiled with a padding option
!! such as -qautodbl=dbl of xlf which makes type conversion
!! of variables even with explicit kind statements.
!!
module constants
  implicit none

  private

  public :: size_of

  public :: kind_is, kind_id, kind_rs, kind_rd
# ifdef QUAD_PRECISION
  public :: kind_rq
# endif

  public :: dp, sp, spc, dpc, ii

  public :: zi, dzi, pi, twopi, dpi, dtwopi

# ifdef NAG_PREC
  public :: nag_kind
# endif

  public :: run_name_size

  !> Defines the length of character string used to store all
  !! file names that are based on the run_name prefix.
#ifdef RUN_NAME_SIZE
  integer, parameter :: run_name_size = RUN_NAME_SIZE
#else
  integer, parameter :: run_name_size = 2000
#endif

  !> Symbolic names for kind type of single and double-precision reals:
  !! (with at least 6 and 12 digits of accuracy)
  integer, parameter :: kind_i1 = selected_int_kind (2)
  integer, parameter :: kind_ih = selected_int_kind (4)
  integer, parameter :: kind_is = selected_int_kind (8)
  integer, parameter :: kind_id = selected_int_kind (15)
  integer, parameter :: kind_rs = selected_real_kind (p=6)
  integer, parameter :: kind_rd = selected_real_kind (p=12)
# ifdef QUAD_PRECISION
  ! There is a selected_real_kind bug in xlf and the following doesn't work
  integer, parameter :: kind_rq = selected_real_kind (p=24)
# endif

  ! <EGH

  !> Single precision real kind. Needed for gryffin99, a fork of the Hammett, Beer & Dorland code
  !! from 1999
  integer, parameter :: sp = selected_real_kind(6)
  !> Double precision real kind. Needed for gryffin99, a fork of the Hammett, Beer & Dorland code
  !! from 1999
  integer, parameter :: dp = selected_real_kind(12)
  !> Single precision complex kind. Needed for gryffin99, a fork of the Hammett, Beer & Dorland code
  !! from 1999
  integer, parameter :: spc = kind((1.0_sp,1.0_sp))
  !> Double precision complex kind. Needed for gryffin99, a fork of the Hammett, Beer & Dorland code
  !! from 1999
  integer, parameter :: dpc = kind((1.0_dp,1.0_dp))
  !> Square root of -1. Needed for gryffin99, a fork of the Hammett, Beer & Dorland code
  !! from 1999
  complex(dp), parameter :: ii = (0._dp, 1._dp)
  ! EGH>

  integer, parameter :: sizeof_i1 = 1
  integer, parameter :: sizeof_ih = 2
  integer, parameter :: sizeof_is = 4
  integer, parameter :: sizeof_id = 8
  integer, parameter :: sizeof_rs = 4
  integer, parameter :: sizeof_rd = 8
  integer, parameter :: sizeof_rq = 16
  integer, parameter :: sizeof_cs = 8
  integer, parameter :: sizeof_cd = 16
  integer, parameter :: sizeof_cq = 32

# if NAG_PREC == _NAGDBLE_
  integer, parameter :: nag_kind=kind_rd
# elif NAG_PREC == _NAGSNGL_
  integer, parameter :: nag_kind=kind_rs
# endif

  !> Square root of -1.
  complex, parameter :: zi = ( 0.0 , 1.0 )
  complex (kind=kind(1.d0)), parameter :: dzi = ( 0.d0 , 1.d0 )

  !> Pi to quad precision, (double if DBLE is unset)
  double precision, parameter :: dpi = &
       3.14159265358979323846264338327950288419716939938
  !> 2*Pi to quad precision, (double if DBLE is unset)
  double precision, parameter :: dtwopi=2.*dpi
  !> Pi to double precision, (single if DBLE is unset)
  real, parameter :: pi = dpi
  !> 2*Pi to double precision, (single if DBLE is unset)
  real, parameter :: twopi= dtwopi

! Note: we will use dp="double precision" for almost everything.
!
! The fortran-90 "kind" types is kind of awkward.  But the old trick of
! using a "-r8" compiler switch to promote all real variables to 64 bits
! doesn't work on some fortran 90 compilers, and so the above use of
! the standard fortran-90 routine selected_real_kind is more portable.
!
! It may not be a good idea to mimic "-r8" by making sp to be identical
! to dp, or to write single and double-precision versions of
! generic subroutines, since on the Cray computers both single and
! "double" precision are 64 bits, and the compiler will complain that
! it can't distinguish the two specific subroutines.  In some cases,
! the cray compiler may be able to distinguish between two real "kinds"
! for the purposes of distinguishing overloaded procedure names,
! even though the two real kinds map to the same precision (64 bits).
!
! If this ever does become a problem, then you may be able to get around it by
! commenting out the double precision function names from the list of
! overloaded procedures (i.e., the "module procedure" statements).
!

  interface size_of
     module procedure size_of_i1, size_of_ih, size_of_is, size_of_id
     module procedure size_of_rs, size_of_rd
     module procedure size_of_cs, size_of_cd
# ifdef QUAD_PRECISION
     module procedure size_of_rq, size_of_cq
# endif
  end interface

contains
  integer function size_of_i1 (arg)
    integer (kind_i1), intent(in) :: arg
    size_of_i1 = sizeof_i1
  end function size_of_i1

  integer function size_of_ih (arg)
    integer (kind_ih), intent(in) :: arg
    size_of_ih = sizeof_ih
  end function size_of_ih

  integer function size_of_is (arg)
    integer (kind_is), intent(in) :: arg
    size_of_is = sizeof_is
  end function size_of_is

  integer function size_of_id (arg)
    integer (kind_id), intent(in) :: arg
    size_of_id = sizeof_id
  end function size_of_id

  integer function size_of_rs (arg)
    real (kind_rs), intent(in) :: arg
    size_of_rs = sizeof_rs
  end function size_of_rs

  integer function size_of_rd (arg)
    real (kind_rd), intent(in) :: arg
    size_of_rd = sizeof_rd
  end function size_of_rd

# ifdef QUAD_PRECISION
  integer function size_of_rq (arg)
    real (kind_rq) :: arg
    size_of_rq = sizeof_rq
  end function size_of_rq
# endif

  integer function size_of_cs (arg)
    complex (kind_rs), intent(in) :: arg
    size_of_cs = sizeof_cs
  end function size_of_cs

  integer function size_of_cd (arg)
    complex (kind_rd), intent(in) :: arg
    size_of_cd = sizeof_cd
  end function size_of_cd

# ifdef QUAD_PRECISION
  integer function size_of_cq (arg)
    complex (kind_rq) :: arg
    size_of_cq = sizeof_cq
  end function size_of_cq
# endif

end module constants

!  real, parameter :: pi = 3.1415926535897931
!  real, parameter :: pi = 3.14159265358979323846, twopi=2.*pi
  ! this is actually quad precision
! Symbolic names for kind type of single and double-precision complex:

!  integer, parameter :: spc = kind((1.0_sp,1.0_sp))
!  integer, parameter :: dpc = kind((1.0_dp,1.0_dp))

!  complex(dp), parameter :: ii = (0._dp, 1._dp)
!  real(dp), parameter :: pi=3.141592653589793238_dp


program strip_mining
  use iso_fortran_env, only : real64
  implicit none

  integer, parameter :: n = 1048576, m=65536
  integer, parameter :: tile = 32
  integer :: i,j,jj
  real(real64),allocatable:: a(:), b(:), c(:)
  real(real64) :: rec

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

  rec = 1.0/n

  do i = 1, n
     a(i) = rec
     c(i) = i
  end do

  do i = 1, m
     b(i) = i*2.0
  end do

  do jj = 1, m, tile
     do i = 1, n
        do j = jj, jj + (tile - 1)
           c(i) = c(i) + a(i) * b(j) * 2*rec
        end do
     end do
  end do

  write(*,*) c(100),c(1000)

end program strip_mining


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

module mod_vector

  use, intrinsic :: iso_fortran_env, only: ik => int32, rk => real64

  implicit none

  private
  public :: vector_t, operator(.unitnorm.), operator(.dot.), operator(.cross.), angle_between

  type vector_t
    real(rk) :: x = 0.0_rk
    real(rk) :: y = 0.0_rk
    real(rk) :: length = 0.0_rk
  contains
    private
    procedure, pass :: write => write_vector
    generic, public :: write(formatted) => write
  endtype

  interface vector_t
    module procedure :: constructor, constructor_from_2d
  endinterface

  interface operator(.unitnorm.)
    module procedure unit_normal
  endinterface

  interface operator(.cross.)
    module procedure vec_cross_product
  endinterface

  interface operator(.dot.)
    module procedure vec_dot_product
  endinterface

contains

  type(vector_t) pure function constructor(x, y) result(vec)
    !< Construcgtor from an (x,y) pair
    real(rk), intent(in) :: x
    real(rk), intent(in) :: y

    vec%x = x
    vec%y = y
    vec%length = sqrt(vec%x**2 + vec%y**2)
  endfunction

  type(vector_t) pure function constructor_from_2d(x, y) result(vec)
    ! //TODO: fix this so no temp array copy warning issued
    !< Constructor from a set of (x,y) pairs
    real(rk), intent(in), dimension(2) :: x !< (x1,x2)
    real(rk), intent(in), dimension(2) :: y !< (y1,y2)

    vec%x = x(2) - x(1)
    vec%y = y(2) - y(1)
    vec%length = sqrt(vec%x**2 + vec%y**2)
  endfunction

  subroutine write_vector(self, unit, iotype, v_list, iostat, iomsg)
    !< Implementation of `write(*,*) vector_t`

    class(vector_t), intent(in) :: self  !< vector class
    integer, intent(in) :: unit  !< input/output unit
    character(*), intent(in) :: iotype
    integer, intent(in)  :: v_list(:)
    integer, intent(out) :: iostat
    character(*), intent(inout) :: iomsg

    write(unit, '(3(a,f0.4))', iostat=iostat) 'Vector(x,y): (', self%x, ', ', self%y, ') Length: ', self%length
  endsubroutine

  type(vector_t) pure function unit_normal(vec) result(norm_vec)
    !< Creat the .unitnorm. operator for the vector_t type
    class(vector_t), intent(in) :: vec
    norm_vec = vector_t(x=vec%x / vec%length, y=vec%y / vec%length)
  endfunction

  real(rk) pure function vec_dot_product(vec1, vec2) result(scalar_dot_product)
    !< Create the .dot. operator for the vector_t type
    class(vector_t), intent(in) :: vec1, vec2
    scalar_dot_product = dot_product([vec1%x, vec1%y],[[vec2%x, vec2%y]])
  endfunction

  real(rk) pure function vec_cross_product(vec1, vec2) result(cross_product)
    !< Create the .cross. operator for the vector_t type. Since these vectors are only 2d, then
    !< the cross product is a scalar quantity
    class(vector_t), intent(in) :: vec1, vec2

    cross_product = vec1%x * vec2%y - vec1%y * vec2%x
  endfunction

  real(rk) pure function angle_between(vec1, vec2) result(angle)
    class(vector_t), intent(in) :: vec1, vec2

    angle = acos(vec1.dot.vec2) / (vec1%length * vec2%length)
  endfunction

endmodule mod_vector


! Variables that all files may need access too
! For instance the outfile unit for writing to the main file
!

module global_parameters_M

    implicit none

!---Define floats
    integer, parameter :: dp=kind(0.d0) !---double precision
    integer, parameter :: sp=kind(1.0)  !--- single precision

!---Nonlinear variables
    integer :: max_iter = 1 ! max num of nonlinear iterations to do
    integer :: max_nl_iter  ! numer of nonllinear iterations to do
    real(dp) :: tolerance = 0.001 ! prescribed tolerance
!---
    integer :: NumTimeSteps

!---Math constants
    real(dp) :: pi
    parameter (pi = 3.1415926535897932_dp)
!---THIS ASSUMES 1 CM MESH SIZING
    real(dp), dimension(3) :: elem_vol_int_fe
    data elem_vol_int_fe / 0.16666667198838597,0.66666665602322805, &
                          0.16666667198838597 /

    integer :: beta_counter

end module global_parameters_M


program main

   integer, parameter :: r9 = selected_real_kind(9, 99)

   print *, 'Information about : selected_real_kind(9, 99)'
   print *, 'KIND      : ', kind(1.1_r9)
   print *, 'PRECISION : ', precision(1.1_r9)
   print *, 'RANGE     : ', range(1.1_r9)

end program


c     =====================================================
      subroutine clawpack46_rpn2bu(ixy,maxm,meqn,mwaves,mbc,mx,ql,
     &   qr,auxl,auxr, wave,s,amdq,apdq)
c     =====================================================
c
c     # Riemann solver for Burgers' equation in 2d:
c     #  u_t + 0.5*(u^2)_x + 0.5*(u^2)_y = 0
c
c     # On input, ql contains the state vector at the left edge of each cell
c     #           qr contains the state vector at the right edge of each cell
c
c     # This data is along a slice in the x-direction if ixy=1
c     #                            or the y-direction if ixy=2.
c     # On output, wave contains the waves,
c     #            s the speeds,
c     #            amdq the  left-going flux difference  A^- \Delta q
c     #            apdq the right-going flux difference  A^+ \Delta q
c
c     # Note that the i'th Riemann problem has left state qr(i-1,:)
c     #                                    and right state ql(i,:)
c     # From the basic clawpack routines, this routine is called with ql = qr
c
c
      implicit double precision (a-h,o-z)
c
      dimension wave(1-mbc:maxm+mbc, meqn, mwaves)
      dimension    s(1-mbc:maxm+mbc, mwaves)
      dimension    ql(1-mbc:maxm+mbc, meqn)
      dimension    qr(1-mbc:maxm+mbc, meqn)
      dimension    auxl(1-mbc:maxm+mbc,2)
      dimension    auxr(1-mbc:maxm+mbc,2)

c      dimension  qpx(1-mbc:maxm+mbc, meqn)
      dimension    f(1-mbc:maxm+mbc, meqn)
c      dimension   fp(1-mbc:maxm+mbc, meqn)
c      dimension  fpx(1-mbc:maxm+mbc, meqn)

      dimension apdq(1-mbc:maxm+mbc, meqn)
      dimension amdq(1-mbc:maxm+mbc, meqn)

      double precision favgl, favgr

      logical efix

c
c
c     # x- and y- Riemann problems are identical, so it doesn't matter if
c     # ixy=1 or 2.
c
      efix = .false.

      do 30 i=3-mbc,mx+mbc-2
c
c        # Compute the wave and speed
c
         favgr = auxl(i,2)
         favgl = auxr(i-1,2)
         wave(i,1,1) = favgr - favgl
         s(i,1) = 0.5*(qr(i-1,1)+ql(i,1))

c        # compute left-going and right-going flux differences:
c        ------------------------------------------------------
         amdq(i,1) = -dmin1(sign(1d0,s(i,1)), 0.d0) * wave(i,1,1)
         apdq(i,1) =  dmax1(sign(1d0,s(i,1)), 0.d0) * wave(i,1,1)

c         if (efix) then
c           # entropy fix for transonic rarefactions:
c            if (q(i-1,1).lt.0.d0 .and. q(i,1).gt.0.d0) then
c               amdq(i,1) = - f(i-1,1)
c               apdq(i,1) =   f(i,1)
c               endif
c            endif

   30   continue
c
      return
      end


program kinds

   use iso_fortran_env

   implicit none

   integer :: i, my_kind

   real :: x_real              ! the default
   real*4 :: x_real4           ! Real with 4 bytes
   real*8 :: x_real8           ! Real with 8 bytes
   DOUBLE PRECISION :: x_db    ! Old way from FORTRAN 66

   integer, parameter :: k9 = selected_real_kind(9)
   real(kind=k9) :: r

   print *, 'Kind for integer            :', kind(i)
   print *, 'Kind for real               :', kind(x_real)
   print *, 'Kind for real*4             :', kind(x_real4)
   print *, 'Kind for real*8             :', kind(x_real8)
   print *, 'Kind for DOUBLE PRECISION   :', kind(x_db)
   print *, ''

   my_kind = selected_real_kind(9)
   print *, 'Which is the "kind" I should use to get 9 significant digits?  ', my_kind

   my_kind = selected_real_kind(15)
   print *, 'Which is the "kind" I should use to get 15 significant digits? ', my_kind

   r = 2._k9;
   print *, 'Value for k9', k9
   print *, 'Square root of 2.0 for default real      :', sqrt(2.0)   ! prints 1.41421354
   print *, 'Square root of 2.0 for DOUBLE PRECISION  :', sqrt(2.0d0) ! prints 1.41421354
   print *, 'Square root of 2.0 for numer of kind(k9) :', sqrt(r)     ! prints 1.4142135623730951

end program


      subroutine InterpFreq ( u, npts0, cu1, NN, nTotal, dt )
      real u(1)
      integer npts, m2, npts2, NN
      complex cu1(1)

      m2 = int( alog(float(npts0))/alog(2.) + 0.9999 )
      npts2 = 2**m2

c     PAD TO POWER OF 2 in the time domain
      do i=npts0+1,npts2
        u(i) = 0.
      enddo
      npts = npts2

c     FILL COMPLEX ARRAY
      do 10 i=1,npts
        cu1(i) = cmplx(u(i),0.0)
  10  continue

c     CALCULATE FORWARD FFT
      call cool ( -1., m2, cu1 )
      df = 1./(npts*dt)
c      do i=1,npts
c        write (60,'( f10.4, 2f12.4)') (i-1)*df, cu1(i)
c      enddo

c     Pad in the frequency domain
      iNyq = npts/2 + 1
      iNyq2 = NN * (npts/2) + 1
c      write (*,'( 2i10)') iNyq, iNyq2
      do i=iNyq+1,iNyq2
        cu1(i) = cmplx(0., 0.)
      enddo

c     Reset nyquist ot half its value (the other half will be added to the neg freq)
      cu1(iNyq) = cu1(iNyq)/2.

c     Load the negative frequencies
      nTotal = 2 * (iNyq2-1)
      do i=iNyq2+1,nTotal
        cu1(i) = conjg (cu1(nTotal+2-i))
      enddo

c     CALCULATE INVERSE FFT
      m3 = m2 + int( alog(float(NN))/alog(2.) + 0.5 )
      call cool ( 1., m3, cu1 )

c     Scale
      do i=1,nTotal
        u(i) = real(cu1(i)) /npts
      enddo

      return
      end


REAL AlphaE
IF (tau .LE. tauAlpha) THEN
	AlphaE = 1
ELSE
	AlphaE = Alpha - ((Alpha - 1) * (1 - tau) / (1 - tauAlpha))
ENDIF
energyLimitedEvaporation = (evapoTranspirationPriestlyTaylor / Alpha) * AlphaE * tau


subroutine nsc_CalculateConservatives(a,ncomp)
   use typre
   use Mod_NSCompressible

   implicit none

   class(NSCompressibleProblem) :: a
   integer(ip),intent(in)   :: ncomp

   integer(ip)             :: iffix_vel,iffix_tem
   integer(ip)             :: idime,ipoin,ndime,npoin,icomp
   real(rp)                :: acvis,actco,accph,accvh

   call a%Mesh%GetNpoin(npoin)
   call a%Mesh%GetNdime(ndime)
   !Physical Parameters
   call a%GetPhysicalParameters(acvis,actco,accph,accvh)

   do icomp = 1,ncomp

      do ipoin = 1,npoin

         iffix_tem = a%kfl_fixno(a%ndofbc,ipoin)
         if(iffix_tem==1) then
             a%tempe(ipoin,icomp)= a%bvess(a%ndofbc,ipoin,1)
         end if

         ! Ideal Gas State Law (could expand into a module)
         a%densf(ipoin,icomp) = (a%press(ipoin,icomp)+a%relpre)/((accph - accvh) * (a%tempe(ipoin,icomp)+a%reltem))

         do idime = 1,ndime
            iffix_vel = a%kfl_fixno(idime+1,ipoin)
            if(iffix_vel==1) then
               a%veloc(idime,ipoin,icomp) = a%bvess(idime+1,ipoin,1)
            end if
            a%momen(idime,ipoin,icomp) = a%veloc(idime,ipoin,icomp) * a%densf(ipoin,icomp)
         end do

         a%energ(ipoin,icomp) = a%densf(ipoin,icomp)*(accvh*(a%tempe(ipoin,icomp)+a%reltem)+dot_product(a%veloc(:,ipoin,icomp),a%veloc(:,ipoin,icomp))/ 2.0_rp)

      enddo
   enddo

end subroutine nsc_CalculateConservatives


       subroutine cl(splc,pref2,wtxt)
C
c put array size parameters in include file - BMS Aug 4 2005

c increase storage space from 65536 to 131072 - July 19 1993
c increase storage space from 32768 to 65536 - April 29 1993
C  Calculates c-weighted level of spectrum based on
c  returned results from FFT passed through in array xt in common spec.
c  Returned value in splc.
c  Square of reference pressure passed through in pref2.
C
c                            B.M.Sullivan Sept 23 1988
c ref1 = American National Standards Institute S12.4
c          "Specifications for Sound Level Meters"

c       parameter (power2 = 131072)
c parameters now in include file
       include 'sigpair_size.inc'
       real fdelta, XT(power2)
       integer m
       common /spec/ XT, m, fdelta

       real wtxt(power2)

       parameter (f1=20.598997,f4=12194.22,const=1.00715)

       const2 = const*const

       splc = 0.0
C First frequency is zero, where the result is 0.0
       do 100 i=2,m
          freq_now = fdelta*(i-1)
          freq_ratio1 = (freq_now/f1)**2
          freq_ratio4 = (freq_now/f4)**2
          weightc = const2 * (freq_ratio1**2) /
     1               ( ((1 + freq_ratio1)**2) *
     2               ((1 + freq_ratio4)**2) )
c (With the 1/3 o.b. levels, we divided by 0.07 (sec) because of the integration
c time of the ear (a la Johnson and Robinson), as the band levels were destined
c for the PL routine. Here, because of the fact that sound level meters are
c assumed to have a 1 sec. integration time, we divide by 1.0 (sec) which is
c invisible.)
	  wtxt(i) = xt(i) * weightc
          splc = splc + wtxt(i)

 100   continue

       if (splc .gt. 0.0) then
          splc = 10.0*log10(splc/pref2)
       else
          splc = 0.0
       endif

       return
       end

       subroutine al(spla,pref2,wtxt)
C
c put array size parameters in include file - BMS Aug 4 2005

c make it a tiny (and so far as I can see unneccesary) bit safer
c            by using ctemp (qv) - BMS Oct 3 1994
c increase storage space from 32768 to 131072 - july 19 1993
C  Calculates a-weighted level of spectrum based on
c  returned results from FFT passed through in array xt in common spec.
c  Returned value in spla.
c  Square of reference pressure passed through in pref2.
C
c                            B.M.Sullivan Oct 19 1988
c ref = "Algebraic Expression for A-Weighting Response" R.M.Aarts, Journal of
c          Sound and Vibration (1987), vol 115(2), p 372

c       parameter (power2 = 131072)
c parameters now in include file
       include 'sigpair_size.inc'
       common /spec/ xt(power2), m, fdelta

       real wtxt(power2)

       complex compfrq,compwt,compdenom,compfact(6),ctemp
       real param(6),factor

       data param / 20.6,20.6,107.7,737.9,12200.0,12200.0/
       data consta /7.397234E+9/

       pi = acos(-1.)
       piby2 = 2.*pi
       do 100 j=1,6
          factor = piby2 * param(j)
          compfact(j) = cmplx(factor,0.0)
 100   continue

       spla = 0.0
C First frequency is zero, where the result is 0.0, so start at 2
       do 200 i=2,m
          freq_now = fdelta*(i-1)
c Redefine frequency from Hz to radians, and make it complex
          freq_rad = freq_now * piby2
          compfrq = cmplx(0.0,freq_rad)
          compdenom  = (compfrq + compfact(1))
          do 150 j=2,6
             compdenom  = compdenom  * (compfrq + compfact(j))
 150      continue
          ctemp = compdenom / consta
          compwt = ( (compfrq**4) / ctemp )
          weighta = cabs (compwt)

c This is a weighting on pressure (not pressure**2), so square it for XT use.
c (With the 1/3 o.b. levels, we divided by 0.07 (sec) because of the integration
c time of the ear (a la Johnson and Robinson), as the band levels were destined
c for the PL routine. Here, because of the fact that sound level meters are
c assumed to have a 1 sec. integration time, we divide by 1.0 (sec) which is
c invisible.)
	  wtxt(i) = xt(i) * weighta * weighta
          spla = spla + wtxt(i)
 200   continue

       if (spla .gt. 0.0) then
          spla = 10.0*log10(spla/pref2)
       else
          spla = 0.0
       endif

       return
       end

       subroutine lin(spllin,pref2)
C
c put array size parameters in include file - BMS Aug 4 2005

c increase storage space from 32768 to 131072 - july 19 1993
C  Calculates unweighted (linear) level of spectrum based on
c  returned results from FFT passed through in array xt in common spec.
c  Returned value in spllin.
c  Square of reference pressure passed through in pref2.
C
c                            B.M.Sullivan Aug 30 1990

c       parameter (power2 = 131072)
c parameters now in include file
       include 'sigpair_size.inc'
       common /spec/ xt(power2), m, fdelta

       spllin = 0.0
C First frequency is zero, where the result is 0.0
       do 100 i=2,m
c (With the 1/3 o.b. levels, we divided by 0.07 (sec) because of the integration
c time of the ear (a la Johnson and Robinson), as the band levels were destined
c for the PL routine. Here, because of the fact that sound level meters are
c assumed to have a 1 sec. integration time, we divide by 1.0 (sec) which is
c invisible.)
          spllin = spllin + xt(i)
 100   continue

       if (spllin .gt. 0.0) then
          spllin = 10.0*log10(spllin/pref2)
       else
          spllin = 0.0
       endif

       return
       end


c     ============================================
      subroutine setaux(maxmx,maxmy,mbc,mx,my,xlower,ylower,dxc,dyc,
     &                  maux,aux,Rsphere)
c     ============================================
c
c     # Set auxiliary arrays for shallow water equations on the sphere.
c
c     # On input: (xc(i),yc(j)) gives uniformly spaced computational grid.
c     # On output: he aux array has the following elements:
c         1  kappa = ratio of cell area to dxc*dyc
c         2  enx = x-component of normal vector to left edge in tangent plane
c         3  eny = y-component of normal vector to left edge in tangent plane
c         4  enz = z-component of normal vector to left edge in tangent plane
c         5  etx = x-component of tangent vector to left edge in tangent plane
c         6  ety = y-component of tangent vector to left edge in tangent plane
c         7  etz = z-component of tangent vector to left edge in tangent plane
c         8  enx = x-component of normal vector to bottom edge in tangent plane
c         9  eny = y-component of normal vector to bottom edge in tangent plane
c        10  enz = z-component of normal vector to bottom edge in tangent plane
c        11  etx = x-component of tangent vector to bottom edge in tangent plane
c        12  ety = y-component of tangent vector to bottom edge in tangent plane
c        13  etz = z-component of tangent vector to bottom edge in tangent plane
c        14  erx = x-component of unit vector in radial direction at cell ctr
c        15  ery = y-component of unit vector in radial direction at cell ctr
c        16  erz = z-component of unit vector in radial direction at cell ctr
c
c
      implicit double precision (a-h,o-z)
      parameter (maxm3 = 1005)
      dimension xc(-3:maxm3), yc(-3:maxm3)
      dimension xp(-3:maxm3,-3:maxm3), yp(-3:maxm3,-3:maxm3)
      dimension zp(-3:maxm3,-3:maxm3)
      dimension theta(-3:maxm3,-3:maxm3), phi(-3:maxm3,-3:maxm3)
      dimension aux(maux,1-mbc:maxmx+mbc,1-mbc:maxmy+mbc)

cf2py integer intent(in) maxmx
cf2py integer intent(in) maxmy
cf2py integer intent(in) mbc
cf2py integer intent(in) mx
cf2py integer intent(in) my
cf2py double precision intent(in) xlower
cf2py double precision intent(in) ylower
cf2py double precision intent(in) dx
cf2py double precision intent(in) dy
cf2py integer optional, intent(in)  maux
cf2py intent(in,out) aux
cf2py double precision intent(in) Rsphere

      pi = 4.d0*datan(1.d0)

      if (mbc .gt. 4) then
          write(6,*)'***  increase size of local arrays in setaux ***'
          stop
      endif

      if (mx+mbc+1.gt.1005 .or. my+mbc+1.gt.1005) then
          write(6,*)'***  increase size of 1005 in setaux ***'
          stop
      endif
c
c     # Set xc and yc so that (xc(i),yc(j)) is the
c     # lower left corner of (i,j) cell in computational space:
c
      do 10 i=1-mbc,mx+mbc+1
         xc(i) = xlower + (i-1.d0) * dxc
   10    continue
c
      do 12 j=1-mbc,my+mbc+1
         yc(j) = ylower + (j-1.d0) * dyc
   12    continue

c     # compute cell corners on sphere and angles phi, theta
c     # related to latitude and longitude
c
      do 15 j=1-mbc,my+mbc+1
         do 15 i=1-mbc,mx+mbc+1

c           # map computational point to (xp,yp,zp) on sphere:
            call mapc2p(xc(i),yc(j),xp(i,j),yp(i,j),zp(i,j),Rsphere)

c           # compute longitude theta from positive x axis:
            r = dsqrt(xp(i,j)**2 + yp(i,j)**2)

c            theta(i,j) = atan2(xp(i,j),yp(i,j))

             if (r.gt.1.d-4) then
               theta(i,j) = dacos(xp(i,j)/r)
             elseif (yp(i,j).gt.0.d0) then
               theta(i,j) = 0.d0
             endif
             if (yp(i,j).lt.0.d0) then
               theta(i,j) = -theta(i,j)
             endif
c           # compute phi, angle down from north pole:
            if (zp(i,j) .gt. 0.d0) then
                phi(i,j) = pi/2.d0 - dacos(r/Rsphere)
              else
                phi(i,j) = pi/2.d0 + dacos(r/Rsphere)
              endif
   15	    continue

c
      do 20 j=1-mbc,my+mbc
         do 20 i=1-mbc,mx+mbc
c
c           # compute normal and tangent vectors to left edge (in tangent plane)
c
c           # tangent vector is edge vector:
            etx = xp(i,j+1) - xp(i,j)
            ety = yp(i,j+1) - yp(i,j)
            etz = zp(i,j+1) - zp(i,j)
            aux(5,i,j) = etx
            aux(6,i,j) = ety
            aux(7,i,j) = etz

c           # normal to sphere in radial direction at midpoint of edge:
            erx = 0.5d0*(xp(i,j) + xp(i,j+1))
            ery = 0.5d0*(yp(i,j) + yp(i,j+1))
            erz = 0.5d0*(zp(i,j) + zp(i,j+1))
c
c           # normal to edge in tangent plane is cross product of et and er:
            enx = ety*erz - etz*ery
            eny = etz*erx - etx*erz
            enz = etx*ery - ety*erx
            ennorm = dsqrt(enx**2 + eny**2 + enz**2)
            aux(2,i,j) = enx/ennorm
            aux(3,i,j) = eny/ennorm
            aux(4,i,j) = enz/ennorm

c           # compute normal and tangent vectors to bottom edge (in tang. pl.)
c
c           # tangent vector is edge vector:
            etx = xp(i+1,j) - xp(i,j)
            ety = yp(i+1,j) - yp(i,j)
            etz = zp(i+1,j) - zp(i,j)
            aux(11,i,j) = etx
            aux(12,i,j) = ety
            aux(13,i,j) = etz

c           # normal to sphere in radial direction at midpoint of edge:
            erx = 0.5d0*(xp(i,j) + xp(i+1,j))
            ery = 0.5d0*(yp(i,j) + yp(i+1,j))
            erz = 0.5d0*(zp(i,j) + zp(i+1,j))
c
c           # normal to edge in tangent plane is cross product of er and et:
            enx = ery*etz - erz*ety
            eny = erz*etx - erx*etz
            enz = erx*ety - ery*etx
            ennorm = dsqrt(enx**2 + eny**2 + enz**2)
            aux(8,i,j) = enx/ennorm
            aux(9,i,j) = eny/ennorm
            aux(10,i,j) = enz/ennorm

c           # normal to sphere in radial direction at cell center:
            xcm = xlower+(i-0.5)*dxc
            ycm = ylower+(j-0.5)*dyc
            call mapc2p(xcm,ycm,xpm,ypm,zpm,Rsphere)

            aux(14,i,j) = xpm
            aux(15,i,j) = ypm
            aux(16,i,j) = zpm

c           # compute area of physical cell from four corners:
c           # find area on the sphere of two spherical triangles obtained
c           # by subdividing rectangle.  See
c           #    http://mathforum.org/library/drmath/view/65316.html

c           # corners are labeled
c           #      1: (i,j)      2: (i+1,j)    3: (i,j+1)    4: (i+1,j+1)

            beta12 = dsin(phi(i,j))*dsin(phi(i+1,j))*
     &                  dcos(theta(i,j) - theta(i+1,j))
     &                + dcos(phi(i,j))*dcos(phi(i+1,j))
            beta23 = dsin(phi(i,j+1))*dsin(phi(i+1,j))*
     &                  dcos(theta(i,j+1) - theta(i+1,j))
     &                 + dcos(phi(i,j+1))*dcos(phi(i+1,j))
            beta13 = dsin(phi(i,j+1))*dsin(phi(i,j))*
     &                  dcos(theta(i,j+1) - theta(i,j))
     &                 + dcos(phi(i,j+1))*dcos(phi(i,j))
            beta24 = dsin(phi(i+1,j+1))*dsin(phi(i+1,j))*
     &                  dcos(theta(i+1,j+1) - theta(i+1,j))
     &                 + dcos(phi(i+1,j+1))*dcos(phi(i+1,j))
            beta34 = dsin(phi(i+1,j+1))*dsin(phi(i,j+1))*
     &                  dcos(theta(i+1,j+1) - theta(i,j+1))
     &                 + dcos(phi(i+1,j+1))*dcos(phi(i,j+1))

c           # great circles distances between corners:
            d12 = Rsphere * dacos(beta12)
            d23 = Rsphere * dacos(beta23)
            d13 = Rsphere * dacos(beta13)
            d24 = Rsphere * dacos(beta24)
            d34 = Rsphere * dacos(beta34)

            s123 = 0.5d0 * (d12 + d23 + d13)
            s234 = 0.5d0 * (d23 + d34 + d24)

c           # spherical excess for each triangle:
            t123 = dtan(s123/2.d0)*dtan((s123-d12)/2.d0)
     &             *dtan((s123-d23)/2.d0)*dtan((s123-d13)/2.d0)
            t123 = dmax1(t123,0.d0)
            E123 = 4.d0*datan(sqrt(t123))

            t234 = dtan(s234/2.d0)*dtan((s234-d23)/2.d0)
     &             *dtan((s234-d34)/2.d0)*dtan((s234-d24)/2.d0)
            t234 = dmax1(t234,0.d0)
            E234 = 4.d0*datan(sqrt(t234))

c           area = Rsphere**2 * (E123 + E234)
            area = (E123 + E234)
c
c           # capacity kappa:
            aux(1,i,j) = area / (dxc*dyc)

   20       continue

       return
       end


      subroutine diff (v, dr, kap, cl, dx, n, vm)
c     calculate  vm(i)=(dV/dx)*r(i)*(kap+1)/cl
c     needed for c3 term to calculate j-average phase shift
c     ref. koelling,harmon j.phys.c,3107(1977). eq.14
      implicit double precision (a-h,o-z)
       include '../HEADERS/dim.h'

      complex*16 v(n), vm(n), vt(nrptx)
      dimension dr(n)
      do 5 i = 1,n
 5    vt(i) = v(i) * dr(i)**2

      vm(1)=((6.0*vt(2)+6.66666666667*vt(4)+1.2*vt(6))-(2.45*vt(1)+7.
     1 5*vt(3)+3.75*vt(5)+.166666666667*vt(7)))/dx
      vm(2)=((6.0*vt(3)+6.66666666667*vt(5)+1.2*vt(7))-(2.45*vt(2)+7.
     1 5*vt(4)+3.75*vt(6)+.166666666667*vt(8)))/dx
      nm2=n-2
      do 10 i=3,nm2
   10 vm(i)=((vt(i-2)+8.0*vt(i+1))-(8.0*vt(i-1)+vt(i+2)))/12.0/dx
      vm(n-1)=(vt(n)-vt(n-2))/(2.0*dx)
      vm(n)=(vt(n-2)*.5-2.0*vt(n-1)+1.5*vt(n))/dx

      do 20 i = 1,n
 20   vm(i) = (vm(i)-2*vt(i))/dr(i) *(kap+1.0)/cl
      return
      end


! Copyright 2012-2018, University of Strathclyde
! Authors: Lawrence T. Campbell
! License: BSD-3-Clause

!> @author
!> Lawrence Campbell,
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> This module contains functions to transform macroparticle variables
!> from the relativistic factor gamma to the scaled longitudinal
!> velocity p2, and vice-versa.

module gtop2

use paratype

implicit none

contains

  subroutine getGamma(gamma, p2, px, py, eta, gamma0, aw)

    implicit none

! Return gamma, given p2, px, py and eta
!
!           ARGUMENTS

    real(kind=wp), intent(in) :: px(:), py(:), p2(:), eta, &
                                 gamma0, aw

!            OUTPUT

    real(kind=wp), intent(out) :: gamma(:)

!          LOCAL ARGS

    gamma = SQRT((1.0_WP + ( aw**2 * (px**2.0_WP + py**2.0_WP) )) * &
                  (1.0_WP + eta * p2 )**2.0_WP / &
                  ( eta * p2 * (eta * p2 + 2.0_WP) ) ) / gamma0

  end subroutine getGamma

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine getP2(p2, gamma, px, py, eta, gamma0, aw)

  implicit none

! Return p2, given Gamma, px, py and eta
!
!  ###########################################
!
!           ARGUMENTS
!
!
!
!  p2       :          Scaled velocity along wiggler axis (output)
!
!  gamma    :          Relativistic factor normalised to gamma_0
!
!  px, py   :          Electron macroparticle transverse momenta,
!                      normalised to aw * m_e * c
!
!  eta      :          Scaled longitudinal velocity of 'reference'
!                      energy
!
!  gamma_0  :          Relativistic factor of 'reference' energy
!
!  aw       :          Undulator parameter (peak)
!

    real(kind=wp), contiguous, intent(in) :: px(:), py(:), gamma(:)
    real(kind=wp), intent(in) :: eta, gamma0, aw

!            OUTPUT

    real(kind=wp), contiguous, intent(out) :: p2(:)

!$OMP WORKSHARE

    p2 = (( 1_wp/sqrt(1_wp - 1_wp / (gamma0**2 * gamma**2) * ( 1 + &
             aw**2*(px**2 + py**2))))-1_wp) / eta

!$OMP END WORKSHARE

  end subroutine getP2

end module gtop2


FUNCTION biodrag(bdrlai,bdrsai,bcrlai,bcrsai,bc0rg,bcxrow,bczht,bszrgh)
!
IMPLICIT NONE
!
INCLUDE 'p1unconv.inc'
!
! PARAMETER definitions
!
REAL,PARAMETER :: fur_dis = 0.5
!
! Function arguments
!
INTEGER :: bc0rg
REAL :: bcrlai,bcrsai,bcxrow,bczht,bdrlai,bdrsai,bszrgh
REAL :: biodrag
!
! Local variables
!
REAL :: red_fac,red_lai,red_sai
!
!     + + + purpose + + +
!     biodrag: combine effects of leaves and stems on drag coef.
!     calling subroutine needs b1glob.inc, c1gen.inc s1sgeo.inc

!     leaves are less effective at reducing the wind speed than
!     stems.  three effects are simulated: 1. streamlining of leaves,
!     2. leaf sheltered in furrow, and
!     3.leaf area confined in wide rows that act as wind barriers.
!     this function combines these effects into a single
!     value for use by other routines. may still be too large.

!     + + + keywords + + +
!     biodrag

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     biodrag  - drag coefficient (no units)
!     bdrlai   - residue leaf area index (sum of all pools)(m^2/m^2)
!     bdrsai   - residue stem silhouette area index (sum of all pools)(m^2/m^2)
!     bcrlai   - crop leaf area index (m^2/m^2)
!     bcrsai   - crop stem silhouette area index (m^2/m^2)
!     bc0rg    - crop seed location flag (0= in furrow, 1=on ridge)
!     bcxrow   - crop row spacing (m)(0 = broadcast)
!     bczht    - crop biomass height (m)
!     bszrgh   - ridge height (mm)

!     + + + parameters + + +
!     fur_dis  - coefficient for discounting drag of plant in furrow bottom

!     + + + global common blocks + + +

!     + + + local variables + + +

!     + + + local variable definitions + + +
!     red_lai     - reduced leaf area index (m^2/m^2)
!     red_sai     - reduced stem area index (m^2/m^2)
!     red_fac     - reduction factor

!     + + + end specifications + + +

      ! place crop values in temporary variables
red_lai = bcrlai
red_sai = bcrsai

      ! check for crop biomass position with respect to the ridge
IF (bc0rg.EQ.0) THEN
          ! biomass in furrow
          ! test plant height and ridge height for minimums
  IF (bczht.GT.(fur_dis*bszrgh*mmtom)) THEN
              ! sufficient height for some effect
     red_fac = (1.0-fur_dis*bszrgh*mmtom/bczht)
     red_lai = red_lai*red_fac
     red_sai = red_sai*red_fac

              ! check for row width effect
     IF (bcxrow.GT.bczht*5.0) THEN
        red_fac = 1.0/(0.92+0.021*bcxrow/(bczht-fur_dis*bszrgh*mmtom))
        red_lai = red_lai*red_fac
     END IF

  ELSE
              ! not tall enough to do anything
     red_lai = 0.0
     red_sai = 0.0
  END IF
          ! biomass not in furrow
          ! test plant height and ridge height for minimums
ELSE IF (bczht.GT.0.0) THEN
              ! check for row width effect
  IF (bcxrow.GT.bczht*5.0) THEN
     red_fac = 1.0/(0.92+0.021*bcxrow/bczht)
     red_lai = red_lai*red_fac
  END IF
ELSE
              ! not tall enough to do anything
  red_lai = 0.0
  red_sai = 0.0
END IF

      ! add discounted crop values to biomass values
red_lai = red_lai + bdrlai
red_sai = red_sai + bdrsai

      ! streamline effect for total leaf area
red_lai = red_lai*0.2*(1.0-exp(-red_lai))

      ! final result
biodrag = red_lai + red_sai
!
END FUNCTION biodrag

Project Documents/Source Code Original/Biodrag.f90


*DECK DPCOEF
      SUBROUTINE DPCOEF (L, C, TC, A)
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
      DOUBLE PRECISION A(*),C,FAC,SAVE,TC(*)
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


module statistics

contains
  !!$--------------------------------------------------

  subroutine density(N,iconfig,data)
    implicit real*8 (a-h,o-z)
    integer  ::N
    real*8   ::data(:)
    integer*1::iconfig(:)
    data( 1 ) = sum(iconfig)*1d0/N
    data( 2 ) = sum((iconfig - data(1))**2)/(N-1)
    return
  end subroutine density

!!$--------------------------------------------------

  subroutine update_mc_density(N,isamples,datum,data)
    implicit real*8 (a-h,o-z)
    real*8   ::data(:,:),datum(:,:)
    isteps = size(datum,1)
    istats = size(datum,2)
    r      = 1d0/isamples
    do i = 1,4
       data(:,i ) = data(:,i )+r*(datum(:,1)**i)
    end do
    return
  end subroutine update_mc_density

!!$--------------------------------------------------

  subroutine correlation(N,datum,corr)
    implicit real*8(a-h,o-z)
    integer::N
    real*8,intent(in ) ::datum(:)
    real*8,intent(out) ::corr(:,:)
    imax_delta = size(corr,2)/2
    isteps = size(datum,1)
    do k =1, imax_delta
       do istep = 1, (isteps - imax_delta)
          corr(istep,2*k-1) = datum(istep)* datum(istep+k)
          corr(istep,2*k  ) = datum(istep)*(datum(istep+k)**2)
       end do
    end do
    return
  end subroutine correlation

!!$--------------------------------------------------

  subroutine update_mc_correlation(N,isamples,ishift,corr1,corr2)
    implicit real*8(a-h,o-z)
    integer::N
    integer::isamples
    integer::ishift
    real*8,intent(in)   ::corr1(:,:)
    real*8,intent(inout)::corr2(:,:)
    r      = 1d0/real(isamples,8)
    isize  = size(corr2,2)
    corr2(:,ishift:isize) = corr2(:,ishift:isize) + ( corr1 * r )
    return
  end subroutine update_mc_correlation

end module statistics


SUBROUTINE asolve_sp(b,x,itrnsp)
  USE mo_kind, only: sp, i4
  USE mo_nrutil, ONLY : assert_eq,nrerror
  use mo_nr, ONLY : sprsdiag
  USE xlinbcg_data_sp
  REAL(SP), DIMENSION(:), INTENT(IN) :: b
  REAL(SP), DIMENSION(:), INTENT(OUT) :: x
  INTEGER(I4), INTENT(IN) :: itrnsp
  INTEGER(I4) :: ndum
  ndum=assert_eq(size(b),size(x),'asolve_sp')
  call sprsdiag(sa,x)
  if (any(x == 0.0_sp)) call nrerror('asolve_sp: singular diagonal matrix')
  x=b/x
END SUBROUTINE asolve_sp

SUBROUTINE asolve_dp(b,x,itrnsp)
  USE mo_kind, only: dp, i4
  USE mo_nrutil, ONLY : assert_eq,nrerror
  use mo_nr, ONLY : sprsdiag
  USE xlinbcg_data_dp
  REAL(DP), DIMENSION(:), INTENT(IN) :: b
  REAL(DP), DIMENSION(:), INTENT(OUT) :: x
  INTEGER(I4), INTENT(IN) :: itrnsp
  INTEGER(I4) :: ndum
  ndum=assert_eq(size(b),size(x),'asolve_dp')
  call sprsdiag(sa,x)
  if (any(x == 0.0_dp)) call nrerror('asolve_dp: singular diagonal matrix')
  x=b/x
END SUBROUTINE asolve_dp


module local_routines
    !!
    !! Setup the radial dam-break problem
    !!
    use global_mod, only: dp, ip, wall_elevation
    use domain_mod, only: domain_type, STG, UH, VH, ELV
    implicit none

    contains

    subroutine set_initial_conditions_radial_dam(domain)
        class(domain_type), target, intent(inout):: domain
        integer(ip):: i,j
        real(dp):: x, y, cx, cy, initial_stage_1, initial_stage_2, radius

        initial_stage_1 = 1.0_dp
        initial_stage_2 = 10.0_dp
        radius = 50.0_dp

        ! Stage
        domain%U(:,:,STG) = initial_stage_1

        ! Elevation
        domain%U(:,:,ELV) = 0._dp
        ! Wall boundaries (without boundary conditions)
        domain%U(1,:,ELV) = 20.0_dp !wall_elevation
        domain%U(domain%nx(1),:,4) = 20.0_dp !wall_elevation
        domain%U(:,1,ELV) = 20.0_dp !wall_elevation
        domain%U(:,domain%nx(2),ELV) = 20.0_dp !wall_elevation

        ! Ensure stage >= elevation
        domain%U(:,:,STG) = max(domain%U(:,:,STG), domain%U(:,:,ELV))

        ! Add a stage perturbation
        cx = (domain%lw(1))*0.5
        cy = (domain%lw(2))*0.5
        do i = 1,domain%nx(1)
            do j = 1, domain%nx(2)
                ! Set perturbation based on distance to the centre
                x = (i-0.5_dp)*domain%dx(1) - cx
                y = (j-0.5_dp)*domain%dx(2) - cy
                if( x*x + y*y < (radius)**2) then
                    domain%U(i,j,STG) = initial_stage_2 !10.0_dp
                end if
            end do
        end do

        domain%manning_squared = 0.0_dp

    end subroutine

end module

!@!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program radial_dam_break
    !!
    !! Radial dam-break problem
    !!
    use global_mod, only: ip, dp, charlen, default_nonlinear_timestepping_method
    use domain_mod, only: domain_type, STG, UH, VH, ELV
    use file_io_mod, only: read_csv_into_array
    use local_routines
    implicit none

    integer(ip):: i, nsteps
    real(dp):: last_write_time
    type(domain_type):: domain

    ! Approx timestep between outputs
    real(dp), parameter :: approximate_writeout_frequency = 0.2_dp
    real(dp), parameter :: final_time = 2.0_dp * 1

    ! length/width
    real(dp), parameter, dimension(2):: global_lw = [400._dp, 400._dp]
    ! lower-left corner coordinate
    real(dp), parameter, dimension(2):: global_ll = [0._dp, 0._dp]
    ! grid size (number of x/y cells)
    integer(ip), parameter, dimension(2):: global_nx = [400, 400] * 2 ! [400, 400]

    ! analytical solution
    real(dp), allocatable :: analytical_solution(:,:)
    character(len=charlen):: analytical_solution_file

    domain%timestepping_method = default_nonlinear_timestepping_method !'rk2' !'euler' !'rk2n'
    !domain%compute_fluxes_inner_method='EEC'

    ! Allocate domain
    CALL domain%allocate_quantities(global_lw, global_nx, global_ll)

    ! Call local routine to set initial conditions
    CALL set_initial_conditions_radial_dam(domain)

    ! Trick to get the code to write out just after the first timestep
    last_write_time = -approximate_writeout_frequency

    ! Evolve the code
    do while (.TRUE.)

        if(domain%time - last_write_time >= approximate_writeout_frequency) then

            last_write_time = last_write_time + approximate_writeout_frequency

            call domain%print()
            call domain%write_to_output_files()

            if (domain%time > final_time) then
                exit
            end if

        end if

        call domain%evolve_one_step()

    end do

    call domain%write_max_quantities()

    call domain%timer%print()

    call domain%compute_depth_and_velocity()

    ! Crude check on peak velocity. The 7.75 is a numerical value, not a proper
    ! comparison with analytical solution. Really this is just a regression test,
    ! FIXME: get a reference solution.
    if((abs(maxval(domain%velocity(:,:,UH)) - 7.75_dp) < 0.05) .and. &
       (abs(maxval(domain%velocity(:,:,VH)) - 7.75_dp) < 0.05) .and. &
       (abs(minval(domain%velocity(:,:,UH)) + 7.75_dp) < 0.05) .and. &
       (abs(minval(domain%velocity(:,:,VH)) + 7.75_dp) < 0.05) .and. &
       ! Symmetry tests here
       (abs(maxval(domain%velocity(:,:,UH)) + minval(domain%velocity(:,:,UH))) < 1.0e-06_dp) .and. &
       (abs(maxval(domain%velocity(:,:,VH)) + minval(domain%velocity(:,:,VH))) < 1.0e-06_dp) ) then
        print*, ' '
        print*, '##############'
        print*, 'PASS'
        print*, '##############'
        print*, ' '
    else
        print*, ' '
        print*, '##############'
        print*, 'FAIL'
        print*, '##############'
        print*, ' '
    end if

    CALL domain%finalise()

end program


!  *******************************************************************
!  *                                                                 *
!  *                       Subroutine las1g                          *
!  *                                                                 *
!  *******************************************************************
!  Single Precision Version 3.34
!  Written by Gordon A. Fenton, TUNS, Feb. 4, 1993
!  Latest Update: Jun 3, 2006
!
!  PURPOSE  generates a realization of a 1-D Gaussian stationary random
!           local average process
!
!  This routine creates a realization of a zero-mean 1-D random process given
!  its variance function (see DVARFN below). Each discrete
!  value generated represents the local average of a realization of
!  the process over the cell length XL/N, where XL is the physical length
!  of the process and N is the number of cells desired. N must be such that
!  N = k1*2**m, for some integer k1 in the range [1,256] and for some integer
!  m in the range [0,16]. Thus the largest value of N is 2^(24) = 16,777,216.
!  The values of k1 and m are computed internally. The construction of the
!  realization proceeds in a recursive fashion as follows;
!    1) generate the first k1 cells directly,
!    2) subdivide each of the k1 cells into two equal parts and generate
!       random values for each part preserving the cell average and closely
!       approximating the covariance structure (the latter is exact within
!       the cell),
!    3) subdivide the 2*k1 cells obtained in step (2) into two equal parts
!       and again generate random values for each part,
!    4) continue the subdivision process until the domain is divided into
!       N equal cells.
!
!  Note that this routine sets up a number of parameters on the first
!  call and thus the time required to produce the first realization
!  is substantially greater than on subsequent calls (see INIT). For
!  more details on this Local Average Subdivision algorithm, see
!
!    1) Fenton, G.A., and Vanmarcke, E.H., "Simulation of Random Fields
!          via Local Average Subdivision", ASCE Journal of Engineering
!          Mechanics, 116(8), 1733-1749, 1990.
!    2) Fenton, G.A., Simulation and Analysis of Random Fields, Ph.D. Thesis,
!          Dept. of Civil Engineering and Operations Research, Princeton
!          University, Princeton, NJ, 1990.
!    3) Vanmarcke, E.H., Random Fields: Analysis and Synthesis, MIT Press,
!          Boston, Massachusetts, 1984.
!    4) Fenton, G.A., Error evaluation of three random field generators,
!          ASCE Journal of Engineering Mechanics (to appear), 1993.
!
!  Arguments to this routine are as follows;
!
!      Z  real vector of length at least (3*N/2) which on output will contain
!         the desired realization in the first N locations. The remainder is
!         used for workspace. (output)
!
!      N  desired number of cells discretizing the process. N must be such
!         that it can be written N = k1*2**m, k1 and m are integers with
!         1 <= k1 <= MXK and 0 <= m <= MXM (see parameters below). (input)
!
!     XL  physical length of the process. (input)
!
! DVARFN  external real*8 function which returns the covariance of the random
!         process between two points separated by a distance V1.
!         DVARFN is referenced as follows
!
!                var = dvarfn( V1 )
!
!         where (V1) is the separation distance. Any other
!         parameters to the function must be passed by common block from the
!         calling routine. The current version of LAS uses the sign on `var'
!         to tell dvarfn to return either the covariance, or the variance of
!         a local average over distance V1. The latter is returned if var < 0,
!         although this feature is no longer used by LAS.
!
!  NBH    integer giving the desired size of the neighborhood to include
!         in the determination of the best linear estimate of the mean value
!         of a sub-cell. At present only two neighborhood sizes are supported:
!         NBH = 3 or 5. Note that the code will run significantly slower using
!         NBH = 5, but it yields improved results for some types of processes
!         (such as damped oscillatory noise). (input)
!
!  KSEED  integer seed to be used to initialize the pseudo-random number
!         generator (which is assumed to be performed by calling rand(kseed)).
!         If KSEED = 0, then a random seed will be used (based on the
!         clock time when this routine is called for the first time).
!         On output, KSEED is set to the value of the actual seed used.
!         (input/output)
!
!  INIT   integer flag which must be set to +/- 1 when parameters of the
!         process are to be calculated or recalculated. If multiple
!         realizations of the same process are desired, then subsequent
!         calls should use INIT not equal to 1 and N1 the same as used
!         initially. If INIT = +1, then both the parameters are calculated
!         and a random realization is returned. If INIT = -1, then just
!         the initial parameters are calculated. (input)
!
!  IOUT   unit number to which error and warning messages are to be logged.
!         (input)
!  ---------------------------------------------------------------------------
!
!  PARAMETERS:
!
!    MXK  the maximum value of k1. Currently 256.
!
!    MXM  represents the maximum number of subdivisions (ie the maximum value
!         of m) that the routine can carry out. Currently 16. Note that this
!         means that N cannot exceed MXK*2**MXM = 16*2**16 = 1,048,576.
!
!    NGS  this routine will generate NGS independent Gaussian random variates
!         at a time (this is because some machines slow down drastically when
!         making multiple calls to an external routine - that is we attempt to
!         minimize the number of calls to VNORM herein).
!
!  Notes:
!    1) Simulation timing is available through common block LASTYM where
!       TI is the time required to set up the parameters of the process
!       and TS is the cumulative simulation time. These timings are
!       obtained through the function SECOND which returns elapsed user
!       time in seconds since the start of the program.
!    2) all variables that start with "d" are double precision - this is
!       used to perform the covariance calculations in extended precision.
!    3) The parameter `tol' is the maximum relative error allowed on the
!       Cholesky decomposition of covariance matrices before a warning
!       message is emitted. The relative error is estimated by computing
!       the lower-right most element of L*L' and comparing to the original
!       element of A (where L*L' = A is the decomposition). This give some
!       measure of the roundoff errors accumulated in the computation of L.
!
!  Requires:
!    1) from libGAFsim:	ISEED, DCVIT1, DCHOL2, DSIFA, DSISL, DAXPY, DSWAP,
!			IDAMAX, DDOT, LAS1I, VNORM, RANDF, SECOND
!    2) external user defined variance function (see DVARFN).
!
!  REVISION HISTORY:
!  3.31	replaced dummy dimensions with a (*) for GNU's compiler (Jun 9/99)
!  3.32	modified writeup above for new dvarfn return value. (Apr 17/01)
!  3.33	increased MXK from 16 to 256. (Aug 10/05)
!  3.34	just initialize if init = -1. (Jun 3/06)
!--------------------------------------------------------------------
      subroutine las1g( z, n, xl, dvarfn, nbh, kseed, init, iout )
      implicit real*8 (d)
      parameter( MXM = 16, MXK = 256, NGS = 4096 )
      real z(*), A(9,MXM), C(3,MXM), C0(MXK,MXK), g(NGS), ge(4*MXM)
      external dvarfn
      save A, C, C0, m, k1
      common/LASTYM/ ti, ts
      data ifirst/1/, two/2.0/
      data tol/1.e-3/
!------------------------------ initialization ---------------------------

      if( ifirst .eq. 1 .or. iabs(init) .eq. 1 ) then
         ti = second()
         ifirst = 0
!					compute parameters for this routine
         call las1i( dvarfn, n, xl, MXM, MXK, nbh, A, C, C0,              &
                      m, k1, iout, tol )
!					initialize the random number generator
         kseed = iseed( kseed )
!					set timers
         ts = 0.
         ti = second() - ti
         if( init .eq. -1 ) return
      endif
!
!------------------------------ create the realization ---------------------
!
      tt = second()
!					create first k1 cells directly
      if( mod(m,2) .eq. 0 ) then
         iz = 0
         jz = n
      else
         iz = n
         jz = 0
      endif
!					generate stage 0 field
      call vnorm( g, k1 )
      do 20 i = 1, k1
         Z(iz+i) = C0(1,i)*g(1)
         do 10 j = 2, i
            Z(iz+i) = Z(iz+i) + C0(j,i)*g(j)
  10     continue
  20  continue
!					generate stage 1, 2, ... M fields
      jx = k1
      if ( nbh .eq. 3 ) then
!					for a neighborhood of 3 (NBH = 3)...
         call vnorm( ge, 2*M )
         do 40 i = 1, M
            ii = 2*i
            it = jz
            jz = iz
            iz = it
            i0 = iz + 1
            j0 = jz + 1
            Z(i0)   = A(1,i)*Z(j0) + A(2,i)*Z(j0+1) + C(1,i)*ge(ii-1)
            Z(i0+1) = two*Z(j0) - Z(i0)
            do 30 jj = 1, jx-2, NGS
               kk = min0( jx-jj-1, NGS )
               call vnorm( g, kk )
               do 30 j = 1, kk
                  i0      = i0 + 2
                  Z(i0)   = A(3,i)*(Z(j0)-Z(j0+2))+Z(j0+1) + C(2,i)*g(j)
                  Z(i0+1) = two*Z(j0+1) - Z(i0)
                  j0      = j0 + 1
  30        continue
            i0      = i0 + 2
            Z(i0+1) = A(1,i)*Z(j0+1) + A(2,i)*Z(j0) + C(1,i)*ge(ii)
            Z(i0)   = two*Z(j0+1) - Z(i0+1)
            jx      = 2*jx
  40     continue
      else
!					for a neighborhood of 5 (NBH = 5)...
         call vnorm( ge, 4*M )
         do 60 i = 1, M
            ii = 4*i
            it = jz
            jz = iz
            iz = it
            i0 = iz + 1
            j0 = jz + 1
            Z(i0)   = A(1,i)*Z(j0) + A(2,i)*Z(j0+1) + A(3,i)*Z(j0+2)      &
                                  + C(1,i)*ge(ii-3)
            Z(i0+1) = two*Z(j0) - Z(i0)
            i0 = i0 + 2
            Z(i0)   = A(4,i)*Z(j0) + A(5,i)*Z(j0+1) + A(6,i)*Z(j0+2)      &
                                  + A(7,i)*Z(j0+3) + C(2,i)*ge(ii-2)
            Z(i0+1) = two*Z(j0+1) - Z(i0)
            do 50 jj = 1, jx-4, NGS
               kk = min0( jx-jj-3, NGS )
               call vnorm( g, kk )
               do 50 j = 1, kk
                  i0      = i0 + 2
                  Z(i0)   = A(8,i)*(Z(j0  ) - Z(j0+4)) + Z(j0+2)          &
                          + A(9,i)*(Z(j0+1) - Z(j0+3)) + C(3,i)*g(j)
                  Z(i0+1) = two*Z(j0+2) - Z(i0)
                  j0      = j0 + 1
  50        continue
            i0      = i0 + 2
            Z(i0+1) = A(4,i)*Z(j0+3) + A(5,i)*Z(j0+2) + A(6,i)*Z(j0+1)    &
                                    + A(7,i)*Z(j0) + C(2,i)*ge(ii-1)
            Z(i0)   = two*Z(j0+2) - Z(i0+1)
            i0      = i0 + 2
            Z(i0+1) = A(1,i)*Z(j0+3) + A(2,i)*Z(j0+2) + A(3,i)*Z(j0+1)    &
                                    + C(1,i)*ge(ii)
            Z(i0)   = two*Z(j0+3) - Z(i0+1)
            jx      = 2*jx
  60     continue
      endif
!					all done, update timer
      ts = ts + (second() - tt)

      return
      end


! Copyright (c) 2020, Lehrstuhl fuer Angewandte Mechanik, Technische
! Universitaet Muenchen.
!
! Distributed under BSD-3-Clause License. See LICENSE-File for more information
!
! Author: Christian Meyer
!

module shapefunction_obj
    use, intrinsic:: iso_fortran_env, only: dp=>real64
    use shapefunction_fun
    implicit none
    private

    public :: shapefunction1d, shapefunction2d, shapefunction3d, &
        create_shapefunction_1d, create_shapefunction_2d, create_shapefunction_3d

    integer, public, parameter :: &
            LINE2 = 12, &
            LINE3 = 13, &
            TRI3 = 23, &
            QUAD4 = 24, &
            TRI6 = 26, &
            QUAD8 = 28, &
            TET4 = 34, &
            HEXA8 = 38, &
            TET10 = 310, &
            HEXA20 = 320

    type :: shapefunction
        integer :: no_of_nodes
        integer :: no_of_local_coordinates
        procedure(), nopass, pointer :: evaluate
        procedure(), nopass, pointer :: jacobian
    end type shapefunction

    type, extends(shapefunction) :: shapefunction1d
        procedure(xi_func), nopass, pointer :: xi_lower
        procedure(xi_func), nopass, pointer :: xi_upper
    end type shapefunction1d

    type, extends(shapefunction) :: shapefunction2d
        procedure(xi_func), nopass, pointer :: xi_lower
        procedure(xi_func), nopass, pointer :: xi_upper
        procedure(eta_func), nopass, pointer :: eta_lower
        procedure(eta_func), nopass, pointer :: eta_upper
    end type shapefunction2d

    type, extends(shapefunction) :: shapefunction3d
        procedure(xi_func), nopass, pointer :: xi_lower
        procedure(xi_func), nopass, pointer :: xi_upper
        procedure(eta_func), nopass, pointer :: eta_lower
        procedure(eta_func), nopass, pointer :: eta_upper
        procedure(zeta_func), nopass, pointer :: zeta_lower
        procedure(zeta_func), nopass, pointer :: zeta_upper
    end type shapefunction3d

    interface
        function xi_func() result(out)
            import :: dp
            real(dp) :: out
        end function xi_func

        function eta_func(xi) result(out)
            import :: dp
            real(dp), intent(in) :: xi
            real(dp) :: out
        end function eta_func

        function zeta_func(xi, eta) result(out)
            import :: dp
            real(dp), intent(in) :: xi, eta
            real(dp) :: out
        end function zeta_func
    end interface

    contains
        function create_line2() result(obj)
            type(shapefunction1d) :: obj
            obj%no_of_nodes = line2_no_of_nodes()
            obj%no_of_local_coordinates = line2_no_of_local_coordinates()
            obj%evaluate => line2_evaluate
            obj%jacobian => line2_jacobian
            obj%xi_lower => line2_xi_lower
            obj%xi_upper => line2_xi_upper
        end function create_line2

        function create_line3() result(obj)
            type(shapefunction1d) :: obj
            obj%no_of_nodes = line3_no_of_nodes()
            obj%no_of_local_coordinates = line3_no_of_local_coordinates()
            obj%evaluate => line3_evaluate
            obj%jacobian => line3_jacobian
            obj%xi_lower => line3_xi_lower
            obj%xi_upper => line3_xi_upper
        end function create_line3

        function create_tri3() result(obj)
            type(shapefunction2d) :: obj
            obj%no_of_nodes = tri3_no_of_nodes()
            obj%no_of_local_coordinates = tri3_no_of_local_coordinates()
            obj%evaluate => tri3_evaluate
            obj%jacobian => tri3_jacobian
            obj%xi_lower => tri3_xi_lower
            obj%xi_upper => tri3_xi_upper
            obj%eta_lower => tri3_eta_lower
            obj%eta_upper => tri3_eta_upper
        end function create_tri3

        function create_quad4() result(obj)
            type(shapefunction2d) :: obj
            obj%no_of_nodes = quad4_no_of_nodes()
            obj%no_of_local_coordinates = quad4_no_of_local_coordinates()
            obj%evaluate => quad4_evaluate
            obj%jacobian => quad4_jacobian
            obj%xi_lower => quad4_xi_lower
            obj%xi_upper => quad4_xi_upper
            obj%eta_lower => quad4_eta_lower
            obj%eta_upper => quad4_eta_upper
        end function create_quad4

        function create_quad8() result(obj)
            type(shapefunction2d) :: obj
            obj%no_of_nodes = quad8_no_of_nodes()
            obj%no_of_local_coordinates = quad8_no_of_local_coordinates()
            obj%evaluate => quad8_evaluate
            obj%jacobian => quad8_jacobian
            obj%xi_lower => quad8_xi_lower
            obj%xi_upper => quad8_xi_upper
            obj%eta_lower => quad8_eta_lower
            obj%eta_upper => quad8_eta_upper
        end function create_quad8

        function create_tri6() result(obj)
            type(shapefunction2d) :: obj
            obj%no_of_nodes = tri6_no_of_nodes()
            obj%no_of_local_coordinates = tri6_no_of_local_coordinates()
            obj%evaluate => tri6_evaluate
            obj%jacobian => tri6_jacobian
            obj%xi_lower => tri6_xi_lower
            obj%xi_upper => tri6_xi_upper
            obj%eta_lower => tri6_eta_lower
            obj%eta_upper => tri6_eta_upper
        end function create_tri6

        function create_hexa8() result(obj)
            type(shapefunction3d) :: obj
            obj%no_of_nodes = hexa8_no_of_nodes()
            obj%no_of_local_coordinates = hexa8_no_of_local_coordinates()
            obj%evaluate => hexa8_evaluate
            obj%jacobian => hexa8_jacobian
            obj%xi_lower => hexa8_xi_lower
            obj%xi_upper => hexa8_xi_upper
            obj%eta_lower => hexa8_eta_lower
            obj%eta_upper => hexa8_eta_upper
            obj%zeta_lower => hexa8_zeta_lower
            obj%zeta_upper => hexa8_zeta_upper
        end function create_hexa8

        function create_tet4() result(obj)
            type(shapefunction3d) :: obj
            obj%no_of_nodes = tet4_no_of_nodes()
            obj%no_of_local_coordinates = tet4_no_of_local_coordinates()
            obj%evaluate => tet4_evaluate
            obj%jacobian => tet4_jacobian
            obj%xi_lower => tet4_xi_lower
            obj%xi_upper => tet4_xi_upper
            obj%eta_lower => tet4_eta_lower
            obj%eta_upper => tet4_eta_upper
        end function create_tet4

        function create_hexa20() result(obj)
            type(shapefunction3d) :: obj
            obj%no_of_nodes = hexa20_no_of_nodes()
            obj%no_of_local_coordinates = hexa20_no_of_local_coordinates()
            obj%evaluate => hexa20_evaluate
            obj%jacobian => hexa20_jacobian
            obj%xi_lower => hexa20_xi_lower
            obj%xi_upper => hexa20_xi_upper
            obj%eta_lower => hexa20_eta_lower
            obj%eta_upper => hexa20_eta_upper
        end function create_hexa20

        function create_tet10() result(obj)
            type(shapefunction3d) :: obj
            obj%no_of_nodes = tet10_no_of_nodes()
            obj%no_of_local_coordinates = tet10_no_of_local_coordinates()
            obj%evaluate => tet10_evaluate
            obj%jacobian => tet10_jacobian
            obj%xi_lower => tet10_xi_lower
            obj%xi_upper => tet10_xi_upper
            obj%eta_lower => tet10_eta_lower
            obj%eta_upper => tet10_eta_upper
        end function create_tet10

        function create_shapefunction_1d(identifier) result(obj)
            integer, intent(in) :: identifier
            type(shapefunction1d) :: obj

            select case(identifier)
                case(LINE2)
                    obj = create_line2()
                case(LINE3)
                    obj = create_line3()
                case default
                    stop 'Shapefunction not available or wrong dimension'
            end select
        end function create_shapefunction_1d

        function create_shapefunction_2d(identifier) result(obj)
            integer, intent(in) :: identifier
            type(shapefunction2d) :: obj

            select case(identifier)
                case(TRI3 )
                    obj = create_tri3()
                case(QUAD4)
                    obj = create_quad4()
                case(TRI6)
                    obj = create_tri6()
                case(QUAD8)
                    obj = create_quad8()
                case default
                    stop 'Shapefunction not available or wrong dimension'
            end select

        end function create_shapefunction_2d

        function create_shapefunction_3d(identifier) result(obj)
            integer, intent(in) :: identifier
            type(shapefunction3d) :: obj

            select case(identifier)
                case(TET4)
                    obj = create_tet4()
                case(HEXA8)
                    obj = create_hexa8()
                case(TET10)
                    obj = create_tet10()
                case(HEXA20)
                    obj = create_hexa20()
                case default
                    stop 'Shapefunction not available or wrong dimension'
            end select
        end function create_shapefunction_3d

end module shapefunction_obj


       SUBROUTINE W3FB03(XI, XJ, XMESHL, TLAT, TLONG)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FB03         CONVERT I,J GRID COORDINATES TO LAT/LON
C   AUTHOR: JONES,R.E.       ORG: W342       DATE: 86-07-17
C
C ABSTRACT: CONVERTS I,J GRID COORDINATES TO THE CORRESPONDING
C   LATITUDE/LONGITUDE ON A SOUTHERN HEMISPHERE POLAR STEREOGRAPHIC
C   MAP PROJECTION.
C
C PROGRAM HISTORY LOG.
C   86-07-17  R.E.JONES   CONVERT TO FORTRAN 77
C   90-08-31  R.E.JONES   CONVERT TO CRAY CFT77 FORTRAN
C
C USAGE:  CALL W3FBO3 (XI, XJ, XMESHL, TLAT, TLONG)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     XI     ARG LIST  REAL I COORDINATE
C     XJ     ARG LIST  REAL J COORDINATE
C     XMESHL ARG LIST  REAL GRID INTERVAL IN KM.
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     TLAT   ARG LIST  REAL  S.H. LATITUDE
C     TLONG  ARG LIST  REAL  LONGITUDE
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     ASIN  ATAN2                                             SYSLIB
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP8/832
C
C$$$
C
C     ...GIVEN ... XI/XJ GRID COORDINATES OF A POINT RELATIVE
C     ...        TO (0,0) AT SOUTH POLE
C     ...TO COMPUTE TLAT,TLONG ON THE SRN HEMI POLAR STEREO PROJECTION
C     ...WITH 80W VERTICAL AT TOP OF THE MAP
C
       DATA  DEGPRD/57.2957795/
       DATA  EARTHR/6371.2/
C
      RE  = (EARTHR * 1.86603) / XMESHL
      GI2 = RE * RE
C
C     ...WHERE GI2 IS THE SQUARE OF DISTANCE IN GRID INTERVALS
C     ...   FROM POLE TO EQUATOR...
C
      R2 = XI * XI + XJ * XJ
      IF (R2 .NE. 0.0) THEN
C
      XLONG = DEGPRD * ATAN2(XJ,XI)
      TLONG = XLONG - 10.0
      IF (TLONG .LT. 0.0) TLONG = TLONG + 360.0
      TLAT  = ASIN((GI2 - R2)/(GI2 + R2)) * DEGPRD
      TLAT  = -TLAT
C
      ELSE
      TLAT = -90.0
C
C     ...FOR SOUTH POLE...
C
      TLONG = 0.0
      ENDIF
C
      RETURN
      END


!*******************************************************************
!                                                                  *
      SUBROUTINE C1E0SM(Q,QM,C,CM,A)
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF FOLLOWING              *
!                                                 ---         ---  *
!                                                 I  Q   1  C   I  *
!     CLEBSCH - GORDAN COEFFICIENT:               I             I  *
!                                                 I  QM  0  CM  I  *
!                                                 ---         ---  *
!                                                                  *
!   Written by G. Gaigalas,                                        *
!   Vilnius,  Lithuania                             December 1993  *
!   Transform to fortran 90/95 by G. Gaigalas       December 2012  *
!   The last modification made by G. Gaigalas       October  2017  *
!                                                                  *
!*******************************************************************
!
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE CONS_C,          ONLY: ZERO, TENTH, ONE, TWO, THREE, EPS
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ittk_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      REAL(DOUBLE), INTENT(IN)  :: Q, QM, C, CM
      REAL(DOUBLE), INTENT(OUT) :: A
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: IIQ, IIC, IS, IG
!-----------------------------------------------
      A=ZERO
      IIQ=TWO*Q+TENTH
      IIC=TWO*C+TENTH
      IF(ITTK(IIQ,IIC,2) == 0)RETURN
      IF(DABS(QM-CM) > EPS) RETURN
      IF((Q+TENTH) < DABS(QM)) RETURN
      IF((C+TENTH) < DABS(CM)) RETURN
      IF(DABS(QM) <= EPS) THEN
       IS=Q+C+ONE+TENTH
       IF((IS/2)*2 /= IS) RETURN
      END IF
      IG=Q-C+TWO+TENTH
      IF(IG <= 0) RETURN
      IF(IG > 3) RETURN
      IF (IG == 1) THEN
        A=DSQRT(((C+CM)*(C-CM))/((TWO*C-ONE)*C))
      ELSE IF (IG == 2) THEN
        A=CM/DSQRT(C*(C+ONE))
      ELSE IF (IG == 3) THEN
        A=-DSQRT(((C+CM+ONE)*(C-CM+ONE))/((C+ONE)*(TWO*C+THREE)))
      END IF
      RETURN
      END SUBROUTINE C1E0SM