      MODULE PHYS

      IMPLICIT NONE

      REAL*8, PARAMETER :: pai = 3.1415926

      REAL*8, PARAMETER :: boltz = 1.3806488D-16 ! Boltzmann constant, erg / K

      REAL*8, PARAMETER :: elec_mass = 9.1093829D-28 ! Electron mass, g

      REAL*8, PARAMETER :: prot_mass = 1.6726217D-24 ! Proton mass, g

      REAL*8, PARAMETER :: bohr_rad = 5.29D-9 ! Bohr radius, cm

      REAL*8, PARAMETER :: fine_str = 7.2973525D-3 ! Fine structure constant

      REAL*8, PARAMETER :: light_speed = 2.9979245D+10 ! Speed of light, cm / s

      REAL*8, PARAMETER :: planck = 6.6260688D-27 ! Planck constant, erg * s

      PUBLIC

      CONTAINS

      REAL*8 FUNCTION HYD_LEV_ENERGY(n) ! Energy of a hydrogen level with principal quantum number n (in CGS units)

      USE MATH

      INTEGER, INTENT(IN) :: n

      HYD_LEV_ENERGY = -elec_mass * DSQ(light_speed * fine_str)  / ISQ(n) / 2.0D0

      RETURN

      END FUNCTION HYD_LEV_ENERGY

      REAL*8 FUNCTION PLANCK_FUNC(nu, T) ! Planck intensity per unit frequency (in CGS units)

      USE MATH

      REAL*8, INTENT(IN) :: nu, T

      REAL*8 :: PLANCK_EXP

      REAL*8 :: PLANCK_FREQ_FACT

      PLANCK_FREQ_FACT = 2.0D0 * planck * DCUBE(nu) / DSQ(light_speed)

      PLANCK_EXP = DEXP(planck * nu / boltz / T)

      PLANCK_FUNC =  PLANCK_FREQ_FACT / (PLANCK_EXP - 1.0D0)

      RETURN

      END FUNCTION PLANCK_FUNC

      END MODULE PHYS


!
!     (c) 2020-2021 Sourcery, Inc.
!     This software was developed for the U.S. Nuclear Regulatory Commission (US NRC) under contract # 31310020D0006:
!     "Technical Assistance in Support of NRC Nuclear Regulatory Research for Materials, Waste, and Reactor Programs"
!
module reference_calc_cpi

implicit none

    contains

    !Function to calculate cpi(t)
    function cpi_t(K, RTndt, T)

        !Variables
        real :: cpi_t
        real, intent(in) :: K, RTndt, T
        real :: aKic, bKic, cKic

        !Calculate aKic, bKic, cKic
        aKic = 19.35+8.335*exp(0.02254*(T-RTndt))
        bKic = 15.61+50.132*exp(0.008*(T-RTndt))
        cKic = 4.0

        !Calculate cpi_t
        if (K < aKic) then
            cpi_t = 0.0
        else
            cpi_t = 1-exp(-((K-aKic)/bKic)**cKic)
        end if

    end function cpi_t

end module


!=======================================
! making complex conjugation
!=======================================
complex*16 function c_link(c)
implicit none
complex*16,intent(in)::c
complex*16::ii
  ii=(0.d00,1.d00)
  c_link=c-2*ii*aimag(c)
  !if(c.ne.0.d00)then
  !  write(*,*)"==>",c,c_link
  !end if
return
end function c_link

!============================================================
! Making a complex numer out of absolute value and argument.
!============================================================
complex*16 function c_make(r,fi)
implicit none
real*8,intent(in)::r,fi
complex*16::ii
  ii=(0.d0,1.d0)
  c_make=r*cos(fi)+ii*r*sin(fi)
return
end function c_make

!========================================================
! An absolute value of a complex number q.
!========================================================
real*8 function c_mod(q)
implicit none
complex*16,intent(in)::q
real*8::x,y
  x=q
  y=aimag(q)
  c_mod=sqrt(x*x+y*y)
return
end function c_mod

!================================================
! An argument of a complex number q.
!================================================
real*8 function arg(q)
implicit none
complex*16,intent(in)::q
real*8::q1,q2,l,dop
real*8::pi
  pi=3.141592653589793d0
  if(q.eq.(0.d0,0.d0))then
    arg=0.d0; goto 11
  end if
  q1=q
  q2=aimag(q)
  l=sqrt(q1**2+q2**2)
  arg=acos(q1/l)
  dop=acos(q1/l)
  if(q2.le.0) then
    arg=2.d0*pi-dop
  end if
11 return
end function arg

complex*16 function f_rc(x)  !создание комплексного числа из вещественного
implicit none
real*8::x
complex*16::ii
  ii=(0.d00,1.d00)
  f_rc=x+0.d00*ii
return
end function f_rc


program lin_alg_main
  use lin_alg
  implicit none
  real(dp) :: a(4), b(3), c(3), x(4), y(4)

  a = [2._dp, 3._dp, 5._dp, 7._dp]
  c = [11._dp, 13._dp, 17._dp]
  b = [19._dp, 23._dp, 29._dp]
  y = [31._dp, 37._dp, 41._dp, 43._dp]

  call tridiag(c,a,b,y,x)
  print*, "using my solution"
  print*, x

  !print*, "--------------"

  call tridiag_nr(c,a,b,y,x)
  print*, "using nr's solution"
  print*, x
end program lin_alg_main


!!## MODULE FUNCTION: Integrate1S_trapezoid
MODULE FUN_Integrate1S_trapezoid
!!### PURPOSE
!! Uses the trapezoid rule to integrate a function <f>
!! defined by a set values <f> and the corresponding
!! set of set of x-values <x>.
!!

!!### USAGE
!! The integration may be performed with a call
!
!        integral = Integrate1S_trapezoid( f , x )
!
!! where the <f> is the list of <N> function values,
!! $f_i=f(x_i),i=1,...,N$ and <x> are those x-values,
!! $x_i,x=1,...,N$.

!!### METHOD
!! The trapezoid rule for integration,
!!
!!  $$ integral = \sum_{i=1}^{N-1} \bar{f}_i \Delta x_i, $$
!!
!! where $\Delta x_i= x_{i+1}-x_i$ and
!! $\bar{f}_i = 0.5(f_i+f_{i+1}) $.
!!

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE Integrate1S_trapezoid
 MODULE PROCEDURE Integrate1S_trapezoid_yRsp_xRsp
 MODULE PROCEDURE Integrate1S_trapezoid_yRsp_xRdp
 MODULE PROCEDURE Integrate1S_trapezoid_yRdp_xRsp
 MODULE PROCEDURE Integrate1S_trapezoid_yRdp_xRdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: Integrate1S_trapezoid

CONTAINS

FUNCTION Integrate1S_trapezoid_yRsp_xRsp( f , x , &
  fbarin , delxin , fbarout , delxout) RESULT(integral)
!!#### LOCAL KINDS
INTEGER,PARAMETER :: KIND_x=KIND_Rsp , KIND_f=KIND_Rsp
INCLUDE "04-B-FUN_Integrate1S_trapezoid.f90.hdr" !function header
!!--begin--
INCLUDE "04-B-FUN_Integrate1S_trapezoid.f90.sup" !setup
INCLUDE "04-B-FUN_Integrate1S_trapezoid.f90.bdy" !function body
!!--end--
END FUNCTION

FUNCTION Integrate1S_trapezoid_yRdp_xRsp( f , x , &
  fbarin , delxin , fbarout , delxout) RESULT(integral)
!!#### LOCAL KINDS
INTEGER,PARAMETER :: KIND_x=KIND_Rsp , KIND_f=KIND_Rdp
INCLUDE "04-B-FUN_Integrate1S_trapezoid.f90.hdr"  !function header
!!--begin--
INCLUDE "04-B-FUN_Integrate1S_trapezoid.f90.sup"  !setup
INCLUDE "04-B-FUN_Integrate1S_trapezoid.f90.bdy" !algorithm
!!--end--
END FUNCTION

FUNCTION Integrate1S_trapezoid_yRsp_xRdp( f , x , &
  fbarin , delxin , fbarout , delxout) RESULT(integral)
!!#### LOCAL KINDS
INTEGER,PARAMETER :: KIND_x=KIND_Rdp , KIND_f=KIND_Rsp
INCLUDE "04-B-FUN_Integrate1S_trapezoid.f90.hdr"  !function header
!!--begin--
INCLUDE "04-B-FUN_Integrate1S_trapezoid.f90.sup"  !setup
INCLUDE "04-B-FUN_Integrate1S_trapezoid.f90.bdy" !algorithm
!!--end--
END FUNCTION

FUNCTION Integrate1S_trapezoid_yRdp_xRdp( f , x , &
  fbarin , delxin , fbarout , delxout) RESULT(integral)
!!#### LOCAL KINDS
INTEGER,PARAMETER :: KIND_x=KIND_Rdp , KIND_f=KIND_Rdp
INCLUDE "04-B-FUN_Integrate1S_trapezoid.f90.hdr"  !function header
!!--begin--
INCLUDE "04-B-FUN_Integrate1S_trapezoid.f90.sup"  !setup
INCLUDE "04-B-FUN_Integrate1S_trapezoid.f90.bdy" !algorithm
!!--end--
END FUNCTION

END MODULE


program simpson_test_wf
      implicit none
      integer, parameter :: n = 1001, dp = selected_real_kind(14)
      integer :: i
      real(kind=dp), dimension(n) :: x, y
      real(kind=dp) :: sum, high, low, dx, x_sq
      real(kind=dp), parameter :: pi = real(4, kind=dp)*atan(real(1, kind=dp))

      interface
        function simpson(x,y,n)
                integer, parameter :: dp = selected_real_kind(14)
                integer, intent(in) :: n
                real(kind=dp) :: simpson
                real(kind=dp), dimension(n), intent(in) :: x, y
        end function simpson
      end interface

      sum=0.0d0
      high = 5.0d0; low = -high;
      dx = (high - low)/(n-1)
      do i=1, n
        x(i) = low + dfloat(i)*dx
        x_sq = x(i)*x(i)
        y(i) = (x_sq - 1.0d0)*exp(-x_sq)
        !write(*, '(i, 2f10.3)') i, x(i), y(i)
      end do

      sum = simpson(x,y,n)
      write(*,*) sum, sqrt(pi)/-2.0d0

end program simpson_test_wf


submodule(forlab_linalg) forlab_linalg_solve

    implicit none

contains

    module procedure solve_sp
    integer :: i, j, m, n
    real(sp), dimension(:), allocatable :: w, y
    real(sp), dimension(:, :), allocatable :: L, U, V
    m = size(A, 1)
    n = size(A, 2)
    if (is_square(A)) then
        x = zeros(m)
        y = zeros(m)
        y(1) = b(1)
        ! LU decomposition to solve LUx = b
        !===================================
        call lu(A, L, U)
        ! Forward substitution: Ly = b
        !==============================
        do i = 2, m
            y(i) = b(i)
            do j = 1, i - 1
                y(i) = y(i) - y(j)*L(i, j)
            end do
        end do
        ! Back substitution: Ux = y
        !===========================
        x(m) = y(m)/U(m, m)
        do i = m - 1, 1, -1
            x(i) = y(i)
            do j = m, i + 1, -1
                x(i) = x(i) - x(j)*U(i, j)
            end do
            x(i) = x(i)/U(i, i)
        end do
    else
        x = svdsolve(A, b)
    end if
    end procedure solve_sp
    module procedure solve_dp
    integer :: i, j, m, n
    real(dp), dimension(:), allocatable :: w, y
    real(dp), dimension(:, :), allocatable :: L, U, V
    m = size(A, 1)
    n = size(A, 2)
    if (is_square(A)) then
        x = zeros(m)
        y = zeros(m)
        y(1) = b(1)
        ! LU decomposition to solve LUx = b
        !===================================
        call lu(A, L, U)
        ! Forward substitution: Ly = b
        !==============================
        do i = 2, m
            y(i) = b(i)
            do j = 1, i - 1
                y(i) = y(i) - y(j)*L(i, j)
            end do
        end do
        ! Back substitution: Ux = y
        !===========================
        x(m) = y(m)/U(m, m)
        do i = m - 1, 1, -1
            x(i) = y(i)
            do j = m, i + 1, -1
                x(i) = x(i) - x(j)*U(i, j)
            end do
            x(i) = x(i)/U(i, i)
        end do
    else
        x = svdsolve(A, b)
    end if
    end procedure solve_dp

end submodule forlab_linalg_solve


program example_lmder1

use minpack_module, only: wp, enorm, lmder1, chkder
use iso_fortran_env, only: nwrite => output_unit

implicit none

integer, parameter :: n = 3
integer, parameter :: m = 15
integer, parameter :: lwa = 5*n+m

integer :: info
real(wp) :: tol, x(n), fvec(m), fjac(m,n)
integer :: ipvt(n)
real(wp) :: wa(lwa)

! The following starting values provide a rough fit.
x = [1.0_wp, 1.0_wp, 1.0_wp]

call check_deriv()

! Set tol to the square root of the machine precision. Unless high precision
! solutions are required, this is the recommended setting.
tol = sqrt(epsilon(1._wp))

call lmder1(fcn, m, n, x, fvec, fjac, m, tol, info, ipvt, wa, lwa)

write(nwrite, '(5x,a,d15.7//,5x,a,16x,i10//,5x,a//(5x,3d15.7))') &
        'FINAL L2 NORM OF THE RESIDUALS', enorm(m, fvec), &
        'EXIT PARAMETER', info, &
        'FINAL APPROXIMATE SOLUTION', x

contains

