!*******************************************************************
!> author: Akira Kageyama
!  date: 2020.01.15
!
!  バーガース方程式を差分法+ルンゲ・クッタ積分法で解き、可視化する。
!
!  神戸大学情報知能工学科の講義 "HPC" （B3対象）用サンプルコード
!
!### 目的
!  この後に説明する3次元Smoke-Ringシミュレーションコードを理解するため。
!
!  3次元Smoke-Ringシミュレーションコードでは
!  基本方程式は違うものの、アルゴリズム（差分法+ルンゲ・クッタ積分法）
!  とシミュレーションコードの構造が同じである。
!
!### 実行方法
!  cd src ; make
!

program main
  use constants_m  ! 定数の読み込み
  use ut_m         ! ユーティリティライブラリ
  use namelist_m   ! namelist機能を使ったパラメータ読み込み
  use rk4_m        ! Runge-Kutta積分法
  implicit none

  real(DR), dimension(:), allocatable :: xpos
           ! 格子点の位置（x座標）の配列  配列サイズはnx
  real(DR), dimension(:), allocatable :: psi
           ! 求める振幅の配列   配列サイズはnx
  real(DR), dimension(:), allocatable :: dpsi01, dpsi02,  &
                                         dpsi03, dpsi04
           ! 4段のRunge-Kutta法に必要となる4つの作業用配列
           ! 1段の作業での被積分関数（振幅psi）の微小な増分量に相当
  integer(SI) :: i, nx
  integer(DI) :: nloop             ! 時間積分の回数
  integer(DI) :: nloop_max = 1000  ! 一度の計算ジョブでの積分回数最大値
  real(DR) :: dx, dt, time, x      ! 格子間隔、時間刻み、時刻、x座標
  real(DR), parameter :: ONE_SIXTH = 1.0_DR / 6.0_DR
                         ! Runge-Kutta法で必要となる定数
                         ! 毎回この割り算をするのは演算の
                         ! 無駄なのでこうして定数として保存する
  real(DR), parameter :: CFL_FACTOR = 0.4_DR
                         ! 時間発展を追跡する計算機シミュレーションでは
                         ! 一般に、時間刻み幅dtが小さいと、効率が悪い。
                         ! 実時間で同じ時刻に到達するまでに必要となる
                         ! 積分回数が多くなるからである。

                         ! だが、ここで採用しているRunge-Kutta法のような
                         ! 陽的な時間積分アルゴリズムではdtを大きく
                         ! しすぎると計算が破綻（発散）する。
                         !
                         ! その発散条件をCFL (Courant-Friedrichs-Lewy)条件
                         ! という。
                         !
                         ! CFL条件はある定数の比例するという形で書ける
                         ! 場合が多い。その定数をCFL_FACTORという。
                         !
                         ! CFL_FACTORは、
                         !   (1) アルゴリズム（ここでは二次精度空間
                         !       中心差分法と4次精度Runge-Kutta時間積分
                         !       の組み合わせ）
                         !   (2) 基本方程式（ここではバーガース方程式）
                         !   (3) 方程式のパラメータ（ここではバーガース
                         !       方程式に含まれる粘性係数）
                         ! で決まり、その値を理論的、または数値的に
                         ! 高精度で求めることが原理的には可能である。
                         !
                         ! しかしながら、CFL_FACTORを高精度で求めること
                         ! は実際上、余り意味がない。（その値をたとえば
                         ! 0.4から0.45にしてもシミュレーションの進行
                         ! 速度が(45/4)倍になるだけである。）
                         !
                         ! ここでは半経験的にこのCFL_FACTORを設定した。
                         !
                         ! 対象方程式（バーガース方程式）やアルゴリズム
                         ! を変更したらこの値も調整する必要がある。

  !
  !    1    2    3    4                                    nx-1  nx
  !    !----!----!----!----!----!--             --!----!----!----!
  !         !               \  /                                 !
  !         !                dx = TWOPI / (nx-2)                 !
  !    x=-PI!<---------------------- TWOPI --------------------->!x=+PI
  !         !                                                    !
  !         !                                                    !
  !  --!----!                                                !---!--
  !  nx-1  nx                                                1   2
  !
  ! 格子点とその番号割当の模式図
  !   * 格子番号は1で始まり、nxまで。
  !   * 周期境界条件を仮定している。周期の長さは2*pi
  !   * 2番の格子点とnx番の格子点が実際は同じ空間位置を指す。
  !   * 同様に1番の格子点と(nx-1)番の格子点が同じ空間位置を指す。

  call namelist__read
     ! Fortranのnamelistという機能を使って
     ! シミュレーションの数値パラメータを読み込む。
     ! ここで読み込むパラメータは2つ
     !  (1) Nx : 格子間隔
     !  (2) Diffusion_coeff : 粘性率に相当する拡散係数
     !
     ! この程度であればわざわざnamelistを使わなくてもいいが、
     ! もっと大規模なシミュレーションになると多数の入力パラメータ
     ! が必要になる。
     !
     ! 定数を設定するconstantsモジュールに直接パラメータを
     ! 書き込むのは得策ではない。なぜならばパラメーターを
     ! 変更するたびに毎回コンパイルする必要が生じるからである。
     !
     ! 入力パラメーターは人間にとって読み書きのしやすい
     ! テキストデータで渡すべきである。
     !
     ! テキストデータをプログラムに渡す時にはパラメーターの
     ! 名前とその値のペアをわかりやすい形で表現できるのが望ましい。
     !
     ! その仕組みがnamelistである。
     !

  nx = namelist__get_integer('Nx')  ! 文字列をキーにして値を取り出す
  dx = TWOPI / (nx-2)               ! 格子間隔。上の図を見よ。
  dt = dx**2 / namelist__get_double('Diffusion_coeff') * CFL_FACTOR
                                    ! CFL条件

  allocate(xpos(nx),psi(nx))   ! 配列の割当
  allocate(dpsi01(nx))
  allocate(dpsi02(nx))
  allocate(dpsi03(nx))
  allocate(dpsi04(nx))

  xpos(:) = 0.0_DR    ! ゼロで初期化。allocate後の配列の値は
  psi(:)  = 0.0_DR    ! ゼロになっているとは限らないので注意。
  dpsi01(:) = 0.0_DR  ! 配列の初期化忘れに起因する混乱（ゼロ
  dpsi02(:) = 0.0_DR  ! だと思って計算した配列に実は非ゼロの
  dpsi03(:) = 0.0_DR  ! ランダムな値が入っていて計算がおかしく
  dpsi04(:) = 0.0_DR  ! なること）はシミュレーションではよくある。

  do i = 1 , nx
    xpos(i) = -PI + dx*(i-2)  ! 格子点位置の設定。上の図を参照せよ。
  end do

  do i = 1 , nx
    x = xpos(i)
    psi(i) = 0.8_DR + 0.2_DR*cos(x)  ! 初期振幅。自由に設定してよい。
  end do
    ! バーガース方程式の性質から振幅の大きい（つまりpsiの値が
    ! 大きい）ところほど移流速度が速い。そのため波の「突っ立ち」
    ! 現象が生じる。
    !
    ! 完全に垂直に突っ立った波は（勾配が無限になるので）
    ! 差分法では表現できないが、バーガース方程式に含まれる
    ! 粘性（拡散）項が急な勾配の発生を抑える。
    !
    ! 粘性係数が大きすぎると波がすぐに拡散して消えてしまう。
    !
    ! 粘性は小さい方が（突っ立ちが見えて）面白いが、小さすぎる
    ! と突っ立ちのために計算が発散してしまう。実験するとよい。
    ! （粘性係数はnamelistで渡している。params.namelistファイル。）
    !
    ! できるだけ粘性を小さくするにはどうしたらよいか？
    ! 格子点数（nx）を大きくすれば良い。急な勾配であってもその
    ! 曲線の中に十分多くの格子点があれば差分が計算できるからである。
    ! これも実験するとよい。

  call ut__message('initial check: nx = ', nx)
    ! 標準出力に文字列と整数値を書き出す。
    ! このような出力はよく使うのでutモジュールに入れた。
  call ut__message('initial check: dx = ', dx)
    ! 同じサブルーチン名で呼び出しているが、こちらは倍精度浮動小数点数
    ! であるdxを書き出すことに注意。多重定義である。

  time = 0.0_DR  ! シミュレーション時刻の設定

  call iSave ! 初期条件の振幅（psi）をディスクに書き出す。
             ! 小文字のiで始まるサブルーチン・関数は
             ! 内部副プログラム、という命名規約を使っている。
             ! つまり "call iなんとか" と書かれていたら、
             ! 呼び出されている "iなんとか" はそのすぐ下の
             ! contains文の後ろに定義があることが分かるので
             ! 見つけやすい。

  do nloop = 1 , nloop_max  ! シミュレーションのメインループ
    !--< Runge-Kutta step 1 >--!
    dpsi01(:) = rk4__step('1st',dt,dx,psi)  ! ルンゲ・クッタ1段目
    call iBoundary_condition(dpsi01)        ! 境界条件の設定
                                            ! 小文字のiで始まっ
                                            ! ているので、内部副
                                            ! プログラム、つまり
                                            ! 下のcontains文の
                                            ! 後で定義されている

    !--< Runge-Kutta step 2 >--!
    dpsi02(:) = rk4__step('2nd',dt,dx,psi,dpsi01)    ! 2段目
    call iBoundary_condition(dpsi02)        ! 境界条件の設定

    !--< Runge-Kutta step 3 >--!
    dpsi03(:) = rk4__step('3rd',dt,dx,psi,dpsi02)    ! 3段目
    call iBoundary_condition(dpsi03)        ! 境界条件の設定

    !--< Runge-Kutta step 4 >--!
    dpsi04(:) = rk4__step('4th',dt,dx,psi,dpsi03)    ! 4段目
    call iBoundary_condition(dpsi04)        ! 境界条件の設定

    time = time + dt  ! 時間の更新
                      ! 【注意】バーガース方程式は時刻tに陽には
                      !   依存しない（方程式にtが直接現れない）ので、
                      !   このように4段の積分が終了した後にdtだけ
                      !   時間を進めても問題ない。
                      !   だが、もしも解くべき基本方程式が時刻tに陽に
                      !   依存する場合には、4段の積分過程の途中で
                      !   時刻をdt/2だけ進める必要がある。詳しくは
                      !   ルンゲ・クッタのアルゴリズムを見よ。

    psi(:) = psi(:) + ONE_SIXTH*(dpsi01(:)      &
                              +2*dpsi02(:)      &
                              +2*dpsi03(:)      &
                                +dpsi04(:))
                      ! ここでは教科書に載っている古典的な4段4次の
                      ! ルンゲ・クッタアルゴリズムをそのまま実装
                      ! している。この方法ではこのように作業配列（dpsi）
                      ! が4つ必要である。同じ4次のルンゲ・クッタ法でも
                      ! 作業配列を少なくするアルゴリズムがある。大規模
                      ! なシミュレーションなどでメモリを節約する必要が
                      ! ある場合は、それらの手法を使うべきである。

    if ( mod(nloop,4)==0 ) then
      call iSave  ! Save the profile to the disk.
         ! gnuplotを使ったアニメーション表示のためにディスクに
         ! 振幅を書き出す。毎ステップ書き出すとディスク容量を
         ! 圧迫する割に視覚的な効果はそれほど向上しない。ここで
         ! は4ステップごとに書き出しているがこの数字は適当に決めた。
         ! 格子点数nxの値などを変更する場合はこの数字も調整が
         ! 必要であろう。
    end if
  end do

