c
c  pressure levels from heights, temperature and mosture.
c

	subroutine z2pres(pres0, z, tabs, q, p)

	implicit none
	include 'grid.inc'

! input:
	real pres0	! surface pressure
	real z(nzm)	! height
	real tabs(nzm)	! absolute temperature, K
	real q(nzm)	! vapor mixing ratio, kg/kg
!output
	real p(nzm)	! pressure levels, mB
!local
	real pi(0:nzm), tv(nzm), coef, tmp
	integer k

	coef = 2.*9.81/1004.

	do k=1,nzm
	 tv(k)=tabs(k)*(1.+0.61*q(k))
	end do

	pi(0)=(pres0/1000.)**0.28586
	pi(1)=pi(0)*tv(1)/(tv(1)+coef/2.*z(1))
	p(1) = 1000.*pi(1)**3.498278
	do k=2,nzm
	 tmp = (tv(k)-tv(k-1)+coef*(z(k)-z(k-1)))*pi(k-1)
	 pi(k)= (-tmp+sqrt(tmp**2+4.*tv(k)*tv(k-1)*pi(k-1)**2))
     &	                                            /(2.*tv(k-1))
	 p(k) = 1000.*pi(k)**3.498278
	end do

	return
	end


module TenaciousTensor
    implicit none

    integer,parameter,private   :: dp = kind(1.d0)

    type Tensor
        integer                 :: rank
        real(dp),allocatable    :: rank2(:,:)
        real(dp),allocatable    :: rank3(:,:,:)
        real(dp),allocatable    :: rank4(:,:,:,:)

        contains

        procedure           :: shadow
        procedure           :: randomize
        procedure           :: zero

        ! Gradient procedures
        procedure           :: GradDesc
        !procedure           :: GradLoss

        final               :: tensor_destructor

    end type

    interface Tensor
        procedure           :: tensor_constructor_2
        procedure           :: tensor_constructor_3
        procedure           :: tensor_constructor_4
    end interface

    interface operator(**)
        module procedure prod_tensor
    end interface

    interface operator(*)
        module procedure Had_tensor
        module procedure real_prod
    end interface

    interface operator(+)
        module procedure sum_tensor
    end interface

    interface operator(-)
        module procedure sub_tensor
    end interface

    interface assignment(=)
        module procedure equal_tensor_1
        module procedure equal_tensor_2
        module procedure equal_tensor_3
        module procedure equal_tensor_4
    end interface

    ! Intrinsic functions
    interface transpose
        module procedure tensor_transp
    end interface

    contains

    !==============================================================!
    !                  CONSTRUCTORS & DESTRUCTORS                  !
    !==============================================================!
    ! rank-2
    function tensor_constructor_2(a,b) result(self)
        implicit none

        integer,intent(in)  :: a,b
        type(Tensor)        :: self

        self%rank = 2
        allocate(self%rank2(a,b))

        self%rank2 = reshape([1,2,3,4],shape(self%rank2))
    end function

    ! rank-3
    function tensor_constructor_3(a,b,c) result(self)
        implicit none

        integer,intent(in)  :: a,b,c
        type(Tensor)        :: self

        self%rank = 3
        allocate(self%rank3(a,b,c))
    end function

    ! rank-4
    function tensor_constructor_4(a,b,c,d) result(self)
        implicit none

        integer,intent(in)  :: a,b,c,d
        type(Tensor)        :: self

        self%rank = 4
        allocate(self%rank4(a,b,c,d))
    end function

    ! Destructor
    subroutine tensor_destructor(self)
        implicit none

        type(Tensor)    :: self

        if (allocated(self%rank2)) then
            deallocate(self%rank2)
        end if
        if (allocated(self%rank3)) then
            deallocate(self%rank3)
        end if
        if (allocated(self%rank4)) then
            deallocate(self%rank4)
        end if
    end subroutine

    !==============================================================!
    !                          OPERATORS                           !
    !==============================================================!

    ! (%)
    function Prod_tensor(a,b) result(c)
        implicit none

        type(Tensor),intent(in) :: a,b
        type(Tensor)            :: c

        select case(a%rank)
            case (2)
                c = Tensor(size(a%rank2,1),size(b%rank2,2))
                c%rank2 = matmul(a%rank2,b%rank2)
        end select
    end function

    ! (*)
    function Had_tensor(a,b) result(c)
        implicit none

        type(Tensor),intent(in) :: a,b
        type(Tensor)            :: c

        select case(a%rank)
            case (2)
                c = Tensor(size(a%rank2,1),size(a%rank2,2))
                c%rank2 = a%rank2 * b%rank2
            case (3)
                c = Tensor(size(a%rank3,1),size(a%rank3,2),size(a%rank3,3))
                c%rank3 = a%rank3 * b%rank3
            case (4)
                c = Tensor(size(a%rank4,1),size(a%rank4,2),size(a%rank4,3),size(a%rank4,4))
                c%rank4 = a%rank4 * b%rank4
        end select
    end function

    ! real x tensor
    function real_prod(a,b) result(c)
        implicit none

        real(dp),intent(in)         :: a
        class(Tensor),intent(in)    :: b
        type(Tensor)                :: c

        select case(b%rank)
            case (2)
                c = Tensor(size(b%rank2,1),size(b%rank2,2))
                c%rank2 = a*b%rank2
            case (3)
                c = Tensor(size(b%rank3,1),size(b%rank3,2),size(b%rank3,3))
                c%rank3 = a*b%rank3
            case (4)
                c = Tensor(size(b%rank4,1),size(b%rank4,2),size(b%rank4,3),size(b%rank4,4))
                c%rank4 = a*b%rank4
        end select
    end function

    ! (+)
    function sum_tensor(a,b) result(c)
        implicit none

        type(Tensor),intent(in) :: a,b
        type(Tensor)            :: c

        select case(a%rank)
            case (2)
                c = Tensor(size(a%rank2,1),size(a%rank2,2))
                c%rank2 = a%rank2 + b%rank2
            case (3)
                c = Tensor(size(a%rank3,1),size(a%rank3,2),size(a%rank3,3))
                c%rank3 = a%rank3 + b%rank3

            case (4)
                c = Tensor(size(a%rank4,1),size(a%rank4,2),size(a%rank4,3),size(a%rank4,4))
                c%rank4 = a%rank4 + b%rank4
        end select
    end function

    ! (-)
    function sub_tensor(a,b) result(c)
        implicit none

        type(Tensor),intent(in) :: a,b
        type(Tensor)            :: c

        select case(a%rank)
            case (2)
                c = Tensor(size(a%rank2,1),size(a%rank2,2))
                c%rank2 = a%rank2 - b%rank2
            case (3)
                c = Tensor(size(a%rank3,1),size(a%rank3,2),size(a%rank3,3))
                c%rank3 = a%rank3 - b%rank3

            case (4)
                c = Tensor(size(a%rank4,1),size(a%rank4,2),size(a%rank4,3),size(a%rank4,4))
                c%rank4 = a%rank4 - b%rank4
        end select
    end function

    ! (=)
    subroutine equal_tensor_1(new,name)
        type(Tensor),intent(out)    :: new
        type(Tensor),intent(in)     :: name

        select case(name%rank)
            case (2)
                new%rank = 2
                allocate(new%rank2(size(name%rank2,1),size(name%rank2,2)))
                new%rank2 = name%rank2
            case (3)
                new%rank = 3
                allocate(new%rank3(size(name%rank3,1),size(name%rank3,2),size(name%rank3,3)))
                new%rank3 = name%rank3
            case (4)
                new%rank = 4
                allocate(new%rank4(size(name%rank4,1),size(name%rank4,2),size(name%rank4,3),size(name%rank4,4)))
                new%rank4 = name%rank4
        end select
    end subroutine

    ! (=) rank2
    subroutine equal_tensor_2(new,name)
        type(Tensor),intent(out)    :: new
        real,intent(in)             :: name(:,:)

        new%rank = 2
        allocate(new%rank2(size(name,1),size(name,2)))
        new%rank2 = name
    end subroutine

    ! (=) rank3
    subroutine equal_tensor_3(new,name)
        type(Tensor),intent(out)    :: new
        real,intent(in)             :: name(:,:,:)

        new%rank = 3
        allocate(new%rank3(size(name,1),size(name,2),size(name,3)))
        new%rank3 = name
    end subroutine

    ! (=) rank4
    subroutine equal_tensor_4(new,name)
        type(Tensor),intent(out)    :: new
        real,intent(in)             :: name(:,:,:,:)

        new%rank = 4
        allocate(new%rank4(size(name,1),size(name,2),size(name,3),size(name,4)))
        new%rank4 = name
    end subroutine

    !==============================================================!
    !                         PROCEDURES                           !
    !==============================================================!
    ! Create a new tensor with the same rank as another
    function shadow(self) result(X)
        implicit none

        class(Tensor),intent(in)    :: self
        type(Tensor)                :: X

        select case(self%rank)
            case (2)
                X = Tensor(size(self%rank2,1),size(self%rank2,2))
            case (3)
                X = Tensor(size(self%rank3,1),size(self%rank3,2),size(self%rank3,3))
            case (4)
                X = Tensor(size(self%rank4,1),size(self%rank4,2),size(self%rank4,3),size(self%rank4,4))
        end select
    end function

    ! Randomize a tensor
    subroutine randomize(self)
        implicit none

        class(Tensor),intent(inout) :: self

        select case(self%rank)
            case(2)
                call random_number(self%rank2)
                self%rank2 = 2*(self%rank2 - 0.5)
            case(3)
                call random_number(self%rank3)
                self%rank3 = 2*(self%rank3 - 0.5)
            case(4)
                call random_number(self%rank4)
                self%rank4 = 2*(self%rank4 - 0.5)
        end select
    end subroutine

    ! Zero a tensor
    subroutine zero(self)
        implicit none

        class(Tensor),intent(inout) :: self

        select case(self%rank)
            case(2)
                self%rank2 = 0.0
            case(3)
                self%rank3 = 0.0
            case(4)
                self%rank4 = 0.0
        end select
    end subroutine

    ! Transpose a tensor
    function tensor_transp(X) result(Y)
        implicit none

        class(Tensor),intent(in)    :: X
        type(Tensor)                :: Y

        select case(X%rank)
            case(2)
                Y = Tensor(size(X%rank2,2),size(X%rank2,1))
                Y%rank2 = transpose(X%rank2)
        end select
    end function

    !---------------------------------------------------------------!
    !                    Gradient Procedures                        !
    !---------------------------------------------------------------!

    ! Gradient Descend
    subroutine GradDesc(self,grad,rate)
        implicit none

        class(Tensor),intent(inout) :: self
        class(Tensor),intent(in)    :: grad
        real,intent(in)             :: rate

        select case(self%rank)
            case(2)
                self%rank2 = self%rank2 - rate*transpose(grad%rank2)
        end select
    end subroutine

    ! Gradient GradLoss