subroutine check_deriv()

    integer :: iflag
    real(wp) :: xp(n), fvecp(m), err(m)

    call chkder(m, n, x, fvec, fjac, m, xp, fvecp, 1, err)
    iflag = 1
    call fcn(m, n, x, fvec, fjac, m, iflag)
    iflag = 2
    call fcn(m, n, x, fvec, fjac, m, iflag)
    iflag = 1
    call fcn(m, n, xp, fvecp, fjac, m, iflag)
    call chkder(m, n, x, fvec, fjac, m, xp, fvecp, 2, err)

    write(nwrite, '(a)') 'Derivatives check (1.0 is correct, 0.0 is incorrect):'
    write(nwrite,'(1p,(5x,3d15.7))') err
    if (any(abs(err-1.0_wp)>epsilon(1.0_wp))) error stop 'Derivative check failed'

end subroutine check_deriv

subroutine fcn(m, n, x, fvec, fjac, ldfjac, iflag)

    integer, intent(in) :: m
    integer, intent(in) :: n
    integer, intent(in) :: ldfjac
    real(wp), intent(in) :: x(n)
    real(wp), intent(inout) :: fvec(m)
    real(wp), intent(inout) :: fjac(ldfjac, n)
    integer, intent(inout) :: iflag

    integer :: i
    real(wp) :: tmp1, tmp2, tmp3, tmp4

    real(wp),parameter :: y(15) = [1.4e-1_wp, 1.8e-1_wp, 2.2e-1_wp, 2.5e-1_wp, 2.9e-1_wp, &
                                   3.2e-1_wp, 3.5e-1_wp, 3.9e-1_wp, 3.7e-1_wp, 5.8e-1_wp, &
                                   7.3e-1_wp, 9.6e-1_wp, 1.34e0_wp, 2.1e0_wp,  4.39e0_wp]

    if (iflag == 1) then
        do i = 1, 15
            tmp1 = i
            tmp2 = 16 - i
            tmp3 = tmp1
            if (i > 8) tmp3 = tmp2
            fvec(i) = y(i) - (x(1) + tmp1/(x(2)*tmp2 + x(3)*tmp3))
        end do
    else
        do i = 1, 15
            tmp1 = i
            tmp2 = 16 - i
            tmp3 = tmp1
            if (i > 8) tmp3 = tmp2
            tmp4 = (x(2)*tmp2 + x(3)*tmp3)**2
            fjac(i,1) = -1.0_wp
            fjac(i,2) = tmp1*tmp2/tmp4
            fjac(i,3) = tmp1*tmp3/tmp4
        end do
    end if

    end subroutine fcn

end program


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE MXMULT(N,MAT1,MAT2,MATR)
      REAL MAT1(N,*),MAT2(N,*),MATR(N,*)

      IF (N .EQ. 4) THEN
          MATR(1,1) = MAT1(1,1)*MAT2(1,1) + MAT1(1,2)*MAT2(2,1) +
     *                MAT1(1,3)*MAT2(3,1) + MAT1(1,4)*MAT2(4,1)
          MATR(1,2) = MAT1(1,1)*MAT2(1,2) + MAT1(1,2)*MAT2(2,2) +
     *                MAT1(1,3)*MAT2(3,2) + MAT1(1,4)*MAT2(4,2)
          MATR(1,3) = MAT1(1,1)*MAT2(1,3) + MAT1(1,2)*MAT2(2,3) +
     *                MAT1(1,3)*MAT2(3,3) + MAT1(1,4)*MAT2(4,3)
          MATR(1,4) = MAT1(1,1)*MAT2(1,4) + MAT1(1,2)*MAT2(2,4) +
     *                MAT1(1,3)*MAT2(3,4) + MAT1(1,4)*MAT2(4,4)

          MATR(2,1) = MAT1(2,1)*MAT2(1,1) + MAT1(2,2)*MAT2(2,1) +
     *                MAT1(2,3)*MAT2(3,1) + MAT1(2,4)*MAT2(4,1)
          MATR(2,2) = MAT1(2,1)*MAT2(1,2) + MAT1(2,2)*MAT2(2,2) +
     *                MAT1(2,3)*MAT2(3,2) + MAT1(2,4)*MAT2(4,2)
          MATR(2,3) = MAT1(2,1)*MAT2(1,3) + MAT1(2,2)*MAT2(2,3) +
     *                MAT1(2,3)*MAT2(3,3) + MAT1(2,4)*MAT2(4,3)
          MATR(2,4) = MAT1(2,1)*MAT2(1,4) + MAT1(2,2)*MAT2(2,4) +
     *                MAT1(2,3)*MAT2(3,4) + MAT1(2,4)*MAT2(4,4)

          MATR(3,1) = MAT1(3,1)*MAT2(1,1) + MAT1(3,2)*MAT2(2,1) +
     *                MAT1(3,3)*MAT2(3,1) + MAT1(3,4)*MAT2(4,1)
          MATR(3,2) = MAT1(3,1)*MAT2(1,2) + MAT1(3,2)*MAT2(2,2) +
     *                MAT1(3,3)*MAT2(3,2) + MAT1(3,4)*MAT2(4,2)
          MATR(3,3) = MAT1(3,1)*MAT2(1,3) + MAT1(3,2)*MAT2(2,3) +
     *                MAT1(3,3)*MAT2(3,3) + MAT1(3,4)*MAT2(4,3)
          MATR(3,4) = MAT1(3,1)*MAT2(1,4) + MAT1(3,2)*MAT2(2,4) +
     *                MAT1(3,3)*MAT2(3,4) + MAT1(3,4)*MAT2(4,4)

          MATR(4,1) = MAT1(4,1)*MAT2(1,1) + MAT1(4,2)*MAT2(2,1) +
     *                MAT1(4,3)*MAT2(3,1) + MAT1(4,4)*MAT2(4,1)
          MATR(4,2) = MAT1(4,1)*MAT2(1,2) + MAT1(4,2)*MAT2(2,2) +
     *                MAT1(4,3)*MAT2(3,2) + MAT1(4,4)*MAT2(4,2)
          MATR(4,3) = MAT1(4,1)*MAT2(1,3) + MAT1(4,2)*MAT2(2,3) +
     *                MAT1(4,3)*MAT2(3,3) + MAT1(4,4)*MAT2(4,3)
          MATR(4,4) = MAT1(4,1)*MAT2(1,4) + MAT1(4,2)*MAT2(2,4) +
     *                MAT1(4,3)*MAT2(3,4) + MAT1(4,4)*MAT2(4,4)

      ELSE

        DO 230 K = 1,N
          DO 200 J = 1,N
            MATR(K,J) = 0.0
 200      CONTINUE
          DO 220 I = 1,N
            DO 210 J = 1,N
              MATR(K,J) = MATR(K,J) + MAT1(K,I)*MAT2(I,J)
 210        CONTINUE
 220      CONTINUE
 230    CONTINUE
      END IF
      RETURN
      END


program quad_test
    use types_mod, only : dp
    use quad_mod, only : quad
    implicit none
    real(kind=dp), parameter :: a = -1.0_dp, b = 1.0_dp

    print *, quad(f, a, b)

contains

    real(kind=dp) function f(x)
        implicit none
        real(Kind=dp), intent(in) :: x
        f = exp(x)
    end function f

end program quad_test


subroutine apply_linearized_pde_operator(t, r, p, output)

! For the PDE q_t = g(r), calculates g'[r](p), i.e. the linearization
! of g, about r, applied to perturbation p
!
! Args:
!   t: Time at which the operator is evaluated.
!   r: Base function of the linearization.
!   p: Perturbation to which the linearized operator is applied.
!   output: g'[r](p), calculated here.

    !$ use omp_lib
    implicit none

    integer :: mx, my, mbc, meqn
    double precision :: x_lower, y_lower, dx, dy
    common /claw_config/ mx, my, mbc, x_lower, y_lower, dx, dy, meqn

    double precision, intent(in) :: t
    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn), intent(in) :: r, p
    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn), intent(out) :: output

    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn) :: temp1, temp2

    double precision :: epsilon, norm_r, norm_p
    double precision, external :: l2_norm

    integer :: ix, iy, ieqn

    norm_r = l2_norm(r)
    norm_p = l2_norm(p)
    epsilon = 1d-4 * norm_r / norm_p

    temp1 = r + epsilon * p
    call apply_pde_operator(t, temp1, output)
    temp1 = r - epsilon * p
    call apply_pde_operator(t, temp1, temp2)

    do ieqn = 1, meqn
        do iy = 1, my
            do ix = 1, mx
                output(ix, iy, ieqn) = (output(ix, iy, ieqn) - temp2(ix, iy, ieqn)) / (2 * epsilon)
            end do
        end do
    end do

end subroutine apply_linearized_pde_operator

double precision function l2_norm(r)
    integer :: mx, my, mbc, meqn
    double precision :: x_lower, y_lower, dx, dy
    common /claw_config/ mx, my, mbc, x_lower, y_lower, dx, dy, meqn
    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn) :: r
    double precision, external :: inner_product
    l2_norm = sqrt(inner_product(r, r))
end function l2_norm


PROGRAM main
  USE OMP_LIB
  IMPLICIT NONE
  ! ...Local Scalars...
  INCLUDE 'mpif.h'
  INTEGER :: i, n, myid, ntasks, ierr, islave, tid, ts_nums
  INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status
  INTEGER, PARAMETER :: master=0, msgtag1=11, msgtag2=12
  DOUBLE PRECISION, PARAMETER :: pi25dt = 3.141592653589793238462643d0
  DOUBLE PRECISION :: a, h, pi, summ, x, mypi
  !
  !...Executable Statements...
  !
  CALL MPI_INIT(ierr)
  CALL MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
  CALL MPI_COMM_SIZE(MPI_COMM_WORLD, ntasks, ierr)

  DO
    IF (myid == 0) THEN ! only master
      ! Input
      WRITE (6,10000)
      READ (5,10001) n
    END IF
    CALL MPI_Bcast(n, 1, MPI_INTEGER, master,MPI_COMM_WORLD,ierr)
    IF (n==0) EXIT

    h = 1.0d0 / n ! stride
    !Calculation of the quadrature formula(summation)
    summ = 0.0d0
    !$OMP PARALLEL DO REDUCTION(+:summ) SHARED(myid,n,ntasks,h) PRIVATE(x,i)
    DO i = (n/ntasks)*myid, (myid+1)*(n/ntasks)-1
      x = h * (i + 0.5d0)
      summ = summ + 4.0 / (1.0 + x * x)
    END DO
    !$OMP END PARALLEL DO

    mypi = h * summ
    CALL MPI_Reduce(mypi, pi, 1, MPI_DOUBLE_PRECISION, MPI_SUM, 0,  MPI_COMM_WORLD, ierr)
    ! Output of the solution
    IF (myid == 0) THEN ! only master
      WRITE (*,*) pi, ABS(pi - pi25dt)
    END IF
  END DO ! ---- main loop end

  CALL MPI_FINALIZE(ierr)
  !
  ! ...Format Declarations...
  !
  10000 format ( "Enter the number of intervals : (0 quits )" )
  10001 format ( i10 )
END PROGRAM main


PROGRAM MAIN
    USE tscr_mod
    USE function_mod
    IMPLICIT NONE
    REAL(8) :: a,b
    INTEGER::k
    CLASS(jifen_type),ALLOCATABLE:: jifen(:)
    INTEGER(4),PARAMETER :: number=50
    REAL(8),PARAMETER :: EPS = 1.0E-8
    INTEGER(4)           :: i,number_fun
    ALLOCATE(jifen(number))
    DO i=1,number
        jifen(i)%t=0
        jifen(i)%s=0
        jifen(i)%c=0
        jifen(i)%r=0
    END DO
    WRITE(*,*)'choose a and b ([a,b]):'
    READ(*,*)a,b
    WRITE(*,*)'choose the function number of the problem'
    WRITE(*,*)'if you first caculate this function,please modify the file:function_mod.f90'
    WRITE(*,*)'then you can define a function number'
    READ(*,*) number_fun
    CALL fun(number_fun,(b-a)/2*(a+b),jifen(1)%t)
    OPEN(81,FILE='output')
    WRITE(*,*)&
    ' k        T             S             C             R'
    WRITE(81,*)&
    ' k        T             S             C             R'
    DO i=1,number
        IF (i>=2) CALL tixing(number_fun,a,b,jifen(i-1),i,jifen(i))
        IF (i>=2) CALL simpson(jifen(i-1),jifen(i))
        IF (i>=3) CALL cotes(jifen(i-1),jifen(i))
        IF (i<=3) WRITE(81,"(I3,2X,F12.9,2x,F12.9,2X,F12.9,2X,F12.9)") i-1,jifen(i)%t,jifen(i)%S,jifen(i)%C,jifen(i)%R
        IF (i<=3) WRITE(*, "(I3,2X,F12.9,2x,F12.9,2X,F12.9,2X,F12.9)") i-1,jifen(i)%t,jifen(i)%S,jifen(i)%C,jifen(i)%R
        IF (i>=4) THEN
            CALL romberg(jifen(i-1),jifen(i))
            WRITE(*, "(I3,2X,F12.9,2x,F12.9,2X,F12.9,2X,F12.9)") i-1,jifen(i)%t,jifen(i)%S,jifen(i)%C,jifen(i)%R
            WRITE(81,"(I3,2X,F12.9,2x,F12.9,2X,F12.9,2X,F12.9)") i-1,jifen(i)%t,jifen(i)%S,jifen(i)%C,jifen(i)%R
            IF (abs(jifen(i)%r-jifen(i-1)%r)<=EPS) EXIT
        END IF
    END DO
    CLOSE(81)
    DEALLOCATE(jifen)
    WRITE(*,*)'This code was written by Huang Yihan'