contains

  subroutine iBoundary_condition(psi)
    real(DR), dimension(nx), intent(inout) :: psi
    ! 周期境界条件  上の説明用コメント図を参照せよ。
    psi(1)    = psi(nx-1)
    psi(nx)   = psi(2)
  end subroutine iBoundary_condition

  subroutine iSave
    integer(SI), save :: counter = 0
    integer(SI) :: i
    ! ディスクへの書き出し
    open(10,file="output.data" // '.' // ut__i2c3(counter))
      ! ファイルオープン
      ! スラッシュ記号2つ連続は文字列連結演算子
      ! ut__i2c3はutモジュールで定義された整数（i）を3文字
      ! に変換する関数
      do i = 1, nx
         write(10,*) xpos(i), psi(i)  ! gnuplotのフォーマット準拠
                                      ! つまりxの値とyの値を空白で区切る
      end do
    close(10)
    counter = counter + 1
    ! ファイル名に整数連番を不可する。その数字のインクリメント
    call ut__message(" Data saved at nloop, time = ", nloop, time)
    ! これも多重定義。文字列に整数、浮動小数点数をつなげて出力
  end subroutine iSave

end program main


PROGRAM me1z

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:10

!       =========================================================
!       Purpose: This program computes the complex exponential
!                integral E1(z) using subroutine E1Z
!       Example:
!                     z            Re[E1(z)]       Im[E1(z)]
!                -----------------------------------------------
!                 3.0    2.0    -.90959209D-02   -.69001793D-02
!                 3.0   -2.0    -.90959209D-02    .69001793D-02
!                -3.0    2.0    -.28074891D+01    .59603353D+01
!                -3.0   -2.0    -.28074891D+01   -.59603353D+01
!                25.0   10.0    -.29302080D-12    .40391222D-12
!                25.0  -10.0    -.29302080D-12   -.40391222D-12
!               -25.0   10.0     .27279957D+10   -.49430610D+09
!               -25.0  -10.0     .27279957D+10    .49430610D+09
!       =========================================================

IMPLICIT COMPLEX*16 (c,z)
IMPLICIT DOUBLE PRECISION (d-h,o-y)
WRITE(*,*)'Please enter x and y ( z =x+iy ) '
!        READ(*,*)X,Y
x=3.0
y=2.0
z=CMPLX(x,y)
CALL e1z(z,ce1)
WRITE(*,*)
WRITE(*,*)'       z           Re[E1(z)]        Im[E1(z)]'
WRITE(*,*)' -----------------------------------------------'
WRITE(*,10)x,y,ce1
10      FORMAT(1X,f5.1,2X,f5.1,1X,2D17.8)
END PROGRAM me1z

SUBROUTINE e1z(z,ce1)

!       ====================================================
!       Purpose: Compute complex exponential integral E1(z)
!       Input :  z   --- Argument of E1(z)
!       Output:  CE1 --- E1(z)
!       ====================================================

COMPLEX, INTENT(IN)                      :: z
COMPLEX, INTENT(OUT)                     :: ce1
IMPLICIT COMPLEX*16 (c,z)
IMPLICIT DOUBLE PRECISION (d-h,o-y)

pi=3.141592653589793D0
el=0.5772156649015328D0
x=REAL(z)
a0=CDABS(z)
IF (a0 == 0.0D0) THEN
  ce1=(1.0D+300,0.0D0)
ELSE IF (a0 <= 10.0.OR.x < 0.0.AND.a0 < 20.0) THEN
  ce1=(1.0D0,0.0D0)
  cr=(1.0D0,0.0D0)
  DO  k=1,150
    cr=-cr*k*z/(k+1.0D0)**2
    ce1=ce1+cr
    IF (CDABS(cr) <= CDABS(ce1)*1.0D-15) EXIT
  END DO
  15         ce1=-el-CDLOG(z)+z*ce1
ELSE
  ct0=(0.0D0,0.0D0)
  DO  k=120,1,-1
    ct0=k/(1.0D0+k/(z+ct0))
  END DO
  ct=1.0D0/(z+ct0)
  ce1=CDEXP(-z)*ct
  IF (x <= 0.0.AND.DIMAG(z) == 0.0) ce1=ce1-pi*(0.0D0,1.0D0)
END IF
RETURN
END SUBROUTINE e1z


module matrix_c
    interface
        subroutine c_matrix_multiply(n, c, a, b) bind(c, name="gemm")
            use iso_c_binding
            implicit none
            integer(c_int), value :: n
            integer(c_int)        :: c(*)
            integer(c_int)        :: a(*)
            integer(c_int)        :: b(*)
        end subroutine
    end interface
end module

module matrix
    implicit none

    type matrix_t
        integer, dimension(:,:), allocatable    :: mat
        integer                                 :: d1
        integer                                 :: d2
    contains
        procedure, pass(this)   :: init => matrix_init
        procedure, pass(this)   :: free => matrix_free
        procedure               :: multiply => matrix_multiply_c
        generic :: operator(*) => multiply
    end type matrix_t

contains

    ! Initialize a matrix
    subroutine matrix_init(this, d1, d2)
        class(matrix_t), intent(inout)  :: this
        integer, intent(in)             :: d1
        integer, intent(in)             :: d2

        call matrix_free(this)

        allocate(this%mat(d1, d2))
        this%d1 = d1
        this%d2 = d2
    end subroutine matrix_init

    !Free a matrix
    subroutine matrix_free(this)
        class(matrix_t), intent(inout) :: this

        if (allocated(this%mat)) then
            deallocate(this%mat)
        end if
        this%d1 = 0
        this%d2 = 0
    end subroutine matrix_free

    ! General matrix multiply
    function matrix_multiply(a, b) result(c)
        type(matrix_t), intent(in) :: a
        type(matrix_t), intent(in) :: b
        type(matrix_t) :: c

        integer :: i, j, k

        call c%init(a%d1, b%d2)

        do i = 1, c%d1
            do j = 1, c%d2
                c%mat(i, j) = 0.0
                do k = 1, a%d2
                    c%mat(i, j) = c%mat(i, j) + a%mat(i, k) * b%mat(k, j)
                end do
            end do
        end do
    end function matrix_multiply

    ! General matrix multiply in c
    function matrix_multiply_c(a, b) result(c)
        use matrix_c
        use iso_c_binding
        class(matrix_t), intent(in) :: a
        type(matrix_t), intent(in) :: b
        type(matrix_t) :: c

        call c%init(a%d1, b%d2)

        call c_matrix_multiply(a%d1, c%mat, a%mat, b%mat)
    end function matrix_multiply_c

end module matrix

program gemm_test
    use matrix
    implicit none

    type(matrix_t) :: A, B, C

    call A%init(2, 2)
    call B%init(2, 2)
    call C%init(2, 2)

    ! Fill A, B with data
    A%mat(1, 1) = 1
    A%mat(1, 2) = 2
    A%mat(2, 1) = 3
    A%mat(2, 2) = 4

    B%mat(1, 1) = 5
    B%mat(1, 2) = 6
    B%mat(2, 1) = 7
    B%mat(2, 2) = 8

    !| 1 2 |   | 5 6 |   | 19 22 |
    !| 3 4 | x | 7 8 | = | 43 50 |

    C = A * B

    write(*,*) 'A: ', A%mat
    write(*,*) 'B: ', B%mat
    write(*,*) 'C: ', C%mat

    C = matrix_multiply(A, B)

    write(*,*) 'A: ', A%mat
    write(*,*) 'B: ', B%mat
    write(*,*) 'C: ', C%mat
end program gemm_test


program test_linalg_diff

    use forlab_linalg, only: diff
    use forlab_linalg, only: linspace, seq
    use forlab_io, only: disp
    implicit none

    real :: x(10)
    integer, allocatable :: i(:)

    call linspace(x, 0.0, 9.0)
    call disp("Test_linalg_diff_real : ")
    call disp(x, "Linspace(x) : ")
    call disp(diff(x), "Test_linalg_diff : ")

    call seq(i, 0, 9, 1)
    call disp("Test_linalg_diff_integer : ")
    call disp(i, "Seq(i) : ")
    call disp(diff(i), "Test_linalg_diff : ")

end program test_linalg_diff


c gmm01f
c  subroutine besseljd.f  (in double precision arithmetic)
c  THIS FILE IS PART OF THE ORIGINAL GMM01F DISTRIBUTION
c  returns an array of the spherical Bessel function of the
c  first kind with a real argument: j_0,j_1,j_2,...,j_{NC}
c  uses Ru Wang's ratio method for the downward recursive
c  calculation of the Riccati-Bessel function Psi_n(z)=z j_n(z)
c  [see Xu et al., Physical Review E, v.60, 2347-2365 (1999)]
      SUBROUTINE besseljd(NC,X,BESJ)
      INTEGER NC,NX,K,N
      DOUBLE PRECISION X,BESJ(0:NC),PN,CN,X2
      DO K=1,NC
         BESJ(K)=0.D0
      ENDDO
      IF(DABS(X).LT.1.D-12) THEN
         BESJ(0)=1.D0
         BESJ(1)=1.D0/3.D0*X
         RETURN
      ENDIF
c  down-recursively calculating an array of the ratio functions
c  P_{NC},P_{NC-1},...,P(2) stored in the same array for j_n,
c  starting with an asymptotic value P_{NX+1}=X/(2 NX+3) at the
c  highest order NX+1, where NX=NC+1.1X+10
      NX=1.1D0*X+10.D0
      NX=NC+NX
      PN=X/DBLE(2*NX+3)
      DO 5 K=1,NX-1
         N=NX-K+1
         CN=DBLE(N)
         PN=X/(DBLE(2*N+1)-PN*X)
         IF(N.GT.NC) GOTO 5
         BESJ(N)=PN
    5 CONTINUE
C  calculating j_0(x) and j_1(x)
      IF(DABS(X)-0.1D0) 10,11,11
   10 X2=X*X
      BESJ(0)=1.D0-X2/72.D0
      BESJ(0)=1.D0-X2/42.D0*BESJ(0)
      BESJ(0)=1.D0-X2/20.D0*BESJ(0)
      BESJ(0)=1.D0-X2/6.D0*BESJ(0)
      BESJ(1)=1.D0/45360.D0-X2/3991680.D0
      BESJ(1)=1.D0/840.D0-X2*BESJ(1)
      BESJ(1)=1.D0/30.0d0-X2*BESJ(1)
      BESJ(1)=X*(1.D0/3.0d0-X2*BESJ(1))
      GOTO 12
   11 BESJ(0)=DSIN(X)/X
      BESJ(1)=(DSIN(X)/X-DCOS(X))/X
c  calculating j_2,...,j_{NC}
   12 DO 20 N=2,NC
         BESJ(N)=BESJ(N)*BESJ(N-1)
   20 CONTINUE
      RETURN
      END


! NormalDeviates - Fortran module for generating univariate and three-variate
!                  random deviates.
!
! Copyright 2020 by Servizi Territorio srl
!                   This is open-source software, covered by the MIT license.
!
! Author: Patti M. Favaron
!
module NormalDeviates

	implicit none

	private

	! Public interface
	public	:: Norm
	public	:: MultiNorm

contains

	! Credit: this routine has been obtained by refactoring of function "random_normal"
	! by Alan Miller (CSIRO Division of Mathematics & Statistics), module 'random.f90'
	function Norm(rvNormValues) result(iRetCode)

		! Routine arguments
		real, dimension(:), intent(inout)	:: rvNormValues
		integer								:: iRetCode

		! Locals
		real	:: u, v, x, y, q
		integer	:: i

		! Constants
		real, parameter	:: s  =  0.449871
		real, parameter	:: t  = -0.386595
		real, parameter	:: a  =  0.19600
		real, parameter	:: b  =  0.25472
		real, parameter	:: r1 =  0.27597
		real, parameter	:: r2 =  0.27846

		! Assume success (will falsify on failure)
		iRetCode = 0

		! Main loop
		if(size(rvNormValues) <= 0) then
			iRetCode = 1
			return
		end if
		do i = 1, size(rvNormValues)

			! Important loop: generate P = (u,v) uniform in rectangle enclosing
			! acceptance region, and iterate until point is really within
			! the acceptance region
			do

				! Get uniform deviates using the compiler's generator
				call RANDOM_NUMBER(u)
				call RANDOM_NUMBER(v)
				v = 1.7156 * (v - 0.5)

				! Evaluate the quadratic form
				x = u - s
				y = ABS(v) - t
				q = x**2 + y*(a*y - b*x)

				! Accept/reject
				if(q < r1) exit
				if(q > r2) cycle
				if(v**2 < -4.0*LOG(u)*u**2) exit
			end do

			! Return ratio of P's coordinates as the normal deviate
			rvNormValues(i) = v/u

		end do

	end function Norm

	! This is all mine (Patti)
	function MultiNorm(rU, rV, rW, rUU, rVV, rWW, rUV, rUW, rVW, rvNormU, rvNormV, rvNormW) result(iRetCode)

		! Routine arguments
		real, intent(in)				:: rU
		real, intent(in)				:: rV
		real, intent(in)				:: rW
		real, intent(in)				:: rUU
		real, intent(in)				:: rVV
		real, intent(in)				:: rWW
		real, intent(in)				:: rUV
		real, intent(in)				:: rUW
		real, intent(in)				:: rVW
		real, dimension(:), intent(out)	:: rvNormU
		real, dimension(:), intent(out)	:: rvNormV
		real, dimension(:), intent(out)	:: rvNormW
		integer							:: iRetCode

		! Locals
		integer							:: n
		integer							:: iErrCode
		real							:: rL11
		real							:: rL12
		real							:: rL13
		real							:: rL22
		real							:: rL23
		real							:: rL33
		real, dimension(:), allocatable	:: rvNormX
		real, dimension(:), allocatable	:: rvNormY
		real, dimension(:), allocatable	:: rvNormZ

		! Assume success (will falsify on failure)
		iRetCode = 0

		! Check input parameters
		if(rUU < 0. .or. rVV < 0. .or. rWW < 0.) then
			iRetCode = 1
			return
		end if
		n = size(rvNormU)
		if(n <= 0) then
			iRetCode = 2
			return
		end if
		if(size(rvNormV) /= n .or. size(rvNormW) /= n) then
			iRetCode = 2
			return
		end if

		! Compute the coefficients of the Cholesky decomposition of covariances matrix
		rL11 = SQRT(rUU)
		rL12 = rUV/rL11
		rL13 = rUW/rL11
		rL22 = SQRT(-(rUV**2/rUU) + rVV)
		rL23 = (-rUV*rUW + rUU*rVW) / SQRT(rUU*(-rUV**2 + rUU*rVV))
		rL33 = SQRT(-(rUW**2/rUU) - (-rUV*rUW + rUU*rVW) * (-rUV*rUW + rUU*rVW) / (rUU**2*(-(rUV**2/rUU) + rVV)) + rWW)

		! Generate three random values distributed according to the multivariate
		! normal distribution with same covariance matrix as computed
		allocate(rvNormX(n), rvNormY(n), rvNormZ(n))
		iErrCode = Norm(rvNormX)
		if(iErrCode /= 0) then
			iRetCode = 3
			deallocate(rvNormX, rvNormY, rvNormZ)
			return
		end if
		iErrCode = Norm(rvNormY)
		if(iErrCode /= 0) then
			iRetCode = 3
			deallocate(rvNormX, rvNormY, rvNormZ)
			return
		end if
		iErrCode = Norm(rvNormZ)
		if(iErrCode /= 0) then
			iRetCode = 3
			deallocate(rvNormX, rvNormY, rvNormZ)
			return
		end if
		rvNormU = rL11*rvNormX + rL12*rvNormY + rL13*rvNormZ + rU
		rvNormV =                rL22*rvNormY + rL23*rvNormZ + rV
		rvNormW =                               rL33*rvNormZ + rW

		! Leave
		deallocate(rvNormX, rvNormY, rvNormZ)

	end function MultiNorm

end module NormalDeviates


      function derivative(fun,xi,hi,idiri,xmini,xmaxi,erroro)
c returns the derivative of f
c
c fun    (INPUT)= function to differentiate
c xi     (INPUT)= point where to compute the derivative
c hi     (INPUT)= initial stepsize
c idiri  (INPUT)= type of derivative (see below)
c xmini  (INPUT)= lower bound in x
c xmaxi  (INPUT)= upper bound in x
c error  (OUTPUT)= estimated error
c
c idiri =-1 --> right derivative
c idiri = 0 --> both-sides derivative
c idiri = 1 --> left derivative
c idiri = 2 --> higher-order both-sides left derivative
      implicit none
      real*8 derivative,fun,xi,hi,xmini,xmaxi,erroro
      integer idiri
c
      integer idir,i,j,itn,jmax
      parameter(itn=2,jmax=2)
c itn = 2 guarantees a fast code. itns >> 2 gives more precise
c results in extreme configurations, but slows the code down
c linearly
      real*8 x,h,hh,error,con,big,dd,
     &xmin,xmax,tiny,res(0:itn,jmax),er(0:itn)
      parameter(con=3d0,big=1d40)
      parameter(tiny=1.d-8)
      external fun
c
      x=xi
      h=hi
      xmin=xmini
      xmax=xmaxi
      idir=idiri
      if(h.eq.0d0)then
         write(*,*)'Error #1 in function derivative'
         stop
      endif
      if(idir.lt.-1.or.idir.gt.2)then
         write(*,*)'Error #2 in function derivative',idir
         stop
      endif
      if(xmin.ge.xmax)then
         write(*,*)'Error #3 in function derivative',x,xmin,xmax
         stop
      endif
c Set the derivative equal to zero and error equal to one if outside range
      if(x.lt.xmin.or.x.gt.xmax)then
        derivative=0.d0
        erroro=1.d0
        return
      endif
c If close to borders of range, use left or right first-order derivative;
c may include higher orders if implemented from the left or right only
      if(x.le.(xmin+tiny))then
        x=xmin+tiny
        idir=-1
      elseif(x.ge.(xmax-tiny))then
        x=xmax-tiny
        idir=1
      endif
c
      h=min(h,min(xmax-x,x-xmin))
      error=big
      dd=0.d0
      do i=0,itn
         hh=h/1d1**(6d0*i/itn)
         do j=1,jmax
            if(idir.eq.0)then
               res(i,j)=(fun(x+hh)-fun(x-hh))/(2d0*hh)
            elseif(idir.eq.-1)then
               res(i,j)=(fun(x+hh)-fun(x))/hh
            elseif(idir.eq.1)then
               res(i,j)=(fun(x)-fun(x-hh))/hh
            elseif(idir.eq.2)then
c second-order formula: yet higher-order formulae exist
c but they require too many evaluations of f, which slows
c the code down quite significantly
               res(i,j)=(fun(x-2*hh)-8*fun(x-hh)
     &                  -fun(x+2*hh)+8*fun(x+hh))/(12d0*hh)
            endif
            if(j.lt.jmax)hh=hh/con
         enddo
         er(i)=abs(abs(res(i,1))-abs(res(i,2)))/
     &         max(abs(res(i,1)),abs(res(i,2)))
         if(er(i).lt.error.and.er(i).ne.0d0)then
            error=er(i)
            dd=(res(i,1)+res(i,2))/2d0
         endif
      enddo
      derivative=dd
      erroro=error*2*abs(dd)
c
      return
      end


double precision FUNCTION GOLDEN(AX,BX,CX,F,TOL,XMIN)
!Given a function F, and given a bracketing triplet of abscissas
!AX, BX, CX (such that BX is between AX and CX, and F(BX) is less
!than both F(AX) and F(CX)), this routine performs a golden section
!search for the minimum, isolating it to a fractional precision of
!about TOL. The abscissa of the minimum is returned as XMIN, and the minimum
!function value is returned as GOLDEN, the returned function value.

IMPLICIT NONE

double precision, INTENT(IN)	:: AX,BX,CX,TOL
double precision, INTENT(OUT)	:: XMIN

double precision	:: F1,F2,X0,X1,X2,X3,R,C,F
PARAMETER(R=.61803399,C=1.-R)  !Golden ratios

EXTERNAL F

X0=AX  !At any given time we will keep trace of 4 points:
X3=CX  !X0,X1,X2,X3.
IF(ABS(CX-BX).GT.ABS(BX-AX)) THEN
	X1=BX
	X2=BX+C*(CX-BX)
ELSE
	X2=BX
	X1=BX-C*(BX-AX)
ENDIF

F1=F(X1)
F2=F(X2)  !Initial function evaluations

1 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)) .AND. ( (ABS(X1) + ABS(X2)) .GT. 1.0d-12)) THEN
	IF(F2.LT.F1) THEN
	  X0=X1
	  X1=X2
	  X2=R*X1+C*X3
	  F1=F2
	  F2=F(X2)
	ELSE
	  X3=X2
	  X2=X1
	  X1=R*X2+C*X0
	  F2=F1
	  F1=F(X1)
	ENDIF