!     function GradLoss(self,expected) result(dX)
!         implicit none
!
!         class(Tensor),intent(in)    :: self
!         class(Tensor),intent(in)    :: expected
!         type(Tensor)                :: dX
!
!         select case(self%rank)
!             case(2)
!                 dX = Tensor(size(self%rank2,2),size(self%rank2,1))
!
!                 X =
!
!

end module

program test
    use Tensors
    implicit none

    integer,parameter   :: dp = kind(1.d0)

    type(Tensor) :: A
    type(Tensor) :: B

    A = Tensor(2,2)
    write(*,*) A%rank2
    B = 2.0_DP*transpose(A)

    write(*,*) B%rank2
end program


C
C $Id: mdscal.f,v 1.8 2008-09-18 00:42:18 kennison Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      DOUBLE PRECISION FUNCTION MDSCAL (XCOP,YCOP,XCOQ,YCOQ)
C
        REAL XCOP,YCOP,XCOQ,YCOQ
C
C If (XCOP,YCOP) and (XCOQ,YCOQ) are the fractional coordinates of two
C points that are the projections (in a manner specified by the current
C state of EZMAP's internal parameters) of two points, P and Q, on the
C surface of the globe, then the value of
C
C     MDSCAL(XCOP,YCOP,XCOQ,YCOQ)
C
C is the angular distance, in degrees, between P and Q, divided by the
C distance, in the fractional coordinate system, between the points that
C represent P and Q on the map.  This may be used to estimate the scale
C of the map in a particular location and a particular direction.
C
C Note that the scale of a map is a unitless quantity representing the
C ratio of a distance on the map to a distance on the globe.  Because
C EZMAP has no way of knowing at what size a map will be displayed, it
C cannot compute an actual scale.
C
C Note also that this routine calls MDGDDP to compute the angular
C distance from A to B and that that routine assumes a spherical earth.
C
        DOUBLE PRECISION MDGDDP,PLAT,PLON,QLAT,QLON
C
C Pre-set value in case we take an error exit.
C
        MDSCAL=0.D0
C
C Find the latitude and longitude of P.
C
        CALL MDPTRI (DBLE(CFUX(XCOP)),DBLE(CFUY(YCOP)),PLAT,PLON)
C
C Find the latitude and longitude of Q.
C
        CALL MDPTRI (DBLE(CFUX(XCOQ)),DBLE(CFUY(YCOQ)),QLAT,QLON)
C
C Compute the angular distance from P to Q and divide by the distance
C between the points on the map in the fractional system.  If either
C point is not projectable, a zero is returned for the scale.
C
        IF (PLAT.NE.1.D12.AND.QLAT.NE.1.D12)
     +    MDSCAL=MDGDDP(PLAT,PLON,QLAT,QLON)/
     +                         DBLE(SQRT((XCOP-XCOQ)**2+(YCOP-YCOQ)**2))
C
C Done.
C
        RETURN
C
      END


module Prng_Class
!!# Prng Class
!!Class providing a pseudo-random number generator with an xorshift128+ or xorshift1024* generator that are both suitable for parallel applications.
!!This is class is thread safe, and can be used in parallel without Prngs on different threads affecting each other.
!!
!!If you are writing serial code, and/or do not need a parallel random number generator, you can use the overloaded functions and subroutines in [[m_random]]. See that module for more
!!information.
!!
!!Side note: The default random number generator in Matlab and Python is the Mersenne Twister algorithm.  This algorithm is not great for parallel applications.  It has a huge period,
!!but you cannot easily jump the state as far as I can tell.  These xorshift algorithms are fantastic, they have a high enough period for most applications, and can be easily jumped in
!!only a few iterations.
!!
!!### Example Serial usage with a randomly generated seed
!!```Fortran
!!program PrngTest
!!
!!use Prng_Class, only: Prng
!!
!!implicit none
!!
!!type(Prng) :: rng
!!integer(i64) :: seed(16)
!!integer(i32) :: i, id
!!
!!real(r64) :: a
!!
!!! Use a constructor to initialize the Prng with a random seed
!!! Using display = .true. will print the randomly generated seed to the screen
!!! So you can reproduce any results later if you wish.
!!rng = Prng(big = .true., display = .true.)
!!
!!! Or you could have set the seed using this
!!! seed = [Some numbers, size 16 if big == .true., size 2 if big == .false.]
!!! and you can use rng = Prng(seed, .true., .true.)
!!
!!! Draw from a uniform distribution
!!call rng%rngUniform(a)
!!
!!! Draw an integer between 1 and 100 inclusive
!!call rng%rngInteger(id, 1, 100)
!!
!!! Other distributions
!!call rng%rngNormal(a)
!!call rng%rngExponential(a, 1.d0)
!!call rng%rngWeibull(a, 1.d0, 1.d0)
!!stop
!!end program
!!```
!!
!!### Example parallel usage using OpenMP
!!```Fortran
!!program PrngTest
!!
!!use omp_lib
!!use Prng_Class, only: Prng, getRandomSeed
!!
!!implicit none
!!
!!type(Prng), allocatable :: rng(:) ! Array of Prng classes, one for each thread
!!integer(i64) :: seed(16) ! Use xorshift1024*, so the seed is size 16
!!integer(i32) :: i, id
!!integer(i32) :: nThreads, iThread
!!
!!real(r64) :: a
!!
!!! Get a randomly generated seed
!!call getRandomSeed(seed, .true.)
!!
!!! Get the number of threads available
!!!$omp parallel
!!  nThreads = omp_get_num_threads()
!!!$omp end parallel
!!
!!! Allocate an array of Prngs, one for each thread
!!allocate(rng(nThreads))
!!
!!! In parallel, initialize each Prng with the same seed, and jump each prng by the thread ID it is associated with.
!!! This allows all Prngs to draw from the same stream, but at different points along the stream.
!!! This is better than giving each Prng its own randomly generated seed.
!!
!!!$omp parallel shared(rng, seed) private(iThread, a)
!!  iThreads = omp_get_thread_num()
!!  rng(iThread + 1) = Prng(seed, big = .true.)
!!  call rng(iThread + 1)%jump(iThread) ! Jump the current thread's Prng by its thread number.
!!  call rng(iThread + 1)%rngNormal(a) ! Draw from normal distribution on each thread
!!!$omp end parallel
!!
!!stop
!!end program
!!```
!!## xorshift128+
!!This module contains routines to generate random numbers using the xorshift128+ method by Vigna's extensions to
!!Marsaglia, G., 2003. Xorshift RNGs. Journal of Statistical Software 8, 1 - 6.
!!
!!This module is a modified version of the public domain code written by Shun Sakuraba in 2015-2016.
!!The original code can be found [here](https://bitbucket.org/shun.sakuraba/xorshiftf90).
!!The modified code in coretran is distributed under the coretran license, see the repository for that information.
!!
!!Vigna's xorshift128+ pseudorandom generator.
!!Sebastiano Vigna. 2014. Further scramblings of Marsaglia's xorshift generators. CoRR, abs/1402.6246.
!! xorshift128+ is known as a fast pseudorandom generator with reasonably good resilience to randomness tests.
!! Since its primary imporance is its speed, do not forget to add inlining directives depending your compiler.
!!
!!
!!### Why xorshift128+ ?
!!The seed of the xorshift128+ can be jumped by k cycles, where each cycle jumps ahead by \(2^{64}\) random numbers, but quickly.
!!This ability to jump is an important aspect for using random number generators in general but especially in parallel
!!in either OpenMP or MPI paradigms.
!!The time taken to generate a 64 bit integer was 1.06 ns on an IntelR CoreTM i7-4770 CPU @3.40GHz (Haswell) as shown in Vigna (2014).
!!xorshift128+ is the better for less massively parallel applications.
!!
!!If the period of the random number generator is too small for your application, consider using the xorshift1024*
!!generator which has a period of \(2^{512}\) numbers. The time to generate a 64 bit integer is slightly slower at 1.36 ns
!!
!!## xorshift1024*
!!This module contains routines to generate random numbers using the xorshift1024* method by Vigna's extensions to
!!Marsaglia, G., 2003. Xorshift RNGs. Journal of Statistical Software 8, 1 - 6.
!!
!!This module is a modified version of the public domain code written by Shun Sakuraba in 2015-2016.
!!The original code can be found [here](https://bitbucket.org/shun.sakuraba/xorshiftf90).
!!The modified code in coretran is distributed under the coretran license, see the repository for that information.
!!
!!Vigna's xorshift1024* pseudorandom generator.
!!Sebastiano Vigna. 2014. An experimental exploration of Marsaglia's xorshift generators, scrambled. CoRR, abs/1402.6246.
!!xorshift1024* is a pseudorandom generator with reasonable speed and a good size state space.
!!
!!
!!### Why xorshift1024* ?
!!The seed of the xorshift1024* can be jumped by k cycles, where each cycle jumps ahead by \(2^{512}\) random numbers, but quickly.
!!This ability to jump is an important aspect for using random number generators in general but especially in parallel
!!in either OpenMP or MPI paradigms.
!!The time taken to generate a 64 bit integer was 1.36 ns on an IntelR CoreTM i7-4770 CPU @3.40GHz (Haswell) as shown in Vigna (2014).
!!xorshift1024* is better for massively parallel applications that draw many realizations.
!!
!!If the size of the random number generator is too much for your application, consider using the xorshift128+
!!generator which has a period of \(2^{64}\) numbers. The time to generate a 64 bit integer is faster at 1.06 ns

use iso_fortran_env, only: output_unit
use variableKind, only: r64, i32, i64
use m_allocate, only: allocate
use m_errors, only: eMsg
use m_time, only: timeToInteger
use m_indexing, only: ind2sub
use m_strings, only: str, printOptions

implicit none

private

public :: Prng
public :: getRandomSeed

type Prng
  !! Class that generates pseudo random numbers. See [[Prng_Class]] for more information on how to use this class.
  integer(i64) :: seed(0:15) = 0
  integer(i32) :: ptr
  logical :: big

contains

  procedure, public :: jump => jump_Prng
    !! Jumps the Prng by \(2^{64}\) numbers if the Prng was instantiated with big = .false. or \(2^{512}\) if big = .true.
    !! This allows the Prng to be used correctly in parallel on multiple threads for OpenMP, or ranks for MPI.

  generic, public :: rngExponential => rngExponential_d1_Prng_, rngExponential_d1D_Prng_, rngExponential_d2D_Prng_, rngExponential_d3D_Prng_
    !! Prng%rngExponential() - Draw from an exponential distribution
    !! $$y = \frac{-ln(\tilde{u})}{\lambda}$$
    !! where \(\tilde{u}\) is a sample from a uniform distribution
  procedure, private :: rngExponential_d1_Prng_ =>  rngExponential_d1_Prng
  procedure, private :: rngExponential_d1D_Prng_ => rngExponential_d1D_Prng
  procedure, private :: rngExponential_d2D_Prng_ => rngExponential_d2D_Prng
  procedure, private :: rngExponential_d3D_Prng_ => rngExponential_d3D_Prng

  generic, public :: rngInteger => rngInteger_i1_Prng_, rngInteger_i1D_Prng_, rngInteger_i2D_Prng_, rngInteger_i3D_Prng_
    !! Prng%rngInteger() - Draw a random integer in the interval \(x_{0} <= \tilde{u} <= x_{1}\)
    !! $$y = x_{0} + (\tilde{u} * x_{1})$$
    !! where \(\tilde{u}\) is a sample from a uniform distribution, and integers are generated such that \(x_{0} <= \tilde{u} <= x_{1}\).
  procedure, private :: rngInteger_i1_Prng_ =>  rngInteger_i1_Prng
  procedure, private :: rngInteger_i1D_Prng_ => rngInteger_i1D_Prng
  procedure, private :: rngInteger_i2D_Prng_ => rngInteger_i2D_Prng
  procedure, private :: rngInteger_i3D_Prng_ => rngInteger_i3D_Prng

  generic, public :: rngNormal => rngNormal_d1_Prng_, rngNormal_d1D_Prng_, rngNormal_d2D_Prng_, rngNormal_d3D_Prng_
    !! Prng%rngNormal() - Draw from a normal distribution.
  procedure, private :: rngNormal_d1_Prng_ => rngNormal_d1_Prng
  procedure, private :: rngNormal_d1D_Prng_ => rngNormal_d1D_Prng
  procedure, private :: rngNormal_d2D_Prng_ => rngNormal_d2D_Prng
  procedure, private :: rngNormal_d3D_Prng_ => rngNormal_d3D_Prng

  generic, public :: rngUniform => rngUniform_d1_Prng_,rngUniform_d1D_Prng_,rngUniform_d2D_Prng_,rngUniform_d3D_Prng_
    !! Prng%rngUniform() - Draw from a uniform distribution
    !! Draws uniform random numbers on (0, 1) using either the xorshift1024* or xorshift128+ algorithms.
  procedure, private :: rngUniform_d1_Prng_ => rngUniform_d1_Prng
  procedure, private :: rngUniform_d1D_Prng_ => rngUniform_d1D_Prng
  procedure, private :: rngUniform_d2D_Prng_ => rngUniform_d2D_Prng
  procedure, private :: rngUniform_d3D_Prng_ => rngUniform_d3D_Prng

  generic, public :: rngWeibull => rngWeibull_d1_Prng_,rngWeibull_d1D_Prng_,rngWeibull_d2D_Prng_,rngWeibull_d3D_Prng_
  !! Prng%rngWeibull() - Draw from a Weibull distribution
  !! $$y = \left[ \frac{-1}{\lambda} ln(\tilde{u}) \right]^{\frac{1}{k}}$$
  !! where \(\tilde{u}\) is a sample from a uniform distribution and
  !! \(\frac{-1}{\lambda} ln(\tilde{u})\) is a draw from an exponential distribution.
procedure, private :: rngWeibull_d1_Prng_ => rngWeibull_d1_Prng
procedure, private :: rngWeibull_d1D_Prng_ => rngWeibull_d1D_Prng
procedure, private :: rngWeibull_d2D_Prng_ => rngWeibull_d2D_Prng
procedure, private :: rngWeibull_d3D_Prng_ => rngWeibull_d3D_Prng
end type

interface Prng
  !!Overloaded Initializer for a Prng - Pseudo random number generator.
  !!Thread safe, xorshift1024* or xorshift128+ generator than can draw from different distributions.
  !!See [[Prng_Class]] for more information on how to use this class.
  module procedure :: initWithSetseed_Prng, initWithRandomSeed_Prng
end interface

public :: rngExponential_unscaled_d1

interface
  !====================================================================!
  module subroutine rngExponential_d1_Prng(this, res, lambda)
    !! Overloaded Type bound procedure Prng%rngExponential()
  !====================================================================!
  class(Prng), intent(inout) :: this
    !! Prng Class
  real(r64), intent(out) :: res
    !! Draw from exponential distribution
  real(r64), intent(in) :: lambda
    !! Inverse scale > 0
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine rngExponential_d1D_Prng(this, res, lambda)
    !! Overloaded Type bound procedure Prng%rngExponential()
  !====================================================================!
  class(Prng), intent(inout) :: this
    !! Prng Class
  real(r64), intent(out) :: res(:)
    !! Draw from exponential distribution
  real(r64), intent(in) :: lambda
    !! Inverse scale > 0
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine rngExponential_d2D_Prng(this, res, lambda)
    !! Overloaded Type bound procedure Prng%rngExponential()
  !====================================================================!
  class(Prng), intent(inout) :: this
    !! Prng Class
  real(r64), intent(out) :: res(:,:)
    !! Draw from exponential distribution
  real(r64), intent(in) :: lambda
    !! Inverse scale > 0
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine rngExponential_d3D_Prng(this, res, lambda)
    !! Overloaded Type bound procedure Prng%rngExponential()
  !====================================================================!
  class(Prng), intent(inout) :: this
    !! Prng Class
  real(r64), intent(out) :: res(:,:,:)
    !! Draw from exponential distribution
  real(r64), intent(in) :: lambda
    !! Inverse scale > 0
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine rngExponential_unscaled_d1(this, res)
  !====================================================================!
  class(Prng)  :: this
    !! Prng Class
  real(r64)  :: res
    !! Draw from exponential distribution
  end subroutine
  !====================================================================!

  !====================================================================!
  module subroutine rngInteger_i1_Prng(this, res, imin, imax)
    !! Overloaded Type bound procedure Prng%rngInteger()
  !====================================================================!
  class(Prng), intent(inout) :: this
    !! Prng Class
  integer(i32), intent(out) :: res
    !! Random integer
  integer(i32), intent(in) :: imin
    !! Draw >= imin
  integer(i32), intent(in) :: imax
    !! Draw <= imax
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine rngInteger_i1D_Prng(this, res, imin, imax)
    !! Overloaded Type bound procedure Prng%rngInteger()
  !====================================================================!
  class(Prng), intent(inout) :: this
    !! Prng Class
  integer(i32), intent(out) :: res(:)
    !! Random integer
  integer(i32), intent(in) :: imin
    !! Draw >= imin
  integer(i32), intent(in) :: imax
    !! Draw <= imax
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine rngInteger_i2D_Prng(this, res, imin, imax)
    !! Overloaded Type bound procedure Prng%rngInteger()
  !====================================================================!
  class(Prng), intent(inout) :: this
    !! Prng Class
  integer(i32), intent(out) :: res(:,:)
    !! Random integer
  integer(i32), intent(in) :: imin
    !! Draw >= imin
  integer(i32), intent(in) :: imax
    !! Draw <= imax
    end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine rngInteger_i3D_Prng(this, res, imin, imax)
    !! Overloaded Type bound procedure Prng%rngInteger()
  !====================================================================!
  class(Prng), intent(inout) :: this
    !! Prng Class
  integer(i32), intent(out) :: res(:,:,:)
    !! Random integer
  integer(i32), intent(in) :: imin
    !! Draw >= imin
  integer(i32), intent(in) :: imax
    !! Draw <= imax
  end subroutine
  !====================================================================!

  !====================================================================!
  module subroutine rngNormal_d1_Prng(this, res, mean, std)
    !! Overloaded Type bound procedure Prng%rngNormal()
  !====================================================================!
  class(prng), intent(inout) :: this
    !! Prng Class
  real(r64), intent(inout) :: res
    !! Draw from random Normal
  real(r64), intent(in), optional :: mean
    !! Mean of the normal distribution
  real(r64), intent(in), optional :: std
    !! Standard deviation of the normal distribution
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine rngNormal_d1D_Prng(this, res, mean, std)
    !! Overloaded Type bound procedure Prng%rngNormal()
  !====================================================================!
  class(prng), intent(inout) :: this
    !! Prng Class
  real(r64), intent(inout) :: res(:)
    !! Draw from random Normal
  real(r64), intent(in), optional :: mean
    !! Mean of the normal distribution
  real(r64), intent(in), optional :: std
    !! Standard deviation of the normal distribution
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine rngNormal_d2D_Prng(this, res, mean, std)
    !! Overloaded Type bound procedure Prng%rngNormal()
  !====================================================================!
  class(prng), intent(inout) :: this
    !! Prng Class
  real(r64), intent(inout) :: res(:,:)
    !! Draw from random Normal
  real(r64), intent(in), optional :: mean
    !! Mean of the normal distribution
  real(r64), intent(in), optional :: std
    !! Standard deviation of the normal distribution
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine rngNormal_d3D_Prng(this, res, mean, std)
    !! Overloaded Type bound procedure Prng%rngNormal()
  !====================================================================!
  class(prng), intent(inout) :: this
    !! Prng Class
  real(r64), intent(inout) :: res(:,:,:)
    !! Draw from random Normal
  real(r64), intent(in), optional :: mean
    !! Mean of the normal distribution
  real(r64), intent(in), optional :: std
    !! Standard deviation of the normal distribution
  end subroutine
  !====================================================================!

  !====================================================================!
  module subroutine rngUniform_d1_Prng(this, res, rmin, rmax)
      !! Overloaded Type bound procedure Prng%rngUniform()
  !====================================================================!
  class(Prng), intent(inout) :: this
    !! Prng Class
  real(r64), intent(inout) :: res
    !! Random uniform
  real(r64), intent(in) :: rmin
    !! Minimum value to draw between. Requires rmax be used as well.
  real(r64), intent(in) :: rmax
    !! Maximum value to draw between. Requires rmin be used as well.
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine rngUniform_d1D_Prng(this, res, rmin, rmax)
    !! Overloaded Type bound procedure Prng%rngUniform()
  !====================================================================!
  class(Prng), intent(inout) :: this
    !! Prng Class
  real(r64), intent(inout) :: res(:)
    !! Random uniform
  real(r64), intent(in) :: rmin
    !! Minimum value to draw between. Requires rmax be used as well.
  real(r64), intent(in) :: rmax
    !! Maximum value to draw between. Requires rmin be used as well.
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine rngUniform_d2D_Prng(this, res, rmin, rmax)
    !! Overloaded Type bound procedure Prng%rngUniform()
  !====================================================================!
  class(Prng), intent(inout) :: this
    !! Prng Class
  real(r64), intent(inout) :: res(:,:)
    !! Random uniform
  real(r64), intent(in) :: rmin
    !! Minimum value to draw between. Requires rmax be used as well.
  real(r64), intent(in) :: rmax
    !! Maximum value to draw between. Requires rmin be used as well.
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine rngUniform_d3D_Prng(this, res, rmin, rmax)
    !! Overloaded Type bound procedure Prng%rngUniform()
  !====================================================================!
  class(Prng), intent(inout) :: this
    !! Prng Class
  real(r64), intent(inout) :: res(:,:,:)
    !! Random uniform
  real(r64), intent(in) :: rmin
    !! Minimum value to draw between. Requires rmax be used as well.
  real(r64), intent(in) :: rmax
    !! Maximum value to draw between. Requires rmin be used as well.
  end subroutine
  !====================================================================!

  !====================================================================!
  module subroutine rngWeibull_d1_Prng(this, res, lambda, k)
    !! Overloaded Type bound procedure Prng%rngWeibull()
  !====================================================================!
  Class(Prng), intent(inout) :: this
    !! Prnge Class
  real(r64), intent(inout) :: res
    !! Draw from Weibull distribution
  real(r64), intent(in) :: lambda
    !! Scale of the distribution
  real(r64), intent(in) :: k
    !! Shape of the distribution
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine rngWeibull_d1D_Prng(this, res, lambda, k)
    !! Overloaded Type bound procedure Prng%rngWeibull()
  !====================================================================!
  Class(Prng), intent(inout) :: this
    !! Prnge Class
  real(r64), intent(inout) :: res(:)
    !! Draw from Weibull distribution
  real(r64), intent(in) :: lambda
    !! Scale of the distribution
  real(r64), intent(in) :: k
    !! Shape of the distribution
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine rngWeibull_d2D_Prng(this, res, lambda, k)
    !! Overloaded Type bound procedure Prng%rngWeibull()
  !====================================================================!
  Class(Prng), intent(inout) :: this
    !! Prnge Class
  real(r64), intent(inout) :: res(:,:)
    !! Draw from Weibull distribution
  real(r64), intent(in) :: lambda
    !! Scale of the distribution
  real(r64), intent(in) :: k
    !! Shape of the distribution
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine rngWeibull_d3D_Prng(this, res, lambda, k)
    !! Overloaded Type bound procedure Prng%rngWeibull()
  !====================================================================!
  Class(Prng), intent(inout) :: this
    !! Prnge Class
  real(r64), intent(inout) :: res(:,:,:)
    !! Draw from Weibull distribution
  real(r64), intent(in) :: lambda
    !! Scale of the distribution
  real(r64), intent(in) :: k
    !! Shape of the distribution
  end subroutine
  !====================================================================!

  !====================================================================!
  module subroutine rngInteger_1024star(this, val)
  !====================================================================!
  class(prng), intent(inout) :: this
  integer(i64), intent(out) :: val
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine jumpState_1024star(this)
  !====================================================================!
  class(prng), intent(inout) :: this
  end subroutine
  !====================================================================!

  !====================================================================!
  module subroutine rngInteger_128plus(this, val)
  !====================================================================!
  class(prng), intent(inout) :: this
  integer(i64), intent(out) :: val
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine jumpState_128plus(this)
  !====================================================================!
  class(prng), intent(inout) :: this
  end subroutine
  !====================================================================!

end interface

public :: rngUniform_xorshift
interface rngUniform_xorshift
  module procedure :: rngUniform_xorshift
  ! !====================================================================!
  ! module subroutine rngUniform_xorshift(this, val)
  ! !====================================================================!
  ! class(prng), intent(inout) :: this
  ! real(r64), intent(out) :: val
  ! end subroutine
  ! !====================================================================!
end interface

contains

!====================================================================!
function initWithSetseed_Prng(seed, big) result(this)
!====================================================================!
type(Prng) :: this
  !! Prng Class
integer(i64), intent(in) :: seed(:)
  !! Fixed seeds of 64 bit integers. If big == true, must be length 16 else must be length 2.
logical, intent(in), optional :: big
  !! Use the high period xorshift1024* (true) or xorshift128+ (false). Default is false.

call setSeed_Prng(this, seed, big)

end function
!====================================================================!
!====================================================================!
function initWithRandomSeed_Prng(big, display) result(this)
!====================================================================!
type(Prng) :: this
  !! Prng Class
logical, intent(in), optional :: big
  !! Use the high period xorshift1024* (true) or xorshift128+ (false). Default is false.
logical, intent(in), optional :: display
  !! Display the randomly generated seed to the screen for reproducibility

logical :: useXorshift1024star
integer(i32) :: i, dt(8)
integer(i64) :: t
integer(i64) :: s(16)
logical :: display_

useXorshift1024star = .false.
if (present(big)) useXorshift1024star = big

if (useXorshift1024star) then
  call getRandomSeed(s, .true.)
else
  call getRandomSeed(s(1:2), .false.)
endif

display_ = .false.
if (present(display)) display_ = display

 if (display_) then
   i = printOptions%threshold
   printOptions%threshold = 0
   write(output_unit,'(a)') 'Random Seed: ['//str(s, delim = ',')//']'
   printOptions%threshold = i
 end if

if (useXorshift1024star) then
  call setSeed_Prng(this, s, .true.)
else
  call setSeed_Prng(this, s(1:2), .false.)
endif

end function
!====================================================================!
!====================================================================!
subroutine getRandomSeed(seed, big)
  !! Gets a randomly generated seed by getting the current integer time
  !! and then using a splitmix algorithm to generate the necessary number of seeds.
!====================================================================!
integer(i64), intent(inout) :: seed(:)
  !! Random seeds of 64 bit integers. If big == true, must be size 16 else must be size 2.
logical, intent(in), optional :: big
  !! Use the high period xorshift1024* (true) or xorshift128+ (false). Default is false.

logical :: useXorshift1024star
integer(i32) :: dt(8)
integer(i32) :: i
integer(i32) :: nSeeds
integer(i64) :: t

useXorshift1024star = .false.
if (present(big)) useXorshift1024star = big

nSeeds = size(seed)

if (useXorshift1024star) then
  if (nSeeds /= 16) call eMsg('getRandomSeed: Seed must have size 16')
else
  if (nSeeds /= 2) call eMsg('getRandomSeed: Seed must have size 2')
endif

call date_and_time(VALUES=dt)

t = timeToInteger(dt)

! use splimix64 for initialization
do i = 1, nSeeds
  call splitmix64(t, seed(i))
end do

end subroutine
!====================================================================!
!====================================================================!
subroutine jump_Prng(this, nJumps)
!====================================================================!
class(Prng), intent(inout) :: this
  !! Prng Class
integer(i32) :: nJumps
  !! Number of times to skip \(2^{64}\) numbers if the Prng was initialized with big = .false.
  !! or $2^{512}$ numbers if big was .true.

integer(i32) :: i
if (this%big) then
  do i = 1, nJumps
    call jumpState_1024star(this)
  enddo
else
  do i = 1, nJumps
    call jumpState_128plus(this)
  enddo
endif

end subroutine
!====================================================================!
!====================================================================!
subroutine setSeed_Prng(this, seed, big)
!====================================================================!
type(Prng), intent(inout) :: this
  !! Prng Class
integer(i64), intent(in) :: seed(:)
  !! Fixed seeds of 64 bit integers. If big == true, must be length 16 else must be length 2.
logical, intent(in), optional :: big
  !! Use the high period xorshift1024* (true) or xorshift128+ (false). Default is false.

logical :: useXorshift1024star
integer(i32) :: i
integer(i32) :: nSeeds
integer(i64) :: tmp

useXorshift1024star = .false.
if (present(big)) useXorshift1024star = big
this%big = useXorshift1024star

if (useXorshift1024star) then
  if (size(seed) /= 16) call eMsg('Prng: For big = .true., seed must have size 16')
  nSeeds = 16
else
  if (size(seed) /= 2) call eMsg('Prng: For big = .false., seed must have size 2')
  nSeeds = 2
endif

if(all(seed(:) == 0_i64)) then
  ! initialize with some non-zero values
  tmp = 0_i64
  do i = 0, nSeeds-1
    call splitmix64(tmp, this%seed(i))
  end do
else
  this%seed(0:nSeeds-1) = seed(1:nSeeds)
endif
this%ptr = 0

end subroutine
!====================================================================!

!====================================================================!
subroutine rngUniform_xorshift(this, val)
!====================================================================!
class(prng), intent(inout) :: this
real(r64), intent(out) :: val

integer(i64) :: rnd
! 1.0 / (1 << 53)
real(r64), parameter :: multiplier = 1.0_r64 / 9007199254740992_r64

if (this%big) then
  call rngInteger_1024star(this, rnd)
else
  call rngInteger_128plus(this, rnd)
endif

! 53-bit, divided by 2^53
val = real(ishft(rnd, -11), kind=r64) * multiplier
end subroutine
!====================================================================!

!====================================================================!
subroutine splitmix64(seed, res)
  !! SplitMix64 implementation for random number seed initialization
!====================================================================!
integer(i64), intent(inout) :: seed
integer(i64) :: res

integer(i64), volatile :: tmp

! As of Fortran95 BOZ literals are available only in DATA stmts.
! Also, gfortran does not allow integer(8) greater than 2^63...
integer(i64), parameter :: step = -7046029254386353131_i64 ! 0x9E3779B97F4A7C15
integer(i64), parameter :: mix1 = -4658895280553007687_i64 ! 0xBF58476D1CE4E5B9
integer(i64), parameter :: mix2 = -7723592293110705685_i64 ! 0x94D049BB133111EB

! gfortran may issue warning at the following lines.
! This is because splitmix64 assumes uint64 wrap-around, which is undefined in F90/95 std.
! Even though there are warnings, AFAIK, generated assembler codes are ones as expected.
tmp = seed + step
seed = tmp
res = tmp
res = ieor(res, ishft(res, -30)) * mix1
res = ieor(res, ishft(res, -27)) * mix2
res = ieor(res, ishft(res, -31))
end subroutine
!====================================================================!
end module


! { dg-do run }

  INTEGER, PARAMETER :: n = 5
  INTEGER, PARAMETER :: a1(n) = SPREAD(1, 1, n)
  INTEGER, PARAMETER :: a2(n, 3) = SPREAD([1,2,3], DIM=1, NCOPIES=n)
  INTEGER, PARAMETER :: a3(3, n) = SPREAD([1,2,3], DIM=2, NCOPIES=n)

  IF (ANY(a1 /= [ 1, 1, 1, 1, 1 ])) STOP 1

  IF (ANY(a2(:, 1) /= 1)) STOP 2
  IF (ANY(a2(:, 2) /= 2)) STOP 3
  IF (ANY(a2(:, 3) /= 3)) STOP 4

  IF (ANY(a3(1, :) /= 1)) STOP 5
  IF (ANY(a3(2, :) /= 2)) STOP 6
  IF (ANY(a3(3, :) /= 3)) STOP 7
END


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   pvl :  Setting functional parameter values (for Bratu's equation)
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, IJAC, ICP(*)
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,*), DFDP(NDIM,*)

      DOUBLE PRECISION E

       E=EXP(U(1))
       F(1)=U(2)
       F(2)=-PAR(1)*E

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

       PAR(1)=0
       U(1)=0.0
       U(2)=0.0

      END SUBROUTINE STPNT

      SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
      DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

       FB(1)=U0(1)
       FB(2)=U1(1)

      END SUBROUTINE BCND

      DOUBLE PRECISION FUNCTION GETU2(U,NDX,NTST,NCOL)
!     ------ --------- -------- -----
      INTEGER, INTENT(IN) :: NDX,NCOL,NTST
      DOUBLE PRECISION, INTENT(IN) :: U(NDX,0:NCOL*NTST)

        GETU2 = U(2,0)

      END FUNCTION GETU2

      SUBROUTINE PVLS(NDIM,U,PAR)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: PAR(*)

      DOUBLE PRECISION, EXTERNAL :: GETP,GETU2
      INTEGER NDX,NCOL,NTST
!----------------------------------------------------------------------
! NOTE :
! Parameters set in this subroutine should be considered as ``solution
! measures'' and be used for output purposes only.
!
! They should never be used as `true'' continuation parameters.
!
! They may, however, be added as ``over-specified parameters'' in the
! parameter list associated with the AUTO-Constant NICP, in order to
! print their values on the screen and in the ``p.xxx file.
!
! They may also appear in the list associated with AUTO-constant NUZR.
!
!----------------------------------------------------------------------
! For algebraic problems the argument U is, as usual, the state vector.
! For differential equations the argument U represents the approximate
! solution on the entire interval [0,1]. In this case its values can
! be accessed indirectly by calls to GETP, as illustrated below, or
! by obtaining NDIM, NCOL, NTST via GETP and then dimensioning U as
! U(NDIM,0:NCOL*NTST) in a seperate subroutine that is called by PVLS.
!----------------------------------------------------------------------

! Set PAR(2) equal to the L2-norm of U(1)
       PAR(2)=GETP('NRM',1,U)

! Set PAR(3) equal to the minimum of U(2)
       PAR(3)=GETP('MIN',2,U)

! Set PAR(4) equal to the value of U(2) at the left boundary.
       PAR(4)=GETP('BV0',2,U)

! Set PAR(5) equal to the value of U(2) at the left boundary using
! another method
       NDX=NINT(GETP('NDX',0,U))
       NTST=NINT(GETP('NTST',0,U))
       NCOL=NINT(GETP('NCOL',0,U))
       PAR(5)=GETU2(U,NDX,NTST,NCOL)
!----------------------------------------------------------------------
! The first argument of GETP may be one of the following:
!        'NRM' (L2-norm),     'MAX' (maximum),
!        'INT' (integral),    'BV0 (left boundary value),
!        'MIN' (minimum),     'BV1' (right boundary value).
!        'MNT' (t value for minimum)
!        'MXT' (t value for maximum)
!        'NDIM', 'NDX' (effective (active) number of dimensions)
!        'NTST' (NTST from constant file)
!        'NCOL' (NCOL from constant file)
!        'NBC'  (active NBC)
!        'NINT' (active NINT)
!        'DTM'  (delta t for all t values, I=1...NTST)
!        'WINT' (integration weights used for interpolation, I=0...NCOL)
!
! Also available are
!   'STP' (Pseudo-arclength step size used).
!   'FLD' (`Fold function', which vanishes at folds).
!   'BIF' (`Bifurcation function', which vanishes at singular points).
!   'HBF' (`Hopf function'; which vanishes at Hopf points).
!   'SPB' ( Function which vanishes at secondary periodic bifurcations).
!   'EIG' ( Eigenvalues/multipliers, I=1...2*NDIM, alternates real/imag parts).
!   'STA' ( Number of stable eigenvalues/multipliers).
!----------------------------------------------------------------------

      END SUBROUTINE PVLS

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT


*DECK DTRCO
      SUBROUTINE DTRCO (T, LDT, N, RCOND, Z, JOB)
C***BEGIN PROLOGUE  DTRCO
C***PURPOSE  Estimate the condition number of a triangular matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2A3
C***TYPE      DOUBLE PRECISION (STRCO-S, DTRCO-D, CTRCO-C)
C***KEYWORDS  CONDITION NUMBER, LINEAR ALGEBRA, LINPACK,
C             TRIANGULAR MATRIX
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DTRCO estimates the condition of a double precision triangular
C     matrix.
C
C     On Entry
C
C        T       DOUBLE PRECISION(LDT,N)
C                T contains the triangular matrix.  The zero
C                elements of the matrix are not referenced, and
C                the corresponding elements of the array can be
C                used to store other information.
C
C        LDT     INTEGER
C                LDT is the leading dimension of the array T.
C
C        N       INTEGER
C                N is the order of the system.
C
C        JOB     INTEGER
C                = 0         T  is lower triangular.
C                = nonzero   T  is upper triangular.
C
C     On Return
C
C        RCOND   DOUBLE PRECISION
C                an estimate of the reciprocal condition of  T .
C                For the system  T*X = B , relative perturbations
C                in  T  and  B  of size  EPSILON  may cause
C                relative perturbations in  X  of size  EPSILON/RCOND .
C                If  RCOND  is so small that the logical expression
C                           1.0 + RCOND .EQ. 1.0
C                is true, then  T  may be singular to working
C                precision.  In particular,  RCOND  is zero  if
C                exact singularity is detected or the estimate
C                underflows.
C
C        Z       DOUBLE PRECISION(N)
C                a work vector whose contents are usually unimportant.
C                If  T  is close to a singular matrix, then  Z  is
C                an approximate null vector in the sense that
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DASUM, DAXPY, DSCAL
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DTRCO
      INTEGER LDT,N,JOB
      DOUBLE PRECISION T(LDT,*),Z(*)
      DOUBLE PRECISION RCOND
C
      DOUBLE PRECISION W,WK,WKM,EK
      DOUBLE PRECISION TNORM,YNORM,S,SM,DASUM
      INTEGER I1,J,J1,J2,K,KK,L
      LOGICAL LOWER
C***FIRST EXECUTABLE STATEMENT  DTRCO
      LOWER = JOB .EQ. 0
C
C     COMPUTE 1-NORM OF T
C
      TNORM = 0.0D0
      DO 10 J = 1, N
         L = J
         IF (LOWER) L = N + 1 - J
         I1 = 1
         IF (LOWER) I1 = J
         TNORM = MAX(TNORM,DASUM(L,T(I1,J),1))
   10 CONTINUE
C
C     RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  T*Z = Y  AND  TRANS(T)*Y = E .
C     TRANS(T)  IS THE TRANSPOSE OF T .
C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C     GROWTH IN THE ELEMENTS OF Y .
C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C     SOLVE TRANS(T)*Y = E
C
      EK = 1.0D0
      DO 20 J = 1, N
         Z(J) = 0.0D0
   20 CONTINUE
      DO 100 KK = 1, N
         K = KK
         IF (LOWER) K = N + 1 - KK
         IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,-Z(K))
         IF (ABS(EK-Z(K)) .LE. ABS(T(K,K))) GO TO 30
            S = ABS(T(K,K))/ABS(EK-Z(K))
            CALL DSCAL(N,S,Z,1)
            EK = S*EK
   30    CONTINUE
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = ABS(WK)
         SM = ABS(WKM)
         IF (T(K,K) .EQ. 0.0D0) GO TO 40
            WK = WK/T(K,K)
            WKM = WKM/T(K,K)
         GO TO 50
   40    CONTINUE
            WK = 1.0D0
            WKM = 1.0D0
   50    CONTINUE
         IF (KK .EQ. N) GO TO 90
            J1 = K + 1
            IF (LOWER) J1 = 1
            J2 = N
            IF (LOWER) J2 = K - 1
            DO 60 J = J1, J2
               SM = SM + ABS(Z(J)+WKM*T(K,J))
               Z(J) = Z(J) + WK*T(K,J)
               S = S + ABS(Z(J))
   60       CONTINUE
            IF (S .GE. SM) GO TO 80
               W = WKM - WK
               WK = WKM
               DO 70 J = J1, J2
                  Z(J) = Z(J) + W*T(K,J)
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
         Z(K) = WK
  100 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
C
      YNORM = 1.0D0
C
C     SOLVE T*Z = Y
C
      DO 130 KK = 1, N
         K = N + 1 - KK
         IF (LOWER) K = KK
         IF (ABS(Z(K)) .LE. ABS(T(K,K))) GO TO 110
            S = ABS(T(K,K))/ABS(Z(K))
            CALL DSCAL(N,S,Z,1)
            YNORM = S*YNORM
  110    CONTINUE
         IF (T(K,K) .NE. 0.0D0) Z(K) = Z(K)/T(K,K)
         IF (T(K,K) .EQ. 0.0D0) Z(K) = 1.0D0
         I1 = 1
         IF (LOWER) I1 = K + 1
         IF (KK .GE. N) GO TO 120
            W = -Z(K)
            CALL DAXPY(N-KK,W,T(I1,K),1,Z(I1),1)
  120    CONTINUE
  130 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (TNORM .NE. 0.0D0) RCOND = YNORM/TNORM
      IF (TNORM .EQ. 0.0D0) RCOND = 0.0D0
      RETURN
      END


FUNCTION gammq_s(a,x,gln)
  USE mo_kind, only: sp
  USE mo_nrutil, ONLY : assert
  use mo_nr, ONLY : gcf,gser
  IMPLICIT NONE
  REAL(SP), INTENT(IN) :: a,x
  REAL(SP), OPTIONAL, INTENT(OUT) :: gln
  REAL(SP) :: gammq_s
  call assert( x >= 0.0,  a > 0.0, 'gammq_s args')
  if (x<a+1.0_sp) then
     if (present(gln)) then
        gammq_s=1.0_sp-gser(a,x,gln)
     else
        gammq_s=1.0_sp-gser(a,x)
     endif
  else
     if (present(gln)) then
        gammq_s=gcf(a,x,gln)
     else
        gammq_s=gcf(a,x)
     endif
  end if
END FUNCTION gammq_s

FUNCTION gammq_v(a,x,gln)
  USE mo_kind, only: sp, i4, lgt
  USE mo_nrutil, ONLY : assert, assert_eq, nrerror
  use mo_nr, ONLY : gcf,gser
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(IN) :: a,x
  REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln
  REAL(SP), DIMENSION(size(a)) :: gammq_v
  LOGICAL(LGT), DIMENSION(size(x)) :: mask
  INTEGER(I4) :: ndum
  ndum=assert_eq(size(a),size(x),'gammq_v')
  call assert( all(x >= 0.0),  all(a > 0.0), 'gammq_v args')
  mask = (x<a+1.0_sp)
  if (present(gln)) then
     if (size(gln) < size(a)) call nrerror('gammq_v: Not enough space for gln')
     gammq_v=merge(1.0_sp-gser(a,merge(x,0.0_sp,mask),gln), &
          gcf(a,merge(x,0.0_sp,.not. mask),gln),mask)
  else
     gammq_v=merge(1.0_sp-gser(a,merge(x,0.0_sp,mask),gln), &
          gcf(a,merge(x,0.0_sp,.not. mask),gln),mask)
  endif
END FUNCTION gammq_v

FUNCTION dgammq_s(a,x,gln)
  USE mo_kind, only: dp
  USE mo_nrutil, ONLY : assert
  use mo_nr, ONLY : gcf,gser
  IMPLICIT NONE
  REAL(DP), INTENT(IN) :: a,x
  REAL(DP), OPTIONAL, INTENT(OUT) :: gln
  REAL(DP) :: dgammq_s
  call assert( x >= 0.0_dp,  a > 0.0_dp, 'dgammq_s args')
  if (x<a+1.0_dp) then
     if (present(gln)) then
        dgammq_s=1.0_dp-gser(a,x,gln)
     else
        dgammq_s=1.0_dp-gser(a,x)
     endif
  else
     if (present(gln)) then
        dgammq_s=gcf(a,x,gln)
     else
        dgammq_s=gcf(a,x)
     endif
  end if
END FUNCTION dgammq_s

FUNCTION dgammq_v(a,x,gln)
  USE mo_kind, only: dp, i4, lgt
  USE mo_nrutil, ONLY : assert, assert_eq, nrerror
  use mo_nr, ONLY : gcf, gser
  IMPLICIT NONE
  REAL(DP), DIMENSION(:), INTENT(IN) :: a,x
  REAL(DP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln
  REAL(DP), DIMENSION(size(a)) :: dgammq_v
  LOGICAL(LGT), DIMENSION(size(x)) :: mask
  INTEGER(I4) :: ndum
  ndum=assert_eq(size(a),size(x),'dgammq_v')
  call assert( all(x >= 0.0_dp),  all(a > 0.0_dp), 'dgammq_v args')
  mask = (x<a+1.0_dp)
  if (present(gln)) then
     if (size(gln) < size(a)) call nrerror('dgammq_v: Not enough space for gln')
     dgammq_v=merge(1.0_dp-gser(a,merge(x,0.0_dp,mask),gln), &
          gcf(a,merge(x,0.0_dp,.not. mask),gln),mask)
  else
     dgammq_v=merge(1.0_dp-gser(a,merge(x,0.0_dp,mask),gln), &
          gcf(a,merge(x,0.0_dp,.not. mask),gln),mask)
  endif
END FUNCTION dgammq_v


function tapf(tau       )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: tapf.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/kernel/src/compute_roller/tapf.f90 $
!!--description-----------------------------------------------------------------
!
! Taper function used to smoothly start-up the program
! in the time dependent roller case. Also used to
! reduce wave forces near boundaries where bound waves
! should leave the domain.
!
! taper funcion runs from 0 to 1 if tau runs from 0 to 1
! function has all derivatives equal to 0 in tau=0 and tau=1
! and is constant outside the range [0,1].
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    implicit none
!
! Global variables
!
    real(fp)         :: tapf
    real(fp), intent(in) :: tau
!
! Local variables
!
    real(fp) :: eps
!
!! executable statements -------------------------------------------------------
!
    eps = 1.0E-5
    if (tau<=eps) then
       tapf = 0.0
    elseif (tau>=1.0 - eps) then
       tapf = 1.0
    else
       tapf = 0.5*(1.0 + tanh((tau - 0.5)/(1.0 - tau)/tau))
    endif
end function tapf


subroutine gpm(k,refractive,N,RT)
    use MOD_dataSpec_wavelength
    implicit none

    real*8, intent(in) :: k(nw), refractive(nw), N
    real*8, intent(out) :: RT(nw,2)

    real*8 :: theta1, theta2
    real*8, dimension(nw) :: tau,t1,t2,x1,x2,x3,x4,x5,x6,r,t,ra,ta
    real*8, dimension(nw) :: delta,beta,va,vb,s1,s2,s3

    ! ********************************************************************************
    ! reflectance and transmittance of one layer
    ! ********************************************************************************
    ! Allen W.A., Gausman H.W., Richardson A.J., Thomas J.R. (1969), Interaction of
    ! isotropic ligth with a compact plant leaf, Journal of the Optical Society of
    ! American, 59:1376-1379.
    ! ********************************************************************************

    Call expint(k,tau)
    ! transmissivity of the layer

    theta1  = 90.
    call tav_abs(theta1,refractive,t1)
    theta2  = 40.
    call tav_abs(theta2,refractive,t2)
    x1      = 1-t1
    x2      = t1**2*tau**2*(refractive**2-t1)
    x3      = t1**2*tau*refractive**2
    x4      = refractive**4-tau**2*(refractive**2-t1)**2
    x5      = t2/t1
    x6      = x5*(t1-1)+1-t2
    r       = x1+x2/x4
    t       = x3/x4
    ra      = x5*r+x6
    ta      = x5*t

    ! ********************************************************************************
    ! reflectance and transmittance of N layers
    ! ********************************************************************************
    ! Stokes G.G. (1862), On the intensity of the light reflected from or transmitted
    ! through a pile of plates, Proceedings of the Royal Society of London, 11:545-556.
    ! ********************************************************************************

    delta   = (t**2-r**2-1)**2-4*r**2
    beta    = (1+r**2-t**2-sqrt(delta))/(2*r)
    va      = (1+r**2-t**2+sqrt(delta))/(2*r)
    vb      = sqrt(beta*(va-r)/(va*(beta-r)))
    s1      = ra*(va*vb**(N-1)-va**(-1)*vb**(-(N-1)))+(ta*t-ra*r)*(vb**(N-1)-vb**(-(N-1)))
    s2      = ta*(va-va**(-1))
    s3      = va*vb**(N-1)-va**(-1)*vb**(-(N-1))-r*(vb**(N-1)-vb**(-(N-1)))
    RT(:,1) = s1/s3
    RT(:,2) = s2/s3

end subroutine


!     calculation cauchy stress
subroutine r_scauchy(det,todet,xto,cstr_element)
  use r_common
  use solid_variables, only: nsd_solid
  implicit none

  real(8),intent(in) :: det,todet
  real(8) xto(3,3)
  real(8) :: cstr_element(6)  !...Cauchy stress
  real(8) :: ss(3,3)
  integer :: isd,jsd

  threedim: if (nsd_solid .eq. 3) then

  ss(1,1)=PK2str(1)
  ss(2,2)=PK2str(2)
  ss(1,3)=PK2str(5)
  ss(3,1)=PK2str(5)
  ss(2,3)=PK2str(4)
  ss(3,2)=PK2str(4)
  ss(1,2)=PK2str(6)
  ss(2,1)=PK2str(6)
  ss(3,3)=PK2str(3)

  cstr_element(1:6) = 0.0d0

  do isd=1,3
     do jsd=1,3
        cstr_element(1)=cstr_element(1) + todet/det*xto(1,isd)*ss(isd,jsd)*xto(1,jsd)
        cstr_element(2)=cstr_element(2) + todet/det*xto(2,isd)*ss(isd,jsd)*xto(2,jsd)
        cstr_element(3)=cstr_element(3) + todet/det*xto(3,isd)*ss(isd,jsd)*xto(3,jsd)
        cstr_element(4)=cstr_element(4) + todet/det*xto(3,isd)*ss(isd,jsd)*xto(2,jsd)
        cstr_element(5)=cstr_element(5) + todet/det*xto(1,isd)*ss(isd,jsd)*xto(3,jsd)
        cstr_element(6)=cstr_element(6) + todet/det*xto(1,isd)*ss(isd,jsd)*xto(2,jsd)
     enddo
  enddo

  endif  threedim

  twodim: if (nsd_solid .eq. 2) then

  ss(1,1)=PK2str(1)
  ss(2,2)=PK2str(2)
  ss(1,2)=PK2str(3)
  ss(2,1)=PK2str(3)

  cstr_element(1:nsd_solid*2) = 0.0d0

  do isd=1,2
     do jsd=1,2
        cstr_element(1)=cstr_element(1) + todet/det*xto(1,isd)*ss(isd,jsd)*xto(1,jsd)
        cstr_element(2)=cstr_element(2) + todet/det*xto(2,isd)*ss(isd,jsd)*xto(2,jsd)
        cstr_element(3)=cstr_element(3) + todet/det*xto(1,isd)*ss(isd,jsd)*xto(2,jsd)
     enddo
  enddo

	endif twodim

  return
end subroutine r_scauchy


c
c -----------------------------------------------------------------------------
c
      double precision function get_max_speed(val,mitot,mjtot,nvar,
     &                          aux,naux,nghost,hx,hy)

      use geoclaw_module
      implicit double precision (a-h,o-z)
      dimension   val(mitot,mjtot,nvar), aux(mitot,mjtot,naux)

      sp_over_h = 0.d0   ! compute max speed over h, since dx may not equal dy
      if (icoordsys .eq. 2) then
        do j = nghost+1, mjtot-nghost
         ymetric = Rearth*pi/180.d0
         hyphys = ymetric*hy

         do i = nghost+1, mitot-nghost
            xmetric = cos(aux(i,j,3))*Rearth*pi/180.d0
            hxphys = xmetric * hx
            h  = val(i,j,1)
            if (h .gt. drytolerance) then
              u  = val(i,j,2)/h
              v  = val(i,j,3)/h
            else
              u = 0.d0
              v = 0.d0
            endif
            sig = sqrt(grav*h)
            sp_over_h = max((abs(u)+sig)/hxphys,(abs(v)+sig)/hyphys,
     &                      sp_over_h)
         end do
         end do
      else  ! speeds in cartesian coords, no metrics needed
         do j = nghost+1, mjtot-nghost
         do i = nghost+1, mitot-nghost
            h  = val(i,j,1)
            if (h .gt. drytolerance) then
              u  = val(i,j,2)/h
              v  = val(i,j,3)/h
            else
              u = 0.d0
              v = 0.d0
            endif
            sig = sqrt(grav*h)
            sp_over_h = max((abs(u)+sig)/hx,(abs(v)+sig)/hy,sp_over_h)
         end do
         end do
      endif

       get_max_speed = sp_over_h

       return
       end


	DOUBLE PRECISION FUNCTION ERF(X)
C*************************************************************************
C
	IMPLICIT NONE
C   COMPUTE ERROR FCN AND COMPLIMENT OF ERROR FUNCTION
C
C       ERF(X) = [2/SQRT(PI)]*{Integral from 0 to X of EXP(-T**2)DT }
C
C   REF: KENNEDY AND GENTLE. STATISTICAL COMPUTING
C        New York:  Marcel and Dekker, Inc  1980:90-92.
C
C*************************************************************************
	DOUBLE PRECISION X,R1,ERFC
	IF (X.GT.0.AND.X.LT.0.46875) THEN
	    ERF=X*R1(X)
	ELSE IF (X.GE.0.46875) THEN
	    ERF=1.-ERFC(X)
      ELSE IF (X .EQ. 0.) THEN
            ERF=0.
	ELSE
	    STOP
	END IF
	RETURN
	END