END PROGRAM


    program testme

    IMPLICIT NONE
    INTEGER, PARAMETER :: wp = KIND(0.0D0) ! working precision
    INTEGER, PARAMETER :: n=1501           ! size of problem
    INTEGER, PARAMETER :: KU=3            ! bandwidth of matrix, KU=1 for dctsv.f90  KU>1 needs dcbsv.f90
    INTEGER, PARAMETER :: KL=0            ! for testing vs lapack version only
                                           ! KL=KU to run non-periodic version of matrix KL=0 runs periodic version
    REAL(wp) :: d(n,2),a(n),b(n),c(n),aij(n,n),bij(n,n),cij(n,n),s(n,2),z(n,2)
    REAL(wp) :: AB(2*KU+1,n),time_end,time_start ! AB(2*KU+1,n) for dcbsv; ! AB(KL+KU+1+i-j,j) for dgbsv
    REAL(wp) :: CD(2*KL+KU+1,n)                  ! CD(KL+KU+1+i-j,j) for dgbsv
    REAL(wp) :: a_short(n-1)                     ! truncated a() for dgtsv
    INTEGER :: i,j,k,INFO,ipiv(n)
!   Copyright (c) 2021   Anthony M de Beus
    AB=0

!   only runs dctsv.f90 if KU=1
!   only runs gauss-jordan if N < 500 (gets too slow)
!   only runs dgbsv and/or dgtsv if KL > 0 (and in fact KL=KU); non-periodic lapack routines, KU=KL=1 for dgtsv

!   This is an example of a band matrix for testing
    aij=0
    do i=1,n
     do j=1,n
      if (ABS(i - j) <= KU ) then  ! regular band
        aij(i,j)=500+3*i-2*j
        if (i > j) then
        aij(i,j)=aij(i,j)+1        ! asymmetry
       endif
      endif
      if (KL == 0) then             ! add the off diagonal terms in KL == 0
       if (ABS(i - j) >= N-KU) then ! cyclic elements
        aij(i,j) = 20+i+2*j
        if (i > j) then
         aij(i,j)=aij(i,j)*2        ! asymmetry
        endif
       endif
      endif
     end do
     end do

    IF (N > 500) then
     do i=1,n
      s(i,1)=57.3*cos(40.0*i)        ! solution vectors
      s(i,2)=10*sin(5.0*i)           ! i and i**2 get too ill-conditioned with large n
     end do
    else
     do i=1,n
      s(i,1)=i                     ! solution vectors
      s(i,2)=i**2
     end do
    endif

    d=matmul(aij,s )               ! RHS vectors
    cij=aij                        ! store a copy

    call CPU_TIME(time_start)
    call DGESV(N, 2, AIJ, N, IPIV, D, N, INFO ) ! overwrites  aij & d
    call CPU_TIME(time_end)
    write(*,*) 'Using full matrix solver from LAPACK, dgesv.f, O(n^2)'
    write(*,*) 'time: ',time_end-time_start
    write(*,*) 'solution error',dot_product((s(:,1)-d(:,1)),(s(:,1)-d(:,1)))
    write(*,*) 'solution error',dot_product((s(:,2)-d(:,2)),(s(:,2)-d(:,2)))
    write(*,*) ' '

    if (N < 1000) then   ! don't do this unless you want to wait a long time
    aij=cij
    d=matmul(aij,s)
    call CPU_TIME(time_start)
    call GaussJordan( N, 2, AIJ, N, D, N, INFO )
    call CPU_TIME(time_end)
    write(*,*) 'Using full matrix solver Gauss-Jordan with inverse, O(n^3)'
    write(*,*) 'time: ',time_end-time_start
    write(*,*) 'solution error',dot_product((s(:,1)-d(:,1)),(s(:,1)-d(:,1)))
    write(*,*) 'solution error',dot_product((s(:,2)-d(:,2)),(s(:,2)-d(:,2)))
    bij=aij
    aij=cij
    aij=matmul(aij,bij)
    bij=0
    do i=1,n
      bij(i,i) = 1.0
    enddo
    write(*,*) 'inverse error ',sum((aij-bij)*(aij-bij))   ! tests the inverse
    write(*,*) ' '
    endif

    aij=cij
    d=matmul(aij,s)

    do i=1,n                                           ! store aij in band-cyclic format
     do j=1,n
      if (aij(i,j) /= 0) then
      k=2*KU+2-mod(N+KU+1+i-j,N)
      AB(k,i)=aij(i,j)
      endif
     end do
    end do

    if (KL > 0) then
    do i=1,n                                           ! store aij in lapack band format if we're testing non-cyclic
     do j=1,n
      if (aij(i,j) /= 0) then
      CD(KL+KU+1+i-j,j)=aij(i,j)
      endif
     end do
    end do
    endif

    IF (KU == 1) then                                  ! store tridiagonal matrices in vector format
    a=AB(1,:)
    b=AB(2,:)
    c=AB(3,:)
    do i=1,n-1
     a_short(i)=a(i+1)                                 ! truncated "a" for dgtsv, don't have to truncate "c"
    end do

    call CPU_TIME(time_start)
    call DCTSV( n, 2, a, b, c, d, n, INFO )            ! overwrites d into solution
    call CPU_TIME(time_end)
    write(*,*) 'Using dctsv.f90, O(n)'
    write(*,*) 'time: ',time_end-time_start
    write(*,*) 'solution error',dot_product((s(:,1)-d(:,1)),(s(:,1)-d(:,1)))
    write(*,*) 'solution error',dot_product((s(:,2)-d(:,2)),(s(:,2)-d(:,2)))
    write(*,*) ' '

!    LAPACK routine for non-cyclic system
     if (KL > 0) then   ! or KL == 1
      d=matmul(aij,s)
      call CPU_TIME(time_start)
      call DGTSV( n, 2, a_short, b, c, d, n, INFO )     ! overwrites b and d into solution
      call CPU_TIME(time_end)
      write(*,*) 'Using dgtsv, O(n)'
      write(*,*) 'time: ',time_end-time_start
      write(*,*) 'solution error',dot_product((s(:,1)-d(:,1)),(s(:,1)-d(:,1)))
      write(*,*) 'solution error',dot_product((s(:,2)-d(:,2)),(s(:,2)-d(:,2)))
      write(*,*) ' '

!     simple tridiagonal algorithm: should be fastest with -O3 compilation
      a=AB(1,:)
      b=AB(2,:)
      c=AB(3,:)
      d=matmul(aij,s)
      call CPU_TIME(time_start)
      call thomas(a,b,c,d,z,n,2)                        ! overwrites b and d, output is z
      call CPU_TIME(time_end)
      write(*,*) 'Using thomas, O(n)'
      write(*,*) 'time: ',time_end-time_start
      write(*,*) 'solution error',dot_product((s(:,1)-z(:,1)),(s(:,1)-z(:,1)))
      write(*,*) 'solution error',dot_product((s(:,2)-z(:,2)),(s(:,2)-z(:,2)))
      write(*,*) ' '

     endif

    ENDIF

    d=matmul(aij,s)
    call CPU_TIME(time_start)
    call DCBSV_F( N, KU, 2, AB, 2*KU+1, d, N, INFO )      ! overwrites d
    call CPU_TIME(time_end)
    write(*,*) 'Using dcbsv.f90, O(n)'
    write(*,*) 'time: ',time_end-time_start
    write(*,*) 'solution error',dot_product((s(:,1)-d(:,1)),(s(:,1)-d(:,1)))
    write(*,*) 'solution error',dot_product((s(:,2)-d(:,2)),(s(:,2)-d(:,2)))
    write(*,*) ' '

        d=matmul(aij,s)
    call CPU_TIME(time_start)
    call DCBSV_R( N, KU, 2, AB, 2*KU+1, d, N, INFO )      ! overwrites d
    call CPU_TIME(time_end)
    write(*,*) 'Using dcbsv.f90, O(n)'
    write(*,*) 'time: ',time_end-time_start
    write(*,*) 'solution error',dot_product((s(:,1)-d(:,1)),(s(:,1)-d(:,1)))
    write(*,*) 'solution error',dot_product((s(:,2)-d(:,2)),(s(:,2)-d(:,2)))
    write(*,*) ' '

!    LAPACK routine for non-cyclic system
     if (KL > 0) then
      d=matmul(aij,s)
      call CPU_TIME(time_start)
      call dgbsv( N, KL, KU, 2, CD, 2*KL+KU+1, IPIV, d, N, INFO ) ! overwrites d into solution
      call CPU_TIME(time_end)
      write(*,*) 'Using dgbsv, O(n)'
      write(*,*) 'time: ',time_end-time_start
      write(*,*) 'solution error',dot_product((s(:,1)-d(:,1)),(s(:,1)-d(:,1)))
      write(*,*) 'solution error',dot_product((s(:,2)-d(:,2)),(s(:,2)-d(:,2)))
     endif

   END PROGRAM testme


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

!> @author
!> Lawrence Campbell, Cynthia Nam
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Module to calculate the error function

MODULE error_fn

USE typesAndConstants
USE nrutil

IMPLICIT NONE
CONTAINS

!********************************************************
!*+*Return the error function*+*!

FUNCTION erf(x)

  IMPLICIT NONE

  REAL(KIND=WP),INTENT(IN) :: x
  REAL(KIND=WP) :: erf

  erf=gammp(0.5_WP,x**2)

  IF (x<0.0) erf=-erf

END FUNCTION erf
!********************************************************
!*+*Return the complementary error function*+*!

FUNCTION erfc(x)

  IMPLICIT NONE

  REAL(KIND=WP),INTENT(IN)   :: x
  REAL(KIND=WP)		   :: erfc

  erfc=merge(1.0_WP+gammp(0.5_WP,x**2),gammq(0.5_WP,x**2),x<0.0)

END FUNCTION erfc
!********************************************************

FUNCTION erfi(Y)
!-----------------------
! Inverse error function
!-----------------------
  REAL(KIND=WP),INTENT(IN)   :: Y
  REAL(KIND=WP)		   :: erfi

!---
! constants and parameters
!---
  INTEGER(KIND=IP)    :: maxit, iter
  REAL(KIND=WP)       :: eps
  REAL(KIND=WP)       :: const
  REAL(KIND=WP)       :: Y0, Y1, DY0, DY1
  REAL(KIND=WP)       :: Derfi

  maxit = 20_IP
  eps   = 0.0000001_WP
  const = sqrt(pi)/2.0_WP

!---
! very small value
!---

  If(abs(Y).LE.eps) then
     erfi = Const*Y
     iter = 1_IP
     Return
  End If

!---
! Newton iterations
!---

  If(abs(Y).LT.1.0_WP) then

     erfi  = const*abs(Y)
     Y0    = ERF(0.9_WP*ERFI)
     Derfi = 0.1_WP*erfi

     Do iter=1,maxit
        Y1  = 1.0_WP - erfc(erfi)
        DY1 = abs(Y) - Y1
        If (abs(DY1).LT.eps) Go to 99
        DY0   = Y1 - Y0
        Derfi = Derfi*DY1/DY0
        Y0    = Y1
        erfi  = erfi + Derfi
        If(abs(Derfi/erfi).LT.eps) Go to 99
     End Do

  End If

!-----------
! unfeasible
!-----------

  Iter = 0_IP     ! Did not converge
  erfi = 0.0_WP

  Return

  99  Continue

  If(Y.LT.0.0_WP) erfi = -erfi

!-----
! Done
!-----
  Return
End Function erfi
!********************************************************

FUNCTION gammp(a,x)

  IMPLICIT NONE

  REAL(KIND=WP),INTENT(IN)			:: a,x
  REAL(KIND=WP)					:: gammp

  CALL assert(x>=0.0, a>0.0,'gammp args')

  IF (x<a+1.0_WP) THEN
     gammp=gser_s(a,x)
  ELSE
     gammp=1.0_WP-gcf(a,x)
  ENDIF

END FUNCTION gammp
!********************************************************

FUNCTION gammq(a,x)

  IMPLICIT NONE

  REAL(KIND=WP),INTENT(IN) :: a,x
  REAL(KIND=WP)	:: gammq

  CALL assert(x>=0.0, a>0.0,'gammq args')

  IF (x<a+1.0_WP) THEN
     gammq=1.0_WP-gser_s(a,x)
  ELSE
     gammq=gcf(a,x)
  ENDIF

END FUNCTION gammq
!********************************************************

FUNCTION gser_s(A,X,GLN)

  REAL(KIND=WP),INTENT(IN) :: A,X
  REAL(KIND=WP),OPTIONAL,INTENT(OUT) :: GLN

  INTEGER(KIND=IP) :: ITMAX,N
  REAL(KIND=WP)	:: gser_s,EPS,AP,SUMM,DEL

  ITMAX=100_IP
  EPS=epsilon(X)

  IF (X == 0.0) THEN
     gser_s=0.0_WP
     RETURN
  ENDIF

  AP=A
  SUMM=1.0_WP/A
  DEL=SUMM

  DO N=1,ITMAX
     AP=AP+1.0_WP
     DEL=DEL*X/AP
     SUMM=SUMM+DEL

     IF (ABS(DEL) < ABS(SUMM)*EPS) EXIT
  ENDDO

  IF (N> ITMAX) CALL nrerror('A too large,ITMAX too small in GSER')

  IF (present(GLN)) THEN

     GLN=gammln(A)
     gser_s=SUMM*EXP(-X+A*LOG(X)-GLN)
  ELSE
     gser_s=SUMM*EXP(-X+A*LOG(X)-gammln(A))
  ENDIF