GOTO 1
ENDIF

IF(F1.LT.F2) THEN
	GOLDEN=F1
	XMIN=X1
ELSE
	GOLDEN=F2
	XMIN=X2
ENDIF

RETURN
END


!>
module m_random

  use m_parameters , only : PI

  implicit none

  private
  public :: prepare_random, random_uniform, random_normal

contains

  ! prepare_random
  subroutine prepare_random (seed)
    integer , intent(in) :: seed
    integer :: n
    integer , allocatable :: s(:)

    call random_seed(size=n)

    allocate(s(n))
    s(:) = seed

    call random_seed(put=s)

  end subroutine prepare_random

  ! random_uniform
  subroutine random_uniform (a, b, x)
    double precision , intent(in) :: a, b
    double precision , intent(out) :: x
    double precision :: r

    call random_number(r)

    x = (1 - r)*(b - a) + a

  end subroutine random_uniform

  ! random_normal
  subroutine random_normal (mu, sigma, x1, x2)
    double precision , intent(in) :: mu, sigma
    double precision , intent(out) :: x1, x2
    double precision :: u1, u2, r

    call random_uniform(0.0d0, 1.0d0, u1)
    call random_uniform(0.0d0, 1.0d0, u2)

    r = sigma*sqrt(-2.0d0 * log(u1))

    x1 = mu + r*cos(2.0d0*PI*u2)
    x2 = mu + r*sin(2.0d0*PI*u2)

  end subroutine random_normal

end module m_random


!..............................................................
!: Program Written by ArkAngeL43                              :
!: Determin if a vertex is a rectangle, Parallelogram         :
!: square, or a Rhombus                                       :
!:                                                            :
!: New line Statement: WRITE(*,'(A,/,A')') 'new line active'  :
!: ALTERNATIVE: print '(*(A))', 'First line', NEW_LINE('a'),  :
!: ..NEW_LINE('a'), 'Second line'                             :
!:                                                            :
!: VARS: REAL: x1..4, y1..4, a..q                             :
!:                                                            :
!: Date: Thu 17 Feb 2022 03:28:20 AM                          :
!:............................................................:
!
!
! ERR: INPUT MUST BE REAL NUMBERS ONLY OR ERROR WILL OCCUR
!...................................................
!: Error termination. Backtrace:                   :
!: #0  0x7f87b138bbd0 in ???                       :
!: #1  0x7f87b138c685 in ???                       :
!: #2  0x7f87b138d25b in ???                       :
!: #3  0x7f87b15b9c98 in ???                       :
!: #4  0x7f87b15bb0c4 in ???                       :
!: #5  0x7f87b15bbcd1 in ???                       :
!: #6  0x56053bbe026a in ???                       :
!: #7  0x56053bbe0e6e in ???                       :
!: #8  0x7f87b11cdd09 in __libc_start_main         :
!:        at ../csu/libc-start.c:308               :
!: #9  0x56053bbe00e9 in ???                       :
!: #10  0xffffffffffffffff in ???                  :
!:.................................................:
!
! DEVELOPER NOTES
!
!
! clear statement but this isnt clear? its just \n\n....... not correct ANSI?
!print *, achar(27)//"[2J"
!print *, "[H[2J[3J" ! not correct code windows support only
! hmmm this one isnt working either
!
!
!WRITE(*,'(2f15.9)',advance='no') CALL SYSTEM('clear')
!
! ended up with
!
! CHARACTER CLEAR*6
! CLEAR=CHAR(27)//'[H'//CHAR(27)//'[J'
! WRITE(*,*)CLEAR

program check_vertext
    implicit none
    real::x1,x2,x3,x4,y1,y2,y3,y4,a,b,c,d,p,q
    CHARACTER CLEAR*6
    CLEAR=CHAR(27)//'[H'//CHAR(27)//'[J'
    WRITE(*,*)CLEAR
    print *, " _______  ______  _____  __   _      ___   ___ "
    print *, "    |    |_____/ |     | | \  | ___ | . | |  _|"
    print *, "    |    |    \_ |_____| |  \_|     |_  | |_  |"
    print *, "                                    |___| |___|"
    print *, "Tron-95 simple math with fortran "
    print *, "            List options work 1 input at a time"
    print *, "=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-="
    print *, ""
    print *, "Number format is as follows: x x"
    print *, ""
    print*, 'Enter the values of x1 and y1: '
    read*,x1,y1
    print*,'enter the value of x2 & y2'
    read*,x2,y2
    print*,'enter the value of x3 & y3'
    read*,x3,y3
    print*,'enter the value of x4 & y4'
    read*,x4,y4
    a=sqrt((x1-x2)**2+(y1-y2)**2)
    b=sqrt((x2-x3)**2+(y2-y3)**2)
    c=sqrt((x3-x4)**2+(y3-y4)**2)
    d=sqrt((x4-x1)**2+(y4-y1)**2)
    p=sqrt((x1-x3)**2+(y1-y3)**2)
    q=sqrt((x2-x4)**2+(y2-y4)**2)
    if(a==c .and. b==d .and. a/=b .and. p==q ) then
    print*,'this is rectangle'

    else if(a==c .and. b==d .and. a/=b .and. p/=q ) then
    print*,'this is Parallelogram'

    else if( a==b .and. b==c .and. c==d .and. d==a .and. p==q ) then
    print*,'this is square'

    else if( a==b .and. b==c .and. c==d .and. d==a .and. p/=q ) then
    print*,'this is Rhombus'
    else
        print*,'[+] This vertext does not seem to be classified as any of the following'
        print*,'|-> Square'
        print*,'|-> Parallelogram'
        print*,'|-> Rhombus'
        print*,'|-> rectangle'
        print*,'|=> FINAL -> Values dont match!'
        !VALUES OF THE FOLLOWING DONT MATCH LIST rectangle, Rhombus, Parallelogram, square -> -> >>>?
        write(*,'(A)') ' ||-< || => || _> Numbers dont seem to be equal to the following list' // achar(13) // achar(10) // ''
    end if
    print*, '------------------------------------'
    write(*,*) " X variables -<1-2> >+>> ", x1, x2
    write(*,*) " X variables -<3-4> >+>> ", x3, x4
    print*, ";;; Y SETS ;;;"
    write(*,*) " Y variables -<1-2> >+>> ", y1, y2
    write(*,*) " Y variables -<3-4> >+>> ", y3, y4
end program check_vertext


      program wave
      implicit none

      integer i, k, ni, nk
      parameter (ni = 3, nk = 3)
      real dt,dx,v,a,b1,dp

      real p(0:ni,0:nk),p0(0:ni,0:nk)

! compute the constant coeffect of the stiffness matrix
      b1 = dt/dx*v
      a = b1*b1

! First inital conditiona and boundary conditions
! Left boundary
      p(0,0) = 0.0
! Time iteration -1 = space loop.
      do 1 i = 1, ni
         p(i,0) = p0(i*dx)
 1    continue
! Right boundary
      p(ni,0) = 0.0

! Second initial condition (with p1=0) and boundary conditions
! Left boundary
      p(0,1) = 0.0
! Time iteration 0 = space loop.
      do 2 i = 1, ni
         dp = p(i+1,0) - 2*p(i,0) + p(i-1,0)
         p(i,1) = p(i,0) + 0.5*a*dp
 2    continue
! Right boundary
      p(ni,1) = 0.0

! Evolution problem and boundary conditions

      do 3 k = 1, nk
! Left boundary
         p(0, k+1) = 0
! Time iteration k = space loop
         do 4 i = 1, ni
            dp = p(i+1,k) - 2*p(i,k) + p(i-1,k)
            p(i,k+1) = 2*p(i,k) - p(i,k-1) + a*dp
 4       continue
! Right boundary
      p(ni,k+1) = 0.0
 3    continue
      end


c---------------------------------------------------------------------
c---------------------------------------------------------------------
      subroutine l2norm ( ldx, ldy, ldz,
     >                    nx0, ny0, nz0,
     >                    ist, iend,
     >                    jst, jend,
     >                    v, sum )
c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c   to compute the l2-norm of vector v.
c---------------------------------------------------------------------

      implicit none

      include 'mpinpb.h'

c---------------------------------------------------------------------
c  input parameters
c---------------------------------------------------------------------
      integer ldx, ldy, ldz
      integer nx0, ny0, nz0
      integer ist, iend
      integer jst, jend
      double precision  v(5,-1:ldx+2,-1:ldy+2,*), sum(5)

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      integer i, j, k, m
      double precision  dummy(5)

      integer IERROR

      do m = 1, 5
         dummy(m) = 0.0d+00
      end do

      do k = 2, nz0-1
         do j = jst, jend
            do i = ist, iend
               do m = 1, 5
                  dummy(m) = dummy(m) + v(m,i,j,k) * v(m,i,j,k)
               end do
            end do
         end do
      end do

c---------------------------------------------------------------------
c   compute the global sum of individual contributions to dot product.
c---------------------------------------------------------------------
      call MPI_ALLREDUCE( dummy,
     >                    sum,
     >                    5,
     >                    dp_type,
     >                    MPI_SUM,
     >                    MPI_COMM_WORLD,
     >                    IERROR )

      do m = 1, 5
         sum(m) = sqrt ( sum(m) / ( (nx0-2)*(ny0-2)*(nz0-2) ) )
      end do

      return
      end


module test_mod
  contains
function sum_function(array)
  real, dimension(:, :) :: array
  real :: sum_function
  integer :: i, j
  sum_function = 0.0

  do i = 1, 5
    do j = 1, 5
      sum_function = sum_function + array(i, j)

    end do
  end do
end function sum_function
end module test_mod

program test
  use test_mod
  real, dimension(10, 10) :: array

  array = 99

  print *, sum_function(array(1:5, 1:5))
end program


module julia_set_mod
    implicit none

    private
    integer, parameter :: max_iters = 255
    real(kind=8), parameter :: max_norm = 2.0D00
    complex(kind=8), parameter :: C = cmplx(-0.622772D00, 0.42193D00, kind=8)

    public :: julia_iterate

