c
c -------------------------------------------------------------------
c
       subroutine vctoprm(q,qp,mitot,mjtot,nvar)
c
c      convert from cell averages in conserved variables to
c      pointwise values in primitive variables.  note for future
c      that may be overwriting conserved variables
c
       use amr_module
       implicit double precision(a-h,o-z)
       include "./quadrature.i"

       dimension q(nvar,mitot,mjtot),qp(nvar,mitot,mjtot)

       include "cuserdt.i"
c
c      given a pointwise value in conserved variables, convert to prim
c      for ex. if already have slopes through conserved vars that preserve
c      cell avgs, evaluate them at selected points
c      ### might be overwriting q with qp
c
       ! hxsq = hx*hx
       ! hysq = hy*hy

       do  j = 1, mjtot
       do  i = 1, mitot
          ! in 3rd order case, pointwise val differs by laplacian from cell average
           qp(1,i,j) = q(1,i,j)
c          qp(:,i,j) = q(:,i,j) - hxsq/24.d0*qxx(:,i,j)
c    &                         - hysq/24.d0*qyy(:,i,j)
          qp(2,i,j) = q(2,i,j)/q(1,i,j)
          qp(3,i,j) = q(3,i,j)/q(1,i,j)
          velsq = qp(2,i,j)**2 + qp(3,i,j)**2
          qp(4,i,j) = gamma1*(q(4,i,j)-.5d0*qp(1,i,j)*velsq)

       end do
       end do
c
       return
       end


! Beam element
!
! author ....... Jan Tomec
! copyright .... Copyright 2020, Project THREAD - University of Rijeka, Faculty of Civil Engineering
! credits ...... Jan Tomec, Gordan Jelenić
! license ...... GPL
! version ...... 1.0.0
! maintainer ... Jan Tomec
! email ........ jan.tomec@gradri.uniri.hr
! status ....... Development
! date ......... 06/05/2020
!
! ------------------------------------------------------------------------------

module beam

	use shape_functions
	use legendre_gauss
	use vector_algebra

	implicit none

	private

	public :: Kg, Fintg, Fextg, curv

	contains

	! compute length of an element
	function element_length (X0, g_ord)

		implicit none

		integer, intent (in) :: g_ord
		double precision, dimension (:, :), intent (in) :: X0
		double precision :: element_length
		integer :: e_ord, i
		double precision, dimension (g_ord) :: pts, wgts
		double precision, dimension (size (X0 (1, :)), g_ord) :: dN
		double precision, dimension (3, g_ord) :: dX0
		double precision, dimension (3) :: intg

		e_ord = size (X0 (1, :)) - 1

		call legauss (g_ord, pts, wgts)
		dN = shdfun (e_ord, pts)

		dX0 = matmul (X0, dN)

		do i = 1, 3
			intg (i) = dot_product (dX0 (i, :), wgts)
		end do
		element_length = norm2 (intg)

	end function element_length

	! compute single Pi matrix
	function Pi (rot)

		implicit none

		double precision, dimension (3, 3), intent (in) :: rot
		double precision, dimension (6, 6) :: Pi

		Pi = 0.0D0
		Pi (1:3, 1:3) = rot
		Pi (4:6, 4:6) = rot

	end function Pi

	! compute single Xi matrix
	function Xi (dX, N, dN)

		implicit none

		double precision, dimension (:), intent (in) :: dX
		double precision, intent (in) :: N, dN
		double precision, dimension (6, 6) :: Xi
		double precision, dimension (3, 3) :: S
		integer :: i

		S = skew (dX)
		Xi = 0.0D0
		do i = 1, 6
			Xi (i, i) = dN
		end do
		Xi (4, 2) = - N * S (1, 2)
		Xi (4, 3) = - N * S (1, 3)
		Xi (5, 1) = - N * S (2, 1)
		Xi (5, 3) = - N * S (2, 3)
		Xi (6, 1) = - N * S (3, 1)
		Xi (6, 2) = - N * S (3, 2)

	end function Xi

	! compute elemental internal forces in nodes
	function Finte (X0, X, f)

		implicit none

		double precision, dimension (:, :), intent (in) :: X0, X
		double precision, dimension (:, :), intent (in) :: f
		double precision, dimension (6, size (X0(1,:))) :: Finte
		integer :: g_ord, nno, e_ord, g, i
		double precision :: L
		double precision, dimension (size (f (1, :))) :: pts, wgts
		double precision, dimension (size (X (1, :)), size (f (1, :))) :: N, dN
		double precision, dimension (3, size (f (1, :))) :: dX
		double precision, dimension (3, 3) :: S
		double precision, dimension (6, 6) :: Xi_i

		g_ord = size (f (1, :))
		nno = size (X (1, :))
		e_ord = nno - 1

		L = element_length (X0, g_ord)
		call legauss (g_ord, pts, wgts)
		N = shfun (e_ord, pts)
		dN = 2.0D0 / L * shdfun (e_ord, pts)

		dX = matmul (X, dN)

		Finte = 0.0D0

		do g = 1, g_ord
			do i = 1, nno
				Xi_i = Xi (dX (:, g), N (i, g), dN (i, g))
				Finte (:, i) = Finte (:, i) + matmul (Xi_i, f (:, g)) * wgts (g)
			end do
		end do

		Finte = L / 2.0D0 * Finte

	end function Finte

	! compute elemental external forces in nodes
	function Fexte (X0, p)

		implicit none

		double precision, dimension (:, :), intent (in) :: X0
		double precision, dimension (:, :), intent (in) :: p
		double precision, dimension (6, size (X0 (1,:))) :: Fexte
		integer :: g_ord, nno, e_ord, g, i
		double precision :: L
		double precision, dimension (size (p (1, :))) :: pts, wgts
		double precision, dimension (size (X0 (1, :)), size (p (1, :))) :: N
		double precision, dimension (6, 6) :: H

		g_ord = size (p (1, :))
		nno = size (X0 (1, :))
		e_ord = nno - 1

		L = element_length (X0, g_ord)
		call legauss (g_ord, pts, wgts)
		N = shfun (e_ord, pts)

		Fexte = 0.0D0

		do g = 1, g_ord
			H = 0.0D0
			do i = 1, nno
				H (1, 1) = N (i, g)
				H (2, 2) = N (i, g)
				H (3, 3) = N (i, g)
				H (4, 4) = N (i, g)
				H (5, 5) = N (i, g)
				H (6, 6) = N (i, g)
				Fexte (:, i) = Fexte (:, i) + matmul (H, p (:, g)) * wgts (g)
			end do
		end do

		Fexte = L / 2.0D0 * Fexte

	end function Fexte

	! compute elemental curvature, internal stresses and new rotation
	subroutine curve (X0, X, th, C, rot, om, f)

		implicit none

		double precision, dimension (:, :), intent (in) :: X0, X, th
		double precision, dimension (6, 6), intent (in) :: C
		double precision, dimension (:, :, :), intent (inout) :: rot
		double precision, dimension (:, :), intent (inout) :: om
		double precision, dimension (:, :), intent (out) :: f
		integer :: g_ord, nno, e_ord, g
		double precision :: L
		double precision, dimension (size (om (1, :))) :: pts, wgts
		double precision, dimension (size (X (1, :)), size (om (1, :))) :: N, dN
		double precision, dimension (3, size (om (1, :))) :: dX, t, dt
		double precision, dimension (size (om (1, :))) :: tn
		double precision, dimension (3, 3) :: R, rotinv
		double precision, dimension (3) ::  b1, b2, b3, a1, a2, a3, Gamma, kappa, fn, fm
		double precision, dimension (3), parameter :: E3 = (/ 0.0D0, 0.0D0, 1.0D0 /)

		g_ord = size (om (1, :))
		nno = size (X0 (1, :))
		e_ord = nno - 1

		L = element_length (X0, g_ord)
		call legauss (g_ord, pts, wgts)
		N = shfun (e_ord, pts)
		dN = 2.0D0 / L * shdfun (e_ord, pts)

		dX = matmul (X, dN)
		t = matmul (th, N)
		dt = matmul (th, dN)
		tn = norm2 (t, dim=1)

		do g = 1, g_ord
			R = rv2mat (t (:, g))
			rot (g, :, :) = matmul (R, rot (g, :, :))
			if (tn (g) == 0) then
				om (:, g) = om (:, g) + dt (:, g)
			else
				b1 = (1.0D0 - sin (tn (g)) / tn (g)) &
				   * dot_product (t (:, g), dt (:, g)) / tn (g) ** 2 * t (:, g)
				b2 = sin (tn (g)) / tn (g) * dt (:, g)
				b3 = (1.0D0 - cos (tn (g))) / tn (g) ** 2 &
				   * cross_product (t (:, g), dt (:, g))
				a1 = cos (tn (g)) * om (:, g)
				a2 = (1.0D0 - cos (tn (g))) / tn (g) ** 2 &
				   * dot_product (t (:, g), om (:, g)) * t (:, g)
				a3 = sin (tn (g)) / tn (g) * cross_product (t (:, g), om (:, g))
				om (:, g) = b1 + b2 + b3 + a1 + a2 + a3
			end if

			rotinv = transpose (rot (g, :, :))
			Gamma = matmul (rotinv, dX (:, g))
			Gamma = Gamma - E3
			kappa = matmul (rotinv, om (:, g))
			fn = matmul (C (1:3, 1:3), Gamma)
			fm = matmul (C (4:6, 4:6), kappa)
			f (1:3, g) = matmul (rot (g, :, :), fn)
			f (4:6, g) = matmul (rot (g, :, :), fm)

		end do

	end subroutine curve

	! compute stiffness of an element
	function Ke (X0, X, rot, C)

		implicit none

		double precision, dimension (:, :), intent (in) :: X0, X
		double precision, dimension (:, :, :), intent (in) :: rot
		double precision, dimension (6, 6), intent (in) :: C
		double precision, dimension (6 * size (X (1, :)), 6 * size (X (1, :))) :: Ke
		integer :: g_ord, nno, e_ord, g, i, j, ii, ij
		double precision :: L
		double precision, dimension (size (rot (:, 1, 1))) :: pts, wgts
		double precision, dimension (size (X (1, :)), size (rot (:, 1, 1))) :: N, dN
		double precision, dimension (3, size (rot (:, 1, 1))) :: dX
		double precision, dimension (6, 6) :: Pi_g, Xi_i, Xi_j, c_g

		g_ord = size (rot (:, 1, 1))
		nno = size (X0 (1, :))
		e_ord = nno - 1

		L = element_length (X0, g_ord)
		call legauss (g_ord, pts, wgts)
		N = shfun (e_ord, pts)
		dN = 2.0D0 / L * shdfun (e_ord, pts)

		dX = matmul (X, dN)

		Ke = 0.0D0

		do g = 1, g_ord
			Pi_g = Pi (rot (g, :, :))
			c_g = matmul (matmul (Pi_g, C), transpose (Pi_g))
			do i = 1, nno
				ii = 6 * (i-1) + 1
				Xi_i = Xi (dX (:, g), N (i, g), dN (i, g))
				do j = 1, nno
					Xi_j = Xi (dX (:, g), N (j, g), dN (j, g))
					ij = 6 * (j-1) + 1
					Ke (ii:ii + 5, ij:ij + 5) = Ke (ii:ii + 5, ij:ij + 5) + &
						wgts (g) * matmul (matmul (Xi_i, c_g), transpose (Xi_j))
				end do
			end do
		end do

		Ke = L / 2.0D0 * Ke

	end function Ke

	! compute stiffness of an element
	function Kgeoe (X0, X, rot, f)

		implicit none

		double precision, dimension (:, :), intent (in) :: X0, X
		double precision, dimension (:, :, :), intent (in) :: rot
		double precision, dimension (:, :), intent (in) :: f
		double precision, dimension (6 * size (X (1, :)), 6 * size (X (1, :))) :: Kgeoe
		integer :: g_ord, nno, e_ord, g, i, j, ii, ij
		double precision :: L
		double precision, dimension (size (rot (:, 1, 1))) :: pts, wgts
		double precision, dimension (size (X (1, :)), size (rot (:, 1, 1))) :: N, dN
		double precision, dimension (6, size (rot (:, 1, 1))) :: dX

		g_ord = size (rot (:, 1, 1))
		nno = size (X0 (1, :))
		e_ord = nno - 1

		L = element_length (X0, g_ord)
		call legauss (g_ord, pts, wgts)
		N = shfun (e_ord, pts)
		dN = 2.0D0 / L * shdfun (e_ord, pts)

		dX = matmul (X, dN)

		Kgeoe = 0.0D0

		do g = 1, g_ord
			do i = 1, nno
				ii = 6 * (i-1) + 1
				do j = 1, nno
					ij = 6 * (j-1) + 1
					Kgeoe (ii:ii + 2, ij + 3:ij + 5) = &
						Kgeoe (ii:ii + 2, ij + 3:ij + 5) - &
						wgts (g) * skew (f (1:3, g)) * dN (i, g) * N (j, g)
					Kgeoe (ii + 3:ii + 5, ij:ij + 2) = &
						Kgeoe (ii + 3:ii + 5, ij:ij + 2) + &
						wgts (g) * skew (f (1:3, g)) * N (i, g) * dN (j, g)
					Kgeoe (ii + 3:ii + 5, ij + 3:ij + 5) = &
						Kgeoe (ii + 3:ii + 5, ij + 3:ij + 5) + &
						wgts (g) * ( &
							-skew (f (4:6, g)) * dN (i, g) * N (j, g) &
							+ matmul (skew (dX (:, g)), skew (f (1:3, g))) &
							* N (i, g) * N (j, g) &
						)
				end do
			end do
		end do

		Kgeoe = L / 2.0D0 * Kgeoe

	end function Kgeoe

	! compute stiffness of an element
	function Kg (ele, X0, X, rot, C, f)

		implicit none

		integer, dimension (:, :), intent (in) :: ele
		double precision, dimension (:, :), intent (in) :: X0, X
		double precision, dimension (:, :, :, :), intent (in) :: rot
		double precision, dimension (6, 6), intent (in) :: C
		double precision, dimension (:, :, :), intent (in) :: f
		double precision, dimension (6 * size (X (1, :)), 6 * size (X (1, :))) :: Kg
		integer :: nno, nele, neno, e, i, j, ei, ej
		integer, dimension (size (ele (1, :))) :: ee
		double precision, dimension (6 * size (ele (1, :)), 6 * size (ele (1, :))) :: Kee

		nno = size (X0 (1, :))
		nele = size (ele (:, 1))

		Kg = 0.0D0

		do e = 1, nele
			ee = ele (e, :)
			neno = size (ee)
			Kee = Ke (X0 (:, ee), X (:, ee), rot (e, :, :, :), C) &
				+ Kgeoe (X0 (:, ee), X (:, ee), rot (e, :, :, :), f (e, :, :))
			do i = 1, neno
				ei = ee (i)
				do j = 1, neno
					ej = ee (j)
					Kg (6 * (ei - 1) + 1:6 * ei, 6 * (ej - 1) + 1:6 * ej) = &
						Kg (6 * (ei - 1) + 1:6 * ei, 6 * (ej - 1) + 1:6 * ej) &
						+ Kee (6 * (i - 1) + 1:6 * i, 6 * (j - 1) + 1:6 * j)
				end do
			end do
		end do

	end function Kg

	! compute global internal force vector
	function Fintg (ele, X0, X, f)

		implicit none

		integer, dimension (:, :), intent (in) :: ele
		double precision, dimension (:, :), intent (in) :: X0, X
		double precision, dimension (:, :, :), intent (in) :: f
		double precision, dimension (6 * size (X (1, :))) :: Fintg
		integer :: nno, nele, neno, e, i, ei
		integer, dimension (size (ele (1, :))) :: ee
		double precision, dimension (6, size (ele (1, :))) :: Fie

		nno = size (X0 (1, :))
		nele = size (ele (:, 1))

		Fintg = 0.0D0

		do e = 1, nele
			ee = ele (e, :)
			neno = size (ee)
			Fie = Finte (X0 (:, ee), X (:, ee), f (e, :, :))
			do i = 1, neno
				ei = ee (i)
				Fintg (6 * (ei - 1) + 1:6 * ei) = &
					Fintg (6 * (ei - 1) + 1:6 * ei) + Fie (:, i)
			end do
		end do

	end function Fintg

	! compute global external force vector
	function Fextg (ele, X0, Q, p)

		implicit none

		integer, dimension (:, :), intent (in) :: ele
		double precision, dimension (:, :), intent (in) :: X0
		double precision, dimension (:, :), intent (in) :: Q
		double precision, dimension (:, :, :), intent (in) :: p
		double precision, dimension (6 * size (X0 (1, :))) :: Fextg
		integer :: nno, nele, neno, e, i, ei
		integer, dimension (size (ele (1, :))) :: ee
		double precision, dimension (6, size (ele (1, :))) :: Fee

		nno = size (X0 (1, :))
		nele = size (ele (:, 1))

		Fextg = 0.0D0

		do e = 1, nele
			ee = ele (e, :)
			neno = size (ee)
			Fee = Fexte (X0 (:, ee), p (e, :, :))
			do i = 1, neno
				ei = ee (i)
				Fextg (6 * (ei - 1) + 1:6 * ei) = &
					Fextg (6 * (ei - 1) + 1:6 * ei) + Fee (:, i)
			end do
		end do

		Fextg = Fextg + reshape (Q, (/ 6 * nno /))

	end function Fextg

	! compute global external force vector
	subroutine curv (ele, X0, X, th, C, rot, om, f)

		implicit none

		integer, dimension (:, :), intent (in) :: ele  ! (no ele, no nodes on ele)
		double precision, dimension (:, :), intent (in) :: X0, X, th  ! (3, no all nodes)
		double precision, dimension (6, 6), intent (in) :: C
		double precision, dimension (:, :, :, :), intent (inout) :: rot  ! (no ele, no gauss, 3, 3)
		double precision, dimension (:, :, :), intent (inout) :: om  ! (no ele, 3, no gauss)
		double precision, dimension (:, :, :), intent (out) :: f  ! (no ele, 6, no gauss)
		integer :: nno, nele, e
		integer, dimension (size (ele (1, :))) :: ee

		nno = size (X0 (1, :))
		nele = size (ele (:, 1))

		do e = 1, nele
			ee = ele (e, :)
			call curve ( &
				X0 (:, ee), X (:, ee), th (:, ee), C, &
				rot (e, :, :, :), om (e, :, :), f (e, :, :) &
			)
		end do

	end subroutine curv