END FUNCTION gser_s
!********************************************************

FUNCTION gcf(a,x,gln)

  REAL(KIND=WP),INTENT(IN)			:: a,x
  REAL(KIND=WP),OPTIONAL,INTENT(OUT)		:: gln
  REAL(KIND=WP)					:: gcf,EPS,FPMIN
  REAL(KIND=WP)					:: an,b,c,d,del,h
  INTEGER(KIND=IP)				:: ITMAX,i

  ITMAX=100_IP
  EPS=epsilon(x)
  FPMIN=tiny(x)/EPS

  IF (x==0.0_WP) THEN
     gcf=1.0_WP
     RETURN
  ENDIF

  b=x+1.0_WP-a
  c=1.0_WP/FPMIN
  d=1.0_WP/b
  h=d

  DO i=1,ITMAX
     an=-i*(i-a)
     b=b+2.0_WP
     d=an*d+b
     IF (ABS(d)<FPMIN) d=FPMIN
     c=b+an/c
     IF (ABS(c)<FPMIN) c=FPMIN
     d=1.0_WP/d
     del=d*c
     h=h*del
     IF (ABS(del-1.0_WP) <=EPS) EXIT
  ENDDO

  IF (i> ITMAX) CALL nrerror ('a too large, ITMAX too small in gcf')
  IF (present(gln)) THEN
     gln=gammln(a)
     gcf=EXP(-x+a*log(x)-gln)*h
  ELSE
     gcf=EXP(-x+a*log(x)-gammln(a))*h
  ENDIF

END FUNCTION gcf
!********************************************************

FUNCTION gammln(xx)

  USE paratype

  IMPLICIT NONE

  REAL(KIND=WP),INTENT(IN) :: xx
  REAL(KIND=WP) :: gammln,tmp,ser,x,y,stp
  REAL(KIND=WP),DIMENSION(6) :: coef

  INTEGER(KIND=IP) :: i

  stp=2.5066282746310005_WP
  coef=(/76.18009172947146_WP,-86.50532032941677_WP,24.01409824083091_WP, &
       -1.231739572450155_WP,0.1208650973866179E-2_WP,-0.5395239384953E-5_WP /)

  IF (xx==0) RETURN

  CALL assert(xx > 0.0,'gammln_s arg')

  x=xx
  tmp=x+5.5_WP
  tmp=(x+0.5_WP)*log(tmp)-tmp
  ser=1.000000000190015_WP
  y=x
  DO i=1,size(coef)
     y=y+1.0_WP
     ser=ser+coef(i)/y
  ENDDO
  gammln=tmp+log(stp*ser/x)

END FUNCTION gammln

END MODULE error_fn


      subroutine ire_daatheta(n_DDLthetatheta,n_DDLxx,n_JSthth,n_JSxx,n_
     &Pthetatheta,n_RRthetatheta,n_RRxx,n_Uthetatheta,n_alpha,n_em4phi,n
     &_metthetatheta,n_metxx,nm1_Athth,np1_Athth,Nx,ht,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 n_DDLthetatheta(Nx)
      real*8 n_DDLxx(Nx)
      real*8 n_JSthth(Nx)
      real*8 n_JSxx(Nx)
      real*8 n_Pthetatheta(Nx)
      real*8 n_RRthetatheta(Nx)
      real*8 n_RRxx(Nx)
      real*8 n_Uthetatheta(Nx)
      real*8 n_alpha(Nx)
      real*8 n_em4phi(Nx)
      real*8 n_metthetatheta(Nx)
      real*8 n_metxx(Nx)
      real*8 nm1_Athth(Nx)
      real*8 np1_Athth(Nx)
      real*8 res
      real*8 qb
      res = 0.0D0
      do i=1, Nx, 1
      qb = -0.5000000000000000D0 * (nm1_Athth(i) - 0.1D1 * np1_Athth(i))
     # / ht + 0.3333333333333333D0 / n_metxx(i) * n_alpha(i) * n_metthet
     #atheta(i) * n_RRxx(i) * n_em4phi(i) - 0.3333333333333333D0 / n_met
     #xx(i) * n_em4phi(i) * n_alpha(i) * n_JSxx(i) * n_metthetatheta(i)
     #- 0.3333333333333333D0 * n_alpha(i) * n_RRthetatheta(i) * n_em4phi
     #(i) + 0.3333333333333333D0 * n_alpha(i) * n_JSthth(i) * n_em4phi(i
     #) - 0.1D1 * n_alpha(i) * n_Uthetatheta(i) - 0.3333333333333333D0 /
     # n_metxx(i) * n_DDLxx(i) * n_metthetatheta(i) * n_em4phi(i) + 0.33
     #33333333333333D0 * n_DDLthetatheta(i) * n_em4phi(i) - 0.1D1 * n_Pt
     #hetatheta(i)
      res = res + qb**2
      end do
      res = sqrt(res/(1*Nx))
      END


program main

!*****************************************************************************80
!
!  Purpose:
!
!    MAIN is the main program for FFT_OPENMP.
!
!  Discussion:
!
!    The complex data in an N vector is stored as pairs of values in a
!    real vector of length 2*N.
!
!  Modified:
!
!    20 March 2009
!
!  Author:
!
!    Original C version by Wesley Petersen.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Wesley Petersen, Peter Arbenz,
!    Introduction to Parallel Computing - A practical guide with examples in C,
!    Oxford University Press,
!    ISBN: 0-19-851576-6,
!    LC: QA76.58.P47.
!
  use omp_lib

  implicit none

  real ( kind = 8 ) error
  logical first
  real ( kind = 8 ) flops
  real ( kind = 8 ) fnm1
  real ( kind = 8 ) ggl
  integer ( kind = 4 ) i
  integer ( kind = 4 ) icase
  integer ( kind = 4 ) it
  integer ( kind = 4 ) ln2
  integer ( kind = 4 ), parameter :: ln2_max = 24
  real ( kind = 8 ) mflops
  integer ( kind = 4 ) n
  integer ( kind = 4 ) nits
  integer ( kind = 4 ) proc_num
  real ( kind = 8 ) seed
  real ( kind = 8 ) sgn
  integer ( kind = 4 ) thread_num
  real ( kind = 8 ), allocatable, dimension ( : ) :: w
  real ( kind = 8 ) wtime
  real ( kind = 8 ), allocatable, dimension ( : ) :: x
  real ( kind = 8 ), allocatable, dimension ( : ) :: y
  real ( kind = 8 ), allocatable, dimension ( : ) :: z
  real ( kind = 8 ) z0
  real ( kind = 8 ) z1

  nits = 10000

  call timestamp ( )
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'FFT_OPENMP'
  write ( *, '(a)' ) '  FORTRAN90 version'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) &
    '  Demonstrate an implementation of the Fast Fourier Transform'
  write ( *, '(a)' ) &
    '  of a complex data vector, using OpenMP for parallel execution.'
!
!  How many processors are available?
!
  proc_num = omp_get_num_procs ( )
  thread_num = omp_get_max_threads ( )

  write ( *, '(a)' ) ' '
  write ( *, '(a,i8)' ) '  The number of processors available = ', proc_num
  write ( *, '(a,i8)' ) '  The number of threads available    = ', thread_num
!
!  Prepare for tests.
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Accuracy check:'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '    FFT ( FFT ( X(1:N) ) ) == N * X(1:N)'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '             N      NITS    Error         Time' // &
    '          Time/Call     MFLOPS'
  write ( *, '(a)' ) ' '

  seed  = 331.0D+00
  n = 1
!
!  LN2 is the log base 2 of N.  Each increase of LN2 doubles N.
!
  do ln2 = 1, ln2_max

    n = 2 * n
!
!  Allocate storage for the complex arrays W, X, Y, Z.
!
!  We handle the complex arithmetic,
!  and store a complex number as a pair of floats, a complex vector as a doubly
!  dimensioned array whose second dimension is 2.
!
    allocate ( w(1:n) )
    allocate ( x(1:2*n) )
    allocate ( y(1:2*n) )
    allocate ( z(1:2*n) )

    first = .true.

    do icase = 0, 1

      if ( first ) then

        do i = 1, 2 * n - 1, 2

          z0 = ggl ( seed )
          z1 = ggl ( seed )
          x(i) = z0
          z(i) = z0
          x(i+1) = z1
          z(i+1) = z1
        end do

      else
!$omp parallel &
!$omp   shared ( x, z, n ) &
!$omp   private ( i, z0, z1 )
!$omp do
        do i = 1, 2 * n - 1, 2
          z0 = 0.0D+00
          z1 = 0.0D+00
          x(i) = z0
          z(i) = z0
          x(i+1) = z1
          z(i+1) = z1
        end do
!$omp end do
!$omp end parallel

      end if
!
!  Initialize the sine and cosine tables.
!
      call cffti ( n, w )
!
!  Transform forward, back
!
      if ( first ) then

        sgn = + 1.0D+00
        call cfft2 ( n, x, y, w, sgn )
        sgn = - 1.0D+00
        call cfft2 ( n, y, x, w, sgn )
!
!  Results should be same as initial multiplied by n
!
        fnm1 = 1.0D+00 / real ( n, kind = 8 )

        error = 0.0D+00
        do i = 1, 2 * n - 1, 2
          error = error &
          + ( z(i)   - fnm1 * x(i) )**2 &
          + ( z(i+1) - fnm1 * x(i+1) )**2
        end do
        error = sqrt ( fnm1 * error )

        first = .false.

      else

        wtime = omp_get_wtime ( )

        do it = 1, nits

          sgn = + 1.0D+00
          call cfft2 ( n, x, y, w, sgn )
          sgn = - 1.0D+00
          call cfft2 ( n, y, x, w, sgn )

        end do

        wtime = omp_get_wtime ( ) - wtime

        flops = 2.0D+00 * real ( nits, kind = 8 ) &
          * ( 5.0D+00 * real ( n, kind = 8 ) * real ( ln2, kind = 8 ) )

        mflops = flops / 1.0D+06 / wtime

        write ( *, '(2x,i12,2x,i8,2x,g14.6,2x,g12.4,2x,g12.4,2x,g12.4)' ) &
          n, nits, error, wtime, wtime / real ( 2 * nits, kind = 8 ), mflops

      end if

    end do

    if ( mod ( ln2, 4 ) == 0 ) then
      nits = nits / 10
    end if

    if ( nits < 1 ) then
      nits = 1
    end if

    deallocate ( w )
    deallocate ( x )
    deallocate ( y )
    deallocate ( z )

  end do
!
!  Terminate.
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'FFT_OPENMP:'
  write ( *, '(a)' ) '  Normal end of execution.'
  write ( *, '(a)' ) ' '
  call timestamp ( )

  stop
end
subroutine cfft2 ( n, x, y, w, sgn )

!*****************************************************************************80
!
!! CFFT2 performs a complex Fast Fourier Transform.
!
!  Modified:
!
!    27 April 2008
!
!  Author:
!
!    Original C version by Wesley Petersen.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Wesley Petersen, Peter Arbenz,
!    Introduction to Parallel Computing - A practical guide with examples in C,
!    Oxford University Press,
!    ISBN: 0-19-851576-6,
!    LC: QA76.58.P47.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the size of the array to be transformed.
!
!    Input/output, real ( kind = 8 ) X(2*N), the data to be transformed.
!    On output, the contents of X have been overwritten by work information.
!
!    Output, real ( kind = 8 ) Y(2*N), the forward or backward FFT of X.
!
!    Input, real ( kind = 8 ) W(N), a table of sines and cosines.
!
!    Input, real ( kind = 8 ) SGN:
!    +1 for a "forward" FFT,
!    -1 for a "backward" FFT.
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) j
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mj
  real ( kind = 8 ) sgn
  logical tgle
  real ( kind = 8 ) w(n)
  real ( kind = 8 ) x(2*n)
  real ( kind = 8 ) y(2*n)

   m = int ( ( log ( real ( n, kind = 8 ) ) / log ( 1.99D+00 ) ) )
   mj = 1
!
!  Toggling switch for work array.
!
  tgle = .true.
  call step ( n, mj, x(1), x((n/2)*2+1), y(1), y(mj*2+1), w, sgn )

  if ( n == 2 ) then
    return
  end if

  do j = 1, m - 2

    mj = mj * 2

    if ( tgle ) then
      call step ( n, mj, y(1), y((n/2)*2+1), x(1), x(mj*2+1), w, sgn )
      tgle = .false.
    else
      call step ( n, mj, x(1), x((n/2)*2+1), y(1), y(mj*2+1), w, sgn )
      tgle = .true.
    end if

  end do
!
!  Last pass through data: move Y to X if needed.
!
  if ( tgle ) then
    x(1:2*n) = y(1:2*n)
  end if

  mj = n / 2
  call step ( n, mj, x(1), x((n/2)*2+1), y(1), y(mj*2+1), w, sgn )

  return
end
subroutine cffti ( n, w )

!*****************************************************************************80
!
!! CFFTI sets up sine and cosine tables needed for the FFT calculation.
!
!  Modified:
!
!    28 April 2008
!
!  Author:
!
!    Original C version by Wesley Petersen.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Wesley Petersen, Peter Arbenz,
!    Introduction to Parallel Computing - A practical guide with examples in C,
!    Oxford University Press,
!    ISBN: 0-19-851576-6,
!    LC: QA76.58.P47.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the size of the array to be transformed.
!
!    Output, real ( kind = 8 ) W(N), a table of sines and cosines.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) arg
  real ( kind = 8 ) aw
  integer ( kind = 4 ) i
  integer ( kind = 4 ) n2
  real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00
  real ( kind = 8 ) w(n)

  n2 = n / 2
  aw = 2.0D+00 * pi / real ( n, kind = 8 )