contains

    elemental function julia_iterate(z0) result(n)
        implicit none
        complex(kind=8), intent(in) :: z0
        integer :: n
        complex(kind=8) :: z
        z = z0
        n = 0
        do while (abs(z) < max_norm .and. n < max_iters)
            z = z**2 + C
            n = n + 1
        end do
    end function julia_iterate

end module julia_set_mod


submodule(euler_interface_m) euler_prob_0012_m
    implicit none

contains

    module character(len=20) function euler0012()
        write (euler0012, "(i20)") ans(500)
    end function euler0012

    function ans(n) result(ret)
        integer, intent(in) :: n
        integer :: ret, i

        i = 0
        ret = 0
        do
            i = i + 1
            ret = ret + i
            if (number_of_divisors(ret) > n) exit
        end do
    end function ans

    function number_of_divisors(val) result(ret)
        integer, intent(in) :: val
        integer :: ret, i, x

        ret = 0
        x = int(sqrt(real(val)))
        do i = 1, x - 1
            if (mod(val, i) == 0) ret = ret + 2
        end do
        if (mod(val, x) == 0) ret = ret + 1
    end function number_of_divisors

end submodule euler_prob_0012_m


      PROGRAM xludcmp
C     driver for routine ludcmp
      INTEGER NP
      PARAMETER(NP=20)
      INTEGER j,k,l,m,n,indx(NP),jndx(NP)
      REAL d,dum,a(NP,NP),xl(NP,NP),xu(NP,NP),x(NP,NP)
      CHARACTER txt*3
      open(7,file='MATRX1.DAT',status='old')
      read(7,*)
10    read(7,*)
      read(7,*) n,m
      read(7,*)
      read(7,*) ((a(k,l), l=1,n), k=1,n)
      read(7,*)
      read(7,*) ((x(k,l), k=1,n), l=1,m)
C     print out a-matrix for comparison with product of lower
C     and upper decomposition matrices.
      write(*,*) 'Original matrix:'
      do 11 k=1,n
        write(*,'(1x,6f12.6)') (a(k,l), l=1,n)
11    continue
C     perform the decomposition
      call ludcmp(a,n,NP,indx,d)
C     compose separately the lower and upper matrices
      do 13 k=1,n
        do 12 l=1,n
          if (l.gt.k) then
            xu(k,l)=a(k,l)
            xl(k,l)=0.0
          else if (l.lt.k) then
            xu(k,l)=0.0
            xl(k,l)=a(k,l)
          else
            xu(k,l)=a(k,l)
            xl(k,l)=1.0
          endif
12      continue
13    continue
C     compute product of lower and upper matrices for
C     comparison with original matrix.
      do 16 k=1,n
        jndx(k)=k
        do 15 l=1,n
          x(k,l)=0.0
          do 14 j=1,n
            x(k,l)=x(k,l)+xl(k,j)*xu(j,l)
14        continue
15      continue
16    continue
      write(*,*) 'Product of lower and upper matrices (unscrambled):'
      do 17 k=1,n
        dum=jndx(indx(k))
        jndx(indx(k))=jndx(k)
        jndx(k)=dum
17    continue
      do 19 k=1,n
        do 18 j=1,n
          if (jndx(j).eq.k) then
            write(*,'(1x,6f12.6)') (x(j,l), l=1,n)
          endif
18      continue
19    continue
      write(*,*) 'Lower matrix of the decomposition:'
      do 21 k=1,n
        write(*,'(1x,6f12.6)') (xl(k,l), l=1,n)
21    continue
      write(*,*) 'Upper matrix of the decomposition:'
      do 22 k=1,n
        write(*,'(1x,6f12.6)') (xu(k,l), l=1,n)
22    continue
      write(*,*) '***********************************'
      write(*,*) 'Press RETURN for next problem:'
      read(*,*)
      read(7,'(a3)') txt
      if (txt.ne.'END') goto 10
      close(7)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xludcmp.for


c gmm01f
c  subroutine tipitaud.f
c  THIS FILE IS PART OF THE ORIGINAL GMM01F DISTRIBUTION
c  calculates pi(m,n) & tau(m,n) up to a specified nmax for all
c  m=0,1,...n at a given x
c  pi(m,n) & tau(m,n) calculated are normalized by
c         C_mn=[(2n+1)(n-m)!/n/(n+1)/(n+m)!]^(1/2)
c  Yu-lin Xu    12/2000

      subroutine tipitaud(nmax,x)
      include 'gmm01f.par'
      parameter (nmp0=(np+1)*(np+4)/2)
      implicit double precision (a-h,o-z)
      common/fnr/fnr(0:2*(np+2))
      common/pitau/pi(nmp0),tau(nmp0)

      nt=(nmax+1)*(nmax+4)/2          ! calculates pi up to nmax+1
      if(nt.gt.nmp0.or.dabs(x).gt.1.d0) then
         write(6,*) 'dimension or argument wrong in sub. tipitaud'
         write(6,*) 'argument: ',x
         stop
      endif
      sx=dsqrt(1.d0-x*x)
      pi(1)=0.d0                     ! pi(0,1)  pi(0,n)=0 when m=0
      pi(2)=dsqrt(.75d0)             ! pi(1,1)
      pi(3)=0.d0                     ! pi(0,2)
      t125=dsqrt(1.25d0)
      pi(4)=t125*x                      ! pi(1,2)
      pi(5)=t125*sx                     ! pi(2,2)
      imn=5
      do i=3,nmax+1
         n=i
         imn=imn+1
         pi(imn)=0.d0                ! pi(0,n)=0
         do 11 j=2,n
            m=j-1
            imn=imn+1
            i1=(n-2)*(n+1)/2+m+1
            if(m.eq.n-1) then
               pi(imn)=fnr(n-1)*fnr(2*n+1)/fnr(n+1)*x*pi(i1)
               goto 11
            endif
            i2=(n-3)*n/2+m+1
            t=fnr(n)*fnr(2*n-3)
            t=fnr(n-2)*fnr(n-m-1)*fnr(n+m-1)/t
            pi(imn)=fnr(2*n-1)*x*pi(i1)-t*pi(i2)
            t=fnr(n+1)*fnr(n-m)*fnr(n+m)
            t=fnr(n-1)*fnr(2*n+1)/t
            pi(imn)=t*pi(imn)
 11	     continue
         imn=imn+1
         i1=(n-2)*(n+1)/2+n
         t=fnr(n-1)*fnr(n+1)
         t=dsqrt(.5d0)*fnr(n)*fnr(2*n+1)/t
         pi(imn)=t*sx*pi(i1)
      enddo
      tx=x*sx
      tau(1)=-dsqrt(1.5d0)*sx          ! tau(0,1)
      tau(2)=pi(2)*x                   ! tau(1,1)
      tau(3)=-dsqrt(7.5d0)*tx          ! tau(0,2)
      tau(4)=t125*(2.d0*x*x-1.d0)      ! tau(1,2)
      tau(5)=t125*tx                   ! tau(2,2)
      imn=5
      do i=3,nmax
         n=i
         do 21 j=1,n+1
            m=j-1
            imn=imn+1
            if(m.eq.0) then
               i1=(n-2)*(n+1)/2+1
               i2=(n-3)*n/2+1
               t=fnr(2*n-3)
               t=fnr(n-2)*fnr(n)/t
               tau(imn)=fnr(2*n-1)*x*tau(i1)-t*tau(i2)
               t=fnr(n-1)*fnr(n+1)
               t=fnr(2*n+1)/t
               tau(imn)=t*tau(imn)
               goto 21
            endif
            i1=n*(n+3)/2+m+1
            t=fnr(n)*fnr(2*n+3)
            t=fnr(n+2)*fnr(2*n+1)*fnr(n-m+1)*fnr(n+m+1)/t
            tau(imn)=t*pi(i1)-dble(n+1)*x*pi(imn)
            tau(imn)=tau(imn)/dble(m)
 21	     continue
      enddo
      return
      end


program main

    use open_linalg_m, only: operator(.x.), matmul
    real :: x(2, 1) = reshape([1, 2], [2, 1]), &
            y(1, 2) = reshape([3, 4], [1, 2])
    real :: z(2, 2)

    z = matmul(x, y)
    do i = 1, 2
        print 100, z(i, :)
    end do

100 format(*(f6.2))

end program main

!@note: Fortran array column first
!  3.00  4.00
!  6.00  8.00


program chicharronera

implicit none

!este programa resueelve una ecuacion cuadratica simple de
!la forma: ax²+bx+c=0

integer:: a,b,c,x
real :: den,discr,term,x1,x2

print*, "favor de ingresar a"
read*, a

print*, "favor de ingresar b"
read*, b

print*, "favor de ingresar c"
read*, c

WRITE(*,*), "Ingrese coeficientes a,b,c"
READ(*,*) a,b,c
IF( a == 0 ) THEN
WRITE(*,*) "La ecuación no tiene término cuadrático"
STOP
ENDIF

discr = b**2 - 4.0*a*c
den = 2.0*a
term = SQRT(ABS(discr))
IF (discr >= 0 ) THEN
x1 = (-b+term)/den
x2 = (-b-term)/den
WRITE(*,*) "x1 = ", x1
WRITE(*,*) "x2 = ", x2

ELSE
x1 = -b/den
x2 = term/den

WRITE(*,*) "x1 = (", x1, " ,", x2, ")"
WRITE(*,*) "x1 = (", x1, " ,", -x2, ")"
ENDIF

STOP
END PROGRAM chicharronera


subroutine radiat(daynr,hour,dayl,sinld,cosld,avrad,sinb,pardir,pardif)
! ----------------------------------------------------------------------
! --- Authors: this routine Astro is based on Sastro (Daniel van Kraalingen)
! --- calculates the fluxes of diffuse and direct photosynthetically
! --- active radiation from the total daily shortwave radiation actually
! --- received (avrad) for a given day of the year and hour of the day.
! --- the input variables dayl, sinld and cosld are calculated in astro.
! --- for more information: see spitters et al. (1988).
! ----------------------------------------------------------------------
      implicit none

      integer daynr

      real  aob,atmtr,avrad,cosld,dayl,dsinb,dsinbe,dso,frdif,hour
      real  par,pardif,pardir,pi,sc,sinb,sinld

      data    pi /3.1415926d0/
! ----------------------------------------------------------------------
! --- calculations on solar elevation
! --- sine of solar elevation sinb
      aob = sinld/cosld
      sinb = max (0.0d0,sinld+cosld*cos(2.0*pi*(hour+12.0d0)/24.0))
! --- integral of sinb
      dsinb = 3600.*(dayl*sinld+24.*cosld*sqrt(1.0d0-aob*aob)/pi)
! --- integral of sinb, corrected for lower atmospheric transmission
! --- at low solar elevations
      dsinbe = 3600.*(dayl*(sinld+0.4*(sinld*sinld+cosld*cosld*0.5))+12.0*cosld*(2.0d0+3.0*0.4*sinld)*sqrt(1.0d0-aob*aob)/pi)

! --- solar constant and daily extraterrestrial radiation
      sc = 1370.*(1.0d0+0.033*cos(2.0*pi*daynr/365.))
      dso = sc*dsinb

! --- diffuse light fraction from atmospheric transmission
      atmtr = avrad/dso
      if (atmtr.gt.0.75d0)  frdif = 0.23d0
      if (atmtr.le.0.75d0.and.atmtr.gt.0.35d0) frdif = 1.33d0-1.46*atmtr
      if (atmtr.le.0.35d0.and.atmtr.gt.0.07d0) frdif = 1.0d0-2.3*(atmtr-0.07d0)**2
      if (atmtr.le.0.07d0) frdif = 1.0d0

! --- photosynthetic active radiation, diffuse and direct
      par = 0.5*avrad*sinb*(1.0d0+0.4*sinb)/dsinbe
      pardif = min (par,sinb*frdif*atmtr*0.5*sc)
      pardir = par-pardif

      return

end subroutine radiat


!Joshua Dorrington 22/03/18 - University of Oxford
!This module generates the coefficients of the barotropic model,
!and also generates the linear time evolution operator

module coeffs
    use, intrinsic :: iso_fortran_env
    use params
    implicit none
    private
    public get_coeffs, build_lin_op

    contains

	    subroutine get_coeffs(b,beta,g,coeff_arr)
		real(dp) :: coeff_arr(11)
		real(dp), intent(in) :: b, beta, g
		coeff_arr(1)=a_coeff(1,b)
		coeff_arr(2)=a_coeff(2,b)
		coeff_arr(3)=beta_coeff(1,b,beta)
		coeff_arr(4)=beta_coeff(2,b,beta)
		coeff_arr(5)=gamma_coeff(1,b,g)
		coeff_arr(6)=gamma_coeff(2,b,g)
		coeff_arr(7)=gamma_prime_coeff(1,b,g)
		coeff_arr(8)=gamma_prime_coeff(2,b,g)
		coeff_arr(9)=d_coeff(1,b)
		coeff_arr(10)=d_coeff(2,b)
		coeff_arr(11)=16._dp*sqrt(2._dp)/(5._dp*pi)

	    end subroutine get_coeffs

            subroutine build_lin_op(mat,coeff)
	        real(dp), dimension(coeff_num),intent(in) :: coeff
		real(dp), dimension(dims,dims) :: mat
		integer :: i, j

		do j=1, dims
		  do i=1, dims
			mat(i,j)=0._dp
		  end do
		end do

		do i=1, dims
		  mat(i,i)=-C
		end do
		mat(1,3)=coeff(7)
		mat(2,3)=coeff(3)
		mat(3,1)=-coeff(5)
		mat(3,2)=-coeff(3)
		mat(4,6)=coeff(8)
		mat(5,6)=coeff(4)
		mat(6,4)=-coeff(6)
		mat(6,5)=-coeff(4)

	    end subroutine build_lin_op

	    function a_coeff(m,b) result(a)
	    	integer, intent(in) :: m
		real(dp), intent(in) :: b
	    	real(dp) :: a
	    	a=8._dp*sqrt(2._dp)*(m**2)*(b**2+(m**2)-1)/(pi*(-1 +4*(m**2))*(b**2+m**2))
	    end function a_coeff

	    function beta_coeff(m,b,beta) result(output)
	    	integer, intent(in) :: m
		real(dp), intent(in) :: beta, b
	    	real(dp) :: output
	    	output=beta*(b**2)/(b**2 + m**2)
	    end function beta_coeff

	    function gamma_coeff(m,b,g) result(gamma_)
	    	integer, intent(in) :: m
		real(dp), intent(in) :: g, b
	    	real(dp) :: gamma_
	    	gamma_=(g*4._dp*sqrt(2._dp)*b*m**3)/((4*(m**2)-1)*pi*(b**2+m**2))
	    end function gamma_coeff

	    function gamma_prime_coeff(m,b,g) result(gamma_p)
		integer, intent(in) :: m
		real(dp), intent(in) :: g,b
		real(dp) :: gamma_p
		gamma_p=(g*4._dp*sqrt(2._dp)*b*m)/((4*(m**2)-1)*pi)
	    end function gamma_prime_coeff

	   function d_coeff(m,b) result(d)
		integer, intent(in) :: m
		real(dp), intent(in) :: b
		real(dp) :: d
		d=(64._dp*sqrt(2._dp)*(b**2-(m**2) + 1))/(15._dp*pi*(b**2 + m**2))
	    end function d_coeff