end module


! ------------------------------------------------------------------------------
! Subroutine for the derivative of Jac with respect to rate coefficients
! Times a user vector
! -----------------------------------------------------------------------------

      SUBROUTINE  dJac_dRcoeff( V, F, U, NCOEFF, JCOEFF, DJDR )

      USE KPP_ROOT_Parameters
      USE KPP_ROOT_StoichiomSP
      IMPLICIT NONE

! V - Concentrations of variable/fixed species
      KPP_REAL V(NVAR), F(NFIX)
! U - User-supplied Vector
      KPP_REAL U(NVAR)
! NCOEFF - the number of rate coefficients with respect to which we differentiate
      INTEGER NCOEFF
! JCOEFF - a vector of integers containing the indices of reactions (rate
!          coefficients) with respect to which we differentiate
      INTEGER JCOEFF(NCOEFF)
! DFDR  - a matrix containg derivative values; specifically,
!         column j contains d Jac(1:NVAR) / d RCT( JCOEFF(j) ) * U
!                     for each 1 <= j <= NCOEFF
!         This matrix is stored in a column-wise linearized format
      KPP_REAL DJDR(NVAR*NCOEFF)

! Local vector for Jacobian of reactant products
      KPP_REAL JV_RPROD(NJVRP)
      KPP_REAL aj
      INTEGER i,j,k

! Compute the Jacobian of all reactant products
      CALL JacReactantProd( V, F, JV_RPROD )

! Compute the derivatives by multiplying column JCOEFF(j) of the stoichiometric matrix with A_PROD
      DO j=1,NCOEFF
!                  Initialize the j-th column of derivative matrix to zero
         DO i=1,NVAR
           DJDR(i+NVAR*(j-1)) = 0.0_dp
         END DO
!                  Column JCOEFF(j) in the stoichiometric matrix times the
!                  ( Gradient of reactant product of the JCOEFF(j)-th reaction X user vector )
!                  give the j-th column of the derivative matrix
!
!          Row JCOEFF(j) of JV_RPROD times the user vector
         aj = 0.0_dp
         DO k=CROW_JVRP(JCOEFF(j)),CROW_JVRP(JCOEFF(j)+1)-1
             aj = aj + JV_RPROD(k)*U(ICOL_JVRP(k))
         END DO
!          Column JCOEFF(j) of Stoichiom. matrix times aj
         DO k=CCOL_STOICM(JCOEFF(j)),CCOL_STOICM(JCOEFF(j)+1)-1
           DJDR(IROW_STOICM(k)+NVAR*(j-1)) = STOICM(k)*aj
         END DO
      END DO

      END SUBROUTINE  dJac_dRcoeff


c
c-----------------------------------------------------------------------
c
c
c
      double precision function p18th(x)
      implicit double precision (a-h,o-z)
c
c     function specifying theta as a function of x along the lower wall
c     theta is the angle of the wall = angle of streamline
c
      if (x.le.0.1d0) slope = 0.d0
      if (x.gt.0.1d0 .and. x.lt.0.7d0) slope = -0.6d0*(x-0.1d0)
      if (x.ge.0.7d0) slope = -0.36d0
      p18th = datan(slope)
      return
      end


*DECK DRC3JJ
      SUBROUTINE DRC3JJ (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM,
     +   IER)
C***BEGIN PROLOGUE  DRC3JJ
C***PURPOSE  Evaluate the 3j symbol f(L1) = (  L1   L2 L3)
C                                           (-M2-M3 M2 M3)
C            for all allowed values of L1, the other parameters
C            being held fixed.
C***LIBRARY   SLATEC
C***CATEGORY  C19
C***TYPE      DOUBLE PRECISION (RC3JJ-S, DRC3JJ-D)
C***KEYWORDS  3J COEFFICIENTS, 3J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS,
C             RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS,
C             WIGNER COEFFICIENTS
C***AUTHOR  Gordon, R. G., Harvard University
C           Schulten, K., Max Planck Institute
C***DESCRIPTION
C
C *Usage:
C
C        DOUBLE PRECISION L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM)
C        INTEGER NDIM, IER
C
C        CALL DRC3JJ (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM, IER)
C
C *Arguments:
C
C     L2 :IN      Parameter in 3j symbol.
C
C     L3 :IN      Parameter in 3j symbol.
C
C     M2 :IN      Parameter in 3j symbol.
C
C     M3 :IN      Parameter in 3j symbol.
C
C     L1MIN :OUT  Smallest allowable L1 in 3j symbol.
C
C     L1MAX :OUT  Largest allowable L1 in 3j symbol.
C
C     THRCOF :OUT Set of 3j coefficients generated by evaluating the
C                 3j symbol for all allowed values of L1.  THRCOF(I)
C                 will contain f(L1MIN+I-1), I=1,2,...,L1MAX+L1MIN+1.
C
C     NDIM :IN    Declared length of THRCOF in calling program.
C
C     IER :OUT    Error flag.
C                 IER=0 No errors.
C                 IER=1 Either L2.LT.ABS(M2) or L3.LT.ABS(M3).
C                 IER=2 Either L2+ABS(M2) or L3+ABS(M3) non-integer.
C                 IER=3 L1MAX-L1MIN not an integer.
C                 IER=4 L1MAX less than L1MIN.
C                 IER=5 NDIM less than L1MAX-L1MIN+1.
C
C *Description:
C
C     Although conventionally the parameters of the vector addition
C  coefficients satisfy certain restrictions, such as being integers
C  or integers plus 1/2, the restrictions imposed on input to this
C  subroutine are somewhat weaker. See, for example, Section 27.9 of
C  Abramowitz and Stegun or Appendix C of Volume II of A. Messiah.
C  The restrictions imposed by this subroutine are
C       1. L2 .GE. ABS(M2) and L3 .GE. ABS(M3);
C       2. L2+ABS(M2) and L3+ABS(M3) must be integers;
C       3. L1MAX-L1MIN must be a non-negative integer, where
C          L1MAX=L2+L3 and L1MIN=MAX(ABS(L2-L3),ABS(M2+M3)).
C  If the conventional restrictions are satisfied, then these
C  restrictions are met.
C
C     The user should be cautious in using input parameters that do
C  not satisfy the conventional restrictions. For example, the
C  the subroutine produces values of
C       f(L1) = ( L1  2.5  5.8)
C               (-0.3 1.5 -1.2)
C  for L1=3.3,4.3,...,8.3 but none of the symmetry properties of the 3j
C  symbol, set forth on page 1056 of Messiah, is satisfied.
C
C     The subroutine generates f(L1MIN), f(L1MIN+1), ..., f(L1MAX)
C  where L1MIN and L1MAX are defined above. The sequence f(L1) is
C  generated by a three-term recurrence algorithm with scaling to
C  control overflow. Both backward and forward recurrence are used to
C  maintain numerical stability. The two recurrence sequences are
C  matched at an interior point and are normalized from the unitary
C  property of 3j coefficients and Wigner's phase convention.
C
C    The algorithm is suited to applications in which large quantum
C  numbers arise, such as in molecular dynamics.
C
C***REFERENCES  1. Abramowitz, M., and Stegun, I. A., Eds., Handbook
C                  of Mathematical Functions with Formulas, Graphs
C                  and Mathematical Tables, NBS Applied Mathematics
C                  Series 55, June 1964 and subsequent printings.
C               2. Messiah, Albert., Quantum Mechanics, Volume II,
C                  North-Holland Publishing Company, 1963.
C               3. Schulten, Klaus and Gordon, Roy G., Exact recursive
C                  evaluation of 3j and 6j coefficients for quantum-
C                  mechanical coupling of angular momenta, J Math
C                  Phys, v 16, no. 10, October 1975, pp. 1961-1970.
C               4. Schulten, Klaus and Gordon, Roy G., Semiclassical
C                  approximations to 3j  and 6j coefficients for
C                  quantum-mechanical coupling of angular momenta,
C                  J Math Phys, v 16, no. 10, October 1975,
C                  pp. 1971-1988.
C               5. Schulten, Klaus and Gordon, Roy G., Recursive
C                  evaluation of 3j and 6j coefficients, Computer
C                  Phys Comm, v 11, 1976, pp. 269-278.
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   750101  DATE WRITTEN
C   880515  SLATEC prologue added by G. C. Nielson, NBS; parameters
C           HUGE and TINY revised to depend on D1MACH.
C   891229  Prologue description rewritten; other prologue sections
C           revised; LMATCH (location of match point for recurrences)
C           removed from argument list; argument IER changed to serve
C           only as an error flag (previously, in cases without error,
C           it returned the number of scalings); number of error codes
C           increased to provide more precise error information;
C           program comments revised; SLATEC error handler calls
C           introduced to enable printing of error messages to meet
C           SLATEC standards. These changes were done by D. W. Lozier,
C           M. A. McClain and J. M. Smith of the National Institute
C           of Standards and Technology, formerly NBS.
C   910415  Mixed type expressions eliminated; variable C1 initialized;
C           description of THRCOF expanded. These changes were done by
C           D. W. Lozier.
C***END PROLOGUE  DRC3JJ
C
      INTEGER NDIM, IER
      DOUBLE PRECISION L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM)
C
      INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM,
     +        NSTEP2
      DOUBLE PRECISION A1, A1S, A2, A2S, C1, C1OLD, C2, CNORM, D1MACH,
     +                 DENOM, DV, EPS, HUGE, L1, M1, NEWFAC, OLDFAC,
     +                 ONE, RATIO, SIGN1, SIGN2, SRHUGE, SRTINY, SUM1,
     +                 SUM2, SUMBAC, SUMFOR, SUMUNI, THREE, THRESH,
     +                 TINY, TWO, X, X1, X2, X3, Y, Y1, Y2, Y3, ZERO