!$omp parallel &
!$omp   shared ( aw, n, w ) &
!$omp   private ( arg, i )
!$omp do
  do i = 1, n2
    arg = aw * real ( i - 1, kind = 8 )
    w(2*i-1) = cos ( arg )
    w(2*i)   = sin ( arg )
  end do
!$omp end do
!$omp end parallel

  return
end
function ggl ( seed )

!*****************************************************************************80
!
!! GGL generates uniformly distributed pseudorandom numbers.
!
!  Modified:
!
!    16 July 2008
!
!  Author:
!
!    Original C version by Wesley Petersen, M Troyer, I Vattulainen.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Wesley Petersen, Peter Arbenz,
!    Introduction to Parallel Computing - A practical guide with examples in C,
!    Oxford University Press,
!    ISBN: 0-19-851576-6,
!    LC: QA76.58.P47.
!
!  Parameters:
!
!    Input/output, real ( kind = 8 ) SEED, used as a seed for the sequence.
!
!    Output, real ( kind = 8 ) GGL, the next pseudorandom value.
!
  implicit none

  real ( kind = 8 ), parameter :: d2 = 0.2147483647D+10
  real ( kind = 8 ) ggl
  real ( kind = 8 ) seed
  real ( kind = 8 ) t

  t = mod ( 16807.0D+00 * real ( seed, kind = 8 ), d2 )
  seed = t
  ggl = real ( ( t - 1.0D+00 ) / ( d2 - 1.0D+00 ), kind = 8 )

  return
end
subroutine step ( n, mj, a, b, c, d, w, sgn )

!*****************************************************************************80
!
!! STEP carries out one step of the workspace version of CFFT2.
!
!  Modified:
!
!    27 April 2008
!
!  Author:
!
!    Original C version by Wesley Petersen.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Wesley Petersen, Peter Arbenz,
!    Introduction to Parallel Computing - A practical guide with examples in C,
!    Oxford University Press,
!    ISBN: 0-19-851576-6,
!    LC: QA76.58.P47.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the size of the arrays.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n)
  real ( kind = 8 ) ambr
  real ( kind = 8 ) ambu
  real ( kind = 8 ) b(n)
  real ( kind = 8 ) c(n)
  real ( kind = 8 ) d(n)
  integer ( kind = 4 ) j
  integer ( kind = 4 ) ja
  integer ( kind = 4 ) jb
  integer ( kind = 4 ) jc
  integer ( kind = 4 ) jd
  integer ( kind = 4 ) jw
  integer ( kind = 4 ) k
  integer ( kind = 4 ) lj
  integer ( kind = 4 ) mj
  integer ( kind = 4 ) mj2
  real ( kind = 8 ) sgn
  real ( kind = 8 ) w(n)
  real ( kind = 8 ) wjw(2)

  mj2 = 2 * mj
  lj  = n / mj2

!$omp parallel &
!$omp   shared ( a, b, c, d, lj, mj, mj2, sgn, w ) &
!$omp   private ( ambr, ambu, j, ja, jb, jc, jd, jw, k, wjw )
!$omp do
  do j = 0, lj - 1

    jw = j * mj
    ja  = jw
    jb  = ja
    jc  = j * mj2
    jd  = jc

    wjw(1) = w(jw*2+1)
    wjw(2) = w(jw*2+2)

    if ( sgn < 0.0D+00 ) then
      wjw(2) = - wjw(2)
    end if

    do k = 0, mj - 1

      c((jc+k)*2+1) = a((ja+k)*2+1) + b((jb+k)*2+1)
      c((jc+k)*2+2) = a((ja+k)*2+2) + b((jb+k)*2+2)

      ambr = a((ja+k)*2+1) - b((jb+k)*2+1)
      ambu = a((ja+k)*2+2) - b((jb+k)*2+2)

      d((jd+k)*2+1) = wjw(1) * ambr - wjw(2) * ambu
      d((jd+k)*2+2) = wjw(2) * ambr + wjw(1) * ambu

    end do
  end do
!$omp end do
!$omp end parallel

  return
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2005
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end


module constants
!==================================================================
!    This module contains all the non-modifiable parameters and
!    all quantities which never change throughout a simulation.
!==================================================================

 !Import parameters:
use parameters

integer,parameter:: nxm1=nx-1, nym1=ny-1, nzm1=nz-1

 !Generic double precision numerical constants:
double precision,parameter:: zero=0.d0, one=1.d0
double precision,parameter:: two=2.d0, three=3.d0
double precision,parameter:: four=4.d0, six=6.d0

double precision,parameter:: f12=one/two, f13=one/three, f14=one/four
double precision,parameter:: f16=one/six, f56=5.d0/six, f112=one/12.d0

double precision,parameter:: small=1.d-12, oms=one-small

!---------------------------------------------------------------------
 !Domain half widths and edge values:
double precision,parameter:: hlx=ellx/two, hlxi=one/hlx, xmin=-hlx
double precision,parameter:: hly=elly/two, hlyi=one/hly, ymin=-hly
double precision,parameter:: zmin=-ellz/two, zmax=zmin+ellz

 !Grid lengths and their inverses:
double precision,parameter:: dx=ellx/dble(nx), dxi=dble(nx)/(ellx*oms)
double precision,parameter:: dy=elly/dble(ny), dyi=dble(ny)/(elly*oms)
double precision,parameter:: dz=ellz/dble(nz), dzi=dble(nz)/(ellz*oms)

 !Grid cell volume:
double precision,parameter:: vcell=dx*dy*dz

!---------------------------------------------------------------------
 !Number of grid cells:
integer,parameter:: ncell=nx*ny*(nz+1)

end module


module m_util
  implicit none
  integer, parameter ::  dp = selected_real_kind(14,100)

  integer, parameter :: max_name_len=100

contains
  ! Solve a system of linear equations A*x = b for a matrix A and
  ! vectors x and b.  Implemented as a wrapper around LAPACK dgesv.
  function solve(M,b) result(x)
    real(dp), intent(in) :: M(:,:)
    real(dp) :: b(:)
    real(dp), dimension(size(M,1),size(M,2)) :: A
    real(dp), dimension(size(b,1)) :: x
    integer ipiv(size(b,1)), N, info

    ! check M is square and b conforms
    if (size(M,1) /= size(M,2)) then
       write (0,*) "solve: Array M passed to solve should be square.  Got ", &
            size(M,1), "x", size(M,2)
       error stop
    end if

    N = size(M, 1)

    ! A and x are overwritten on output of dgesv, so copy
    A = M
    x = b
    call dgesv(N, 1, A, N, ipiv, x, N, info)

    ! check for success
    if (info /= 0) then
       write (0,*) "solve: dgesv returned an error code (", info, ")"
       error stop
    end if

  end function solve

  ! in place inverse
  subroutine ninv(A)
    real(dp), dimension(:,:), intent(inout) :: A
    integer, dimension(:), allocatable :: piv
    real(dp), dimension(1) :: lwork_real
    real(dp), dimension(:), allocatable :: work
    integer :: lwork, N, info

    N = size(A,1)

    allocate(integer :: piv(N))

    call dgetrf(N, N, A, N, piv, info)

    call dgetri(N, A, N, piv, lwork_real, -1, info)
    lwork = nint(lwork_real(1))
    allocate(real(dp) :: work(lwork))
    call dgetri(N, A, N, piv, work, lwork, info)

  end subroutine ninv

  function logdet(A)
    real(dp) :: logdet
    real(dp), dimension(:,:), intent(in) :: A
    real(dp), dimension(:,:), allocatable :: tmp
    integer, dimension(:), allocatable :: ipiv
    integer :: N, info, i

    N = size(A,1)

    allocate(real(dp) :: tmp(N, N))
    allocate(integer :: ipiv(N))

    tmp = A
    call dgetrf(N, N, tmp, N, ipiv, info)

    logdet = 0.0_dp
    do i=1,N
       logdet = logdet + log(abs(tmp(i,i)))
    end do

  end function logdet

end module m_util


! =============================================================================
!                       Test FFT module
!
!       This unit test checks the FFT module with reference solutions.
! =============================================================================
program test_fft_2
    use unit_test
    use constants, only : pi, twopi, zero, one
    use stafft, only : initfft, forfft
    implicit none

    integer, parameter          :: n = 16
    double precision            :: trig(2 * n)
    integer                     :: factors(5)
    double precision            :: fun(n)
    double precision            :: ref(2 * n)            ! reference solution in Fourier space
    double precision            :: a ! 0 < a < 1
    double precision            :: da = 0.1d0
    double precision            :: err = zero
    double precision, parameter :: atol = dble(1.0e-14)

    ! set up FFT
    call initfft(n, factors, trig)

    ! test function 1
    a = da
    do while (a <= 0.9d0)

        ! initialize function
        fun = func_1(a, n)

        ! compute reference solution
        call dft(n, fun, ref)

        ! forward FFT (Hermitian form) (overwrites fun)
        call forfft(1, n, fun, trig, factors)

        err = max(err, get_max_absolute_error(n, fun, ref))

        a = a + da
    enddo

    ! test function 2
    a = da
    do while (a <= 0.9d0)

        ! initialize function
        fun = func_2(a, n)

        ! compute reference solution
        call dft(n, fun, ref)

        ! forward FFT (Hermitian form) (overwrites fun)
        call forfft(1, n, fun, trig, factors)

        err = max(err, get_max_absolute_error(n, fun, ref))

        a = a + da
    enddo

    ! final check

    call print_result_dp('Test FFT transform', err, atol)

    contains

        ! initialize function in real space from -pi to pi
        ! f(x) = 1 / (1 - a * cos(x + 1))
        ! 0 < a < 1
        function func_1(a, n) result(f1)
            double precision, intent(in) :: a
            integer,          intent(in) :: n
            double precision             :: f1(n)
            double precision             :: dx, xx, phase
            integer                      :: j

            phase = one ! phase offset in radians

            dx = twopi / dble(n)
            do j = 0, n-1
                xx = -pi + dx * dble(j)
                f1(j+1) = one / (one - a * dcos(xx + phase))
            enddo
        end function func_1

        ! initialize function in real space from -pi to pi
        ! f(x) = 1 / (1 - a * sin(x + 1))
        ! 0 < a < 1
        function func_2(a, n) result(f2)
            double precision, intent(in) :: a
            integer,          intent(in) :: n
            double precision             :: f2(n)
            double precision             :: dx, xx, phase
            integer                      :: j

            phase = one ! phase offset in radians

            dx = twopi / dble(n)
            do j = 0, n-1
                xx = -pi + dx * dble(j)
                f2(j+1) = one / (one - a * dsin(xx + phase))
            enddo
        end function func_2

        ! discrete Fourier transform
        subroutine dft(m, f, fhat)
            integer,          intent(in)  :: m
            double precision, intent(in)  :: f(m)       ! function in real space
            double precision, intent(out) :: fhat(2*m)  ! function in Fourier space
            double precision              :: fac, arg
            integer                       :: k, l
            double precision              :: sfac       ! normalization factor

            fhat = 0.d0
            fac = twopi / dble(m)

            do k = 0, m - 1
                do l = 0, m - 1
                    arg = fac * dble(k * l)
                    fhat(k+1)   = fhat(k+1)   + f(l+1) * dcos(arg)
                    fhat(k+1+m) = fhat(k+1+m) - f(l+1) * dsin(arg)
                enddo
            enddo

            sfac = one / dsqrt(dble(m))

            fhat = fhat * sfac

        end subroutine dft

        function get_max_absolute_error(n, fun, ref) result(err)
            integer,          intent(in) :: n
            double precision, intent(in) :: fun(n), ref(2 * n)
            double precision             :: err, err_cos, err_sin
            integer                      :: i, j, k, nw

            nw = n / 2

            ! Cosine coefficients
            err_cos = maxval(abs(ref(1:nw+1) - fun(1:nw+1)))

            ! Sine coefficients
            i = 1
            j = nw - 1
            k = n + 1

            err_sin = maxval(abs(ref(k+i:k+j) - fun(k-i:k-j:-1)))

            err = max(err_cos, err_sin)

        end function get_max_absolute_error

end program test_fft_2


c=======================================================================
c
c     subroutine HLRETM
c
c     This function computes the log h-returns from matrix of values
c
c           r(t+h) = log[price(t+h)/price(t)] for t = 1,...,n-h
c
c-----------------------------------------------------------------------
      SUBROUTINE hlretm ( n, p, X, h, R, info )
c-----------------------------------------------------------------------
c
c     INPUT :
c            n      : number of prices (n > h)                   integer
c            p      : number of assets (p >= 1)                  integer
c            X      : assets price (n*p)                          double
c            h      : horizon (h > 0)                            integer
c
c     OUTPUT :
c            R      : log-returns ( n-h * p)                      double
c            info   : diagnostic argument                        integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, p, h, info
      DOUBLE PRECISION X(n,*), R(*)
c
c     local variables
      INTEGER ipri, jpri, k, nl
      DOUBLE PRECISION price, myzero
      PARAMETER ( myzero = 1.E-15 )
c
c     intrinsic functions
      INTRINSIC log
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
      nl   = n - h
      k    = 1
c
c     test the number of points
      IF (n .le. h) THEN
        info = -2
        RETURN
      ENDIF