end module coeffs


program rungekutta
implicit none
real(kind=kind(1.0D0)) :: t,dt,tstart,tstop
real(kind=kind(1.0D0)) :: y,k1,k2,k3,k4
tstart =0.0D0 ; tstop =10.0D0 ; dt = 0.1D0
y = 1.0D0
t = tstart
write(6,'(A,f4.1,A,f12.8,A,es13.6)') 'y(',t,') = ',y,' Error = '&
           &,abs(y-(t**2+4.0d0)**2/16.0d0)
do; if ( t .ge. tstop ) exit
   k1 = f (t           , y                 )
   k2 = f (t+0.5D0 * dt, y +0.5D0 * dt * k1)
   k3 = f (t+0.5D0 * dt, y +0.5D0 * dt * k2)
   k4 = f (t+        dt, y +        dt * k3)
   y = y + dt *( k1 + 2.0D0 *( k2 + k3 ) + k4 )/6.0D0
   t = t + dt
   if(abs(real(nint(t))-t) .le. 1.0D-12) then
      write(6,'(A,f4.1,A,f12.8,A,es13.6)') 'y(',t,') = ',y,' Error = '&
           &,abs(y-(t**2+4.0d0)**2/16.0d0)
   end if
end do
contains
  function f (t,y)
    implicit none
    real(kind=kind(1.0D0)),intent(in) :: y,t
    real(kind=kind(1.0D0)) :: f
    f = t*sqrt(y)
  end function f
end program rungekutta


module test_supporting_functions_mod
   use supporting_functions_mod
   use funit
   implicit none

contains

	@test
	subroutine test_logical2integer_true()
		logical :: boole_in
		integer :: value

		boole_in = .TRUE.
		value = logical2integer(boole_in)

		@assertEqual(value,1,message = "Testing logical2integer with true value")

	end subroutine test_logical2integer_true

	@test
	subroutine test_logical2integer_false()
		logical :: boole_in
		integer :: value

		boole_in = .FALSE.
		value = logical2integer(boole_in)

		@assertEqual(value,0,message = "Testing logical2integer with false value")

	end subroutine test_logical2integer_false

	@test
	subroutine test_calc_eigval()

		integer :: N = 3
		double precision,dimension(3,3) :: A, VR
		double precision,dimension(3) :: WR
		double precision,dimension(3) :: eigvals
		double precision,dimension(3) :: eigvector1, eigvector2, eigvector3

		A = reshape((/3.d0, 2.d0, -2.d0, -1.d0, 0.d0, 2.d0, 0.d0, 0.d0, -1.d0/), (/N, N/))

		call calc_eigval(N,A,WR,VR)

	  	eigvals = [-1.d0,1.d0,2.d0]
	  	@assertEqual(WR, eigvals, tolerance=1e-13, message="Test calc_eigval, compare eigenvalues")

	  	eigvector1 = [0.d0,0.d0,1.d0]
	  	eigvector2 = [-1.d0,-2.d0,-1.d0] / SQRT(6.d0)
	  	eigvector3 = [-1.d0,-1.d0,0.d0] / SQRT(2.d0)

	  	@assertEqual(VR(:,1), eigvector1, tolerance=1e-13, message="Test calc_eigval, compare first eigenvector")
	  	@assertEqual(VR(:,2), eigvector2, tolerance=1e-13, message="Test calc_eigval, compare second eigenvector")
	  	@assertEqual(VR(:,3), eigvector3, tolerance=1e-13, message="Test calc_eigval, compare third eigenvector")

	  	!A needs to get declared again, because it gets overwritten in the calc_eigval subroutine
	  	A = reshape((/3.d0, 2.d0, -2.d0, -1.d0, 0.d0, 2.d0, 0.d0, 0.d0, -1.d0/), (/N, N/))

	  	@assertEqual(matmul(A, VR(:,1)), VR(:,1)*WR(1), tolerance=1e-13, message="Test calc_eigval, use eigenvalue equation")
	  	@assertEqual(matmul(A, VR(:,2)), VR(:,2)*WR(2), tolerance=1e-13, message="Test calc_eigval, use eigenvalue equation")
	  	@assertEqual(matmul(A, VR(:,3)), VR(:,3)*WR(3), tolerance=1e-13, message="Test calc_eigval, use eigenvalue equation")

	end subroutine test_calc_eigval

end module test_supporting_functions_mod


*DECK LSSUDS
      SUBROUTINE LSSUDS (A, X, B, N, M, NRDA, U, NRDU, IFLAG, MLSO,
     +   IRANK, ISCALE, Q, DIAG, KPIVOT, S, DIV, TD, ISFLG, SCALES)