C
      DATA  ZERO,EPS,ONE,TWO,THREE /0.0D0,0.01D0,1.0D0,2.0D0,3.0D0/
C
C***FIRST EXECUTABLE STATEMENT  DRC3JJ
      IER=0
C  HUGE is the square root of one twentieth of the largest floating
C  point number, approximately.
      HUGE = SQRT(D1MACH(2)/20.0D0)
      SRHUGE = SQRT(HUGE)
      TINY = 1.0D0/HUGE
      SRTINY = 1.0D0/SRHUGE
C
C     LMATCH = ZERO
      M1 = - M2 - M3
C
C  Check error conditions 1 and 2.
      IF((L2-ABS(M2)+EPS.LT.ZERO).OR.
     +   (L3-ABS(M3)+EPS.LT.ZERO))THEN
         IER=1
cdjh         CALL XERMSG('SLATEC','DRC3JJ','L2-ABS(M2) or L3-ABS(M3) '//
cdjh     +      'less than zero.',IER,1)
         RETURN
      ELSEIF((MOD(L2+ABS(M2)+EPS,ONE).GE.EPS+EPS).OR.
     +   (MOD(L3+ABS(M3)+EPS,ONE).GE.EPS+EPS))THEN
         IER=2
cdjh         CALL XERMSG('SLATEC','DRC3JJ','L2+ABS(M2) or L3+ABS(M3) '//
cdjh     +      'not integer.',IER,1)
         RETURN
      ENDIF
C
C
C
C  Limits for L1
C

      L1MIN = MAX(ABS(L2-L3),ABS(M1))
      L1MAX = L2 + L3
C
C  Check error condition 3.
      IF(MOD(L1MAX-L1MIN+EPS,ONE).GE.EPS+EPS)THEN
         IER=3
cdjh         CALL XERMSG('SLATEC','DRC3JJ','L1MAX-L1MIN not integer.',IER,1)
         RETURN
      ENDIF
      IF(L1MIN.LT.L1MAX-EPS)   GO TO 20
      IF(L1MIN.LT.L1MAX+EPS)   GO TO 10
C
C  Check error condition 4.
      IER=4
cdjh      CALL XERMSG('SLATEC','DRC3JJ','L1MIN greater than L1MAX.',IER,1)
      RETURN
C
C  This is reached in case that L1 can take only one value,
C  i.e. L1MIN = L1MAX
C
   10 CONTINUE
C     LSCALE = 0
      THRCOF(1) = (-ONE) ** INT(ABS(L2+M2-L3+M3)+EPS) /
     1 SQRT(L1MIN + L2 + L3 + ONE)
      RETURN
C
C  This is reached in case that L1 takes more than one value,
C  i.e. L1MIN < L1MAX.
C
   20 CONTINUE
C     LSCALE = 0
      NFIN = INT(L1MAX-L1MIN+ONE+EPS)
      IF(NDIM-NFIN)  21, 23, 23
C
C  Check error condition 5.
   21 IER = 5

cdjh      CALL XERMSG('SLATEC','DRC3JJ','Dimension of result array for '//
cdjh     +            '3j coefficients too small.',IER,1)
      RETURN
C
C
C  Starting forward recursion from L1MIN taking NSTEP1 steps
C
   23 L1 = L1MIN
      NEWFAC = 0.0D0
      C1 = 0.0D0
      THRCOF(1) = SRTINY
      SUM1 = (L1+L1+ONE) * TINY
C
C
      LSTEP = 1
   30 LSTEP = LSTEP + 1
      L1 = L1 + ONE
C
C
      OLDFAC = NEWFAC
      A1 = (L1+L2+L3+ONE) * (L1-L2+L3) * (L1+L2-L3) * (-L1+L2+L3+ONE)
      A2 = (L1+M1) * (L1-M1)
      NEWFAC = SQRT(A1*A2)
      IF(L1.LT.ONE+EPS)   GO TO 40
C
C
      DV = - L2*(L2+ONE) * M1 + L3*(L3+ONE) * M1 + L1*(L1-ONE) * (M3-M2)
      DENOM = (L1-ONE) * NEWFAC
C
      IF(LSTEP-2)  32, 32, 31
C
   31 C1OLD = ABS(C1)
   32 C1 = - (L1+L1-ONE) * DV / DENOM
      GO TO 50
C
C  If L1 = 1, (L1-1) has to be factored out of DV, hence
C
   40 C1 = - (L1+L1-ONE) * L1 * (M3-M2) / NEWFAC
C
   50 IF(LSTEP.GT.2)   GO TO 60
C
C
C  If L1 = L1MIN + 1, the third term in the recursion equation vanishes,
C  hence
      X = SRTINY * C1
      THRCOF(2) = X
      SUM1 = SUM1 + TINY * (L1+L1+ONE) * C1*C1
      IF(LSTEP.EQ.NFIN)   GO TO 220
      GO TO 30
C
C
   60 C2 = - L1 * OLDFAC / DENOM
C
C  Recursion to the next 3j coefficient X
C
      X = C1 * THRCOF(LSTEP-1) + C2 * THRCOF(LSTEP-2)
      THRCOF(LSTEP) = X
      SUMFOR = SUM1
      SUM1 = SUM1 + (L1+L1+ONE) * X*X
      IF(LSTEP.EQ.NFIN)   GO TO 100
C
C  See if last unnormalized 3j coefficient exceeds SRHUGE
C
      IF(ABS(X).LT.SRHUGE)   GO TO 80
C
C  This is reached if last 3j coefficient larger than SRHUGE,
C  so that the recursion series THRCOF(1), ... , THRCOF(LSTEP)
C  has to be rescaled to prevent overflow
C
C     LSCALE = LSCALE + 1
      DO 70 I=1,LSTEP
      IF(ABS(THRCOF(I)).LT.SRTINY)   THRCOF(I) = ZERO
   70 THRCOF(I) = THRCOF(I) / SRHUGE
      SUM1 = SUM1 / HUGE
      SUMFOR = SUMFOR / HUGE
      X = X / SRHUGE
C
C  As long as ABS(C1) is decreasing, the recursion proceeds towards
C  increasing 3j values and, hence, is numerically stable.  Once
C  an increase of ABS(C1) is detected, the recursion direction is
C  reversed.
C
   80 IF(C1OLD-ABS(C1))   100, 100, 30
C
C
C  Keep three 3j coefficients around LMATCH for comparison with
C  backward recursion.
C
  100 CONTINUE
C     LMATCH = L1 - 1
      X1 = X
      X2 = THRCOF(LSTEP-1)
      X3 = THRCOF(LSTEP-2)
      NSTEP2 = NFIN - LSTEP + 3
C
C
C
C
C  Starting backward recursion from L1MAX taking NSTEP2 steps, so
C  that forward and backward recursion overlap at three points
C  L1 = LMATCH+1, LMATCH, LMATCH-1.
C
      NFINP1 = NFIN + 1
      NFINP2 = NFIN + 2
      NFINP3 = NFIN + 3
      L1 = L1MAX
      THRCOF(NFIN) = SRTINY
      SUM2 = TINY * (L1+L1+ONE)
C
      L1 = L1 + TWO
      LSTEP = 1
  110 LSTEP = LSTEP + 1
      L1 = L1 - ONE
C
      OLDFAC = NEWFAC
      A1S = (L1+L2+L3)*(L1-L2+L3-ONE)*(L1+L2-L3-ONE)*(-L1+L2+L3+TWO)
      A2S = (L1+M1-ONE) * (L1-M1-ONE)
      NEWFAC = SQRT(A1S*A2S)
C
      DV = - L2*(L2+ONE) * M1 + L3*(L3+ONE) * M1 + L1*(L1-ONE) * (M3-M2)
C
      DENOM = L1 * NEWFAC
      C1 = - (L1+L1-ONE) * DV / DENOM
      IF(LSTEP.GT.2)   GO TO 120
C
C  If L1 = L1MAX + 1, the third term in the recursion formula vanishes
C
      Y = SRTINY * C1
      THRCOF(NFIN-1) = Y
      SUMBAC = SUM2
      SUM2 = SUM2 + TINY * (L1+L1-THREE) * C1*C1
C
      GO TO 110
C
C
  120 C2 = - (L1 - ONE) * OLDFAC / DENOM
C
C  Recursion to the next 3j coefficient Y
C
      Y = C1 * THRCOF(NFINP2-LSTEP) + C2 * THRCOF(NFINP3-LSTEP)
C
      IF(LSTEP.EQ.NSTEP2)   GO TO 200
C
      THRCOF(NFINP1-LSTEP) = Y
      SUMBAC = SUM2
      SUM2 = SUM2 + (L1+L1-THREE) * Y*Y
C
C  See if last unnormalized 3j coefficient exceeds SRHUGE
C
      IF(ABS(Y).LT.SRHUGE)   GO TO 110
C
C  This is reached if last 3j coefficient larger than SRHUGE,
C  so that the recursion series THRCOF(NFIN), ... ,THRCOF(NFIN-LSTEP+1)
C  has to be rescaled to prevent overflow
C
C     LSCALE = LSCALE + 1
      DO 130 I=1,LSTEP
      INDEX = NFIN - I + 1
      IF(ABS(THRCOF(INDEX)).LT.SRTINY)   THRCOF(INDEX) = ZERO
  130 THRCOF(INDEX) = THRCOF(INDEX) / SRHUGE
      SUM2 = SUM2 / HUGE
      SUMBAC = SUMBAC / HUGE
C
C
      GO TO 110
C
C
C  The forward recursion 3j coefficients X1, X2, X3 are to be matched
C  with the corresponding backward recursion values Y1, Y2, Y3.
C
  200 Y3 = Y
      Y2 = THRCOF(NFINP2-LSTEP)
      Y1 = THRCOF(NFINP3-LSTEP)
C
C
C  Determine now RATIO such that YI = RATIO * XI  (I=1,2,3) holds
C  with minimal error.
C
      RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 )
      NLIM = NFIN - NSTEP2 + 1
C
      IF(ABS(RATIO).LT.ONE)   GO TO 211
C
      DO 210 N=1,NLIM
  210 THRCOF(N) = RATIO * THRCOF(N)
      SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC
      GO TO 230
C
  211 NLIM = NLIM + 1
      RATIO = ONE / RATIO
      DO 212 N=NLIM,NFIN
  212 THRCOF(N) = RATIO * THRCOF(N)
      SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC
      GO TO 230
C
  220 SUMUNI = SUM1
C
C
C  Normalize 3j coefficients
C
  230 CNORM = ONE / SQRT(SUMUNI)
C
C  Sign convention for last 3j coefficient determines overall phase
C
      SIGN1 = SIGN(ONE,THRCOF(NFIN))
      SIGN2 = (-ONE) ** INT(ABS(L2+M2-L3+M3)+EPS)
      IF(SIGN1*SIGN2) 235,235,236
  235 CNORM = - CNORM
C
  236 IF(ABS(CNORM).LT.ONE)   GO TO 250
C
      DO 240 N=1,NFIN
  240 THRCOF(N) = CNORM * THRCOF(N)
      RETURN
C
  250 THRESH = TINY / ABS(CNORM)
      DO 251 N=1,NFIN
      IF(ABS(THRCOF(N)).LT.THRESH)   THRCOF(N) = ZERO
  251 THRCOF(N) = CNORM * THRCOF(N)
C
      RETURN
      END


SUBROUTINE formm(stress,m1,m2,m3)
!
! This subroutine forms the derivatives of the invariants with respect to
! stress in 2- or 3-d.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::stress(:)
 REAL(iwp),INTENT(OUT)::m1(:,:),m2(:,:),m3(:,:)
 REAL(iwp)::sx,sy,txy,tyz,tzx,sz,dx,dy,dz,sigm,zero=0.0_iwp,one=1.0_iwp,  &
   two=2.0_iwp,three=3.0_iwp,six=6.0_iwp,nine=9.0_iwp
 INTEGER::nst,i,j
 nst=UBOUND(stress,1)
 SELECT CASE(nst)
 CASE(4)
   sx=stress(1)
   sy=stress(2)
   txy=stress(3)
   sz=stress(4)
   dx=(two*sx-sy-sz)/three
   dy=(two*sy-sz-sx)/three
   dz=(two*sz-sx-sy)/three
   sigm=(sx+sy+sz)/three
   m1=zero
   m2=zero
   m3=zero
   m1(1,1:2)=one
   m1(2,1:2)=one
   m1(4,1:2)=one
   m1(1,4)=one
   m1(4,4)=one
   m1(2,4)=one
   m1=m1/nine/sigm
   m2(1,1)=two/three
   m2(2,2)=two/three
   m2(4,4)= two/three
   m2(2,4)=-one/three
   m2(4,2)=-one/three
   m2(1,2)=-one/three
   m2(2,1)=-one/three
   m2(1,4)=-one/three
   m2(4,1)=-one/three
   m2(3,3)=two
   m3(3,3)=-dz
   m3(1:2,3)=txy/three
   m3(3,1:2)=txy/three
   m3(3,4)=-two*txy/three
   m3(4,3)=-two*txy/three
   m3(1,1)=dx/three
   m3(2,4)=dx/three
   m3(4,2)=dx/three
   m3(2,2)=dy/three
   m3(1,4)=dy/three
   m3(4,1)=dy/three
   m3(4,4)=dz/three
   m3(1,2)=dz/three
   m3(2,1)=dz/three
 CASE(6)
   sx=stress(1)
   sy=stress(2)
   sz=stress(3)
   txy=stress(4)
   tyz=stress(5)
   tzx=stress(6)
   sigm=(sx+sy+sz)/three
   dx=sx-sigm
   dy=sy-sigm
   dz=sz-sigm
   m1=zero
   m2=zero
   m1(1:3,1:3)=one/(three*sigm)
   DO i=1,3
     m2(i,i)=two
     m2(i+3,i+3)=six
   END DO
   m2(1,2)=-one
   m2(1,3)=-one
   m2(2,3)=-one
   m3(1,1)=dx
   m3(1,2)=dz
   m3(1,3)=dy
   m3(1,4)=txy
   m3(1,5)=-two*tyz
   m3(1,6)=tzx
   m3(2,2)=dy
   m3(2,3)=dx
   m3(2,4)=txy
   m3(2,5)=tyz
   m3(2,6)=-two*tzx
   m3(3,3)=dz
   m3(3,4)=-two*txy
   m3(3,5)=tyz
   m3(3,6)=tzx
   m3(4,4)=-three*dz
   m3(4,5)=three*tzx
   m3(4,6)=three*tyz
   m3(5,5)=-three*dx
   m3(5,6)=three*txy
   m3(6,6)=-three*dy
   DO i=1,6
     DO j=i+1,6
       m1(j,i)=m1(i,j)
       m2(j,i)=m2(i,j)
       m3(j,i)=m3(i,j)
     END DO
   END DO
   m1=m1/three
   m2=m2/three
   m3=m3/three
 CASE DEFAULT
   WRITE(*,*)"nst size not recognised in formm"
 END SELECT