c
c     log return(s)
      DO jpri = 1,p
         DO ipri = 1,nl
            price = X(ipri,jpri)
            IF (price .lt. myzero) THEN
               info = -103
               RETURN
            ENDIF
            R(k) = log( X(ipri + h,jpri) / price )
            k = k + 1
         ENDDO
      ENDDO
      RETURN
      END


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_rot2_unitvec2gen
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the generator for a Givens rotation represented by 2
! real numbers: A strictly real cosine and a scrictly real sine.  The first
! column is constructed to be parallel with the real vector [A,B]^T.
!
! The vector [A,B]^T is assumed to be nearly unit, that is
!
!   abs(A^2 + B^2 - 1) = O(eps).
!
! In this case it is possible to compute the norm without a squareroot using a
! single newton iteration.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  A               REAL(8)
!                    the first component of the real vector [A,B]^T
!
!  B               REAL(8)
!                    the second component of the real vector [A,B]^T
!
! OUTPUT VARIABLES:
!
!  C               REAL(8)
!                    on exit contains the generator for the cosine
!                    component of the Givens rotation
!
!  S               REAL(8)
!                    on exit contains the generator for the sine
!                    component of the Givens rotation
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_rot2_unitvec2gen(A,B,C,S)

  implicit none

  ! input variables
  real(8), intent(in) :: A,B
  real(8), intent(inout) :: C,S

  ! compute variables
  real(8) :: X

  ! compute difference from unity and approximate 1/sqrt(x)
  X = 5d-1*(3d0-(A*A + B*B))

  ! construct rotation
  C = A*X
  S = B*X

end subroutine d_rot2_unitvec2gen


      SUBROUTINE fit(x,y,ndata,sig,mwt,a,b,siga,sigb,chi2,q)
      INTEGER mwt,ndata
      REAL a,b,chi2,q,siga,sigb,sig(ndata),x(ndata),y(ndata)
CU    USES gammq
      INTEGER i
      REAL sigdat,ss,st2,sx,sxoss,sy,t,wt,gammq
      sx=0.
      sy=0.
      st2=0.
      b=0.
      if(mwt.ne.0) then
        ss=0.
        do 11 i=1,ndata
          wt=1./(sig(i)**2)
          ss=ss+wt
          sx=sx+x(i)*wt
          sy=sy+y(i)*wt
11      continue
      else
        do 12 i=1,ndata
          sx=sx+x(i)
          sy=sy+y(i)
12      continue
        ss=float(ndata)
      endif
      sxoss=sx/ss
      if(mwt.ne.0) then
        do 13 i=1,ndata
          t=(x(i)-sxoss)/sig(i)
          st2=st2+t*t
          b=b+t*y(i)/sig(i)
13      continue
      else
        do 14 i=1,ndata
          t=x(i)-sxoss
          st2=st2+t*t
          b=b+t*y(i)
14      continue
      endif
      b=b/st2
      a=(sy-sx*b)/ss
      siga=sqrt((1.+sx*sx/(ss*st2))/ss)
      sigb=sqrt(1./st2)
      chi2=0.
      if(mwt.eq.0) then
        do 15 i=1,ndata
          chi2=chi2+(y(i)-a-b*x(i))**2
15      continue
        q=1.
        sigdat=sqrt(chi2/(ndata-2))
        siga=siga*sigdat
        sigb=sigb*sigdat
      else
        do 16 i=1,ndata
          chi2=chi2+((y(i)-a-b*x(i))/sig(i))**2
16      continue
        q=gammq(0.5*(ndata-2),0.5*chi2)
      endif
      return
      END

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


chapter xvii, example 3. bivariate spline interpolation
c  followed by conversion to pp-repr and evaluation
c  from  * a practical guide to splines *  by c. de boor
calls  spli2d(bsplvb,banfac/slv),interv,bspp2d(bsplvb*),ppvalu(interv*)
c     parameter nx=7,kx=3,ny=6,ky=4
c     integer i,iflag,j,jj,lefty,lx,ly,mflag
c     real bcoef(nx,ny),breakx(6),breaky(4),coef(kx,5,ky,3),taux(nx)
c    *	  ,tauy(ny),tx(10),ty(10)
c    *	       ,work1(nx,ny),work2(nx),work3(42)
c    *	       ,work4(kx,kx,ny),work5(ny,kx,5),work6(ky,ky,21)
      integer i,iflag,j,jj,kp1,kx,ky,lefty,lx,ly,mflag,nx,ny
      real bcoef(7,6),breakx(6),breaky(4),coef(3,5,4,3),taux(7)
     *	  ,tauy(6),tx(10),ty(10)
     *	       ,work1(7,6),work2(7),work3(42)
     *	       ,work4(3,3,6),work5(6,3,5),work6(4,4,21)
      real ppvalu,g,x,y
      data nx,kx,ny,ky / 7,3,6,4 /
c     note that , with the above parameters, lx=5, ly = 3
      equivalence (work4,work6)
      g(x,y) = amax1(x-3.5,0.)**2 + amax1(y-3.,0.)**3
c *** set up data points and knots
c     in x, interpolate between knots by parabolic splines, using
c     not-a-knot end condition
      do 10 i=1,nx
   10	 taux(i) = float(i)
      do 11 i=1,kx
	 tx(i) = taux(1)
   11	 tx(nx+i) = taux(nx)
      kp1 = kx+1
      do 12 i=kp1,nx
   12	 tx(i) = (taux(i-kx+1) + taux(i-kx+2))/2.
c     in y, interpolate at knots by cubic splines, using not-a-knot
c     end condition
      do 20 i=1,ny
   20	 tauy(i) = float(i)
      do 21 i=1,ky
	 ty(i) = tauy(1)
   21	 ty(ny+i) = tauy(ny)
      kp1 = ky+1
      do 22 i=kp1,ny
   22	 ty(i) = tauy(i-ky+2)