C***BEGIN PROLOGUE  LSSUDS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BVSUP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (LSSUDS-S, DLSSUD-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C    LSSUDS solves the underdetermined system of equations  A Z = B,
C    where A is N by M and N .LE. M.  In particular, if rank A equals
C    IRA, a vector X and a matrix U are determined such that X is the
C    UNIQUE solution of smallest length, satisfying A X = B, and the
C    columns of U form an orthonormal basis for the null space of A,
C    satisfying A U = 0 .  Then all solutions Z are given by
C              Z = X + C(1)*U(1) + ..... + C(M-IRA)*U(M-IRA)
C    where U(J) represents the J-th column of U and the C(J) are
C    arbitrary constants.
C    If the system of equations are not compatible, only the least
C    squares solution of minimal length is computed.
C
C *********************************************************************
C   INPUT
C *********************************************************************
C
C     A -- Contains the matrix of N equations in M unknowns, A remains
C          unchanged, must be dimensioned NRDA by M.
C     X -- Solution array of length at least M.
C     B -- Given constant vector of length N, B remains unchanged.
C     N -- Number of equations, N greater or equal to 1.
C     M -- Number of unknowns, M greater or equal to N.
C     NRDA -- Row dimension of A, NRDA greater or equal to N.
C     U -- Matrix used for solution, must be dimensioned NRDU by
C          (M - rank of A).
C          (storage for U may be ignored when only the minimal length
C           solution X is desired)
C     NRDU -- Row dimension of U, NRDU greater or equal to M.
C             (if only the minimal length solution is wanted,
C              NRDU=0 is acceptable)
C     IFLAG -- Status indicator
C           =0  for the first call (and for each new problem defined by
C               a new matrix A) when the matrix data is treated as exact
C           =-K for the first call (and for each new problem defined by
C               a new matrix A) when the matrix data is assumed to be
C               accurate to about K digits.
C           =1  for subsequent calls whenever the matrix A has already
C               been decomposed (problems with new vectors B but
C               same matrix A can be handled efficiently).
C     MLSO -- =0 if only the minimal length solution is wanted.
C             =1 if the complete solution is wanted, includes the
C                linear space defined by the matrix U.
C     IRANK -- Variable used for the rank of A, set by the code.
C     ISCALE -- Scaling indicator
C               =-1 if the matrix A is to be pre-scaled by
C               columns when appropriate.
C               If the scaling indicator is not equal to -1
C               no scaling will be attempted.
C            For most problems scaling will probably not be necessary.
C     Q -- Matrix used for the transformation, must be dimensioned
C            NRDA by M.
C     DIAG,KPIVOT,S, -- Arrays of length at least N used for internal
C      DIV,TD,SCALES    storage (except for SCALES which is M).
C     ISFLG -- Storage for an internal variable.
C
C *********************************************************************
C   OUTPUT
C *********************************************************************
C
C     IFLAG -- Status indicator
C            =1 if solution was obtained.
C            =2 if improper input is detected.
C            =3 if rank of matrix is less than N.
C               To continue, simply reset IFLAG=1 and call LSSUDS again.
C            =4 if the system of equations appears to be inconsistent.
C               However, the least squares solution of minimal length
C               was obtained.
C     X -- Minimal length least squares solution of A Z = B
C     IRANK -- Numerically determined rank of A, must not be altered
C              on succeeding calls with input values of IFLAG=1.
C     U -- Matrix whose M-IRANK columns are mutually orthogonal unit
C          vectors which span the null space of A. This is to be ignored
C          when MLSO was set to zero or IFLAG=4 on output.
C     Q -- Contains the strictly upper triangular part of the reduced
C           matrix and transformation information.
C     DIAG -- Contains the diagonal elements of the triangular reduced
C             matrix.
C     KPIVOT -- Contains the pivotal information.  The row interchanges
C               performed on the original matrix are recorded here.
C     S -- Contains the solution of the lower triangular system.
C     DIV,TD -- Contains transformation information for rank
C               deficient problems.
C     SCALES -- Contains the column scaling parameters.
C
C *********************************************************************
C
C***SEE ALSO  BVSUP
C***REFERENCES  H. A. Watts, Solving linear least squares problems
C                 using SODS/SUDS/CODS, Sandia Report SAND77-0683,
C                 Sandia Laboratories, 1977.
C***ROUTINES CALLED  J4SAVE, OHTROL, ORTHOR, R1MACH, SDOT, XERMAX,
C                    XERMSG, XGETF, XSETF
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   900510  Fixed an error message.  (RWC)
C   910408  Updated the AUTHOR and REFERENCES sections.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  LSSUDS
      DIMENSION A(NRDA,*),X(*),B(*),U(NRDU,*),Q(NRDA,*),
     1          DIAG(*),KPIVOT(*),S(*),DIV(*),TD(*),SCALES(*)
C
C **********************************************************************
C
C     MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED
C     BY THE FUNCTION R1MACH.
C
C***FIRST EXECUTABLE STATEMENT  LSSUDS
      URO = R1MACH(4)
C
C **********************************************************************
C
      IF (N .LT. 1  .OR.  M .LT. N  .OR.  NRDA .LT. N) GO TO 1
      IF (NRDU .NE. 0  .AND.  NRDU .LT. M) GO TO 1
      IF (IFLAG .LE. 0) GO TO 5
      IF (IFLAG .EQ. 1) GO TO 25
C
C     INVALID INPUT FOR LSSUDS
    1 IFLAG=2
      CALL XERMSG ('SLATEC', 'LSSUDS', 'INVALID INPUT PARAMETERS.', 2,
     +   1)
      RETURN
C
    5 CALL XGETF(NFATAL)
      MAXMES = J4SAVE (4,0,.FALSE.)
      ISFLG=-15
      IF (IFLAG .EQ. 0) GO TO 7
      ISFLG=IFLAG
      NFAT = -1
      IF (NFATAL .EQ. 0) NFAT=0
      CALL XSETF(NFAT)
      CALL XERMAX(1)
C
C     COPY MATRIX A INTO MATRIX Q
C
    7 DO 10 K=1,M
         DO 10 J=1,N
   10       Q(J,K)=A(J,K)
C
C     USE ORTHOGONAL TRANSFORMATIONS TO REDUCE Q TO LOWER
C     TRIANGULAR FORM
C
      CALL ORTHOR(Q,N,M,NRDA,IFLAG,IRANK,ISCALE,DIAG,KPIVOT,SCALES,
     1            DIV,TD)
C
      CALL XSETF(NFATAL)
      CALL XERMAX(MAXMES)
      IF (IRANK .EQ. N) GO TO 15
C
C     FOR RANK DEFICIENT PROBLEMS USE ADDITIONAL ORTHOGONAL
C     TRANSFORMATIONS TO FURTHER REDUCE Q
C
      IF (IRANK .NE. 0) CALL OHTROL(Q,N,NRDA,DIAG,IRANK,DIV,TD)
      RETURN
C
C     STORE DIVISORS FOR THE TRIANGULAR SOLUTION
C
   15 DO 20 K=1,N
   20    DIV(K)=DIAG(K)
C
C
   25 IF (IRANK .GT. 0) GO TO 40
C
C     SPECIAL CASE FOR THE NULL MATRIX
      DO 35 K=1,M
         X(K)=0.
         IF (MLSO .EQ. 0) GO TO 35
         U(K,K)=1.
         DO 30 J=1,M
            IF (J .EQ. K) GO TO 30
            U(J,K)=0.
   30    CONTINUE
   35 CONTINUE
      DO 37 K=1,N
         IF (B(K) .GT. 0.) IFLAG=4
   37 CONTINUE
      RETURN
C
C     COPY CONSTANT VECTOR INTO S AFTER FIRST INTERCHANGING
C     THE ELEMENTS ACCORDING TO THE PIVOTAL SEQUENCE
C
   40 DO 45 K=1,N
         KP=KPIVOT(K)
   45    X(K)=B(KP)
      DO 50 K=1,N
   50    S(K)=X(K)
C
      IRP=IRANK+1
      NU=1
      IF (MLSO .EQ. 0) NU=0
      IF (IRANK .EQ. N) GO TO 60
C
C     FOR RANK DEFICIENT PROBLEMS WE MUST APPLY THE
C     ORTHOGONAL TRANSFORMATION TO S
C     WE ALSO CHECK TO SEE IF THE SYSTEM APPEARS TO BE INCONSISTENT
C
      NMIR=N-IRANK
      SS=SDOT(N,S(1),1,S(1),1)
      DO 55 L=1,IRANK
         K=IRP-L
         GAM=((TD(K)*S(K))+SDOT(NMIR,Q(IRP,K),1,S(IRP),1))/
     1             (TD(K)*DIV(K))
         S(K)=S(K)+GAM*TD(K)
         DO 55 J=IRP,N
   55       S(J)=S(J)+GAM*Q(J,K)
      RES=SDOT(NMIR,S(IRP),1,S(IRP),1)
      IF (RES .LE. SS*(10.*MAX(10.**ISFLG,10.*URO))**2) GO TO 60
C
C     INCONSISTENT SYSTEM
      IFLAG=4
      NU=0
C
C     APPLY FORWARD SUBSTITUTION TO SOLVE LOWER TRIANGULAR SYSTEM
C
   60 S(1)=S(1)/DIV(1)
      IF (IRANK .EQ. 1) GO TO 70
      DO 65 K=2,IRANK
   65    S(K)=(S(K)-SDOT(K-1,Q(K,1),NRDA,S(1),1))/DIV(K)
C
C     INITIALIZE X VECTOR AND THEN APPLY ORTHOGONAL TRANSFORMATION
C
   70 DO 75 K=1,M
         X(K)=0.
         IF (K .LE. IRANK) X(K)=S(K)
   75 CONTINUE
C
      DO 80 JR=1,IRANK
         J=IRP-JR
         MJ=M-J+1
         GAMMA=SDOT(MJ,Q(J,J),NRDA,X(J),1)/(DIAG(J)*Q(J,J))
         DO 80 K=J,M
   80       X(K)=X(K)+GAMMA*Q(J,K)
C
C     RESCALE ANSWERS AS DICTATED
C
      DO 85 K=1,M
   85    X(K)=X(K)*SCALES(K)
C
      IF ((NU .EQ. 0) .OR. (M .EQ. IRANK)) RETURN
C
C     INITIALIZE U MATRIX AND THEN APPLY ORTHOGONAL TRANSFORMATION
C
      L=M-IRANK
      DO 100 K=1,L
         DO 90 I=1,M
            U(I,K)=0.
            IF (I .EQ. IRANK+K) U(I,K)=1.
   90    CONTINUE
C
         DO 100 JR=1,IRANK
            J=IRP-JR
            MJ=M-J+1
            GAMMA=SDOT(MJ,Q(J,J),NRDA,U(J,K),1)/(DIAG(J)*Q(J,J))
            DO 100 I=J,M
  100          U(I,K)=U(I,K)+GAMMA*Q(J,I)
C
      RETURN
      END


c function pchisq.f
c
c source
c   Bevington, pages 192-193.
c
c purpose
c   evaluate probability for exceeding chi square
c
c usage
c   result = pchisq (chisqr, nfree)
c
c description of parameters
c   chisqr - comparison value of reduced chi square
c   nfree  - number of degrees of freedom
c
c subroutines and function subprograms required
c   gamma (x)
c      calculates gamma function for integers and half-integers
c
c comments
c   calculation is approximate for nfree odd and
c      chi square greater than 50
c
	function pchisq (chisqr,nfree)
	double precision z,term,sum
11	if (nfree) 12,12,14
12	pchisq=0.
	goto 60
14	free=nfree
	z=chisqr*free/2.
	neven=2*(nfree/2)
	if (nfree-neven) 21,21,41
c
c number of degrees of freedom is even
c
21	imax=nfree/2
	term=1.
	sum=0.
31	do 34 i=1,imax
	fi=i
	sum=sum+term
34	term=term*z/fi
35	pchisq=sum*dexp(z)
	goto 60
c
c number of degrees of freedom is odd
c
41	if (z-25) 44,44,42
42	z=chisqr*(free-1.)/2.
	goto 21
44	pwr=free/2.
	term=1.
	sum=term/pwr
51	do 56 i=1,1000
	fi=i
	term=-term*z/fi
	sum=sum+term/(pwr+fi)
55	if (dabs(term/sum)-0.00001) 57,57,56
56	continue
57	pchisq=1.-(z**pwr)*sum/gamma(pwr)
60	return
	end


!==============================================================
! Simple Pendulum
! Author: Devansh Shukla
!==============================================================
program simple_pendulum
    ! Program to compute motion of a simple pendulum.

    implicit none
    real*8, parameter :: PI=3.141593, g=9.80665 !m/s^2
    real*8 :: l=0.0, omega=0.0, theta0=PI/4.0, theta, dtheta, ddtheta
    real*8 :: t0=0.0, tf=0.0, dt=0.0, t=0.0
    real*8 ::  x, y, vx, vy
    character(LEN=*), parameter :: FMT = "(F10.6, x, F10.6, x, F10.6, x, F10.6, x, F10.6, x, F10.6, x, F10.6, x, F10.6, x, F10.6)"
    character(len=*), parameter :: fmt1="(A10, A10, A10, xA10, xxxxA10, A10, A10, A10, xA10)"

    theta(t) = theta0*cos(omega*(t-t0))
    dtheta(t) = -omega * theta0 * sin(omega*(t-t0))
    ddtheta(t) = -omega * omega * theta0 * cos(omega*(t-t0))
    x(t) = l * sin(theta(t))
    y(t) = -l * cos(theta(t))
    vx(t) = l * dtheta(t) * cos(theta(t))
    vy(t) = l * dtheta(t) * sin(theta(t))

    open(UNIT=8, FILE="SimplePendulum.dat")

    print *, "Enter length (l)"
    read *, l
    omega = sqrt(g/l)

    print *, "Enter the value of theta0"
    read *, theta0

    print *, "Enter time: initial (t0), final (tf), increment (dt)"
    read *, t0, tf, dt
    if (dt .le. 0.0) stop "Illegal value of dt"

    print *, "------------------------------------------------------"
    print "(x,A,F10.4,F10.4,F10.4)", "l, omega, T =", l, omega, 2.0*PI / omega
    print "(x,A,F10.4,F10.4,F10.4)", "theta0 =", theta0
    print "(x,A,F10.4,F10.4,F10.4)", "t0, tf, dt =", t0, tf, dt
    print *, "------------------------------------------------------"
    print *, "Computing..."

    write (8, *) "# t0=", t0
    write (8, *) "# t l theta(t) dtheta(t) ddtheta(t) x(t) y(t) vx(t) vy(t)"

    print fmt1, "time", "length", "theta", "dtheta", "ddtheta(t)", "x(t)", "y(t)", "vx(t)", "vy(t)"
    t = t0
    do while (t <= tf)
        write (*, FMT) t, l, theta(t), dtheta(t), ddtheta(t), x(t), y(t), vx(t), vy(t)
        write (8, FMT) t, l, theta(t), dtheta(t), ddtheta(t), x(t), y(t), vx(t), vy(t)
        t = t + dt
    enddo
    print *, "------------------------------------------------------"
    close(8)

end program simple_pendulum


module mcrt_functions
    use types
    implicit none

    contains

        real(dp) function sample_exp()
        ! Sample from the exponential distribution using a random number in the range 0 -> 1
            real(dp) :: rand

            call RANDOM_NUMBER(rand)
            sample_exp = -log(rand)
        end function

        real(dp) function mc_gen_L(tau_max, r_max) result(tau_out)
            ! generate an optical depth and then scale it according to the maximum tau and the max_radius
            real(dp) :: tau, tau_max, r_max

            tau = sample_exp()
            tau_out = tau/tau_max*r_max
        end function

        real(dp) function mc_gen_first_L(tau_e, r_max) result(tau_out)
            ! generate the first optical depth in the case that you want forced first scattering
            real(dp) :: tau, tau_e, r_max

            ! we use a separate function to calculate the depth to ensure that the value is bounded in the range 0 -> tau_edge
            tau = mc_first_depth(tau_e)
            tau_out = tau/tau_e*r_max
        end function

        real(dp) function norm(vector)
            ! calculate the magnitude/norm of a given vector
            real(dp), intent(in) :: vector(:)
            real(dp) :: total
            integer :: i

            total = 0.0_dp
            ! note this is not the most elegant solution but it works
            do i = 1,size(vector)
                total = total + vector(i)**2
            end do

            norm = sqrt(total)
        end function

        real(dp) function mean(array)
            ! calculate the mean of a 1D array that is passed
            real(dp), intent(in) :: array(:)
            real(dp) :: total

            total = sum(array)

            mean = total/size(array)
        end function

        real(dp) function variance(array)
            ! calculate the variance of a 1D array that is passed
            real(dp) :: array(:), mean_val, total
            integer :: i

            mean_val = mean(array)
            total = 0.0_dp
            do i = 1, size(array)
                total = (array(i) - mean_val)**2
            end do

            variance = total/(size(array)-1)
        end function

        real(dp) function mc_first_depth(tau_edge) result(tau)
            ! generate the correct optical depth for forced first scatter where we want to ensure the value
            ! is bounded on 0 -> tau_edge
            real(dp) , intent(in) :: tau_edge
            real(dp) :: rand
            call RANDOM_NUMBER(rand)

            tau = -log(1-rand*(1-exp(-tau_edge)))
        end function

        real(dp) function edge_length(pos, nhat, r_max)
            ! calculate the distance from a point within a sphere along some direction nhat to the surface
            real(dp), intent(in) :: pos(3), nhat(3), r_max
            real(dp) :: dot, r
            dot = dot_product(pos, nhat)
            r = norm(pos)

            edge_length = -dot + sqrt(dot**2 - (r**2 - r_max**2))
        end function

        real(dp) function blob_initial_length(pos, nhat, r_max)
            ! for Q3 - generate the length a packet should advance to hit the surface of the blob
            real(dp), intent(in) :: pos(3), nhat(3), r_max
            real(dp) :: dot, r

            dot = dot_product(pos, nhat)
            r = norm(pos)

            blob_initial_length = -dot - sqrt(dot**2 - (r**2 - r_max**2))
        end function

        real(dp) function gen_pw_wt(wt, pos, nhat_view, r_max, tau)
            ! generating a peel weight for the next event estimator that can be used when binning to ensure the packets are given the correct weighting
            real(dp), intent(in) :: pos(:), nhat_view(:), r_max, tau, wt
            real(dp) :: tau_peel

            ! using the equation that we discussed during lectures
            tau_peel = tau*edge_length(pos, nhat_view, r_max)/r_max
            gen_pw_wt = 1.0/(4*pi)*exp(-tau_peel)*wt
        end function

        real(dp) function gen_flux_wt(wt, pos, nhat, r_max, tau)
            ! performing the same operation as above but in this case we don't want the 1/4pi factor so we correct for it
            real(dp), intent(in) :: pos(:), nhat(:), r_max, tau, wt
            real(dp) :: pw_wt

            pw_wt = gen_pw_wt(wt, pos, nhat, r_max, tau)
            gen_flux_wt = 4*pi*pw_wt
        end function

        real(dp) function trapz_int(y_array, x_array) result(integral)
            ! a trapezoidal integration routine that takes an x and y array and returns the trapezoidal numerical integral
            ! unused at the moment
            real(dp), intent(in) :: y_array(:), x_array(:)
            integer :: N, i

            if ( size(y_array) == size(x_array) ) then
                N = size(y_array)
            else
                stop 'You have passed 2 arrays of different size, this is not allowed'
            end if

            integral = 0.0

            do i = 1, N-1
                integral = integral + 0.5*(y_array(i+1) + y_array(i))*(x_array(i+1) - x_array(i))
            end do
        end function

        subroutine image_calculate(position, theta, phi, x, y)
            ! calculate the image positions using the expressions discussed in class to ensure that we can bin the packets correctly
            real(dp), intent(in) :: position(3), theta, phi
            real(dp), intent(out) :: x, y

            x = position(2)*cos(phi) - position(1)*sin(phi)
            y = position(3)*sin(theta) - position(2)*cos(theta)*sin(phi) - position(1)*cos(theta)*cos(phi)
        end subroutine

        subroutine exit_angles(nhat, theta, phi)
            ! calculate the azimuth and altitude angles of a specific vector nhat
            real(dp), intent(in) :: nhat(3)
            real(dp), intent(out) :: theta, phi

            theta = acos(nhat(3)/norm(nhat))
            phi = atan2(nhat(2), nhat(1))
        end subroutine

        subroutine mc_emit(n)
            ! the emission subroutine for MC packets, creates two random numbers and uses them to generate two values
            ! theta and phi which can be used to create an nhat vector
            real(dp), intent(inout) :: n(:)
            real(dp) :: random_num1, random_num2, theta, phi

            if (size(n) /= 3) stop 'Incorrect size of array'

            call RANDOM_NUMBER(random_num1)
            call RANDOM_NUMBER(random_num2)

            theta = acos(2*random_num1-1)
            phi = 2*pi*random_num2

            n(1) = sin(theta)*cos(phi)
            n(2) = sin(theta)*sin(phi)
            n(3) = cos(theta)
        end subroutine

        elemental subroutine mc_update(old_pos, n, length)
            ! update the location of the packets by walking them along the distance that has been calculated for them
            real(dp), intent(out) :: old_pos
            real(dp), intent(in) :: n, length

            old_pos = old_pos + n*length
        end subroutine

        subroutine blob_initial_pos(pos, r_max)
            ! generating a plane of uniform illumination for the blob, setting it at an arbitrary illumination location (along the x axis)
            real(dp) :: pos(3), rand1, radius, phi, r_max

            call RANDOM_NUMBER(rand1)
            call RANDOM_NUMBER(radius)

            phi = 2*pi*rand1
            pos(1) = -r_max
            pos(2) = sqrt(radius)*sin(phi)
            pos(3) = sqrt(radius)*cos(phi)
        end subroutine

        subroutine blob_emit_bias(n)
            ! ensuring that the particles are emitted parallel towards the target, this subroutine only generates xhat unit vectors
            real(dp), intent(inout) :: n(:)
            n(1) = 1.0
            n(2) = 0.0
            n(3) = 0.0
        end subroutine

        subroutine linspace(start, finish, r)
            ! a subroutine that I wrote to replicate the function np.linspace() in NumPy, useful I've needed a linear space of numbers
            ! simply calculates the difference in start and finish then creates an appropriate number of elements to fill that space
            real(dp), intent(in) :: start, finish
            real(dp), intent(out) :: r(:)
            real(dp) :: step
            integer :: num, i

            num = size(r)
            step = (finish - start)/num

            do i = 1, num
                r(i) = start + (i-1)*step
            end do
        end subroutine linspace

        elemental subroutine zeros(array)
            ! a subrountine to generate an array of zeros so that you don't worry about the garbage they're filled with.
            ! pretty much useless since you can do array(:,:) = 0 and set it all at once
            real(dp), intent(out) :: array
            array = 0
        end subroutine

        subroutine image_bin(xim, yim, xbins, ybins, image_grid, pw_wt, r_max, tau)
            ! bin the data depending on locations within the x, y space so that an image can be created
            real(dp), intent(in) :: xim, yim, pw_wt, r_max
            integer :: xloc, yloc, tau, xbins, ybins
            real(dp) :: image_grid(:,:,:)

            xloc = int((xim/r_max)*xbins/2 + xbins/2 + 1)
            yloc = int((yim/r_max)*xbins/2 + ybins/2 + 1)

            image_grid(tau, xloc, yloc) = image_grid(tau, xloc, yloc) + pw_wt
        end subroutine

        subroutine initialise_image_plane(nhat_view, etheta, ephi)
            ! create an image plane with a specific vector nhat so that images can be taken onto that plane.
            ! uses minus signs to ensure that the nhat vector points as it should towards the blob in Q3
            real(dp), intent(in) :: etheta, ephi
            real(dp), intent(inout) :: nhat_view(3)

            nhat_view(1) = -sin(etheta)*cos(ephi)
            nhat_view(2) = -sin(etheta)*sin(ephi)
            nhat_view(3) = -cos(etheta)
        end subroutine

end module mcrt_functions


module integration

! This module contains the routines for the time integration and the computation
! of numerical fluxes (Rusanov in this example).

  use pde
  use global_module

  implicit none

  real(kind=8), dimension(Neq,Nx,Ny) :: U_new ! Working variable

  contains

  ! ========================================================================

  subroutine forward_Euler_step(U, dt)

    ! This function performs one step of the Forward Euler explicit time integrator

    implicit none

    real(kind=8), dimension(Neq,Nx,Ny), intent(inout)  :: U

    real(kind=8), intent(in) :: dt
    integer :: i, j, eqID

    real(kind=8), dimension(Neq) :: F_N, F_S, F_W, F_E

    ! First, assign BCs. Wall BCs need to be updated in time, taking the value
    ! from neighboring cells.
    call assign_BCs(U) ! See the pde.f03 module

    ! Update solution using the forward Euler integrator
    ! INTERNAL CELLS only (4 ghost cells per side)
    do j = 5, Ny-4
      do i = 5, Nx-4

        call compute_fluxes(U, i, j, F_N, F_S, F_W, F_E)

        U_new(:,i,j) = U(:,i,j) - dt/dx*(F_E - F_W) - dt/dy*(F_N - F_S)

        ! Check that the solution did not diverge
        do eqID = 1, Neq
          if (isnan(U_new(eqID,i,j))) then
            print*, 'Solution diverged, try with a smaller time step! Aborting.'
            stop
          end if
        end do

      end do
    end do

    ! Save solution (internal cells ONLY! Do not overwrite ghost cells!)
    U(:,5:Nx-4,5:Ny-4) = U_new(:,5:Nx-4,5:Ny-4)

  end subroutine

  ! ========================================================================

  subroutine RK3_step(U, dt)

    ! This function performs one step of the Forward Euler explicit time integrator

    implicit none

    real(kind=8), dimension(Neq,Nx,Ny), intent(inout)  :: U

    real(kind=8), intent(in) :: dt
    integer :: i, j, eqID

    real(kind=8), dimension(Neq, Nx, Ny) :: U1, U2
    real(kind=8), dimension(Neq) :: F_N, F_S, F_W, F_E

    ! First, assign BCs. Wall BCs need to be updated in time, taking the value
    ! from neighboring cells.
    call assign_BCs(U) ! See the pde.f03 module

    U1 = U ! Init
    U2 = U ! Init

    do j = 5, Ny-4 ! Internal cells only
      do i = 5, Nx-4

        call compute_fluxes(U, i, j, F_N, F_S, F_W, F_E)

        U1(:,i,j) = U(:,i,j) - dt/dx*(F_E - F_W) - dt/dy*(F_N - F_S)

      end do
    end do

    call assign_BCs(U1)

    do j = 5, Ny-4 ! Internal cells only
      do i = 5, Nx-4

        call compute_fluxes(U1, i, j, F_N, F_S, F_W, F_E)

        U2(:,i,j) = 3.0d0/4.0d0*U(:,i,j) +1.0d0/4.0d0*U1(:,i,j) - &
                    1.0d0/4.0d0*dt/dx*(F_E - F_W) - 1.0d0/4.0d0*dt/dy*(F_N - F_S)

      end do
    end do

    call assign_BCs(U2)

    do j = 5, Ny-4 ! Internal cells only
      do i = 5, Nx-4

        call compute_fluxes(U2, i, j, F_N, F_S, F_W, F_E)

        U_new(:,i,j) = 1.0d0/3.0d0*U(:,i,j) + 2.0d0/3.0d0*U2(:,i,j) - &
                       2.0d0/3.0d0*dt/dx*(F_E - F_W) - 2.0d0/3.0d0*dt/dy*(F_N - F_S)

        ! Check that the solution did not diverge
        do eqID = 1, Neq
          if (isnan(U_new(eqID,i,j))) then
            print*, 'Solution diverged, try with a smaller time step! Aborting.'
            stop
          end if
        end do

      end do
    end do

    ! Save solution (internal cells ONLY! Do not overwrite ghost cells!)
    U(:,5:Nx-4,5:Ny-4) = U_new(:,5:Nx-4,5:Ny-4)

  end subroutine

  ! ========================================================================

  subroutine midpoint_Euler_step(U, dt)

    ! This function performs one step of the Forward Euler explicit time integrator

    implicit none

    real(kind=8), dimension(Neq,Nx,Ny), intent(inout)  :: U

    real(kind=8), intent(in) :: dt
    integer :: i, j, eqID

    real(kind=8), dimension(Neq) :: F_N, F_S, F_W, F_E

    ! First, assign BCs. Wall BCs need to be updated in time, taking the value
    ! from neighboring cells.
    call assign_BCs(U) ! See the pde.f03 module

    U_new = U ! Init (for ghost cells)

    ! Compute first half step, and write it in U_new
    do j = 5, Ny-4
      do i = 5, Nx-4
        call compute_fluxes(U, i, j, F_N, F_S, F_W, F_E)
        U_new(:,i,j) = U(:,i,j) - dt/dx*(F_E - F_W) - dt/dy*(F_N - F_S)
      end do
    end do

    call assign_BCs(U_new)

    ! Compute full step, but computing fluxes from U_new
    do j = 5, Ny-4
      do i = 5, Nx-4

        call compute_fluxes(U_new, i, j, F_N, F_S, F_W, F_E)

        U(:,i,j) = U(:,i,j) - dt/dx*(F_E - F_W) - dt/dy*(F_N - F_S)

        ! Check that the solution did not diverge
        do eqID = 1, Neq
          if (isnan(U(eqID,i,j))) then
            print*, 'Solution diverged, try with a smaller time step! Aborting.'
            stop
          end if
        end do

      end do
    end do

  end subroutine

  ! ========================================================================

  subroutine compute_fluxes(U, i, j, F_N, F_S, F_W, F_E)

    ! Select which numerical flux to use

    implicit none

    real(kind=8), dimension(Neq,Nx,Ny), intent(in)  :: U
    real(kind=8), dimension(Neq),       intent(out) :: F_N, F_S, F_W, F_E
    integer, intent(in) :: i, j

    if ( flux_type_Rusanov .eqv. .true. ) then

      call compute_fluxes_Rusanov(U, i, j, F_N, F_S, F_W, F_E)

    end if

  end subroutine

  ! ========================================================================

  subroutine compute_fluxes_Rusanov(U, i, j, F_N, F_S, F_W, F_E)

    ! Computes Rusanov numerical fluxes for the cell (i,j)

    implicit none

    real(kind=8), dimension(Neq,Nx,Ny), intent(in)  :: U
    real(kind=8), dimension(Neq),       intent(out) :: F_N, F_S, F_W, F_E
    integer, intent(in) :: i, j

    integer :: eqID
    real(kind=8), dimension(Neq) :: U_L, U_R, F_L, F_R

    real(kind=8) :: ws_min_L, ws_max_L, ws_min_R, ws_max_R, ws_max ! wave speeds

    ! ------ North interface

    ! Reconstruct the solution, passing the four cells that neighbor the interface
    call reconstruct_sol_interface(U(:,i,j-2), U(:,i,j-1), U(:,i,j), U(:,i,j+1), U(:,i,j+2), U(:,i,j+3), U_L, U_R)

    call compute_flux_ws_y(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_y(U_R, F_R, ws_max_R, ws_min_R)

    ws_max = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

    F_N = 0.5*(F_R + F_L) - ws_max/2.0*(U_R-U_L) ! Rusanov flux

    ! ------ South interface

    ! Reconstruct the solution, passing the four cells that neighbor the interface
    call reconstruct_sol_interface(U(:,i,j-3), U(:,i,j-2), U(:,i,j-1), U(:,i,j), U(:,i,j+1), U(:,i,j+2), U_L, U_R)

    call compute_flux_ws_y(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_y(U_R, F_R, ws_max_R, ws_min_R)

    ws_max = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

    F_S = 0.5*(F_R + F_L) - ws_max/2.0*(U_R-U_L) ! Rusanov flux

    ! ------ East interface

    ! Reconstruct the solution, passing the four cells that neighbor the interface
    call reconstruct_sol_interface(U(:,i-2,j), U(:,i-1,j), U(:,i,j), U(:,i+1,j), U(:,i+2,j), U(:,i+3,j), U_L, U_R)

    call compute_flux_ws_x(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_x(U_R, F_R, ws_max_R, ws_min_R)

    ws_max = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

    F_E = 0.5*(F_R + F_L) - ws_max/2.0*(U_R-U_L) ! Rusanov flux

    ! ------ West interface

    ! Reconstruct the solution, passing the four cells that neighbor the interface
    call reconstruct_sol_interface(U(:,i-3,j), U(:,i-2,j), U(:,i-1,j), U(:,i,j), U(:,i+1,j), U(:,i+2,j), U_L, U_R)

    call compute_flux_ws_x(U_L, F_L, ws_max_L, ws_min_L)
    call compute_flux_ws_x(U_R, F_R, ws_max_R, ws_min_R)

    ws_max = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

    F_W = 0.5*(F_R + F_L) - ws_max/2.0*(U_R-U_L) ! Rusanov flux

  end subroutine

  ! ========================================================================

  subroutine reconstruct_sol_interface(U_m3, U_m2, U_m1, U_p1, U_p2, U_p3, U_L, U_R)

  ! Takes the four points around an interface (minus_1, minus_2, plus_1, plus_2) and
  ! computes the left and right states using first order or MUSCL TVD-limited reconstruction

    real(kind=8), dimension(Neq), intent(in)  :: U_m3, U_m2, U_m1, U_p1, U_p2, U_p3
    real(kind=8), dimension(Neq), intent(out) :: U_L, U_R

    ! Working variables
    integer      :: eID              ! equation ID
    real(kind=8) :: theta_L, theta_R ! ratio of consecutive gradients
    real(kind=8), dimension(Neq) :: P_m3, P_m2, P_m1, P_p1, P_p2, P_p3, P_L, P_R ! primitive variables
    real(kind=8) :: d0, d1, b0, b1, a0, a1, omega0, omega1, P0, P1 ! WENO 3rd order
    real(kind=8) :: b2, a2, omega2, P2                             ! additional for WENO 5th order

    if (space_order .EQ. 1) then  ! ***** First order solution *****

      U_L = U_m1
      U_R = U_p1

    else if (space_order .EQ. 2) then  ! ***** Second order solution - MUSCL TVD *****

      ! Perform reconstruction in primitive variables
      call compute_primitive_from_conserved(U_m2, P_m2)
      call compute_primitive_from_conserved(U_m1, P_m1)
      call compute_primitive_from_conserved(U_p1, P_p1)
      call compute_primitive_from_conserved(U_p2, P_p2)

      do eID = 1, Neq ! Loop on the quantities

        ! Compute ratio of consecutive gradients
        theta_L = (P_p1(eID) - P_m1(eID))/(P_m1(eID) - P_m2(eID) + 1.0d-15) ! Add a small tolerance
        theta_R = (P_p2(eID) - P_p1(eID))/(P_p1(eID) - P_m1(eID) + 1.0d-15) ! Add a small tolerance

        ! Limited linear reconstruction
        P_L(eID) = P_m1(eID) + phi_limiter(theta_L)*(P_m1(eID) - P_m2(eID))/2.0
        P_R(eID) = P_p1(eID) - phi_limiter(1.0d0/(theta_R+1.0d-15))*(P_p2(eID) - P_p1(eID))/2.0

      end do

      ! Compute conservative variables
      call compute_conserved_from_primitive(P_L, U_L)
      call compute_conserved_from_primitive(P_R, U_R)

    else if (space_order .eq. 3) then ! ***** Third order in space, WENO 3 *****

      ! Perform reconstruction in primitive variables
      call compute_primitive_from_conserved(U_m2, P_m2)
      call compute_primitive_from_conserved(U_m1, P_m1)
      call compute_primitive_from_conserved(U_p1, P_p1)
      call compute_primitive_from_conserved(U_p2, P_p2)

      do eID = 1, Neq ! Loop on the quantities

        ! ---------- APPROXIMATE v_int^L (left state) ------------

        d0 = 2.0d0/3.0d0
        d1 = 1.0d0/3.0d0

        b0 = (P_p1(eID) - P_m1(eID))**2
        b1 = (P_m1(eID) - P_m2(eID))**2

        a0 = d0/(1.0d-6 + b0)**2
        a1 = d1/(1.0d-6 + b1)**2

        omega0 = a0/(a0+a1) ! Rescale
        omega1 = a1/(a0+a1) ! Rescale

        ! Approximate v for r=0 and r=1
        P0 = 0.5d0*P_m1(eID) + 0.5d0*P_p1(eID)
        P1 = -0.5d0*P_m2(eID) + 3.0d0/2.0d0*P_m1(eID)

        P_L(eID) = omega0*P0 + omega1*P1

        ! ---------- APPROXIMATE v_int^R (right state) ------------

        b0 = (P_p1(eID) - P_m1(eID))**2
        b1 = (P_p2(eID) - P_p1(eID))**2

        a0 = d0/(1.0d-6 + b0)**2
        a1 = d1/(1.0d-6 + b1)**2

        omega0 = a0/(a0+a1) ! Rescale
        omega1 = a1/(a0+a1) ! Rescale

        ! Approximate v for r=0 and r=1
        P0 = 0.5d0*P_m1(eID) + 0.5d0*P_p1(eID)
        P1 = -0.5d0*P_p2(eID) + 3.0d0/2.0d0*P_p1(eID)

        P_R(eID) = omega0*P0 + omega1*P1;

      end do

      ! Compute conservative variables
      call compute_conserved_from_primitive(P_L, U_L)
      call compute_conserved_from_primitive(P_R, U_R)

    else if (space_order .eq. 5) then ! ***** Fifth order in space, WENO 5 *****

      ! Perform reconstruction in primitive variables
      call compute_primitive_from_conserved(U_m3, P_m3)
      call compute_primitive_from_conserved(U_m2, P_m2)
      call compute_primitive_from_conserved(U_m1, P_m1)
      call compute_primitive_from_conserved(U_p1, P_p1)
      call compute_primitive_from_conserved(U_p2, P_p2)
      call compute_primitive_from_conserved(U_p3, P_p3)

      do eID = 1, Neq ! Loop on the quantities

        ! ---------- APPROXIMATE v_int^L (left state) ------------

        b0 = 13.0d0/12.0d0*(P_m3(eID)-2.0*P_m2(eID) + P_m1(eID))**2 &
           + 1.0d0/4.0d0*(P_m3(eID)-4.0*P_m2(eID)+3.0*P_m1(eID))**2

        b1 = 13.0d0/12.0d0*(P_m2(eID)-2.0*P_m1(eID) + P_p1(eID))**2 &
           + 1.0d0/4.0d0*(P_m2(eID)-P_p1(eID))**2

        b2 = 13.0d0/12.0d0*(P_m1(eID)-2.0*P_p1(eID) + P_m2(eID))**2 &
           + 1.0d0/4.0d0*(3.0*P_m1(eID)-4.0*P_p1(eID)+P_p2(eID))**2

        a0 = 1.0d0/10.0d0*(1.0d0/(1.0d-6 + b0)**2)
        a1 = 6.0d0/10.0d0*(1.0d0/(1.0d-6 + b1)**2)
        a2 = 3.0d0/10.0d0*(1.0d0/(1.0d-6 + b2)**2)

        omega0 = a0/(a0+a1+a2)
        omega1 = a1/(a0+a1+a2)
        omega2 = a2/(a0+a1+a2)

        P_L(eID) = omega0*(2.0d0/6.0d0*P_m3(eID) - 7.0d0/6.0d0*P_m2(eID) + 11.0d0/6.0d0*P_m1(eID)) &
                 + omega1*(-1.0d0/6.0d0*P_m2(eID) + 5.0d0/6.0d0*P_m1(eID) + 2.0d0/6.0d0*P_p1(eID)) &
                 + omega2*(2.0d0/6.0d0*P_m1(eID) + 5.0d0/6.0d0*P_p1(eID) - 1.0d0/6.0d0*P_p2(eID))

        ! ---------- APPROXIMATE v_int^R (right state) ------------

        b0 = 13.0d0/12.0d0*(P_p1(eID)-2.0*P_p2(eID) + P_p3(eID))**2 &
           + 1.0d0/4.0d0*(3.0*P_p1(eID)-4.0*P_p2(eID)+P_p3(eID))**2

        b1 = 13.0d0/12.0d0*(P_m1(eID)-2.0*P_p1(eID) + P_p2(eID))**2 &
           + 1.0d0/4.0d0*(P_m1(eID)-P_p2(eID))**2

        b2 = 13.0d0/12.0d0*(P_m2(eID)-2.0*P_m1(eID) + P_p1(eID))**2 &
           + 1.0d0/4.0d0*(P_m2(eID)-4.0*P_m1(eID)+3.0*P_p1(eID))**2

        a0 = 1.0d0/10.0d0*(1.0d0/(1.0d-6 + b0)**2)
        a1 = 6.0d0/10.0d0*(1.0d0/(1.0d-6 + b1)**2)
        a2 = 3.0d0/10.0d0*(1.0d0/(1.0d-6 + b2)**2)

        omega0 = a0/(a0+a1+a2)
        omega1 = a1/(a0+a1+a2)
        omega2 = a2/(a0+a1+a2)

        P_R(eID) = omega2*(-1.0d0/6.0d0*P_m2(eID) + 5.0d0/6.0d0*P_m1(eID) + 2.0d0/6.0d0*P_p1(eID)) &
                 + omega1*(2.0d0/6.0d0*P_m1(eID)  + 5.0d0/6.0d0*P_p1(eID) - 1.0d0/6.0d0*P_p2(eID)) &
                 + omega0*(11.0d0/6.0d0*P_p1(eID) - 7.0d0/6.0d0*P_p2(eID) + 2.0d0/6.0d0*P_p3(eID))

      end do

      ! Compute conservative variables
      call compute_conserved_from_primitive(P_L, U_L)
      call compute_conserved_from_primitive(P_R, U_R)

    else

      write(*,*) "Attention! Order of the space integration not implemented! Check global_module file!"
      write(*,*) "Aborting!"
      stop

    end if

  end subroutine

  ! ========================================================================

  real(kind=8) function phi_limiter(theta)

    real(kind=8), intent(in) :: theta ! ratio of consecutive gradients

    phi_limiter = (theta*theta + theta)/(theta*theta + 1.0) ! van Albada symmetric limiter
    ! phi_limiter = (theta + abs(theta))/(1.0 + abs(theta)) ! van Leer limiter

  end function

end module


	SUBROUTINE enercalc(Nx,isignf,isignb,isys,ntable,nwork,dt,Es,&
                            enkin,enstr,enpot,en,kx,temp1,temp2,&
                            v,vold,u,uold,tabledz,tablezd,work)

	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This subroutine program calculates the energy for the nonlinear
	! Klein-Gordon equation in 1 dimension
	! u_{tt}-u_{xx}+u=Es*|u|^2u
	!
	! The energy density is given by
	! 0.5u_t^2+0.5u_x^2+0.5u^2+Es*0.25u^4
	!
	! INPUT
	!
	! .. Scalars ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  planfx			= Forward 2d fft plan
	!  planbx			= Backward 2d fft plan
	!  dt				= timestep
	!  Es				= +1 for focusing, -1 for defocusing
	! .. Arrays ..
	!  u 				= approximate solution
	!  v 				= Fourier transform of approximate solution
	!  uold 			= approximate solution
	!  vold 			= Fourier transform of approximate solution
	!  temp1			= array to hold temporary values
	!  temp2			= array to hold temporary values
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!
	! OUTPUT
	!
	! .. Scalars ..
	!  enkin			= Kinetic energy
	!  enstr			= Strain energy
	!  enpot			= Potential energy
	!  en				= Total energy
	!
	! LOCAL VARIABLES
	!
	! .. Scalars ..
	!  i				= loop counter in x direction
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! 	FFTW3	 -- Fast Fourier Transform in the West Library
	!			(http://www.fftw.org/)
	! 	OpenMP library
	!USE omp_lib
	IMPLICIT NONE
	! Declare variables
	INTEGER(KIND=4), INTENT(IN)			     :: Nx
	REAL(KIND=8), INTENT(IN)			     :: dt,Es
	COMPLEX(KIND=8), DIMENSION(1:Nx/2 + 1), INTENT(IN)   :: kx
	REAL(KIND=8), DIMENSION(1:Nx), INTENT(IN)	     :: u,uold
        COMPLEX(KIND=8), DIMENSION(1:Nx/2 + 1), INTENT(IN)   :: v,vold
	REAL(KIND=8), DIMENSION(1:Nx), INTENT(INOUT)	     :: temp1
        COMPLEX(KIND=8), DIMENSION(1:Nx/2 + 1), INTENT(INOUT):: temp2
	REAL(KIND=8), INTENT(OUT)			     :: enkin,enstr
	REAL(KIND=8), INTENT(OUT)			     :: enpot,en
	INTEGER(kind=4), INTENT(IN)                          :: ntable,nwork
        INTEGER(kind=4), INTENT(INOUT)                       :: isys
        INTEGER(kind=4), INTENT(IN)                          :: isignb, isignf
        REAL(kind=8)                                         :: scale
        REAL(kind=8), DIMENSION(1:ntable), INTENT(INOUT)     :: tablezd,tabledz
        REAL(kind=8), DIMENSION(1:nwork), INTENT(INOUT)      :: work
        INTEGER(KIND=4)			                     :: i
	REAL(kind=8), PARAMETER                   :: c=0.5d0,t=0.0d0
        scale=1.0d0/(REAL(Nx,kind(0d0)))
	!.. Strain energy ..
	DO i=1,Nx/2 + 1
		temp2(i)=0.5d0*kx(i)*(vold(i)+v(i))
	END DO
        CALL ZDFFT(isignb,Nx,scale,temp2,temp1,tablezd,work,isys)
        enstr=0.0d0
	DO i=1,Nx
		enstr=enstr+0.5d0*abs(temp1(i))**2
	END DO
	! .. Kinetic Energy ..
        enkin=0.0d0
	DO i=1,Nx
		enkin=enkin+0.5d0*( abs(u(i)-uold(i))/dt )**2
	END DO

	! .. Potential Energy ..
        enpot=0.0D0
	DO i=1,Nx
		enpot=enpot+0.5d0*(abs((u(i)+uold(i))*0.50d0))**2&
				-0.125d0*Es*(abs(u(i))**4+abs(uold(i))**4)
	END DO
        !enpot=enpot/Nx
        !enkin=enkin/Nx
        !enstr=enstr/Nx
	en=enpot+enkin+enstr

	END SUBROUTINE enercalc


module m_Thomas
  implicit none
  contains

    subroutine InnerProductForm(a)
      implicit none
      real(8),intent(inout) :: a(:,:)
      real(8) :: dajk
      integer :: i,j,k,n

      n=size(a(1,:))
      do k=1,n
        do j=1,k-1
          dajk = a(j,k)
          do i=j+1,n
            a(i,k) = a(i,k)-a(i,j)*dajk
          enddo
        enddo
        a(k,k) = 1.0d0/a(k,k)
        do i=k+1,n
          a(i,k) = a(i,k)*a(k,k)
        enddo
      enddo
      return
    end subroutine InnerProductForm

    subroutine Substitution(a,b)
      implicit none
      real(8),intent(inout) :: a(:,:),b(:,:)
      real(8),allocatable :: l(:,:),u(:,:),y(:,:)
      integer ::  i,j,k,n,m
      n = size(a(1,:))
      m = size(b(1,:))
      allocate(l(n,n),u(n,n),y(n,n))
      !L,Uを生成
      do j = 1,n
        do i = 1,j-1
          u(i,j) = a(i,j)
        enddo
        u(j,j) = 1.0d0/a(j,j)
        l(j,j) = 1
        do i = j+1,n
          l(i,j) = a(i,j)
        enddo
      enddo
      !ynを導出
      do k = 1,m
        y(1,k) = b(1,k)
        do i = 2,n
            y(i,k) = b(i,k)
            do j=1,i-1
              y(i,k) = y(i,k)-l(i,j)*y(j,k)
            enddo
        enddo
      enddo
      !xnを導出 (=b')
      do k = 1,m
        b(n,k) = y(n,k)/u(n,n)
        do i = n-1,1,-1
          b(i,k) = y(i,k)
          do j = i+1,n
            b(i,k) = b(i,k)-u(i,j)*b(j,k)
          enddo
          b(i,k) = b(i,k)/u(i,i)
        enddo
      enddo
      !write(*,*) b,"b"
      return
    end subroutine Substitution

    subroutine InverseMatrix(a,b)
      !B'=A^-1*Bを返す
      implicit none
      real(8),intent(in) :: a(:,:)
      real(8),intent(inout) :: b(:,:)
      real(8),allocatable :: IPF(:,:)
      integer :: n
      n = size(a(1,:))
      IPF = a
      call InnerProductForm(IPF)
      call Substitution(IPF,b)
      return
    end subroutine InverseMatrix

    subroutine n_Thomas(c,a,b,r)
      implicit none
      real(8),intent(inout) :: c(:,:,:),a(:,:,:),b(:,:,:),r(:,:,:)
      !row,column,index
      integer :: i,n

      n = size(r(1,1,:))
      call InverseMatrix(a(:,:,1),b(:,:,1))
      do i = 2,n
        a(:,:,i) = a(:,:,i)-MATMUL(c(:,:,i),b(:,:,i-1))
        call InverseMatrix(a(:,:,i),b(:,:,i))
      enddo
      call InverseMatrix(a(:,:,1),r(:,:,1))
      do i = 2,n
        r(:,:,i) = r(:,:,i) - MATMUL(c(:,:,i),r(:,:,i-1))
        call InverseMatrix(a(:,:,i),r(:,:,i))
      enddo
      do i = n-1,1,-1
        r(:,:,i) = r(:,:,i)- MATMUL(b(:,:,i),r(:,:,i+1))
      enddo
      return
    end subroutine n_Thomas

    subroutine Thomas(c,a,b,r)
      implicit none
      real(8),intent(inout) :: c(:),a(:),b(:),r(:)
      integer :: i,n

      n = size(r)
      b(1) = b(1)/a(1)
      do i = 2,n
        a(i) = a(i)-c(i)*b(i-1)
        b(i) = b(i)/a(i)
      enddo
      r(1) = r(1)/a(1)
      do i = 2,n
        r(i) = (r(i)-c(i)*r(i-1))/a(i)
      enddo
      do i = n-1,1,-1
        r(i) = r(i)-b(i)*r(i+1)
      enddo
      return
    end subroutine Thomas

end module m_Thomas