RETURN
END SUBROUTINE formm


      real*8 function intl1(t1)
      implicit none
      real*8 t1,x1,z,Q2,k1,k2
      real*8 eepdf_tilde,eepdf_tilde_power
      real*8 eepdf_tilde_calc
      integer id
      common /intl/ z,Q2,k1,k2,id
      real*8 res
      x1=1d0-t1**(1d0/(1d0-k1))
      res=eepdf_tilde(x1,Q2,id,11,11)/(1d0-k1)
c     print *,t1,z,x1,z/x1,res
      intl1=res
      end

      real*8 function intl2(t2)
      implicit none
      real*8 t2,x2,z,Q2,k1,k2
      real*8 eepdf_tilde,eepdf_tilde_power
      real*8 eepdf_tilde_calc
      integer id
      common /intl/ z,Q2,k1,k2,id
      real*8 res
      x2=1d0-t2**(1d0/(1d0-k2))
      res=eepdf_tilde(x2,Q2,id,-11,-11)/(1d0-k2)
      intl2=res
      end

      real*8 function totlumi(Q2par,idpar)
      implicit none
      real*8 eepdf_tilde
      real*8 eepdf_tilde_power
      real*8 intl1,intl2
      real*8 dgauss
      external eepdf_tilde,eepdf_tilde_power,intl1,intl2,dgauss
      real*8 zpar,Q2par
      integer idpar
      real*8 z,Q2,k1,k2
      real*8 res_y,res_x,res_grid
      real*8 factor
      integer id
      common /intl/ z,Q2,k1,k2,id
      real*8 res1,res2
      Q2=Q2par
      id=idpar
      k1=eepdf_tilde_power(Q2,id,11,11)
      k2=eepdf_tilde_power(Q2,id,-11,-11)
      res1=dgauss(intl1,0d0,1d0,1d-6)
      res2=dgauss(intl2,0d0,1d0,1d-6)
c     print *,z,id,res1,res2
      totlumi=res1*res2
c     print *,id,res1,res2,totlumi
      end

      program main
      implicit none
      real*8 totlumi,eepdf_tilde_power
      external totlumi,eepdf_tilde_power
      real*8 z,Q2
      real*8 res1,res2,res3,res4,res
      Q2=137d0*137d0
      res1=totlumi(Q2,1)
      res2=totlumi(Q2,2)
      res3=totlumi(Q2,3)
      res4=totlumi(Q2,4)
      res=res1+res2+res3+res4
      print *,res
      end program


      SUBROUTINE MB02NY( UPDATU, UPDATV, M, N, I, K, Q, E, U, LDU, V,
     $                   LDV, DWORK )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To separate a zero singular value of a bidiagonal submatrix of
C     order k, k <= p, of the bidiagonal matrix
C
C               |Q(1) E(1)  0    ...   0   |
C               | 0   Q(2) E(2)        .   |
C           J = | .                    .   |
C               | .                  E(p-1)|
C               | 0   ...  ...   ...  Q(p) |
C
C     with p = MIN(M,N), by annihilating one or two superdiagonal
C     elements E(i-1) (if i > 1) and/or E(i) (if i < k).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPDATU  LOGICAL
C             Indicates whether the user wishes to accumulate in a
C             matrix U the left-hand Givens rotations S, as follows:
C             = .FALSE.:  Do not form U;
C             = .TRUE. :  The given matrix U is updated (postmultiplied)
C                         by the left-hand Givens rotations S.
C
C     UPDATV  LOGICAL
C             Indicates whether the user wishes to accumulate in a
C             matrix V the right-hand Givens rotations T, as follows:
C             = .FALSE.:  Do not form V;
C             = .TRUE. :  The given matrix V is updated (postmultiplied)
C                         by the right-hand Givens rotations T.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix U.  M >= 0.
C
C     N       (input) INTEGER
C             The number of rows of the matrix V.  N >= 0.
C
C     I       (input) INTEGER
C             The index of the negligible diagonal entry Q(I) of the
C             bidiagonal matrix J, I <= p.
C
C     K       (input) INTEGER
C             The index of the last diagonal entry of the considered
C             bidiagonal submatrix of J, i.e., E(K-1) is considered
C             negligible, K <= p.
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (p)
C             where p = MIN(M,N).
C             On entry, Q must contain the diagonal entries of the
C             bidiagonal matrix J.
C             On exit, Q contains the diagonal entries of the
C             transformed bidiagonal matrix S' J T.
C
C     E       (input/output) DOUBLE PRECISION array, dimension (p-1)
C             On entry, E must contain the superdiagonal entries of J.
C             On exit, E contains the superdiagonal entries of the
C             transformed bidiagonal matrix S' J T.
C
C     U       (input/output) DOUBLE PRECISION array, dimension (LDU,p)
C             On entry, if UPDATU = .TRUE., U must contain the M-by-p
C             left transformation matrix.
C             On exit, if UPDATU = .TRUE., the Givens rotations S on the
C             left, annihilating E(i) if i < k, have been postmultiplied
C             into U.
C             U is not referenced if UPDATU = .FALSE..
C
C     LDU     INTEGER
C             The leading dimension of the array U.
C             LDU >= max(1,M) if UPDATU = .TRUE.;
C             LDU >= 1        if UPDATU = .FALSE..
C
C     V       (input/output) DOUBLE PRECISION array, dimension (LDV,p)
C             On entry, if UPDATV = .TRUE., V must contain the N-by-p
C             right transformation matrix.
C             On exit, if UPDATV = .TRUE., the Givens rotations T on the
C             right, annihilating E(i-1) if i > 1,  have been
C             postmultiplied into V.
C             V is not referenced if UPDATV = .FALSE..
C
C     LDV     INTEGER
C             The leading dimension of the array V.
C             LDV >= max(1,N) if UPDATV = .TRUE.;
C             LDV >= 1        if UPDATV = .FALSE..
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (MAX(1,LDWORK))
C             LDWORK >= 2*MAX(K-I,I-1),  if UPDATV = UPDATU = .TRUE.;
C             LDWORK >= 2*(K-I), if UPDATU = .TRUE., UPDATV = .FALSE.;
C             LDWORK >= 2*(I-1), if UPDATV = .TRUE., UPDATU = .FALSE.;
C             LDWORK >= 1,       if UPDATU = UPDATV = .FALSE..
C
C     METHOD
C
C     Let the considered bidiagonal submatrix be
C
C               |Q(1) E(1)  0                    ...   0   |
C               | 0   Q(2) E(2)                        .   |
C               | .                                    .   |
C               | .           Q(i-1) E(i-1)            .   |
C          Jk = | .                   Q(i) E(i)        .   |.
C               | .                       Q(i+1) .     .   |
C               | .                              ..    .   |
C               | .                                  E(k-1)|
C               | 0    ...                       ...  Q(k) |
C
C     A zero singular value of Jk manifests itself by a zero diagonal
C     entry Q(i) or in practice, a negligible value of Q(i).
C     When a negligible diagonal element Q(i) in Jk is present, the
C     bidiagonal submatrix Jk is split by the routine into 2 or 3
C     unreduced bidiagonal submatrices by annihilating E(i) (if i < k)
C     using Givens rotations S on the left and by annihilating E(i-1)
C     (if i > 1) using Givens rotations T on the right until Jk is
C     reduced to the form:
C
C               |Q(1) E(1)  0                ...   0   |
C               | 0         .                ...   .   |
C               | .                          ...   .   |
C               | .       Q(i-1) 0                 .   |
C     S' Jk T = | .              0   0             .   |.
C               | .                 Q(i+1)   .     .   |
C               | .                          ..    .   |
C               | .                              E(k-1)|
C               | 0    ...                   ...  Q(k) |
C
C     For more details, see [1, pp.11.12-11.14].
C
C     REFERENCES
C
C     [1] Dongarra, J.J., Bunch, J.R., Moler C.B. and Stewart, G.W.
C         LINPACK User's Guide.
C         SIAM, Philadelphia, 1979.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997.
C     Supersedes Release 2.0 routine MB02BZ by S. Van Huffel, Katholieke
C     University, Leuven, Belgium.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Bidiagonal matrix, orthogonal transformation, singular values.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      LOGICAL           UPDATU, UPDATV
      INTEGER           I, K, LDU, LDV, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), E(*), Q(*), U(LDU,*), V(LDV,*)
C     .. Local Scalars ..
      INTEGER           I1, IROT, L, L1, NROT
      DOUBLE PRECISION  C, F, G, R, S
C     .. External Subroutines ..
      EXTERNAL          DLARTG, DLASR
C     .. Intrinsic Functions ..
      INTRINSIC         MIN
C     .. Executable Statements ..
C
C     For speed, no tests of the input scalar arguments are done.
C
C     Quick return if possible.
C
      IF ( M.LE.0 .OR. N.LE.0 )
     $   RETURN
C
      IF ( I.LE.MIN( M, N ) ) Q(I) = ZERO
C
C     Annihilate E(I) (if I < K).
C
      IF ( I.LT.K ) THEN
         C = ZERO
         S = ONE
         IROT = 0
         NROT = K - I
C
         DO 20 L = I, K-1
            G = E(L)
            E(L) = C*G
            CALL DLARTG( Q(L+1), S*G, C, S, R )
            Q(L+1) = R
            IF ( UPDATU ) THEN
               IROT = IROT + 1
               DWORK(IROT) = C
               DWORK(IROT+NROT) = S
            END IF
   20    CONTINUE
C
         IF ( UPDATU )
     $      CALL DLASR( 'Right', 'Top', 'Forward', M, NROT+1, DWORK(1),
     $                  DWORK(NROT+1), U(1,I), LDU )
      END IF
C
C     Annihilate E(I-1) (if I > 1).
C
      IF ( I.GT.1 ) THEN
         I1 = I - 1
         F  = E(I1)
         E(I1) = ZERO
C
         DO 40 L1 = 1, I1 - 1
            L = I - L1
            CALL DLARTG( Q(L), F, C, S, R )
            Q(L) = R
            IF ( UPDATV ) THEN
               DWORK(L) = C
               DWORK(L+I1) = S
            END IF
            G =  E(L-1)
            F = -S*G
            E(L-1) = C*G
   40    CONTINUE
C
         CALL DLARTG( Q(1), F, C, S, R )
         Q(1) = R
         IF ( UPDATV ) THEN
            DWORK(1) = C
            DWORK(I) = S
            CALL DLASR( 'Right', 'Bottom', 'Backward', N, I, DWORK(1),
     $                  DWORK(I), V(1,1), LDV )
         END IF
      END IF
C
      RETURN
C *** Last line of MB02NY ***
      END


! Demonstrates parametric polymorphism through subroutines-calling-functions.
program squarePoly2
  implicit none
  real :: x
  real :: y

  != unit(m) :: a
  real :: a
  != unit(s) :: b
  real :: b

  call squareP(x, y, a, b)
  call squareP(y, x, b, a)

  contains

  real function square(x)
    real :: x
    square = x * x
  end function

  subroutine squareP(x,y,a,b)
    real :: x, y, a, b
    x = square(a)
    y = square(b)
  end subroutine squareP

end program squarePoly2


module stackops

use, intrinsic:: iso_fortran_env, only: stderr=>error_unit
use global
use assert, only: wp, isclose
use funcs

implicit none (type, external)

interface push_stack
procedure push_stack_r, cpush_stack, rpush_stack
end interface push_stack

interface printx
procedure printx_r, cprintx, rprintx
end interface

complex(wp), parameter, private :: c0 = (0._wp, 0._wp)

contains

!***********************************************************************************************************************************
!  PUSH_STACK
!
!  Push a number onto the real stack.
!***********************************************************************************************************************************

SUBROUTINE PUSH_STACK_r(X)
real(wp), INTENT(IN) :: X

stack = cshift(stack, -1)

STACK(1) = X
END SUBROUTINE PUSH_STACK_r

!***********************************************************************************************************************************
!  push_stack
!
!  Push a number onto the complex stack.
!***********************************************************************************************************************************

SUBROUTINE CPUSH_STACK(X)
COMPLEX(wp), INTENT(IN) :: X

 cstack = cshift(cstack, -1)

 CSTACK(1) = X
END SUBROUTINE CPUSH_STACK

!***********************************************************************************************************************************
!  RPUSH_STACK
!
!  Push a number onto the rational stack.
!***********************************************************************************************************************************

SUBROUTINE RPUSH_STACK(RN,RD)
INTEGER, INTENT(IN) :: RN,RD

rnstack = cshift(rnstack, -1)
rdstack = cshift(rdstack, -1)

RNSTACK(1) = RN
RDSTACK(1) = RD

END SUBROUTINE RPUSH_STACK

!***********************************************************************************************************************************
!  DROP_STACK
!
!  Drop a number from the real stack.
!***********************************************************************************************************************************

SUBROUTINE DROP_STACK(N)
INTEGER, INTENT(IN) :: N