c  *** generate and print out function values
      print 620,(tauy(i),i=1,ny)
  620 format(11h given data//6f12.1)
      do 32 i=1,nx
	 do 31 j=1,ny
   31	    bcoef(i,j) = g(taux(i),tauy(j))
   32	 print 632,taux(i),(bcoef(i,j),j=1,ny)
  632 format(f5.1,6e12.5)
c
c  *** construct b-coefficients of interpolant
c
      call spli2d(taux,bcoef,tx,nx,kx,ny,work2,work3,work1,iflag)
      call spli2d(tauy,work1,ty,ny,ky,nx,work2,work3,bcoef,iflag)
c
c  *** convert to pp-representation
c
      call bspp2d(tx,bcoef,nx,kx,ny,work4,breakx,work5,lx)
      call bspp2d(ty,work5,ny,ky,lx*kx,work6,breaky,coef,ly)
c
c  *** evaluate interpolation error at mesh points and print out
      print 640,(tauy(j),j=1,ny)
  640 format(//20h interpolation error//6f12.1)
      do 45 j=1,ny
	 call interv(breaky,ly,tauy(j),lefty,mflag)
	 do 45 i=1,nx
	    do 41 jj=1,ky
   41	     work2(jj)=ppvalu(breakx,coef(1,1,jj,lefty),lx,kx,taux(i),0)
   45	    work1(i,j) = g(taux(i),tauy(j)) -
     *	    ppvalu(breaky(lefty),work2,1,ky,tauy(j),0)
      do 46 i=1,nx
   46	 print 632,taux(i),(work1(i,j),j=1,ny)
					stop
      end


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ellu_pt_near_far( knf, n, c, g, p, xnf )

!  Determine the point xnf in the specified ellipsoid E that is
!  closest (for knf=1) or furthest (for knf=2) from the specified point p.
!  The ellipsoid E is given by:
!  { x | norm(G^T * (x-c) ) <=1 ), where G is an n x n lower triangular
!  matrix.  The array g contains the matrix G (unpacked format).

!  S.B. Pope  6/12/04, 12/1/2006

implicit none

integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: knf, n
real(k_dp), intent(in)  :: c(n), g(n,n), p(n)
real(k_dp), intent(out) :: xnf(n)

integer    :: itmax = 100  !  max. iterations in dgqt
real(k_dp) :: atol = 1.d-12, rtol = 1.d-4  !  tolerances for dgqt

integer    :: info, i, j
real(k_dp) :: gi(n,n), delta, par, f, sig_min, sig_max, r, dist
real(k_dp) :: a(n,n), b(n), ynf(n), z(n), wa1(n), wa2(n), sign

!  Method:  E = { y | y^T * y <= 1 } where y = G^T * (x-c),  x = c + G^{-T} * y
!  Now  (x-p)^T * (x-p) = ( [c-p]^T + y^T * G^{-1} ) * ( G^{-T} * y + [c-p] ).
!  Thus in y-space, the nearest point ynf minimizes
!     fn(y) =  1/2 * y^T * G^{-1} * G^{-T} * y + [c-p]^T * G^{-T} * y,
!           =  1/2 y^T * An * y + bn^T * y,  where
!        An = G^{-1} * G^{-T},  bn = G^{-1} * [c-p]
!  Similarly the furthest point ynf minimizes
!     ff(y) =  -1/2 * y^T * G^{-1} * G^{-T} * y - [c-p]^T * G^{-T} * y,
!           =   1/2 y^T * Af * y + bf^T * y,  where
!        Af =  -G^{-1} * G^{-T},  bf = -G^{-1} * [c-p]

!  xnf = G^{-T} * ynf + c

if( knf == 1 ) then
   sign = 1.d0   ! for nearest point
elseif( knf == 2 ) then
   sign = -1.d0  ! for furthest point
else
   write(0,*)'ell_pt_near_far: bad value of knf = ', knf
   stop
endif

!-----------  special treatment for E being a spheroid
!  examine diagonal
sig_min =  huge(1.d0)
sig_max = -huge(1.d0)

do j = 1, n
   sig_min = min( abs(g(j,j)), sig_min )
   sig_max = max( abs(g(j,j)), sig_max )
end do

if( 1.d0 - sig_min/sig_max < rtol ) then
! diagonal is constant (within rtol); check off-diagonals
   sig_max = -huge(1.d0)
   do i = 2, n
      do j = 1, i-1
         sig_max = max( abs(g(i,j)), sig_max )
      end do
   end do
   if( n==1 ) sig_max = 0.d0  !  no off-diagonals for n=1

   if( sig_max/sig_min < rtol ) then
!  E is a spheroid of radius 1/sig_min
      r    = 1.d0 / sig_min
      xnf  = c - p
      dist = sqrt( sum(xnf*xnf) )

      if( knf == 1 ) then  !  nearest point
         if( dist <= r ) then
            xnf = p
         else
            xnf = c - r * xnf / dist
         endif

      else  !  furthest point

         if( dist > 0.d0 ) then
            xnf = c + r * xnf / dist
         else
            xnf    = c
            xnf(1) = xnf(1) + r  !  arbitrarily chose 1-direction
         endif

      endif
      return  !  all done for E being a spheroid

   endif
endif

!---------- treat E not being a spheroid

gi = g
call dtrtri( 'L', 'N', n, gi, n, info )  !  G^{-1}

b = sign * (c-p)
call dtrmv( 'L', 'N', 'N', n, gi, n, b, 1 )  !  b = G^{-1} * [c-p]

a = 0.d0  !  a = lower triangle of gi

do j = 1, n
   a(j:n,j) = gi(j:n,j)
end do

! B = alpha * B * op(A) = G^{-1} * G^{-T}

call dtrmm ( 'R', 'L', 'T', 'N', n, n, sign, gi, n, a, n )

delta = 1.d0
par   = 0.d0

!  minimize f(y) = (1/2) * y^T * A * y + b^T * y,  subject to |y|<= delta

call dgqt(n,a,n,b,delta,rtol,atol,itmax,par,f,ynf,info,z,wa1,wa2)

if( info >= 3 ) then
   write(0,*)'ellu_pt_near_far: dgqt incomplete convergence, info = ', info
   write(0,*)'n = ', n, '  a, b ='
   write(0,'((1p,3e13.4))') a
   write(0,'((1p,3e13.4))') b
endif

if( knf == 1 ) then
   xnf = ynf
else
   xnf = ynf / sqrt( sum(ynf*ynf) )  !  small correction to enforce unit length
endif

call dtrmv( 'L', 'T', 'N', n, gi, n, xnf, 1 )  !  xnf = G^{-T} * ynf + c
xnf = xnf + c

return
end subroutine ellu_pt_near_far


program arrays_03_func
implicit none
integer :: x(10), s, i
do i = 1, size(x)
    x(i) = i
end do
s = mysum(x)
print *, s
if (s /= 55) error stop

contains

    integer function mysum(a) result(r)
    integer, intent(in) :: a(:)
    integer :: i
    r = 0
    do i = 1, size(a)
        r = r + a(i)
    end do
    end function
end


! qinit routine for parabolic bowl problem, only single layer
subroutine qinit(meqn, mbc, mx, my, xlower, ylower, dx, dy, q, maux, aux)
    implicit none

    ! Subroutine arguments
    integer, intent(in) :: meqn, mbc, mx, my, maux
    real(kind=8), intent(in) :: xlower, ylower, dx, dy
    real(kind=8), intent(inout) :: q(meqn, 1-mbc:mx+mbc, 1-mbc:my+mbc)
    real(kind=8), intent(inout) :: aux(maux, 1-mbc:mx+mbc, 1-mbc:my+mbc)

    ! Other storage
    integer :: i, j
    real(kind=8) :: rx2, ry2

    ! initialize the q array
    q = 0D0

    do i=1-mbc,mx+mbc

        rx2 = xlower + (i - 0.5d0) * dx - 20D0
        rx2 = rx2 * rx2

        do j=1-mbc,my+mbc

            ry2 = ylower + (j - 0.5d0) * dy - 30D0
            ry2 = ry2 * ry2

            if ((rx2 + ry2) <= 25D0) then
                q(1, i, j) = 0.2D0
            endif
        enddo
    enddo

end subroutine qinit


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   log :    The logistic map
!----------------------------------------------------------------------
!----------------------------------------------------------------------

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

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

      DOUBLE PRECISION x, mu

      x=U(1)
      mu=PAR(1)

       F(1)=mu*x*(1-x)

      IF(IJAC.EQ.0)RETURN

       DFDU(1,1)=mu*(1-2*x)

      IF(IJAC.EQ.1)RETURN

       DFDP(1,1)=x*(1-x)

      END SUBROUTINE FUNC

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

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

       PAR(1)=0 ! mu
       U(1)=0 ! x

      END SUBROUTINE STPNT

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


       SUBROUTINE W3FA12(PLN,COLRAD,JCAP,EPS)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FA12         COMPUTES LEGENDRE POLYNOMIALS
C   AUTHOR: SELA,JOE         ORG: W323        DATE: 80-10-28
C
C ABSTRACT:  SUBROUTINE COMPUTES LEGENDRE POLYNOMIALS AT A
C   GIVEN LATITUDE.
C
C PROGRAM HISTORY LOG:
C   80-10-20  JOE SELA
C   84-06-01  R.E.JONES   CHANGE TO IBM VS FORTRAN
C   93-04-12  R.E.JONES   CHANGES FOR CRAY, DOUBLE PRECISION TO REAL
C
C USAGE:  CALL W3FA12 (PLN,COLRAD,JCAP,EPS)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     COLRAD ARG LIST  COLATITUDE IN RADIANS OF DESIRED POINT.
C     JCAP   ARG LIST  FOR RHOMBOIADAL TRUNCATION OF ZONAL WAVE
C     EPS    ARG LIST  COEFF. USED IN RECURSION EQUATION.
C                      DIMENSION OF EPS IS (JCAP+2)*(JCAP+1)
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     PLN    ARG LIST  REAL LOCATIONS CONTAIN LEGENDRE
C                      POLNOMIALS , SIZE IS (JCAP+2)*(JCAP+1)
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     COS   SIN   SNGL                                        SYSTEM
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP8/864
C
C***
C
       REAL A
       REAL B
       REAL COLRAD
       REAL COS2
       REAL EPS(*)
       REAL FL
       REAL PROD
       REAL P1
       REAL P2
       REAL P3
       REAL SINLAT
       REAL PLN(*)
C
       SAVE
C
         SINLAT = COS(COLRAD)
         COS2   = 1.0 - SINLAT * SINLAT
         PROD   = 1.0
         A      = 1.0
         B      = 0.0
         JCAP1  = JCAP+1
         JCAP2  = JCAP+2
C
         DO 300 LL = 1,JCAP1
           L   = LL - 1
           FL  = L
           JLE = L * JCAP2
           IF (L.EQ.0) GO TO 100
             A = A + 2.0
             B = B + 2.0
             PROD = PROD * COS2 * A / B
 100       CONTINUE
           P1 = SQRT (0.5 * PROD)
           PLN(JLE+1) = P1
           P2 = SQRT(2.0 * FL + 3.0) * SINLAT * P1
           PLN(JLE+2) = P2
C
           DO 200 N = 3,JCAP2
             LINDEX = JLE + N
             P3 = (SINLAT*P2 - EPS(LINDEX-1)*P1)/EPS(LINDEX)
             PLN(LINDEX) = P3
             P1 = P2
             P2 = P3
200        CONTINUE
300      CONTINUE
         RETURN
C
       END


! Copyright (c) 2019 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Module mlf_gamma_dist
  Use ieee_arithmetic
  Use iso_c_binding
  Use mlf_utils
  Use mlf_rand
  IMPLICIT NONE
  PRIVATE

  Public :: Digamma, Trigamma, RandomGamma, GammaDensity, TetraGamma

  real(c_double), parameter :: m_gamma = 0.5772156649015328606d0 ! Euler-Maschenori constant
  real(c_double), parameter :: zeta2 = (mlf_PI**2)/6d0 ! Zeta(2)
  real(c_double), parameter :: zeta3 = 1.2020569031595942853997d0 ! Apéry's constant (Zeta(3))
  real(c_double), parameter :: zeta4 = (mlf_PI**4)/90d0 ! Zeta(4)
Contains
  Elemental Real(c_double) Function GammaDensity(alpha, x) Result(y)
    real(c_double), intent(in) :: alpha, x
    y = x**(alpha-1)*EXP(-x-LOG_GAMMA(alpha))
  End Function GammaDensity

  Real(c_double) Function RandomGamma(alpha, theta) Result(y)
    real(c_double), intent(in) :: alpha
    real(c_double), intent(in), optional :: theta
    real(c_double) :: r, Xr(2)
    real(c_double) :: c, d, v, w, p
    If(alpha == 1d0) Then
      ! Exponential sampling
      CALL RANDOM_NUMBER(r)
      y = -LOG(1d0-r)
    Else If(alpha > 1d0) Then
      ! Use Marsaglia's method from 'A Simple Method for Generating Gamma Variables'
      d = alpha-1d0/3d0
      c = 1d0/SQRT(9*d)
      Do
        ! Genereate v =(1+cx)^3 with x normal and v > 0
        Do
          CALL mlf_randN2(Xr)
          v = 1+c*Xr(1)
          p = Xr(1)
          If(v > 0) EXIT
          v = 1+c*Xr(2)
          p = Xr(2)
          If(v > 0) EXIT
        End Do
        v = v**3
        y = d * v
        CALL RANDOM_NUMBER(r)
        If(r < 1-0.331d0*p**4) EXIT
        If(LOG(r) < 0.5d0*p**2+d*(1-v+LOG(v))) EXIT
      End Do
    Else ! alpha < 1d0
      ! Use Dagpunar's method as presented in 'Principles of random variate generation'
      d = 1d0-alpha
      p = d/(d+alpha*EXP(-d))
      Do
        CALL RANDOM_NUMBER(r)
        If(r > p) Then
          y = d - LOG((1-r)/(1-p))
          w = d*LOG(y/d)
        Else
          y = d*(r/p)**(1d0/alpha)
          w = y
        Endif
        CALL RANDOM_NUMBER(r)
        If(r > 0d0 .AND. r >= 1-w) Then
          If(r*(w+1) >= 1 .OR. -LOG(r) <= w) CYCLE
        Endif
        EXIT
      End Do
    Endif
    If(PRESENT(theta)) y = theta*y
  End Function RandomGamma

  ! Clean versions of Digamma and Trigamma that are elemental and use NaN as an error instead
  ! of using a supplementar argument
  Elemental Real(c_double) Function Digamma(x) Result(y)
    ! Based on Jose Bernado's Algorithms AS 103
    real(c_double), intent(in) :: x
    real(c_double), parameter :: S = 1d-6, C = 8.5d0
    real(c_double), parameter :: B(5) = [-1d0/12d0, 1d0/120d0, -1d0/252d0, &
      1d0/240d0, -1d0/132d0]
    real(c_double) :: z, r, r2
    If(x <= 0) Then
      ! Invalid input x
      ! TODO??: implement negative values =/= {0, -1, -2, ...}
      y = IEEE_VALUE(y, IEEE_QUIET_NAN)
      RETURN
    Endif
    If(x <= S) Then
      ! Approximation when x is small
      ! zeta2 term come from trigamma function at x -> 0:
      ! phi'(x) = sum_i>=0 1/(i+x)^2 ~= 1/x² + Zeta(2) + o(1)
      y = -m_gamma - 1d0/x + zeta2*x
      RETURN
    Endif
    z = x
    y = 0
    Do While(z <= C)
      ! Use Digamma(x+1) = Digamma(x) + 1/x
      y = y - 1d0/z
      z = z + 1d0
    End Do
    ! Approximation when x -> infty
    r = 1d0/z
    r2 = r*r
    y = y + LOG(z) - 0.5d0*r + r2*(B(1)+r2*(B(2)+r2*(B(3)+r2*(B(4)+r2*B(5)))))
  End Function Digamma

  Elemental Real(c_double) Function Trigamma(x) Result(y)
    ! Based on BE Schneider's Algorithms AS 121
    real(c_double), intent(in) :: x
    real(c_double), parameter :: S = 1d-4, C = 6d0
    real(c_double), parameter :: B(4) = [1d0/6d0, -1d0/30d0, 1d0/42d0, -1d0/30d0]
    real(c_double) :: z, r, r2
    If(x <= 0) Then
      ! Invalid input x
      y = IEEE_VALUE(y, IEEE_QUIET_NAN)
      RETURN
    Endif
    If(x <= S) Then
      ! Approximation when x is small
      ! phi'(x) = sum_i>=0 1/(i+x)^2 ~= 1/x² + Zeta(2) + o(1)
      y = x**(-2) + zeta2
    Endif
    z = x
    y = 0
    Do While(z <= C)
      ! Use psi'(x+1) = psi'(x) - 1/x²
      y = y + z**(-2)
      z = z + 1d0
    End Do
    r = 1d0/z
    r2 = r*r
    ! y = x^-1 + 1/2*x^-2 + 1/6*x^-3 - 1/30*x^-5 + 1/42*x^-7 -1/30*x^-9
    y = y + r * (1d0+0.5d0*r+r2*(B(1)+r2*(B(2)+r2*(B(3)+r2*B(4)))))
  End Function Trigamma

  ! Tetragamma function (derivative of the trigamma function)
  Elemental Real(c_double) Function TetraGamma(x) Result(y)
    real(c_double), intent(in) :: x
    real(c_double), parameter :: S = 1d-4, C = 6d0
    real(c_double) :: z, r, r2
    If(x <= 0) Then
      ! Invalid input x
      y = IEEE_VALUE(y, IEEE_QUIET_NAN)
      RETURN
    Endif
    If(x <= S) Then
      ! TetraGamma(x) = sum_i>=0 -2*(x+i)**-3
      !              ~= -2/x**3 + zeta3 + 6*zeta4*x
      y = -2*(x**(-3)+zeta3)+6*zeta4*x
      RETURN
    Endif
    z = x
    y = 0
    Do While(z <= C)
      ! Use psi''(x+1) = psi''(x) - 2/x^3
      y = y - 2*z**(-3)
      z = z + 1d0
    End Do
    r = 1d0/z
    r2 = r*r
    ! y = -x^-2 - x^-3 - 1/2*x^-4 + 1/6*x^-6 - 1/6*x^-8 + 3/10*x^-10
    y = y + r2*(-1d0 -r + r2*(-1d0/2d0 + r2*(1d0/6d0 + r2*(-1d0/6d0 + 0.3d0*r2))))
  End Function TetraGamma
End Module mlf_gamma_dist


function foo(p)
  double precision foo
  double precision p(2)
  foo=p(1)**2+p(2)**2;
  return
end function foo

program main
  double precision foo
  double precision p(2)
  integer np
  double precision precision
  np=2
  precision=1e-10
  p(1)=4000
  p(2)=5000
  write(*,*) p,foo(p)
  call optimize_powell(foo,np,p,precision)
  write(*,*) p,foo(p)
end program main


submodule(euler_interface_m) euler_prob_0019_m
    implicit none

contains

    module character(len=20) function euler0019()
        write (euler0019, "(i20)") ans(1901, 2000)
    end function euler0019

    integer function ans(from, to)
        integer, intent(in) :: from, to
        integer :: month(12), dow
        integer :: tmp, i, j

        month = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]
        tmp = 0
        dow = 1
        outer: do i = from, to
            if (is_leap(i)) then
                month(2) = 29
            end if

            inner: do j = 1, size(month)
                dow = dow + mod(month(j), 7) - 1
                if (mod(dow, 7) == 0) then
                    tmp = tmp + 1
                end if
            end do inner
        end do outer
        ans = tmp
    end function ans

    logical function is_leap(n)
        integer, intent(in) :: n

        is_leap = .false.
        if (((mod(n, 4) == 0) .and. (mod(n, 100) /= 0)) .or. &
            (mod(n, 400) == 0)) is_leap = .true.
    end function is_leap

end submodule euler_prob_0019_m


! PR target/35662
! { dg-do run }
! { dg-options "-O1" }

subroutine f(x, y, z)
  real, intent (in) :: x
  real, intent (out) :: y, z
  y = sin (x)
  z = cos (x)
end subroutine f

program pr35662
  real :: x, y, z
  x = 3.1415926535897932384626433832795029
  call f (x, y, z)
  if (abs (y) > 1.0e-5 .or. abs (z + 1.0) > 1.0e-5) STOP 1
  x = x / 2.0
  call f (x, y, z)
  if (abs (y - 1.0) > 1.0e-5 .or. abs (z) > 1.0e-5) STOP 2
end program pr35662


program test_random
  use, intrinsic :: iso_fortran_env
  use utility_m
  implicit none
  integer       , parameter :: num = 100000
  integer(int64), parameter :: maxint32 = huge(0_int32)
  real(real64)  , parameter :: to_real64 = 1 / (real(maxint32, real64) + 1)
  integer                 :: myseed, i
  real(real64)            :: myrnd, summation, summation2

  summation  = 0.0_real64
  summation2 = 0.0_real64
  myseed = 1
  do i = 1, num
     call gen_LCG(myseed, myrnd)
     call test_rangeof_LCG(myrnd)
     summation  = summation  + myrnd
     summation2 = summation2 + myrnd*myrnd
  end do

  !> check average and variance.
  block
    real(real64) :: average, average2, variance
    average  = summation  / num
    average2 = summation2 / num
    variance = average2 - average*average
    if (abs(average - 1/2.0_real64) > 0.1_real64) then
       write(error_unit, '(a, es30.15)') "LCG, average: ", average
       call util_error_stop("Average(LCG) is not near 1/2"&
            , __LINE__, __FILE__)
    end if
    if (abs(average2 - 1/3.0_real64) > 0.1_real64) then
       write(error_unit, '(a, es30.15)') "LCG, average^2: ", average2
       call util_error_stop("Average^2(LCG) is not near 1/3"&
            , __LINE__, __FILE__)
    end if
    if (abs(variance - 1/12.0_real64) > 0.1_real64) then
       write(error_unit, '(a, es30.15)') "LCG, variance: ", variance
       call util_error_stop("Variance(LCG) is not near 1/12"&
            , __LINE__, __FILE__)
    end if
  end block

contains

  !> check reange of random number by LCG.
  subroutine test_rangeof_LCG(rnd)
    real(real64), intent(in) :: rnd
    if (rnd < 0.0_rkind .or. rnd >= 1.0_rkind) then
       write(error_unit, '(a, es30.15)') "LCG: ", rnd
       call util_error_stop("Range of LCG is out of [0,1)"&
            , __LINE__, __FILE__)
    end if
  end subroutine test_rangeof_LCG

  !> generage random number by LCG.
  subroutine gen_LCG(seed, rnd)
    integer     , intent(inout) :: seed
    real(real64), intent(out)   :: rnd
    integer(int64)              :: longseed
    longseed = int(seed*48271, int64)
    seed     = int(iand(longseed, z'FFFFFFFFFFFFFFFF'), int32)
    rnd      = (seed*to_real64+1)/2 ! [0, 1)
  end subroutine gen_LCG

end program test_random


module utils

    implicit none

    real, parameter :: pi=4.*atan(1.), infinity=huge(1.)

    interface random
        module procedure random_uni
        module procedure random_uni_range
    end interface random

    contains

    real function degrees_to_radians(degrees)

        implicit none

        real, intent(IN):: degrees

        degrees_to_radians = degrees * pi / 180.

    end function degrees_to_radians

    subroutine init_rng(input_seed, fwd)
    ! initiate RNG state with reproducable state

        implicit none

        integer, optional, intent(IN) :: input_seed(:)
        logical, optional, intent(IN) :: fwd

        integer, allocatable :: seed(:)
        integer              :: n, i
        logical              :: ffwd
        real                 :: a

        call random_seed(size=n)
        allocate(seed(n))

        if(present(input_seed))then
            seed = 0
            seed = input_seed
        else
            seed = 1234567
        end if

        if(present(fwd))then
            ffwd = fwd
        else
            ffwd = .true.
        end if

        call random_seed(put=seed)

        !fast forward rng state 100 times to avoid any potential bad seeds
        if(ffwd)then
            call random_seed(get=seed)
            do i = 1, 100
                a = random()
                call random_seed(get=seed)
            end do
        end if
    end subroutine init_rng

    real function random_uni()

        implicit none

        call random_number(random_uni)

    end function random_uni

    real function random_uni_range(min, max)

        implicit none

        real, intent(IN) :: min, max

        random_uni_range = min + (max-min)*random_uni()

    end function random_uni_range

    real function clamp(x, min, max)

        implicit none

        real, intent(IN) :: x, min, max

        if(x < min)then
            clamp = min
            return
        end if
        if(x > max)then
            clamp = max
            return
        end if
        clamp = x

    end function clamp

end module utils


      LOGICAL FUNCTION EQUAL_SP( VAL1, VAL2, REL_DIF )

!***********************************************************************
!* Tolerant Equality Between two Single Precision Numbers
!*
!* Language: Fortran
!*
!* Author: Stuart G. Mentzer
!*
!* Date: 1999/08/20
!***********************************************************************

      ! Arguments ______________________________________________________

      REAL VAL1 ! First value to compare

      REAL VAL2 ! Second value to compare

      REAL REL_DIF ! Relative difference for comparison

      ! Test for equality with tolerance
      IF ( ABS( VAL1 - VAL2 ) .LE.
     & REL_DIF * MAX( ABS( VAL1 ), ABS( VAL2 ) ) ) THEN
        EQUAL_SP = .TRUE.
      ELSE
        EQUAL_SP = .FALSE.
      END IF

      RETURN
      END

      LOGICAL FUNCTION EQUAL_DP( VAL1, VAL2, REL_DIF )

!***********************************************************************
!* Tolerant Equality Between two Double Precision Numbers
!*
!* Language: Fortran
!*
!* Author: Stuart G. Mentzer
!*
!* Date: 1999/08/20
!***********************************************************************

      ! Arguments ______________________________________________________

      DOUBLE PRECISION VAL1 ! First value to compare

      DOUBLE PRECISION VAL2 ! Second value to compare

      DOUBLE PRECISION REL_DIF ! Relative difference for comparison

      ! Test for equality with tolerance
      IF ( ABS( VAL1 - VAL2 ) .LE.
     & REL_DIF * MAX( ABS( VAL1 ), ABS( VAL2 ) ) ) THEN
        EQUAL_DP = .TRUE.
      ELSE
        EQUAL_DP = .FALSE.
      END IF

      RETURN
      END


program quad
! simple quadratic equation solver, without complex numbers.
    implicit none
    real(kind=8) :: a,b,c,d,e
    read *, a,b,c

    if (b**2-4*a*c .lt. 0) then
        10 format("The complex roots are: ", f5.2 , X , "+ i(" , f5.2 , ") and " , f5.2 , X , "- i(" &
        , f5.2 , ")")
        print 10, -b/2*a, sqrt(-(b**2-4*a*c))/2*a, -b/2*a, sqrt(-(b**2-4*a*c))/2*a
    else
        20 format(" The roots are: ", f5.2, ' and ', f5.2)
        print 20, (-b+sqrt(b**2-4*a*c))/2*a,(-b-sqrt(b**2-4*a*c))/2*a
    endif

end program quad


! { dg-do run }
!
! PR fortran/38282
!
implicit none
integer :: a(2,1)

a(1,1) = 35
a(2,1) = -74

if (iand(a(1,1),a(2,1)) /= iall(a)) STOP 1
if (iand(a(1,1),a(2,1)) /= iall(array=[35, -74])) STOP 2
if (any (iand(a(1,1),a(2,1)) /= iall(a,dim=1))) STOP 3
if (iand(a(1,1),a(2,1)) /= iall(dim=1,mask=[.true.,.true.],array=[35, -74])) STOP 4

if (ior(a(1,1),a(2,1)) /= iany(a)) STOP 5
if (ior(a(1,1),a(2,1)) /= iany(array=[35, -74])) STOP 6
if (any (ior(a(1,1),a(2,1)) /= iany(a,dim=1))) STOP 7
if (ior(a(1,1),a(2,1)) /= iany(dim=1,mask=[.true.,.true.],array=[35, -74])) STOP 8

if (ieor(a(1,1),a(2,1)) /= iparity(a)) STOP 9
if (ieor(a(1,1),a(2,1)) /= iparity(array=[35, -74])) STOP 10
if (any (ieor(a(1,1),a(2,1)) /= iparity(a,dim=1))) STOP 11
if (ieor(a(1,1),a(2,1)) /= iparity(dim=1,mask=[.true.,.true.],array=[35, -74])) STOP 12

end


| Simple Sudoku solver posted in comp.lang.forth by Jorge Acereda Macia
| http://tinyurl.com/yfjlnl
| Ported to Reva and further enhanced by Ron Aaron 22 Dec 2006
3 constant BLOCK_SIZE
BLOCK_SIZE BLOCK_SIZE * constant ROW_SIZE
ROW_SIZE ROW_SIZE * constant SUDOKU_SIZE

1 constant DIFFICULT
2 constant MEDIUM
3 constant EASY

0 value start
0 value end
create colbuf ROW_SIZE cells allot
create rowbuf ROW_SIZE cells allot
create blkbuf ROW_SIZE cells allot
: bounds ( a n ) over + swap ;
: wipe ( addr -- , erase buffer) ROW_SIZE cells zero ;
: row ( index -- row , row for index) ROW_SIZE / ;
: col ( index -- col , col for index) ROW_SIZE mod ;
: blk ( index -- blk , blk for index)
    dup row BLOCK_SIZE / BLOCK_SIZE * swap col BLOCK_SIZE / + ;
: inc ( val index buf -- , accumulate value at index in buffer)
    >r >r dup if 1 swap 2* << then r> cells r> + +! ;
: markrow ( val index -- , mark value in row) row rowbuf inc ;
: markcol ( val index -- , mark value in col) col colbuf inc ;
: markblk ( val index -- , mark value in blk) blk blkbuf inc ;
: elem ( index -- val , element at index) cells start + @ ;
: mark ( val index -- , mark value in buffers)
    2dup markrow 2dup markcol markblk ;
: valid ( buf -- flag, check for valid combination in buffer)
    0 swap 8 cells bounds do
       i @ $AAAAAAAA and +
    loop not ;
: validate ( -- ok?, check for valid combination)
    colbuf wipe rowbuf wipe blkbuf wipe
    SUDOKU_SIZE 0 do i elem i mark loop
    colbuf valid rowbuf valid and blkbuf valid and ;
: back ( addr|0 -- addr|0 )
    dup if cell- then ;
: nomore ( addr|0 -- flag )
    dup if dup @ ROW_SIZE = else 1 then ;
: (solve) ( addr -- addr|0 )
    dup end =if drop 0 ;then
    validate 0; drop
    dup @ if | Found a fixed number, skip it
          cell+ (solve) back
    else | Found a free number, try all the possibilities
          repeat
			1 over +! cell+ (solve) back nomore
		  not
		  while
          dup if dup off then
    then ;
: .sudoku ( addr -- , print board)
    to start
    SUDOKU_SIZE 0 do i elem . i col 8 = if cr then loop cr ;
: solve ( addr -- , solve sudoku)
    to start  start SUDOKU_SIZE cells + to end  start (solve) drop
    validate ;

needs random/gm
: empty? ( a -- flag ) @ 0 = ;
: remaining ( a -- n ) | get number of remaining squares
	0 swap
	SUDOKU_SIZE 0do
		dup empty?	| count a' item
		if _1+ then
		cell+
	loop drop
	;
: 0fill ( a -- ) | replace all NUL characters with '0
." hi"
	SUDOKU_SIZE 0do
		dup @ 0if '0 over ! then
		1+
	loop drop
	;
: unused ( a -- ix ) | return index of random unused square
	repeat
		rand 0 max SUDOKU_SIZE mod tuck	| ix a ix
		cells over +				| ix a a'
		empty? if drop ;then		| ix a
		nip
	again
	;
create possibles 9 cells allot
: randvalue ( a ix -- a ix v ) | look in the rows and columns to find possibles
	| prefill w/ possible values
	possibles ROW_SIZE 0do
		i 1+ over ! cell+ loop drop
	2dup	| a ix a ix
	| iterate the row it's in:
	row ROW_SIZE * cells + |  a ix row-of-ix
		ROW_SIZE 0do dup i cells + @
			'0 - cells possibles + off
			loop drop | a ix
	| iterate the column...
	| find a value
	repeat
		possibles rand 0 max 9 mod cells + @
		dup not
	while
	;
| Fill one-quarter of remaining squares
: (gen) ( a -- )
	dup remaining 2 >>
	0do
		| probe for an unused square
		dup unused | a ix
		| get a random possible valule
		randvalue	| a ix v
		| set the value
		>r cells over + r> swap !
	loop
	;
: rand1-9 ( -- n ) rand 0 max 9 mod 1+ ;

create sofar 10 allot
: get1-9 ( -- n )
	rand1-9 | n
	| is it valid?
	dup sofar + c@ 0if
		| yes! flag it
		dup sofar + over swap c!
	;then
	| no, try again
	drop get1-9
	;
: fillblock ( a -- )
	| blank out the ones tried
	sofar 10 zero
	3 0do
		3 0do
			get1-9 over
	.s cr
			!  cell+
		loop
		6 cells +
	loop drop
	;
: gen ( a difficulty -- ) |  create a new sudoku at the 81 bytes pointed to by "a"
	over SUDOKU_SIZE cells zero	| create empty sudoku
	| fill in one block with numbers
	| there are 36 possible starting places
	over rand 0 max 36 mod
	| a diff a start
	|	over rand1-9 9 mod				| a diff a n
	6 /mod						| a diff a col row
	ROW_SIZE cells * + +			| a diff a[n]
|	ROW_SIZE cells * +			| a diff a[n]
	fillblock
	over .sudoku
	over solve 0if ." No solution" 2drop else over .sudoku then
	;

: sudoku: create
	'; parse scratch lplace
	scratch lcount 0do
		count dup '0 '9 between
		if '0 - , else drop then
	loop  drop ;
sudoku: sudoku1
	100 804 020
	020 000 456
	003 205 000

	000 400 805
	789 050 000
	000 006 203

	801 000 700
	000 123 080
	205 000 009 ;

sudoku: s1
	100	890	000
	470	002	000
	006	500	020
	360	005	010
	000	070	000
	090	100	046
	020	004	800
	000	700	035
	000	068	009 ;

{{ ." Sudoku 1:" cr sudoku1 .sudoku sudoku1 solve
   if
	." Solution: " cr sudoku1 .sudoku
   else
	." No solution." cr
   then
}}