STACK(N:stack_size-1) = STACK(N+1:stack_size)

stack(stack_size) = 0._wp

END SUBROUTINE DROP_STACK

!***********************************************************************************************************************************
!  CDROP_STACK
!
!  Drop a number from the complex stack.
!***********************************************************************************************************************************

SUBROUTINE CDROP_STACK(N)
INTEGER, INTENT(IN) :: N

 CSTACK(N:stack_size-1) = CSTACK(N+1:stack_size)

 Cstack(stack_size) = 0._wp

END SUBROUTINE CDROP_STACK

!***********************************************************************************************************************************
!  RDROP_STACK
!
!  Drop a number from the rational stack.
!***********************************************************************************************************************************

SUBROUTINE RDROP_STACK (N)
INTEGER, INTENT(IN) :: N

RNSTACK(N:stack_size-1) = RNSTACK(N+1:stack_size)
RDSTACK(N:stack_size-1) = RDSTACK(N+1:stack_size)

RNstack(stack_size) = 0
RDstack(stack_size) = 0

END SUBROUTINE RDROP_STACK

!***********************************************************************************************************************************
!  PRINTX
!
!  Print a real number to a string.
!***********************************************************************************************************************************

SUBROUTINE PRINTX_r(X, NUMSTR)

real(wp), INTENT(IN) :: X
CHARACTER(100), INTENT(OUT) :: NUMSTR

real(wp) :: TMPX
CHARACTER(9) :: F1, F2, F3
character(1) :: F

write(F,'(I1)') DISP_DIGITS
F1 ='(4F15.'//F//')'
F2 = '(5ES15.'//F//')'
F3 = '(5EN15.'//F//')'

IF (BASE_MODE == 10) THEN                                                   ! DEC mode
   SELECT CASE (DISP_MODE)
      CASE (1)                                                                ! print X (FIX)
         WRITE (NUMSTR, F1) X
         IF (INDEX(NUMSTR,'*') /= 0)  WRITE(NUMSTR, F2) X

         READ (NUMSTR, *) TMPX
         IF (.not.isclose(x, 0._wp) .AND. isclose(TMPX,0._wp)) WRITE (NUMSTR, F2) X      !   disp. underflow
      CASE (2)                                                                ! print X (SCI)
         WRITE (NUMSTR, F2) X
      CASE (3)                                                                ! print X (ENG)
         WRITE (NUMSTR, F3) X
      CASE (4)                                                                ! print X (ALL)
         WRITE (NUMSTR, '(1PG23.15)') X
   END SELECT
ELSE
   SELECT CASE (BASE_MODE)
      CASE (2)                                                                ! print X (BIN)
         WRITE (NUMSTR, '(B0)') INT(X)
      CASE (8)                                                                ! print X (OCT)
         WRITE (NUMSTR, '(O0)') INT(X)
      CASE (16)                                                               ! print X (HEX)
         WRITE (NUMSTR, '(Z0)') INT(X)
   END SELECT
END IF

END SUBROUTINE PRINTX_r

!***********************************************************************************************************************************
!  CPRINTX
!
!  Print a complex number to a string.
!***********************************************************************************************************************************

      SUBROUTINE CPRINTX (X, NUMSTR)

      COMPLEX(wp), INTENT(IN) :: X
      CHARACTER(LEN=100), INTENT(OUT) :: NUMSTR

      COMPLEX(wp) :: TMPX
      CHARACTER(LEN=100) :: FMTSTR

      IF (BASE_MODE == 10) THEN                                                   ! DEC mode
         SELECT CASE (DISP_MODE)
            CASE (1)                                                                ! print X (FIX)
               WRITE (UNIT=FMTSTR, FMT=800) DISP_DIGITS, DISP_DIGITS
  800          FORMAT ("(ES25.",I0,",SP,4X,F25.",I0,")")
               WRITE (UNIT=NUMSTR, FMT=FMTSTR) REAL(X, WP), AIMAG(X)
               IF (INDEX(NUMSTR,'*') /= 0) THEN                                   !   disp. overflow
                  WRITE (UNIT=FMTSTR, FMT=810)  DISP_DIGITS, DISP_DIGITS
  810             FORMAT ("(EN25.",I0,",SP,4X,ES25.",I0,")")
                  WRITE (UNIT=NUMSTR, FMT=FMTSTR) REAL(X, WP), AIMAG(X)
               END IF
               READ (UNIT=NUMSTR, FMT=*) TMPX
               IF (.not.isclose(x, C0) .AND. isclose(TMPX, C0)) THEN                     !   disp. underflow
                  WRITE (UNIT=FMTSTR, FMT=820) DISP_DIGITS, DISP_DIGITS
  820             FORMAT ("(EN25.",I0,",SP,4X,ES25.",I0,")")
                  WRITE (UNIT=NUMSTR, FMT=FMTSTR) REAL(X, WP), AIMAG(X)
               END IF
            CASE (2)                                                                ! print X (SCI)
               WRITE (UNIT=FMTSTR, FMT=830) DISP_DIGITS, DISP_DIGITS
  830          FORMAT ("(ES25.",I0,",SP,4X,ES25.",I0,")")
               WRITE (UNIT=NUMSTR, FMT=FMTSTR) REAL(X, WP), AIMAG(X)
            CASE (3)                                                                ! print X (ENG)
               WRITE (UNIT=FMTSTR, FMT=840) DISP_DIGITS, DISP_DIGITS
  840          FORMAT ("(EN25.",I0,",SP,4X,ES25.",I0,")")
               WRITE (UNIT=NUMSTR, FMT=FMTSTR) REAL(X, WP), AIMAG(X)
            CASE (4)                                                            ! print X (ALL)
               WRITE (UNIT=FMTSTR, FMT='(A)') '(1PG23.15,SP,4X,G23.15)'
               WRITE (UNIT=NUMSTR, FMT=FMTSTR) REAL(X, WP), AIMAG(X)
         END SELECT
      ELSE
         SELECT CASE (BASE_MODE)
            CASE (2)                                                                ! print X (BIN)
               WRITE (UNIT=FMTSTR, FMT='(A)') '(B0,4X,B0,2H i)'
               WRITE (UNIT=NUMSTR, FMT=FMTSTR) INT(REAL(X, WP)), INT(AIMAG(X))
            CASE (8)                                                                ! print X (OCT)
               WRITE (UNIT=FMTSTR, FMT='(A)') '(O0,4X,O0,2H i)'
               WRITE (UNIT=NUMSTR, FMT=FMTSTR) INT(REAL(X, WP)), INT(AIMAG(X))
            CASE (16)                                                               ! print X (HEX)
               WRITE (UNIT=FMTSTR, FMT='(A)') '(Z0,4X,Z0,2H i)'
               WRITE (UNIT=NUMSTR, FMT=FMTSTR) INT(REAL(X, WP)), INT(AIMAG(X))
         END SELECT
      END IF

      END SUBROUTINE CPRINTX

!***********************************************************************************************************************************
!  RPRINTX
!
!  Print a rational number to a string.
!***********************************************************************************************************************************

SUBROUTINE RPRINTX (RN, RD, NUMSTR)

INTEGER, INTENT(IN) :: RN, RD
CHARACTER(LEN=100), INTENT(OUT) :: NUMSTR
INTEGER :: A1, A2, A3

SELECT CASE (BASE_MODE)
   CASE (2)                                                                   ! print X (BIN)
      IF (RD == 1) THEN
         WRITE (UNIT=NUMSTR, FMT='(B0)') RN
      ELSE
         SELECT CASE (FRACTION_MODE)
            CASE (1)
               WRITE (UNIT=NUMSTR, FMT='(B0,A3,B0)') RN,' / ', RD
            CASE (2)
               CALL FRAC_TO_MIXED (RN, RD, A1, A2, A3)
               WRITE (UNIT=NUMSTR, FMT='(B0,3X,B0,A3,B0)') A1, A2,' / ', A3
         END SELECT
      END IF
   CASE (8)                                                                   ! print X (OCT)
      IF (RD == 1) THEN
         WRITE (UNIT=NUMSTR, FMT='(O0)') RN
      ELSE
         SELECT CASE (FRACTION_MODE)
            CASE (1)
               WRITE (UNIT=NUMSTR, FMT='(O0,A3,O0)') RN, ' / ',RD
            CASE (2)
               CALL FRAC_TO_MIXED (RN, RD, A1, A2, A3)
               WRITE (UNIT=NUMSTR, FMT='(O0,3X,O0,A3,O0)') A1, A2, ' / ', A3
         END SELECT
      END IF
   CASE (10)                                                                  ! print X (DEC)
      IF (RD == 1) THEN
         WRITE (UNIT=NUMSTR, FMT='(I0)') RN
      ELSE
         SELECT CASE (FRACTION_MODE)
            CASE (1)
               WRITE (UNIT=NUMSTR, FMT='(I0,A3,I0)') RN,' / ', RD
            CASE (2)
               CALL FRAC_TO_MIXED (RN, RD, A1, A2, A3)
               WRITE (UNIT=NUMSTR, FMT='(I0,3X,I0,A3,I0)') A1, A2,' / ', A3
         END SELECT
      END IF
   CASE (16)                                                                  ! print X (HEX)
      IF (RD == 1) THEN
         WRITE (UNIT=NUMSTR, FMT='(Z0)') RN
      ELSE
         SELECT CASE (FRACTION_MODE)
            CASE (1)
               WRITE (UNIT=NUMSTR, FMT='(Z0,A3,Z0)') RN,' / ', RD
            CASE (2)
               CALL FRAC_TO_MIXED (RN, RD, A1, A2, A3)
               WRITE (UNIT=NUMSTR, FMT='(Z0,3X,Z0,A3,Z0)') A1, A2,' / ', A3
         END SELECT
      END IF
!         CASE (16)                                                                  ! print X (HEX)
!            IF (RD == 1) THEN
!               WRITE (UNIT=NUMSTR, FMT='(Z0)') RN
!            ELSE
!               WRITE (UNIT=NUMSTR, FMT='(Z0,3H / ,Z0)') RN, RD
!            END IF
END SELECT

END SUBROUTINE RPRINTX

end module stackops


! The Computer Language Benchmarks Game
! http://shootout.alioth.debian.org/
!
! Original C contributed by Sebastien Loisel
! Conversion to C++ by Jon Harrop
! OpenMP parallelize by The Anh Tran
! Add SSE by The Anh Tran
! Reconversion into C by Dan Farina
! Conversion to Fortran by Brian Taylor

program main
!$ use omp_lib
implicit none

character(len=6) :: argv
integer :: n
real*8, allocatable :: u(:), v(:), tmp(:)
integer :: n2, r_begin, r_end
real*8 uv, vv
integer :: i, tid, tcount, chunk, ite

call get_command_argument(1, argv)
read (argv, *) n

n2 = n / 2

allocate(u(0:n-1), v(0:n-1), tmp(0:n-1))

uv = 0.d0
vv = 0.d0

!$omp parallel default(shared) private(i,tid,tcount,chunk,r_begin,r_end)

!$omp do schedule(static)
do i = 0, n - 1
  u(i) = 1.d0
end do

! penguin: convert to single thread version
!tid = omp_get_thread_num()
tid = 0
!tcount = omp_get_num_threads()
tcount = 1
chunk = n / tcount

r_begin = tid * chunk
if (tid < tcount - 1) then
  r_end = r_begin + chunk - 1
else
  r_end = n - 1
end if

do i = 1, 10
  call eval_AtA_times_u(r_begin, r_end, u, v)
  call eval_AtA_times_u(r_begin, r_end, v, u)
end do

!$omp do schedule(static) reduction(+:uv) reduction(+:vv)
do i = 0, n - 1
  uv = uv + u(i) * v(i)
  vv = vv + v(i) * v(i)
end do
!$omp end do nowait

!$omp end parallel

!write (*, "(f0.9)") sqrt(uv / vv)
!penguin: change the format to match with R's (6 digit)
write (*, "(f0.6)") sqrt(uv / vv)

contains

! Return element (i,j) of matrix A
pure function eval_A(i, j)
real*8 :: eval_A
integer, intent(in) :: i, j
real*8 :: di, dj
integer :: d
di = real(i,8)
dj = real(j,8)
eval_A = 1.d0 / (0.5d0 * ((di + dj) * (di + dj + 1.d0)) + di + 1.d0)
end function

subroutine eval_A_times_u(r_begin, r_end, src, dest)
integer, intent(in) :: r_begin, r_end
real*8, intent(in) :: src(0:)
real*8, intent(out) :: dest(0:)
real*8 sum1
integer :: i, j
do i = r_begin, r_end
  sum1 = 0.d0
  do j = 0, n - 1
    sum1 = sum1 + src(j) * eval_A(i, j)
  end do
  dest(i) = sum1
end do
end subroutine

subroutine eval_At_times_u(r_begin, r_end, src, dest)
integer, intent(in) :: r_begin, r_end
real*8, intent(in) :: src(0:)
real*8, intent(out) :: dest(0:)
real*8 sum1
integer :: i, j
do i = r_begin, r_end
  sum1 = 0.d0
  do j = 0, n - 1
    sum1 = sum1 + src(j) * eval_A(j, i)
  end do
  dest(i) = sum1
end do
end subroutine

subroutine eval_AtA_times_u(r_begin, r_end, src, dest)
integer, intent(in) :: r_begin, r_end
real*8, intent(in) :: src(0:)
real*8, intent(out) :: dest(0:)
call eval_A_times_u(r_begin, r_end, src, tmp)
!$omp barrier
call eval_At_times_u(r_begin, r_end, tmp, dest)
!$omp barrier
end subroutine

end program


program main

  use boxlib
  use multifab_module
  use bl_IO_module
  use layout_module
  use init_phi_module
  use write_plotfile_module
  use advance_module
  use define_bc_module

  implicit none

  ! stuff you can set with the inputs file (otherwise use default values below)
  integer :: dim, nsteps, plot_int, n_cell, max_grid_size
  integer :: bc_x_lo, bc_x_hi, bc_y_lo, bc_y_hi, bc_z_lo, bc_z_hi

  ! dummy indices using for reading in inputs file
  integer :: un, farg, narg
  logical :: need_inputs_file, found_inputs_file
  character(len=128) :: inputs_file_name

  integer, allocatable :: phys_bc(:,:)
  integer, allocatable :: lo(:), hi(:)
  integer :: istep,i

  real(dp_t), allocatable :: prob_lo(:), prob_hi(:)
  real(dp_t) :: dx, dt, time, start_time, run_time, run_time_IOproc

  logical, allocatable :: is_periodic(:)

  type(box)      :: bx
  type(boxarray) :: ba
  type(layout)   :: la
  type(multifab) :: phi

  type(bc_tower) :: the_bc_tower

  namelist /probin/ dim, nsteps, plot_int, n_cell, max_grid_size, &
       bc_x_lo, bc_x_hi, bc_y_lo, bc_y_hi, bc_z_lo, bc_z_hi

  ! if running in parallel, this will print out the number of MPI
  ! processes and OpenMP threads
  call boxlib_initialize()

  ! parallel_wtime() returns the number of wallclock-time seconds since
  ! the program began
  start_time = parallel_wtime()

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! default values - will get overwritten by the inputs file

  dim           = 2
  nsteps        = 1000
  plot_int      = 100
  n_cell        = 256
  max_grid_size = 64

  ! allowable options for this example are
  ! -1 = PERIODIC
  ! 12 = OUTLET (dphi/dn=0 at boundary)
  ! 15 = NO_SLIP_WALL (wall with fixed phi=1)
  bc_x_lo       = -1 ! PERIODIC
  bc_x_hi       = -1 ! PERIODIC
  bc_y_lo       = -1 ! PERIODIC
  bc_y_hi       = -1 ! PERIODIC
  bc_z_lo       = -1 ! PERIODIC
  bc_z_hi       = -1 ! PERIODIC

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

  ! read inputs file and overwrite any default values
  narg = command_argument_count()
  need_inputs_file = .true.
  farg = 1
  if ( need_inputs_file .AND. narg >= 1 ) then
     call get_command_argument(farg, value = inputs_file_name)
     inquire(file = inputs_file_name, exist = found_inputs_file )
     if ( found_inputs_file ) then
        farg = farg + 1
        un = unit_new()
        open(unit=un, file = inputs_file_name, status = 'old', action = 'read')
        read(unit=un, nml = probin)
        close(unit=un)
        need_inputs_file = .false.
     end if
  end if

  ! now that we have dim, we can allocate these
  allocate(lo(dim),hi(dim))
  allocate(phys_bc(dim,2))
  allocate(is_periodic(dim))
  allocate(prob_lo(dim),prob_hi(dim))

  ! physical problem is a box on (-1,-1) to (1,1)
  prob_lo(:) = -1.d0
  prob_hi(:) =  1.d0

  ! build a single array to hold domain boundary conditions
  phys_bc(1,1) = bc_x_lo
  phys_bc(1,2) = bc_x_hi
  phys_bc(2,1) = bc_y_lo
  phys_bc(2,2) = bc_y_hi
  if (dim .eq. 3) then
     phys_bc(3,1) = bc_z_lo
     phys_bc(3,2) = bc_z_hi
  end if

  ! build an array indicating periodicity in each direction
  is_periodic(:) = .false.
  do i=1,dim
     if (phys_bc(i,1) .eq. -1 .and. phys_bc(i,2) .ne. -1) then
        call bl_error("Invalid BC's - both lo and hi need to be periodic")
     end if
     if (phys_bc(i,2) .eq. -1 .and. phys_bc(i,1) .ne. -1) then
        call bl_error("Invalid BC's - both lo and hi need to be periodic")
     end if
     if (phys_bc(i,1) .eq. -1 .and. phys_bc(i,2) .eq. -1) then
        is_periodic(i) = .true.
     end if
  end do

  ! create a box from (0,0) to (n_cell-1,n_cell-1)
  lo(:) = 0
  hi(:) = n_cell-1
  bx = make_box(lo,hi)

  ! the grid spacing is the same in each direction
  dx = (prob_hi(1)-prob_lo(1)) / n_cell

  ! initialize the boxarray to be one single box
  call boxarray_build_bx(ba,bx)

  ! overwrite the boxarray to respect max_grid_size
  call boxarray_maxsize(ba,max_grid_size)

  ! build the layout, la
  ! the third argument is the problem domain, which in this case is bx
  call layout_build_ba(la,ba,bx,pmask=is_periodic)

  call destroy(ba)

  ! build boundary conditions
  call bc_tower_init(the_bc_tower,1,dim,phys_bc)
  call bc_tower_level_build(the_bc_tower,1,la)

  ! build multifab with 1 component and 1 ghost cell
  call multifab_build(phi,la,1,1)

  ! initialze phi
  call init_phi(phi,dx,prob_lo,the_bc_tower)

  istep = 0
  time = 0.d0

  ! choose a time step with a diffusive CFL of 0.9
  dt = 0.9d0*dx**2/(2.d0*dim)

  ! write out plotfile 0
  call write_plotfile(la,phi,istep,dx,time,prob_lo,prob_hi)

  do istep=1,nsteps

     ! we only want one processor to write to screen
     if ( parallel_IOProcessor() ) then
        print*,'Advancing time step',istep,'with dt=',dt
     end if

     ! advance phi
     call advance(phi,dx,dt,the_bc_tower)

     time = time + dt

     if (mod(istep,plot_int) .eq. 0 .or. istep .eq. nsteps) then
        ! write out plotfile
        call write_plotfile(la,phi,istep,dx,time,prob_lo,prob_hi)
     end if

  end do

  ! make sure to destroy the multifab or you'll leak memory
  call destroy(phi)
  call destroy(la)
  call bc_tower_destroy(the_bc_tower)

  deallocate(lo,hi,is_periodic,prob_lo,prob_hi)

  ! deallocate temporary boxarrays and communication mappings
  call layout_flush_copyassoc_cache()

  ! check for memory that should have been deallocated
  if ( parallel_IOProcessor() ) then
     print*, 'MEMORY STATS AT END OF PROGRAM'
     print*, ' '
  end if
  call print(multifab_mem_stats(),    "    multifab")
  call print(fab_mem_stats(),         "         fab")
  call print(boxarray_mem_stats(),    "    boxarray")
  call print(layout_mem_stats(),      "      layout")
  call print(boxassoc_mem_stats(),    "    boxassoc")
  call print(fgassoc_mem_stats(),     "     fgassoc")
  call print(syncassoc_mem_stats(),   "   syncassoc")
  call print(copyassoc_mem_stats(),   "   copyassoc")
  call print(fluxassoc_mem_stats(),   "   fluxassoc")

  ! parallel_wtime() returns the number of wallclock-time seconds since
  ! the program began
  run_time = parallel_wtime() - start_time

  ! collect run_time from each processor and store the maximum
  call parallel_reduce(run_time_IOproc, run_time, MPI_MAX, &
                       proc = parallel_IOProcessorNode())

  if ( parallel_IOProcessor() ) then
     print*,"Run time (s) =",run_time_IOproc
  end if

  call boxlib_finalize()

end program main


!==============================================================================
!!
!> @anchor  test_astro
!!
!> @brief   Program for testing transformation mean anomaly to true anomaly and vice versa.
!!		S/R from slam_astro_conversions are used
!!
!> @author  Eduard Gamper (EG)
!!
!> @date

!!
05.01.2015 (initial design)

!!

!!
!> @todo    Implement example for getGMST()\n
!!	    Check s/r setEarthRadius(), setEarthGeopotentialRadius() or setEarthGravity(): No
!!	    Warning message for wrong (too low/high) input\n
!!
!> @details Program for testing transformation mean anomaly to true anomaly and vice versa.
!!		Used equations in functions: Vallado, S.54 eq.2-6, S.56 eq. 2-13, 2-14
!!
!!
!> @copyright Institute of Space Systems / TU Braunschweig
!!
!------------------------------------------------------------------------

program test_astro

use slam_astro
use slam_io, only: slam_message
use slam_error_handling
use slam_types
use slam_orbit_types
use slam_math, only: eps15, pi, twopi

implicit none

real(dp) :: radiusEarth		   	    ! Earth's radius / km (EGM96, EGM2008)
real(dp) :: radiusEarth_egm		    ! Earth's radius / km (EGM96, EGM2008)
real(dp) :: radiusEarth_eigen	    ! Earth's radius / km (EIGEN_GL04C, IAU)
real(dp) :: massofEarth		      	! Earth's mass in kg
real(dp) :: gravityconstantEarth	! gravity constant km^3/s^2
real(dp) :: gravityconstantEarth_new	! gravity constant km^3/s^2
real(dp) :: gravityconstant		    ! gravity constant km^3/s^2
real(dp) :: omegaEarth_default		! Earth's rotational rate rad/s for EGM96, EGM08, EIGEN_GL04C
real(dp) :: omegaEarth_iau		    ! Earth's rotational rate rad/s for IAU
real(dp) :: flattening          	! flattening
real(dp) :: radiussun    		      ! radius of the sun
real(dp) :: eccentricitysquared   ! 2f - f**2
real(dp) :: astronomicalunit		  ! 1 astronomical unit (au)
real(dp) :: LOD				            ! Length of Day
real(dp) :: juliandate			      ! Julian date
real(dp) :: modifiedjuliendate    ! Modified julien date
real(dp) :: tut1			            ! Centuries of JD
real(dp) :: orbitalperiod		      ! Orbital period
real(dp) :: semimajoraxis		      ! Semi major axis
real(dp) :: speedoflight		      ! Speed of light
real(dp) :: AstronomicalUnitInEarthRadii_expected

logical 	:: error = .false.	    ! Error flag

!** Definition of astro constants. Values are the same as in slam_astro but other variable names. Needed for comparison.
radiusEarth_egm = 6378.1363d0
radiusEarth_eigen = 6378.13646d0
gravityconstantEarth = 398600.4415d0
astronomicalunit = 149597870.7d0
gravityconstant = 6.67428d-20
massofEarth = gravityconstantEarth/gravityconstant
LOD = 0.0017230d0 !Example from EOP, 1.1.1962
omegaEarth_default = 7.2921158553d-5
omegaEarth_iau = 7.292115146706979d-5*(1.d0 - LOD/86400.d0)
flattening = 1.d0/298.257223563d0
eccentricitysquared = flattening*(2.d0 - flattening)
radiussun = 696.d3
semimajoraxis = 7100.0d0
orbitalperiod = twopi*sqrt(semimajoraxis**3.d0/gravityconstantEarth)
speedoflight = 299792458.d0
AstronomicalUnitInEarthRadii_expected = astronomicalunit / radiusEarth_eigen ! for default configuration using EIGEN-GL04C

write(*,*) ''

!** Test whether constants are initialized already. At the moment they are not initialized.
if(isAstroInitialized() .neqv. .false.) then
  error = .true.
  CALL slam_message('ERROR: Constants already initialized!',1)
end if

!** Test initAstroConstants(); EGM96=EGM2008 and EIGEN_GL04C=IAU; only Earth radius differs in constants

!** Check Earth radius for different models; EGM96=1, EGM08=2, EIGEN_GL04C=3, IAU=4 are defined in slam_astro
CALL initAstroConstants(EGM96) ! EGM96=1
if (abs(getEarthRadius() - radiusEarth_egm) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR: Deviation in Earth radius (EGM96).',1)
end if
CALL initAstroConstants(EGM08) ! EGM2008 = 2
if (abs(getEarthRadius() - radiusEarth_egm) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR: Deviation in Earth radius (EGM2008).',1)
end if
CALL initAstroConstants(EIGEN_GL04C) ! EIGEN_GL04C = 3; Default
if (abs(getEarthRadius() - radiusEarth_eigen) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR: Deviation in Earth radius (EIGEN_GL04C).',1)
end if
CALL initAstroConstants(IAU) ! IAU = 4; Default
if (abs(getEarthRadius() - radiusEarth_eigen) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR: Deviation in Earth radius (IAU).',1)
end if

!** Test whether constants were initialized.
if(isAstroInitialized() .eqv. .false.) then
  error = .true.
  CALL slam_message('ERROR: Constants not properly initialized!',1)
end if

!** Check astronomical unit
if (abs(getAstronomicalUnit() - astronomicalunit) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR: Deviation in astronomical unit.',1)
end if

!** Check Earth gravity
if (abs(getEarthGravity() - gravityconstantEarth) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR: Deviation in Earth gravity.',1)
end if

!** Check Earth mass
if (abs(getEarthMass() - massofEarth) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR: Deviation in Earth mass.',1)
end if

!** Check geopotential radius
if (abs(getEarthGeopotentialRadius() - radiusEarth_eigen) .gt. eps15) then !Here radiusEarth_eigen is default. In slam astro it depends which Earth radius is initialized.
  error = .true.
  CALL slam_message('ERROR: Deviation in Earth geopotential radius.',1)
end if

!** Check Earth rotation for different models
if (abs(getEarthRotation(LOD, EGM96) - omegaEarth_default) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR: Deviation in Earth rotation (EGM96).',1)
end if
if (abs(getEarthRotation(LOD, EGM08) - omegaEarth_default) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR: Deviation in Earth rotation (EGM2008).',1)
end if
if (abs(getEarthRotation(LOD, EIGEN_GL04C) - omegaEarth_default) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR: Deviation in Earth rotation (EIGEN_GL04C).',1)
end if
if (abs(getEarthRotation(LOD, IAU) - omegaEarth_iau) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR: Deviation in Earth rotation (IAU).',1)
end if
if (abs(getEarthRotation(LOD, 23) - omegaEarth_default) .gt. eps15) then ! Random number (here 23) for default case
  error = .true.
  CALL slam_message('ERROR: Deviation in Earth rotation (default).',1)
end if

!** Check Earth's eccentricity squared
if (abs(getEesqrd() - eccentricitysquared) .gt. eps15) then !Here radiusEarth_eigen is default. In slam astro it depends which Earth radius is initialized.
  error = .true.
  CALL slam_message('ERROR: Deviation in Earth eccentricity squared.',1)
end if

!** Check flattening
if (abs(getFlattening() - flattening) .gt. eps15) then !Here radiusEarth_eigen is default. In slam astro it depends which Earth radius is initialized.
  error = .true.
  CALL slam_message('ERROR: Deviation in flattening.',1)
end if

!** Check GMST !Implement real example!
juliandate = 2448855.009722d0
modifiedjuliendate = juliandate - 2400000.5d0
tut1 = (juliandate - 2451545.d0)/36525.d0
if (abs(mod(4.8949612128d0 + (230121.675315423d0 + (6.77071394d-6 - 4.508767234d-10*tut1)*tut1)*tut1, twopi) - getGMST(modifiedjuliendate)) .gt. eps15) then !Here radiusEarth_eigen is default. In slam astro it depends which Earth radius is initialized.
  error = .true.
  CALL slam_message('ERROR: Deviation in GMST.',1)
end if

!** Check sun radius
if (abs(getSunRadius() - radiussun) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR: Deviation in sun radius.',1)
end if

!** Check orbital period
if (abs(getOrbitalPeriod(semimajoraxis) - orbitalperiod) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR: Deviation in orbital period.',1)
end if

!** Check speed of light
if (abs(getSpeedOfLight() - speedoflight) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR: Deviation in speed of light.',1)
end if

!** Test for setting own Earth gravity.
  !** Test for too wrong (too low) earth gravity --> value must be rejected --> old value should be still valid
gravityconstantEarth_new = 330000.d0
CALL setEarthGravity(gravityconstantEarth_new)
if (abs(getEarthGravity() - gravityconstantEarth) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR in setting Earth gravity (too low value).',1)
end if
  !** Test for appropriate gravity constant --> new value must be valid
gravityconstantEarth_new = 398600.d0
CALL setEarthGravity(gravityconstantEarth_new)
if (abs(getEarthGravity() - gravityconstantEarth_new) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR in setting Earth gravity (appropriate value).',1)
end if

!** Test for setting own Earth radius.
  !** Test for too wrong (too low) Earth radius --> value must be rejected --> old value should be still valid
radiusEarth = 5000.d0
CALL setEarthRadius(radiusEarth)
if (abs(getEarthRadius() - radiusEarth_eigen) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR in setting Earth radius (too low value).',1)
end if
  !** Test for appropriate Earth radius --> new value must be valid
radiusEarth = 6350.d0
CALL setEarthRadius(radiusEarth)
if (abs(getEarthRadius() - radiusEarth) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR in setting Earth radius (appropriate value).',1)
end if

!** Test for setting own Earth's geopotential radius.
  !** Test for too wrong (too low) Earth geopotential radius --> value must be rejected --> old value should be still valid
radiusEarth = 5000.d0
CALL setEarthGeopotentialRadius(radiusEarth)
if (abs(getEarthGeopotentialRadius() - radiusEarth_eigen) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR in setting Earth geopotential radius (too low value).',1)
end if
  !** Test for appropriate Earth geopotential radius --> new value must be valid
radiusEarth = 6350.d0
CALL setEarthGeopotentialRadius(radiusEarth)
if (abs(getEarthGeopotentialRadius() - radiusEarth) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR in setting Earth geopotential radius (appropriate value).',1)
end if

!** Test for getting the AU in earth radii
write(*,*) getAstronomicalUnitInEarthRadii()
write(*,*) AstronomicalUnitInEarthRadii_expected
if (abs(getAstronomicalUnitInEarthRadii() - AstronomicalUnitInEarthRadii_expected) .gt. eps15) then
  error = .true.
  CALL slam_message('ERROR in auer getter(appropriate value).',1)
end if

!** Display conclusion
if (error) then
  CALL slam_message('Some tests failed.',1)
  error = .true.
else
  CALL slam_message('All tests passed.', 1)
end if
write(*,*) ''

end Program test_astro


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 2015 Adrian Martinez Vargas                            %
!                                                                      %
! This software may be modified and distributed under the terms        %
! of the MIT license.  See the LICENSE.txt file for details.           %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
! Junior University.  All rights reserved.                             %
!                                                                      %
! The programs in GSLIB are distributed in the hope that they will be  %
! useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
! responsibility to anyone for the consequences of using them or for   %
! whether they serve any particular purpose or work at all, unless he  %
! says so in writing.  Everyone is granted permission to copy, modify  %
! and redistribute the programs in GSLIB, but only under the condition %
! that this notice and the above copyright notice remain intact.       %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!-----------------------------------------------------------------------
!
! The functions and subroutines below were modified from the
! version 2.0 of the gslib code written in fortran 77
!
! The objective is to add functionality to GSLIB and to link
! this code with python using f2py. It uses f90 code convention.
! The arrays are dynamic and externally declared (from python)
!
! the code was converted from Fortran 77 to Fortran 90 using F2F.pl
!
! for more information please refer to:
! - gslib77 source code: http://www.statios.com/software/gslib77_ls.tar.gz
! - GSLIB: Geostatistical Software Library and User's Guide. Second edition
!   by Clayton V. Deutsch, Andre G. Journel, 1997.
! - F2PY Users Guide: http://docs.scipy.org/doc/numpy-dev/f2py/
! - F2F https://bitbucket.org/lemonlab/f2f
!-----------------------------------------------------------------------

!*********************************************************************************
!     Subroutines in GSLIB (auxiliary functions)
!*********************************************************************************
! include 'setrot.f90'
! include 'cova3.f90'
! include 'getindx.f90'
include 'locate.f90'
! this includes sortem and dsortem
include 'sortem.f90'
include 'acorni.f90'
include 'gauinv.f90'
include 'powint.f90'
include 'gcum.f90'

!***********************************************************************
!
!
!     Subroutines for data transformation (nscore and bactransform)
!
!
!***********************************************************************

subroutine anatbl(va,wt, nd, despike, transin, transout, error)
    !-----------------------------------------------------------------------

    !                Compute Normal Scores transformation table
    !                for gaussian anamorphosis (no weight implemented)
    !                *************************************************

    ! PROGRAM NOTES:

    !   1. Create a transformation table from data or reference distribution
    !   2. This is almost the same to ns_ttable but:
    !         - wight factor: wtfac = 1.0/(twt+1)
    !         - y is calculated upper bin: wt_ns(j) = cp

    ! Version from Adrian martinez Vargas, 2015

    ! TODO: remove tied values ex. z(i+1)-z(i)<eps (see Xavier paper: A disjunctive kriging program for assessing point-support conditional distributions)

    !-----------------------------------------------------------------------

    implicit none

    ! input
    real*8, intent(in), dimension (nd) :: va, wt
    integer, intent(in) :: nd
    integer, optional :: despike   ! warning present(despike) is always true

    ! output
    real*8, intent (out), dimension (nd)  :: transin, transout
    integer, intent(out) :: error

    ! internal
    real*8 :: EPSLON
    real*8 :: ixv (12)
    real*8, dimension (nd) :: vr, wt_ns
    real*8 ::  twt,wtfac,w,cp,vrg,acorni, p
    real :: vrrg
    real*8, dimension(1) :: c,d,e,f,g,h    ! these are dummies for dsortem
    integer :: KORDEI, MAXOP1, i, istart, iend, ierr, j

    if (.NOT. present(despike)) despike= 1   ! we make despiking the default option

    EPSLON=1.0e-4

    do i=1,MAXOP1
        ixv(i) = 0.0
    end do
    ixv(1) = 69069
    do i=1,1000
        p = real(acorni(ixv, KORDEI))
    end do

    ! calculat total wight
    twt=0
    do i=1, nd
        if(wt(nd) <= 1.0e-10) then
               error = 10         ! Wight too small review your data and try again
            return
        end if
        wt_ns(i) = wt(i)

        if (despike>0) then
            vr(i) = va(i) + acorni(ixv, KORDEI)*dble(EPSLON)
        else
            vr(i) = va(i)
        end if
        twt = twt + wt_ns(i)
    end do

    if(nd <= 1 .OR. real(twt) <= EPSLON) then
        error = 100       !'ERROR: too few data'
        return
    endif

    ! Sort data by value:

    istart = 1
    iend   = nd
    call dsortem(istart,iend,vr,1,wt_ns,c,d,e,f,g,h)

    ! Compute the cumulative probabilities and write transformation table

    wtfac = 1.0/(twt+1)
    cp    = 0.0
    do j=istart,iend
        w     =  wtfac*wt_ns(j)
        cp    =  cp + w
        wt_ns(j) = cp
        call gauinv(wt_ns(j),vrrg,ierr)
        vrg = dble(vrrg)
        transin(j) = vr(j)
        transout(j) = vrg
    end do

end subroutine anatbl

!---------------------------------------------------------------------------
!     Subroutine ns_ttable (this one part of the nscore program)
!---------------------------------------------------------------------------
subroutine ns_ttable(va,wt, nd, despike, transin, transout, error)
    !
    ! This code is based on GSLIB nscore
    !
    !-----------------------------------------------------------------------

    !                Compute Normal Scores transformation table
    !                ***********************************

    ! PROGRAM NOTES:

    !   1. Create a transformation table from data or reference distribution

    ! Version from Adrian martinez Vargas, 2015

    !-----------------------------------------------------------------------

    implicit none

    ! input
    real*8, intent(in), dimension (nd) :: va, wt
    integer, intent(in) :: nd
    integer, optional :: despike   ! warning present(despike) is always true

    ! output
    real*8, intent (out), dimension (nd)  :: transin, transout
    integer, intent(out) :: error

    ! internal
    real*8 :: EPSLON
    real*8 :: ixv (12)
    real*8, dimension (nd) :: vr, wt_ns
    real*8 ::  twt,wtfac,w,cp,oldcp,vrg,acorni, p
    real :: vrrg
    real*8, dimension(1) :: c,d,e,f,g,h    ! these are dummies for dsortem
    integer :: KORDEI, MAXOP1, i, istart, iend, ierr, j

    if (.NOT. present(despike)) despike=-1

    EPSLON=1.0e-6

    ! ACORN parameters:
    KORDEI=12 ! this is hard coded... ixv (KORDEI=12)
    MAXOP1 = KORDEI+1

    do i=1,MAXOP1
        ixv(i) = 0.0
    end do
    ixv(1) = 69069
    do i=1,1000
        p = real(acorni(ixv, KORDEI))
    end do

    ! calculat total wight
    twt=0
    do i=1, nd
        if(wt(nd) <= 1.0e-10) then
               error = 10         ! Weight too small review your data and try again
            return
        end if
        wt_ns(i) = wt(i)
        if (despike>0) then
            vr(i) = va(i) + acorni(ixv, KORDEI)*dble(EPSLON)
        else
            vr(i) = va(i)
        end if
        twt = twt + wt_ns(i)
    end do

    if(nd <= 1 .OR. real(twt) <= EPSLON) then
        error = 100       !'ERROR: too few data'
        return
    endif

    ! Sort data by value:

    istart = 1
    iend   = nd
    call dsortem(istart,iend,vr,1,wt_ns,c,d,e,f,g,h)

    ! Compute the cumulative probabilities and write transformation table

    wtfac = 1.0/twt
    oldcp = 0.0
    cp    = 0.0
    do j=istart,iend
        w     =  wtfac*wt_ns(j)
        cp    =  cp + w
        wt_ns(j) = (cp + oldcp)/2.0
        call gauinv(wt_ns(j),vrrg,ierr)
        vrg = dble(vrrg)
        transin(j) = vr(j)
        transout(j) = vrg
        oldcp =  cp
        ! Now, reset the weight to the normal scores value:
        ! wt_ns(j) = vrg
    end do

end subroutine ns_ttable

subroutine nscore(va, nd, transin, transout, nt, getrank , nsc)

    !-----------------------------------------------------------------------

    !                Compute Normal Scores of a Data Set
    !                ***********************************

    ! PROGRAM NOTES:

    !   2. Random Despiking (THIS IS WHY WE NEED A RANDOM NUMBER GENERATOR)

    !-----------------------------------------------------------------------

    implicit none

    ! input
    integer, intent(in) :: nd, nt
    !f2py intent(in,copy) :: transin, transout
    !f2py integer intent(hide),depend(transin) :: nt=shape(transin,0)

    logical, intent(in):: getrank
    real*8, intent (in), dimension (nt) :: transin, transout
    real*8, intent(in), dimension (nd) :: va
    !f2py intent(in,copy) :: va
    !f2py integer intent(hide),depend(va) :: nd=shape(va,0)

    ! output
    real*8, intent(out), dimension(nd):: nsc

    ! internal
    real*8 :: doubone, dpowint
    real*8 :: EPSLON
    real*8 :: ixv (12)
    integer :: KORDEI, MAXOP1, i, j
    real*8 :: vrg,acorni, p, yy, vrr
    real ::  pp, gcum

    doubone=1.0
    EPSLON=1.0e-6

    ! ACORN parameters:
    KORDEI=12 ! this is hard coded... ixv (KORDEI=12)
    MAXOP1 = KORDEI+1

    ! TODO: review this part... ixv was suppose to be in shared memory space (use inout instad?)
    do i=1,MAXOP1
        ixv(i) = 0.0
    end do
    ixv(1) = 69069
    do i=1,1000
        p = real(acorni(ixv, KORDEI))
    end do

    ! Normal Scores Transform:
    do i=1, nd

        vrr = dble(va(i))+acorni(ixv, KORDEI)*dble(EPSLON)

        ! Now, get the normal scores value for "vrr"

        call dlocate(transin,nt,1,nt,vrr,j)
        j   = min(max(1,j),(nd-1))
        vrg = dpowint(transin(j),transin(j+1),transout(j),transout(j+1),vrr,doubone)

        ! Write the rank order instead of the rank?

        if(getrank) then
            pp  = real(vrg)
            yy  = gcum(pp)
            vrg = dble(yy)
        end if

        nsc(i) = vrg

    end do

end subroutine nscore

double precision function tttbacktr(vrgs,nt,vr,vrg,zmin,zmax,ltail,ltpar, utail,utpar)
    !-----------------------------------------------------------------------

    !           Back Transform Univariate Data from Normal Scores
    !           *************************************************

    ! This subroutine backtransforms a standard normal deviate from a
    ! specified back transform table and option for the tails of the
    ! distribution.  Call once with "first" set to true then set to false
    ! unless one of the options for the tail changes.

    ! INPUT VARIABLES:

    !   vrgs             normal score value to be back transformed
    !   nt               number of values in the back transform tbale
    !   vr(nt)           original data values that were transformed
    !   vrg(nt)          the corresponding transformed values
    !   zmin,zmax        limits possibly used for linear or power model
    !   ltail            option to handle values less than vrg(1):
    !   ltpar            parameter required for option ltail
    !   utail            option to handle values greater than vrg(nt):
    !   utpar            parameter required for option utail

    !-----------------------------------------------------------------------

    implicit none

    ! input
    real*8, intent(in), dimension(nt) :: vr, vrg
    real*8, intent(in) ::    ltpar,utpar, vrgs,zmin,zmax
    integer, intent(in) ::   ltail,utail, nt

    ! internal
    real*8 :: cdflo, cdfbt, cpow, cdfhi,lambda, EPSLON, dpowint, dgcum
    integer :: j

    EPSLON=1.0e-20

    ! Value in the lower tail?    1=linear, 2=power, (3 and 4 are invalid):

    if(vrgs <= vrg(1)) then
        tttbacktr = vr(1)
        cdflo  = dgcum(vrg(1))
        cdfbt  = dgcum(vrgs)
        if(ltail == 1) then
            tttbacktr = dpowint(dble(0.0),cdflo,zmin,vr(1),cdfbt,dble(1.0))
        else if(ltail == 2) then
            cpow   = 1.0 / ltpar
            tttbacktr = dpowint(dble(0.0),cdflo,zmin,vr(1),cdfbt,cpow)
        endif

    ! Value in the upper tail?     1=linear, 2=power, 4=hyperbolic:

    else if(vrgs >= vrg(nt)) then
        tttbacktr = vr(nt)
        cdfhi  = dgcum(vrg(nt))
        cdfbt  = dgcum(vrgs)
        if(utail == 1) then
            tttbacktr = dpowint(cdfhi,dble(1.0),vr(nt),zmax,cdfbt,dble(1.0))
        else if(utail == 2) then
            cpow   = 1.0 / utpar
            tttbacktr = dpowint(cdfhi,dble(1.0),vr(nt),zmax,cdfbt,cpow)
        else if(utail == 4) then
            lambda = (vr(nt)**utpar)*(1.0-dgcum(vrg(nt)))
            tttbacktr = (lambda/(1.0-dgcum(vrgs)))**(1.0/utpar)
        endif
    else

    ! Value within the transformation table:

        call dlocate(vrg,nt,1,nt,vrgs,j)
        j = max(min((nt-1),j),1)
        tttbacktr = dpowint(vrg(j),vrg(j+1),vr(j),vr(j+1),vrgs,dble(1.0))
    endif

    return

end function tttbacktr

!---------------------------------------------------------------------------
!     Subroutine bacnscore (this is the bactr program for bac transformation of normal score variables)
!---------------------------------------------------------------------------
subroutine backtr(vnsc, nd, transin, transout, nt, ltail,utail, ltpar,utpar, zmin,zmax, getrank, va, error)
    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    !                                                                      %
    ! Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
    ! Junior University.  All rights reserved.                             %
    !                                                                      %
    ! The programs in GSLIB are distributed in the hope that they will be  %
    ! useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
    ! responsibility to anyone for the consequences of using them or for   %
    ! whether they serve any particular purpose or work at all, unless he  %
    ! says so in writing.  Everyone is granted permission to copy, modify  %
    ! and redistribute the programs in GSLIB, but only under the condition %
    ! that this notice and the above copyright notice remain intact.       %
    !                                                                      %
    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    !-----------------------------------------------------------------------

    !                     Gaussian Back Transformation
    !                     ****************************

    ! PROGRAM NOTES:

    !  1. ltail, utail options: 1=linear interpolation, 2=power model
    !     interpolation, and 4=hyperbolic model interpolation (only for
    !     upper tail)

    ! EXTERNAL REFERENCES:

    !   gcum     Inverse of Gaussian cumulative distribution function
    !   locate   locate a position in an array
    !   dpowint   power law interpolation (real*8)

    !-----------------------------------------------------------------------

    implicit none

    ! input
    integer, intent(in) :: nd, nt
    logical, intent(in) ::  getrank
    integer, intent(in) :: ltail,utail
    real*8,  intent(in) :: ltpar,utpar, zmin,zmax
    real*8, intent(in),   dimension(nd) :: vnsc
    real*8, intent (in), dimension (nt) :: transin, transout
    !kkkf2py intent(in,copy) :: transin, transout,vnsc
    !kkkf2py integer intent(hide),depend(transin) :: nt=shape(transin,0)
    !kkkf2py integer intent(hide),depend(vnsc) :: nd=shape(vnsc,0)

    ! output
    real*8, intent(out), dimension(nd):: va
    integer, intent(out) :: error

    ! internal
    real*8 :: tttbacktr, p, bac
    real*8 :: EPSLON
    integer :: i, ierr

    EPSLON=0.00001

    ! Check for error situation:

    if(ltail /= 1 .AND. ltail /= 2) then
        error = 10 ! 'ERROR invalid lower tail option only allow 1 or 2 - see manual '
        return
    endif
    if(utail /= 1 .AND. utail /= 2 .AND. utail /= 4) then
        error = 11 ! 'ERROR invalid upper tail option, only allow 1,2 or 4 - see manual '
        return
    endif
    if(utail == 4 .AND. utpar < 1.0) then
        error = 12 ! 'ERROR invalid power for hyperbolic tail, must be greater than 1.0!'
        return
    endif

    ! Read in the transformation table:

    do i=1, nt
        if(i > 1) then
            if(transin(i) < transin(i-1) .OR. transout(i) < transout(i-1)) then
                error = 100 ! 'ERROR transformation table must be monotonic increasing! '
                return
            endif
        endif
    end do

    ! Check for error situation:

    if(utail == 4 .AND. transin(nt) <= 0.0) then
        error = 200   ! 'ERROR can not use hyperbolic tail with negative values! - see manual '
        return
    endif
    if(zmin > transin(1)) then
        error = 210   ! 'ERROR zmin should be no larger than the first entry in the transformation table '
        return
    endif
    if(zmax < transin(nt)) then
        error = 220   ! 'ERROR zmax should be no less than the last entry in the transformation table '
        return
    endif

    ! Now do the transformation using tttbacktr function

    do i=1, nd

        if(getrank) then
            p = vnsc(i)
            call dgauinv(p,vnsc(i),ierr)
        end if
        bac = tttbacktr(vnsc(i),nt,transin,transout,zmin,zmax,ltail,ltpar,utail,utpar)
        if(bac < zmin) bac = zmin
        if(bac > zmax) bac = zmax

        va(i)=bac

    end do

    return

end subroutine backtr


module probin
  use pf_mod_dtype

  double precision, parameter :: pi     = 3.141592653589793d0

  integer, parameter :: maxlevs = 3

  integer, save :: wtype

  character(len=64), save :: problem_type, window_type

  double precision, save :: Lx     ! domain size x
  double precision, save :: dt     ! time step
  double precision, save :: Tfin   ! Final time

  double precision, save :: abs_res_tol ! absolute residual tolerance
  double precision, save :: rel_res_tol ! relative residual tolerance

  ! optimization problem parameters
  double precision, save :: alpha        ! regularization parameter
  double precision, save :: tol_grad     ! gradient tolerance, stop optimization if gradient norm below
  double precision, save :: tol_obj      ! objective function tolerance, stop optimization if objective function value below
  integer,          save :: max_opt_iter ! maximum number of optimization iterations
  double precision, save :: max_step_size ! maximum/initial step size for line search (Armijo only; in WP this gets increased); use for experimenting with warm starts

  integer, save :: ndim            ! number of dimensions
  integer, save :: nnodes(maxlevs) ! number of nodes
  integer, save :: nvars(maxlevs)  ! number of grid points
  integer, save :: nsteps          ! number of time steps
  logical, save :: Finterp
  integer, save :: do_imex          ! set to 1 to use imex sweeper, otherwise misdc
  integer, save :: warmstart        ! set to 1 to use previous solution as initialization in state solve
  integer, save :: nsweeps(maxlevs) ! Sweeps at each levels
  integer, save :: nsweeps_pred(maxlevs)   ! Sweeps during predictor
  integer, save :: test_no          ! to distinguish individual test runs
  integer, save :: opt_method       ! 0: steepest descent, 1: Polak-Ribiere nonlinear conjugate gradient
                                    ! 2: Dai-Yuan ncg      3: Fletcher-Reeves ncg
  logical, save :: use_wolfe        ! whether to use strong Wolfe stepsize (if false, use Armijo)
  logical, save :: write_numpy      ! whether to output numpy arrays of control, state, gradient
                                    ! turn off for timing experiments

  character(len=32), save :: pfasst_nml !  file for setting PFASST options
  character(len=20), save :: fbase      !  base name for run
  character(len=64), save :: foutbase   !  base name for output file
  character(len=44) :: foutfoo          !  temp used to create foutbase
  character(len=128), save :: logfile   !  file to use for output of optimization progress
  integer, save    :: poutmod

  character(len=64), save :: output ! directory name for output
  CHARACTER(LEN=255) :: istring     ! stores command line argument
  CHARACTER(LEN=255) :: message     ! use for I/O error messages

  integer :: ios,iostat
  namelist /params/ Finterp, ndim, nnodes, nvars, nsteps
  namelist /params/ pfasst_nml,fbase ,poutmod, output
  namelist /params/ abs_res_tol, rel_res_tol, tol_grad, tol_obj
  namelist /params/ dt, Tfin, Lx, alpha, max_opt_iter
  namelist /params/ do_imex, warmstart, logfile, nsweeps, nsweeps_pred
  namelist /params/ max_step_size, test_no, opt_method, use_wolfe, write_numpy

contains

  subroutine probin_init(filename)
    character(len=*), intent(in) :: filename
    integer :: i
    CHARACTER(len=32) :: arg
    integer :: un

    !
    ! defaults
    !

    Finterp = .FALSE.
    ndim     = 1
    nnodes  = [ 2, 3, 3 ]
    nsteps  = -1

    Lx      = 1._pfdp
    dt      = 0.01_pfdp
    Tfin    = 1.0_pfdp

    abs_res_tol = 0.0
    rel_res_tol = 0.0

    do_imex = 1
    warmstart = 0
    max_opt_iter = 100
    alpha = 0.05
    tol_grad = 1e-6
    tol_obj  = 1e-6
    max_step_size = 1.0

    opt_method = 0
    use_wolfe = .false.
    write_numpy = .true.

    poutmod = 1

    test_no=0
    logfile = "progress.log"

    nsweeps =  [1, 1, 1]
    nsweeps_pred = [1, 1, 1]
    !
    ! read
    !
    !  Read in stuff from a file
    un = 9
    write(*,*) 'opening file ',TRIM(filename), '  for input'
    open(unit=un, file = filename, status = 'old', action = 'read') ! do that with MPI_File_Open?
    read(unit=un, nml = params)
    close(unit=un)

    i = 0
    DO
       CALL get_command_argument(i, arg)
       IF (LEN_TRIM(arg) == 0) EXIT
       if (i > 0) then
          istring="&PARAMS "//TRIM(arg)//" /"
          READ(istring,nml=params,iostat=ios,iomsg=message) ! internal read of NAMELIST
       end if
       i = i+1
    END DO

    !  Reset dt if Tfin is set
    if (Tfin .gt. 0.0) dt = Tfin/nsteps

    output = "Dat/pfasst_V/numpy"

  end subroutine probin_init

end module probin


!##############################################################################
! PROGRAM Plotgraphs
!
! ## How to plot graphs with the plotting functions from the toolbox
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program Plotgraphs

    use toolbox

    implicit none
    real*8 :: x(0:100), y(0:100)
    integer :: i1

    ! Initialize x values
    do i1 = 0, 100
        x(i1) = 1d0/100d0*dble(i1)
    enddo

    ! Calculate plot data
    y = x**2
    call plot(x, y)

    ! execute plot program
    call execplot()

    ! Calculate data for roots
    y = x**(1d0/2d0)

    ! you can specify a legend entry in the plot as follows
    call plot(x, y, legend='square root')

    ! the same for a cubic root
    y = x**(1d0/3d0)
    call plot(x, y, legend='cubic root')

    ! execute plot program and give the plot a title
    call execplot(title='Roots')

    ! plot has many more options that are specified here
    y = x**(1d0/2d0)
    call plot(x, y, color='green', linewidth=3d0, marker=2, &
            markersize=0.7d0,  noline=.false., legend='square root')

    y = x**(1d0/3d0)
    call plot(x, y, color='#5519D6', marker=5, markersize=1.2d0, &
              noline=.true., legend='cubic root')

    call execplot(xlim=(/0d0, 1.1d0/), xticks=0.1d0, &
           xlabel='x-Axis', ylim=(/0d0, 1.4d0/), yticks=0.2d0, &
           ylabel='y-Axis', title='Roots', legend='rs', &
           filename='testplot', filetype='eps', output='testdata')

end program


/* Examples for testing */

 "hello";

lambda x:<a:Bool,b:Bool>. x;

unit;

timesfloat 2.0 3.14159;

let x=true in x;

{x=true, y=false};
{x=true, y=false}.x;
{true, false};
{true, false}.1;

lambda x:Bool. x;
(lambda x:Bool->Bool. if x false then true else false)
  (lambda x:Bool. if x then false else true);

lambda x:Nat. succ x;
(lambda x:Nat. succ (succ x)) (succ 0);

T = Nat->Nat;
lambda f:T. lambda x:Nat. f (f x);

lambda x:A. x;