program test_general_bv
  use mod_orrb
  implicit none

  character(len=40) :: test_name
  character(len=*), parameter :: fmt="(A40, 'Time: ',ES8.2,', ubw: ',I3,', error: ',ES8.2, ', ', A10)"

  real(kind=dp) :: t0, t1
  type(error_info) :: error
  integer(kind=int32) :: na, lbwa, ubwa, j
  real(kind=dp), parameter :: tol=1e-14, c=1.5
  !
  real(kind=dp), dimension(:,:), allocatable :: a_d, a0_d, a1_d
  complex(kind=dp), dimension(:,:), allocatable :: a_z, a0_z, a1_z
  type(d_bv), allocatable :: bv_d
  type(z_bv), allocatable :: bv_z

  call initialize_errors

  print *
  print *, "--------------------------------"
  print *
  print *, "Real BV Decomposition Tests"
  print *

  na=40
  lbwa=3; ubwa=5
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a_d=general(bv_d,error)
  a1_d=a_d
  call cpu_time(t0)
  bv_d=bv(a_d,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_d=general(bv_d,error)
  test_name="Random Real BV;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,bv_d%ubw,t0,t1,c*tol,error)

  na=40
  lbwa=3; ubwa=0
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a_d=general(bv_d,error)
  a1_d=a_d
  call cpu_time(t0)
  bv_d=bv(a_d,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_d=general(bv_d,error)
  test_name="Random Real BV, ubwa=0;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,bv_d%ubw,t0,t1,c*tol,error)

  na=40
  lbwa=3; ubwa=1
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a_d=general(bv_d,error)
  a1_d=a_d
  call cpu_time(t0)
  bv_d=bv(a_d,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_d=general(bv_d,error)
  test_name="Random Real BV, ubwa=1;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,bv_d%ubw,t0,t1,c*tol,error)

  na=1
  lbwa=0; ubwa=0
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a_d=general(bv_d,error)
  a1_d=a_d
  call cpu_time(t0)
  bv_d=bv(a_d,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_d=general(bv_d,error)
  test_name="Random Real BV, na=1;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,bv_d%ubw,t0,t1,c*tol,error)

  na=2
  lbwa=1; ubwa=1
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a_d=general(bv_d,error)
  a1_d=a_d
  call cpu_time(t0)
  bv_d=bv(a_d,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_d=general(bv_d,error)
  test_name="Random Real BV, na=2;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,bv_d%ubw,t0,t1,c*tol,error)

  na=3
  lbwa=1; ubwa=1
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a_d=general(bv_d,error)
  a1_d=a_d
  call cpu_time(t0)
  bv_d=bv(a_d,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_d=general(bv_d,error)
  test_name="Random Real BV, na=3;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,bv_d%ubw,t0,t1,c*tol,error)

  na=4
  lbwa=2; ubwa=2
  bv_d=d_random_bv(na,lbwa,ubwa,error=error)
  a_d=general(bv_d,error)
  a1_d=a_d
  call cpu_time(t0)
  bv_d=bv(a_d,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_d=general(bv_d,error)
  test_name="Random Real BV, na=4;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,bv_d%ubw,t0,t1,c*tol,error)

  na=50
  lbwa=3; ubwa=13
  bv_d=d_random_bv(na,[ (lbwa, j=1,na) ], &
       [ (ubwa, j=1,ubwa-1), (ubwa-1, j=ubwa,na) ], error=error )
  a_d=general(bv_d, error)
  a1_d=a_d
  call cpu_time(t0)
  bv_d=bv(a_d,lbwa,lbwa,ubwa+1,tol, error)
  call cpu_time(t1)
  a0_d=general(bv_d, error)
  test_name="Random Real Square Termination BV;"
  call d_output_result(test_name,a0_d,a1_d,ubwa,bv_d%ubw,t0,t1,c*tol,error)

  print *
  print *, "--------------------------------"
  print *
  print *, "Complex BV Decomposition Tests"
  print *
  na=40
  lbwa=3; ubwa=5
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a_z=general(bv_z,error)
  a1_z=a_z
  call cpu_time(t0)
  bv_z=bv(a_z,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_z=general(bv_z)
  test_name="Random Complex BV;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,bv_z%ubw,t0,t1,c*tol,error)

  na=40
  lbwa=3; ubwa=0
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a_z=general(bv_z,error)
  a1_z=a_z
  call cpu_time(t0)
  bv_z=bv(a_z,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_z=general(bv_z)
  test_name="Random Complex BV, ubwa=0;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,bv_z%ubw,t0,t1,c*tol,error)

  na=40
  lbwa=3; ubwa=1
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a_z=general(bv_z,error)
  a1_z=a_z
  call cpu_time(t0)
  bv_z=bv(a_z,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_z=general(bv_z)
  test_name="Random Complex BV, ubwa=1;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,bv_z%ubw,t0,t1,c*tol,error)

  na=1
  lbwa=0; ubwa=0
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a_z=general(bv_z,error)
  a1_z=a_z
  call cpu_time(t0)
  bv_z=bv(a_z,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_z=general(bv_z,error)
  test_name="Random Complex BV, na=1;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,bv_z%ubw,t0,t1,c*tol,error)

  na=2
  lbwa=1; ubwa=1
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a_z=general(bv_z,error)
  a1_z=a_z
  call cpu_time(t0)
  bv_z=bv(a_z,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_z=general(bv_z,error)
  test_name="Random Complex BV, na=2;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,bv_z%ubw,t0,t1,c*tol,error)

  na=3
  lbwa=1; ubwa=1
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a_z=general(bv_z,error)
  a1_z=a_z
  call cpu_time(t0)
  bv_z=bv(a_z,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_z=general(bv_z,error)
  test_name="Random Complex BV, na=3;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,bv_z%ubw,t0,t1,c*tol,error)

  na=4
  lbwa=2; ubwa=2
  bv_z=z_random_bv(na,lbwa,ubwa,error=error)
  a_z=general(bv_z,error)
  a1_z=a_z
  call cpu_time(t0)
  bv_z=bv(a_z,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_z=general(bv_z,error)
  test_name="Random Complex BV, na=4;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,bv_z%ubw,t0,t1,c*tol,error)

  na=50
  lbwa=3; ubwa=13
  bv_z=z_random_bv(na,[ (lbwa, j=1,na) ], &
       [ (ubwa, j=1,ubwa-1), (ubwa-1, j=ubwa,na) ], error=error )
  a_z=general(bv_z, error)
  a1_z=a_z
  call cpu_time(t0)
  bv_z=bv(a_z,lbwa,lbwa,ubwa+1,tol,error)
  call cpu_time(t1)
  a0_z=general(bv_z,error)
  test_name="Random Complex Square Termination BV;"
  call z_output_result(test_name,a0_z,a1_z,ubwa,bv_z%ubw,t0,t1,c*tol,error)

contains

  subroutine d_output_result(name,a0,a1,ubw0,ubw1,t0,t1,bnd,error)
    character(len=*) :: name
    real(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: ubw0, ubw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (ubw0==ubw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, ubw1, berr, test_result
    end if
  end subroutine d_output_result

  subroutine z_output_result(name,a0,a1,ubw0,ubw1,t0,t1,bnd,error)
    character(len=*) :: name
    complex(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: ubw0, ubw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (ubw0==ubw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, ubw1, berr, test_result
    end if
  end subroutine z_output_result

end program test_general_bv


MODULE PolynomialBasisModuleX_Lagrange

  USE KindModule, ONLY: &
    DP, Zero, One
  USE QuadratureModule, ONLY: &
    InitializeQuadratures, &
    xG1, xG2, xG3, xG4
  USE ProgramHeaderModule, ONLY: &
    nDOFX, nNodesX, nNodes

  IMPLICIT NONE
  PRIVATE

  INTERFACE
    PURE REAL(DP) FUNCTION Basis( x0 )
      USE KindModule, ONLY: DP
      REAL(DP), INTENT(IN) :: x0
    END FUNCTION Basis
  END INTERFACE

  TYPE :: PolynomialBasisType
    PROCEDURE (Basis), POINTER, NOPASS :: P
  END TYPE PolynomialBasisType

  REAL(DP),                  ALLOCATABLE         :: nodes(:,:)
  INTEGER,                   ALLOCATABLE, PUBLIC :: IndLX_Q(:,:)
  TYPE(PolynomialBasisType), ALLOCATABLE, PUBLIC :: L_X1(:), dL_X1(:)
  TYPE(PolynomialBasisType), ALLOCATABLE, PUBLIC :: L_X2(:), dL_X2(:)
  TYPE(PolynomialBasisType), ALLOCATABLE, PUBLIC :: L_X3(:), dL_X3(:)

  PUBLIC :: InitializePolynomialBasisX_Lagrange

CONTAINS

  SUBROUTINE InitializePolynomialBasisX_Lagrange

    CALL InitializeQuadratures

    ALLOCATE( nodes(nNodes,nNodes) )
    CALL InitializeNodes

    ALLOCATE( L_X1(nNodesX(1)), dL_X1(nNodesX(1)) )
    CALL InitializeBasis( L_X1, dL_X1 )

    ALLOCATE( L_X2(nNodesX(2)), dL_X2(nNodesX(2)) )
    CALL InitializeBasis( L_X2, dL_X2 )

    ALLOCATE( L_X3(nNodesX(3)), dL_X3(nNodesX(3)) )
    CALL InitializeBasis( L_X3, dL_X3 )

    ALLOCATE( IndLX_Q(1:3,nDOFX) )
    CALL InitializeIndices_TensorProductBasis

  END SUBROUTINE InitializePolynomialBasisX_Lagrange

  SUBROUTINE InitializeNodes

    SELECT CASE ( nNodes )

      CASE ( 1 )

        CALL SetNodes( xG1 )

      CASE ( 2 )

        CALL SetNodes( xG2 )

      CASE ( 3 )

        CALL SetNodes( xG3 )

      CASE ( 4 )

        CALL SetNodes( xG4 )

      CASE DEFAULT

        WRITE(*,*)
        WRITE(*,*) "  Invalid nNodes  "
        STOP

    END SELECT

  END SUBROUTINE InitializeNodes

  SUBROUTINE SetNodes( x )

    REAL(DP), DIMENSION(nNodes), INTENT(inout) :: x

    INTEGER :: i, j, k

    nodes(nNodes,:) = x

    DO j = 1, nNodes
      k = 1
      DO i = 1, nNodes
        IF( i == j ) CYCLE
        nodes(k,j) = x(i)
        k = k + 1
      END DO
    END DO

  END SUBROUTINE SetNodes

  SUBROUTINE InitializeBasis( P, dP )

    TYPE(PolynomialBasisType), DIMENSION(:) :: P, dP

    SELECT CASE ( SIZE( P ) )

      CASE ( 1 )

        P (1) % P => Unity
        dP(1) % P => Empty

      CASE ( 2 )

        P (1) % P =>  Lagrange_1
        P (2) % P =>  Lagrange_2
        dP(1) % P => dLagrange_1
        dP(2) % P => dLagrange_2

      CASE ( 3 )

        P (1) % P =>  Lagrange_1
        P (2) % P =>  Lagrange_2
        P (3) % P =>  Lagrange_3
        dP(1) % P => dLagrange_1
        dP(2) % P => dLagrange_2
        dP(3) % P => dLagrange_3

      CASE ( 4 )

        P (1) % P =>  Lagrange_1
        P (2) % P =>  Lagrange_2
        P (3) % P =>  Lagrange_3
        P (4) % P =>  Lagrange_4
        dP(1) % P => dLagrange_1
        dP(2) % P => dLagrange_2
        dP(3) % P => dLagrange_3
        dP(4) % P => dLagrange_4

      CASE DEFAULT

        WRITE(*,*)
        WRITE(*,*) "  Invalid Basis Size  "
        STOP

    END SELECT

  END SUBROUTINE InitializeBasis

  SUBROUTINE InitializeIndices_TensorProductBasis

    INTEGER :: i, iNodeX1, iNodeX2, iNodeX3

    i = 0
    DO iNodeX3 = 1, nNodesX(3)
    DO iNodeX2 = 1, nNodesX(2)
    DO iNodeX1 = 1, nNodesX(1)

      i = i + 1

      IndLX_Q(1:3,i) = [ iNodeX1, iNodeX2, iNodeX3 ]

    END DO
    END DO
    END DO

  END SUBROUTINE InitializeIndices_TensorProductBasis

  !***************************************************************************
  !  Elements of Lagrange Polynomial Basis
  !***************************************************************************

  PURE REAL(DP) FUNCTION Unity( x )
    REAL(DP), INTENT(IN) :: x
    Unity = One
    RETURN
  END FUNCTION Unity

  PURE REAL(DP) FUNCTION Lagrange_1( x )
    REAL(DP), INTENT(IN) :: x
    Lagrange_1 = Lagrange( x, nodes(:,1) )
    RETURN
  END FUNCTION Lagrange_1

  PURE REAL(DP) FUNCTION Lagrange_2( x )
    REAL(DP), INTENT(IN) :: x
    Lagrange_2 = Lagrange( x, nodes(:,2) )
    RETURN
  END FUNCTION Lagrange_2

  PURE REAL(DP) FUNCTION Lagrange_3( x )
    REAL(DP), INTENT(IN) :: x
    Lagrange_3 = Lagrange( x, nodes(:,3) )
    RETURN
  END FUNCTION Lagrange_3

  PURE REAL(DP) FUNCTION Lagrange_4( x )
    REAL(DP), INTENT(IN) :: x
    Lagrange_4 = Lagrange( x, nodes(:,4) )
    RETURN
  END FUNCTION Lagrange_4

  PURE REAL(DP) FUNCTION Lagrange( x, xx )

    REAL(DP),                    INTENT(in) :: x
    REAL(DP), DIMENSION(nNodes), INTENT(in) :: xx

    INTEGER :: i

    Lagrange = One
    DO i = 1, nNodes - 1
      Lagrange = Lagrange * ( x - xx(i) ) / ( xx(nNodes) - xx(i) )
    END DO

  END FUNCTION Lagrange

  !***************************************************************************
  !  Derivative of Lagrange Polynomial Basis
  !***************************************************************************

  PURE REAL(DP) FUNCTION Empty( x )

    REAL(DP), INTENT(IN) :: x

    Empty = Zero

  END FUNCTION Empty

  PURE REAL(DP) FUNCTION dLagrange_1( x )

    REAL(DP), INTENT(IN) :: x

    dLagrange_1 = dLagrange( x, nodes(:,1) )

  END FUNCTION dLagrange_1

  PURE REAL(DP) FUNCTION dLagrange_2( x )

    REAL(DP), INTENT(IN) :: x

    dLagrange_2 = dLagrange( x, nodes(:,2) )

  END FUNCTION dLagrange_2

  PURE REAL(DP) FUNCTION dLagrange_3( x )

    REAL(DP), INTENT(IN) :: x

    dLagrange_3 = dLagrange( x, nodes(:,3) )

  END FUNCTION dLagrange_3

  PURE REAL(DP) FUNCTION dLagrange_4( x )

    REAL(DP), INTENT(IN) :: x

    dLagrange_4 = dLagrange( x, nodes(:,4) )

  END FUNCTION dLagrange_4

  PURE REAL(DP) FUNCTION dLagrange( x, xx )

    REAL(DP),                    INTENT(IN) :: x
    REAL(DP), DIMENSION(nNodes), INTENT(IN) :: xx

    INTEGER  :: i, j
    REAL(DP) :: Denominator, Numerator

    Denominator = One
    DO i = 1, nNodes - 1
      Denominator = Denominator * ( xx(nNodes) - xx(i) )
    END DO

    dLagrange = Zero
    DO i = 1, nNodes - 1
      Numerator = One
      DO j = 1, nNodes - 1
        IF( j == i ) CYCLE
        Numerator = Numerator * ( x - xx(j) )
      END DO
      dLagrange = dLagrange + Numerator / Denominator
    END DO

  END FUNCTION dLagrange

END MODULE PolynomialBasisModuleX_Lagrange


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c
c     12/96
c
c     a program for testing all divergence and inverse divergence routines
c
c     (1) first set an irrotational vector field v,w
c
c     (2) compute the coefficients br,bi,cr,ci of (v,w) using vector analysis
c
c     (3) compute the divergence of (v,w) using divec,dives,divgc,divgs
c
c     (4) analystically compute the divergence and compare with (3)
c
c     (5) invert the divergence and compare with the irrotational (v,w)
c
      program tdiv
c
c     set dimensions with parameter statements
c
      parameter(nnlat= 15,nnlon=  9, nnt = 2)
c *** be sure to set
c     mmdb = min0(nlat,(nlon+1)/2), mmdab = min0(nlat,(nnlon+2)/2)
      parameter (mmdab = (nnlon+2)/2, mmdb = (nnlon+1)/2)
      parameter (lleng= 5*nnlat*nnlat*nnlon,llsav=15*nnlat*nnlat*nnlon)
      parameter (lldwork = 4*nnlat*nnlat)
      dimension work(lleng),wsave(llsav)
      dimension br(mmdb,nnlat,nnt),bi(mmdb,nnlat,nnt)
      dimension dwork(lldwork)
      dimension cr(mmdb,nnlat,nnt),ci(mmdb,nnlat,nnt)
      dimension a(mmdab,nnlat,nnt),b(mmdab,nnlat,nnt)
      dimension dv(nnlat,nnlon,nnt)
      dimension thetag(nnlat),dtheta(nnlat),dwts(nnlat)
      dimension v(nnlat,nnlon,nnt),w(nnlat,nnlon,nnt)
      dimension pertrb(nnt)
      double precision dtheta, dwts
c
c     set dimension variables
c
      nlat = nnlat
      nlon = nnlon
      nmax = max0(nlat,nlon)
      mdab = mmdab
      mdb = mmdb

      lwork = lleng
      lsave = llsav
      nt = nnt
      call iout(nlat,"nlat")
      call iout(nlon,"nlon")
      call iout(nt,"  nt")
      isym = 0
      ityp = 0
c
c     set equally spaced colatitude and longitude increments
c
      pi = 4.0*atan(1.0)
      dphi = (pi+pi)/nlon
      dlat = pi/(nlat-1)
c
c     compute nlat gaussian points in thetag
c
      ldwork = lldwork
      call gaqd(nlat,dtheta,dwts,dwork,ldwork,ier)
      do  i=1,nlat
	thetag(i) = dtheta(i)
      end do
      call name("gaqd")
      call iout(ier," ier")
      call vecout(thetag,"thtg",nlat)
c
c     test all divergence and inverse divergence subroutines
c
      do icase=1,4
      call name("****")
      call name("****")
      call iout(icase,"icas")
c
c     set vector field v,w
c
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    x = sint*cosp
	    y = sint*sinp
	    z = cost
	    dxdt = cost*cosp
	    d2xdt2 = -sint*cosp
	    dxdp = -sint*sinp
	    d2xdp2 = -sint*cosp
	    dydt = cost*sinp
	    d2ydt2 = -sint*sinp
	    dydp = sint*cosp
	    d2ydp2 = -sint*sinp
	    dzdt = -sint
	    d2zdt2 = -cost
	    dzdp = 0.0
	    d2zdp2 = 0.0
	    if (k.eq.1) then
	       sf = x*y
	       dsfdt = x*dydt+y*dxdt
	       dsfdp = x*dydp+y*dxdp
	       v(i,j,k) = dsfdt
	       w(i,j,k) = cosp*dydp+sinp*dxdp
c              dv = 1/sint*(d(sint*v)/dt + dw/dp)
	       dvdt = x*d2ydt2 + 2.*dxdt*dydt + y*d2xdt2
c              1/sint*dwdp = 1/sint*(cosp*d2ydp2-sinp*dydp+sinp*d2xdp2+cosp*dxdp)
c                          = -4.*sinp*cosp
	       dv(i,j,k) = dvdt + cost*(cosp*dydt+sinp*dxdt) -4.*cosp*sinp
	    else if (k.eq.2) then
	       sf = x*z
	       dsfdt = x*dzdt+z*dxdt
	       dsfdp = x*dzdp+z*dxdp
	       v(i,j,k) = dsfdt
	       w(i,j,k) = -cost*sinp
	       dvdt = x*d2zdt2+2.*dzdt*dxdt + z*dx2dt2
c              dv = 1/sint*(d(sint*v)/dt + dw/dp)
	       dv(i,j,k) = -6.*cost*sint*cosp
	    else if (k.eq.3) then
	       sf = y*z
	       dsfdt = y*dzdt+z*dydt
	       dsfdp = y*dzdp+z*dydp
	       v(i,j,k) = dsfdt
	       w(i,j,k) = z*cosp
	       dv(i,j,k) = -6.*cost*sint*sinp
	    end if
	  end do
	end do
      end do

c     if (nmax.lt.10) then
c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(v(1,1,kk),"   v",nlat,nlon)
c     call aout(w(1,1,kk),"   w",nlat,nlon)
c     call aout(dv(1,1,kk),"  dv",nlat,nlon)
c     end do
c     end if

      if (icase.eq.1) then

      call name("**ec")
c
c     analyze vector field
c
      call vhaeci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("shs ")
      call iout(ierror,"ierr")

      call vhaec(nlat,nlon,isym,nt,v,w,nlat,nlon,br,bi,cr,ci,mdb,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

cc    if (nmax.lt.10) then
cc    do kk=1,nt
cc    call iout(kk,"**kk")
cc    call aout(br(1,1,kk),"  br",mdb,nlat)
cc    call aout(bi(1,1,kk),"  bi",mdb,nlat)
cc    call aout(cr(1,1,kk),"  cr",mdb,nlat)
cc    call aout(ci(1,1,kk),"  ci",mdb,nlat)
cc    end do
cc    end if
c
c     compute divergence of (v,w) in dv
c

      call shseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("shsi")
      call iout(ierror,"ierr")

      call divec(nlat,nlon,isym,nt,dv,nlat,nlon,br,bi,mdb,nlat,
     +wsave,lsave,work,lwork,ierror)
      call name("div ")
      call iout(ierror,"ierr")
      call iout(nlat,"nlat")
      call iout(nlon,"nlon")

      else if (icase.eq.2) then

      call name("**es")
      call shsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("shsi")
      call iout(ierror,"ierr")

      call dives(nlat,nlon,isym,nt,dv,nlat,nlon,br,bi,mdb,nlat,
     +wsave,lsave,work,lwork,ierror)

      call name("div ")
      call iout(ierror,"ierr")

      else if (icase .eq. 3) then

      call name("**gc")

      call shsgci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("shsi")
      call iout(ierror,"ierr")

      call divgc(nlat,nlon,isym,nt,dv,nlat,nlon,br,bi,mdb,nlat,
     +wsave,lsave,work,lwork,ierror)
      call name("div ")
      call iout(ierror,"ierr")

      else if (icase .eq. 4) then

      call name("**gs")

      call shsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("shsi")
      call iout(ierror,"ierr")

      call divgs(nlat,nlon,isym,nt,dv,nlat,nlon,br,bi,mdb,nlat,
     +wsave,lsave,work,lwork,ierror)
      call name("div ")
      call iout(ierror,"ierr")

      end if

c     if (nmax.lt.10) then
c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(dv(1,1,kk),"  dv",nlat,nlon)
c     end do
c     end if
c
c     compute "error" in dv
c
      err2 = 0.0
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    x = sint*cosp
	    y = sint*sinp
	    z = cost
	    dxdt = cost*cosp
	    d2xdt2 = -sint*cosp
	    dxdp = -sint*sinp
	    d2xdp2 = -sint*cosp
	    dydt = cost*sinp
	    d2ydt2 = -sint*sinp
	    dydp = sint*cosp
	    d2ydp2 = -sint*sinp
	    dzdt = -sint
	    d2zdt2 = -cost
	    dzdp = 0.0
	    d2zdp2 = 0.0
	    if (k.eq.1) then
	       sf = x*y
	       dvdt = x*d2ydt2 + 2.*dxdt*dydt + y*d2xdt2
	       dve = dvdt + cost*(cosp*dydt+sinp*dxdt) - 4.*cosp*sinp
	    else if (k.eq.2) then
c              sf = x*z
	       dve = -6.*sint*cost*cosp
	    else if (k.eq.3) then
c              sf = y*z
	       dve = -6.*cost*sint*sinp
	    end if
	       err2 = err2 + (dv(i,j,k)-dve)**2
	  end do
	end do
      end do
c
c     set and print least squares error in dv
c
      err2 = sqrt(err2/(nt*nlat*nlon))
      call vout(err2,"err2")
c
c     now recompute (v,w) inverting dv using idiv(ec,es,gc,gs)
c
      do kk=1,nt
      do j=1,nlon
      do i=1,nlat
      v(i,j,kk) = 0.0
      w(i,j,kk) = 0.0
      end do
      end do
      end do

      if (icase.eq.1) then

      call name("**ec")

      call shaeci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("shai")
      call iout(ierror,"ierr")

      call shaec(nlat,nlon,isym,nt,dv,nlat,nlon,a,b,
     +mdab,nlat,wsave,lsave,work,lwork,ierror)
      call name("sha ")
      call iout(ierror,"ierr")
      call iout(lsave,"lsav")
      call iout(lwork,"lwrk")

c     if (nmax.lt.10) then
c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(a(1,1,kk),"   a",nlat,nlat)
c     call aout(b(1,1,kk),"   b",nlat,nlat)
c     end do
c     end if

      call vhseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("idvi")
      call iout(ierror,"ierr")

      call idivec(nlat,nlon,isym,nt,v,w,nlat,nlon,a,b,
     +mdab,nlat,wsave,lsave,work,lwork,pertrb,ierror)
      call name("idiv")
      call iout(ierror,"ierr")
      call vecout(pertrb,"prtb",nt)

      else if (icase.eq.2) then

      call name("**es")

      call shaesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("shai")
      call iout(ierror,"ierr")

      call shaes(nlat,nlon,isym,nt,dv,nlat,nlon,a,b,
     +mdab,nlat,wsave,lsave,work,lwork,ierror)
      call name("sha ")
      call iout(ierror,"ierr")
      call iout(lsave,"lsav")
      call iout(lwork,"lwrk")

      call vhsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("idvi")
      call iout(ierror,"ierr")

      call idives(nlat,nlon,isym,nt,v,w,nlat,nlon,a,b,
     +mdab,nlat,wsave,lsave,work,lwork,pertrb,ierror)
      call name("idiv")
      call iout(ierror,"ierr")
      call vecout(pertrb,"prtb",nt)

      else if (icase.eq.3) then

      call name("**gc")

      call shagci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("shai")
      call iout(ierror,"ierr")

      call shagc(nlat,nlon,isym,nt,dv,nlat,nlon,a,b,
     +mdab,nlat,wsave,lsave,work,lwork,ierror)
      call name("sha ")
      call iout(ierror,"ierr")
      call iout(lsave,"lsav")
      call iout(lwork,"lwrk")

      call vhsgci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("idvi")
      call iout(ierror,"ierr")

      call idivgc(nlat,nlon,isym,nt,v,w,nlat,nlon,a,b,
     +mdab,nlat,wsave,lsave,work,lwork,pertrb,ierror)
      call name("idiv")
      call iout(ierror,"ierr")
      call vecout(pertrb,"prtb",nt)

      else if (icase.eq.4) then

      call name("**gs")

      call shagsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("shai")
      call iout(ierror,"ierr")

      call shags(nlat,nlon,isym,nt,dv,nlat,nlon,a,b,
     +mdab,nlat,wsave,lsave,work,lwork,ierror)
      call name("sha ")
      call iout(ierror,"ierr")
      call iout(lsave,"lsav")
      call iout(lwork,"lwrk")

      call vhsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("idvi")
      call iout(ierror,"ierr")

      call idivgs(nlat,nlon,isym,nt,v,w,nlat,nlon,a,b,
     +mdab,nlat,wsave,lsave,work,lwork,pertrb,ierror)
      call name("idiv")
      call iout(ierror,"ierr")
      call vecout(pertrb,"prtb",nt)

      end if

c     if (nmax.lt.10) then
c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(v(1,1,kk),"   v",nlat,nlon)
c     call aout(w(1,1,kk),"   w",nlat,nlon)
c     end do
c     end if

c
c     compare this v,w with original
c
      err2v = 0.0
      err2w = 0.0
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    x = sint*cosp
	    y = sint*sinp
	    z = cost
	    dxdt = cost*cosp
	    dxdp = -sint*sinp
	    dydt = cost*sinp
	    dydp = sint*cosp
	    dzdt = -sint
	    dzdp = 0.0
	    if (k.eq.1) then
	       sf = x*y
	       dsfdt = x*dydt+y*dxdt
	       dsfdp = x*dydp+y*dxdp
	       ve = dsfdt
	       we = cosp*dydp+sinp*dxdp
	    else if (k.eq.2) then
	       sf = x*z
	       dsfdt = x*dzdt+z*dxdt
	       dsfdp = x*dzdp+z*dxdp
	       ve = dsfdt
	       we = -cost*sinp
	    else if (k.eq.3) then
	       sf = y*z
	       dsfdt = y*dzdt+z*dydt
	       dsfdp = y*dzdp+z*dydp
	       ve = dsfdt
	       we = z*cosp
	    else if (k.eq.4) then
	    end if
	    err2v = err2v + (v(i,j,k)-ve)**2
	    err2w = err2w + (w(i,j,k)-we)**2
	  end do
	end do
      end do
      err2v = sqrt(err2v/(nlat*nlon*nt))
      err2w = sqrt(err2w/(nlat*nlon*nt))
      call vout(err2v,"errv")
      call vout(err2w,"errw")

c
c     end of icase loop
c
      end do
      end
c
      subroutine iout(ivar,nam)
      real nam
      write(6,10) nam , ivar
   10 format(1h a4, " = ",i8)
      return
      end
c
      subroutine vout(var,nam)
      real nam
      write(6,10) nam , var
   10 format(1h a4," = ",e12.5)
      return
      end
c
      subroutine name(nam)
      real nam
      write(6,100) nam
  100 format(1h a8)
      return
      end
c
      subroutine vecout(vec,nam,len)
      dimension vec(len)
      real nam
      write(6,109) nam, (vec(l),l=1,len)
  109 format(1h a4,/(1h 8e11.4))
      return
      end


      PROGRAM FTEX03D
C
C  Example of CURVSDP, CURVPSDP.
C
C  Define dimensions, declare arrays.
C
      PARAMETER (IDIM=10,IOUT=201)
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION YS
      DOUBLE PRECISION YSP
      DOUBLE PRECISION TEMP
      DOUBLE PRECISION XO
      DOUBLE PRECISION YO
      DOUBLE PRECISION YOS
      DOUBLE PRECISION YOSP
      DOUBLE PRECISION SIGMA
      DOUBLE PRECISION D
      DOUBLE PRECISION S
      DOUBLE PRECISION EPS
      DOUBLE PRECISION XR
      DOUBLE PRECISION XL
      DOUBLE PRECISION XINC
      DOUBLE PRECISION CURV2DP
      DOUBLE PRECISION P
      DOUBLE PRECISION CURVP2DP
      DIMENSION X(IDIM),Y(IDIM),YS(IDIM),YSP(IDIM),TEMP(IDIM,11)
      DIMENSION XO(IOUT),YOS(IOUT),YOSP(IOUT)
C
C Specify the input data.
C
C
      DATA X/0.000D0,0.210D0,0.360D0,0.540D0,1.000D0,1.500D0,1.970D0,
     +     2.300D0,2.500D0,2.700D0/
      DATA Y/0.000D0,2.600D0,3.000D0,2.500D0,0.000D0,-1.000D0,0.000D0,
     +     0.800D0,0.920D0,0.700D0/
C
C  Call CURVSDP setup.
C
      SIGMA = 1.0D0
      D = 0.3D0
      ISW = 1
      S = DBLE(IDIM)
      EPS = SQRT(2.D0/S)
      CALL CURVSDP(IDIM,X,Y,D,ISW,S,EPS,YS,YSP,SIGMA,TEMP,IERR)
C
C  Call CURVP2DP and calculate the interpolated values and the integrals.
C
      XR = 5.D0
      XL = -1.D0
      XINC = (XR-XL)/ (IOUT-1)
      DO 10 I = 1,IOUT
          XO(I) = XL + (I-1)*XINC
          YOS(I) = CURV2DP(XO(I),IDIM,X,YS,YSP,SIGMA)
   10 CONTINUE
C
C  Call CURVPSDP setup.
C
      P = 3.D0
      CALL CURVPSDP(IDIM,X,Y,P,D,ISW,S,EPS,YS,YSP,SIGMA,TEMP,IERR)
C
C  Call CURVP2DP and calculate the interpolated values.
C
      DO 15 I = 1,IOUT
          YOSP(I) = CURVP2DP(XO(I),IDIM,X,YS,P,YSP,SIGMA)
   15 CONTINUE
C
C This next section plots the data. You must have a double precision
C version of NCAR Graphics in order for this section to compile and
C run correctly.  For now, it is commented out.
C
C  Plot the results.
C
C      CALL DRWFT3(XL,XR,IDIM,X,Y,IOUT,XO,YO,YOS,YOSP)
C
      STOP
      END
C      SUBROUTINE DRWFT3(XL,XR,II,X,Y,IO,XO,YO,YOS,YOSP)
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C      DOUBLE PRECISION XL
C      DOUBLE PRECISION XR
C      DOUBLE PRECISION X
C      DOUBLE PRECISION Y
C      DOUBLE PRECISION XO
C      DOUBLE PRECISION YO
C      DOUBLE PRECISION YOS
C      DOUBLE PRECISION YOSP
C      DOUBLE PRECISION YPOS_TOP
C      DOUBLE PRECISION YB
C      DOUBLE PRECISION YT
C
C      DATA YPOS_TOP/0.95D0/
C
C  Open GKS, open and activate a workstation.
C
C      CALL GOPKS(IERRF,ISZDM)
C      CALL GOPWK(IWKID,LUNIT,IWTYPE)
C      CALL GACWK(IWKID)
C
C  Define a color table.
C
C      CALL GSCR(IWKID,0,1.0D0,1.0D0,1.0D0)
C      CALL GSCR(IWKID,1,0.0D0,0.0D0,0.0D0)
C      CALL GSCR(IWKID,2,1.0D0,0.0D0,0.0D0)
C      CALL GSCR(IWKID,3,0.0D0,1.0D0,0.0D0)
C      CALL GSCR(IWKID,4,0.0D0,0.0D0,1.0D0)
C      CALL GSCLIP(1)
C
C  Graph the interpolated function values and mark the original
C  input data points.
C
C      YB = -2.0D0
C      YT = 4.0D0
C      CALL BKGFT3(XL,XR,YPOS_TOP,'CURVSDP',0.42D0,YB,YT)
C      CALL GRIDAL(6,5,3,1,1,1,10,XL,YB)
C
C  Mark the original data points.
C
C      CALL GSMKSC(2.D0)
C      CALL GSPMCI(4)
C      CALL GPM(II,X,Y)
C
C  Graph the interpolated function values.
C
C      CALL GPL(IO,XO,YOS)
C
C  Graph the periodic function.
C
C      CALL BKGFT3(XL,XR,YPOS_TOP-0.5D0,'CURVPSDP',0.42D0,YB,YT)
C      CALL GRIDAL(6,5,3,1,1,1,10,XL,YB)
C      CALL GPL(IO,XO,YOSP)
C      CALL GSPLCI(1)
C
C  Mark the original data points.
C
C      CALL GSMKSC(2.D0)
C      CALL GSPMCI(4)
C      CALL GPM(II,X,Y)
C
C      CALL FRAME
C
C      CALL GDAWK(IWKID)
C      CALL GCLWK(IWKID)
C      CALL GCLKS
C
C      RETURN
C      END
C      SUBROUTINE BKGFT3(XL,XR,YPOS,LABEL,XLP,YB,YT)
C      DOUBLE PRECISION XL
C      DOUBLE PRECISION XR
C      DOUBLE PRECISION YPOS
C      DOUBLE PRECISION XLP
C      DOUBLE PRECISION YB
C      DOUBLE PRECISION YT
C      DOUBLE PRECISION XX
C      DOUBLE PRECISION YY
C      DIMENSION XX(2),YY(2)
C      CHARACTER*(*) LABEL
C
C      CALL SET(0.D0,1.D0,0.D0,1.D0,0.D0,1.D0,0.D0,1.D0,1)
C      CALL PCSETI('FN',21)
C      CALL PLCHHQ(XLP,YPOS-0.03D0,LABEL,0.025D0,0.D0,-1.D0)
C      CALL SET(0.13D0,0.93D0,YPOS-0.35D0,YPOS,XL,XR,YB,YT,1)
C      XX(1) = XL
C      XX(2) = XR
C      YY(1) = 0.D0
C      YY(2) = 0.D0
C      CALL GSPLCI(2)
C      CALL GPL(2,XX,YY)
C      CALL GSPLCI(1)
C
C      CALL GASETI('LTY',1)
C      CALL PCSETI('FN',21)
C      CALL GASETR('XLS',0.02D0)
C      CALL GASETC('XLF','(F4.1)')
C      CALL GASETR('YLS',0.02D0)
C      CALL GASETC('YLF','(F5.2)')
C      CALL GASETR('XMJ',0.02D0)
C      CALL GASETR('YMJ',0.02D0)
C
C      RETURN
C      END


$ Declare
   SUBROUTINE GeometryFactorY (StressType, a, c, b, W, theta, Y)
!
! According to BS 7910:2005 M.3 Flat plates
! but: g is different en the complete elliptic integral of the second kind is missing.
!
! Parameters
   INTEGER,          INTENT(IN)    :: StressType  ! 1 = Surface flaws membrane loading
                                                  ! 2 = Surface flaws bending loading
   DOUBLE PRECISION, INTENT(IN)    :: a           ! Crack depth
   DOUBLE PRECISION, INTENT(IN)    :: c           ! Crack width
   DOUBLE PRECISION, INTENT(IN)    :: B           ! Plate thickness
   DOUBLE PRECISION, INTENT(IN)    :: W           ! Plate width
   DOUBLE PRECISION, INTENT(IN)    :: theta       ! Angle in radians (0 => c, pi/2 => a)
   DOUBLE PRECISION, INTENT(OUT)   :: Y           ! Geometry factor
!
! Declarations
   DOUBLE PRECISION                :: fw
   DOUBLE PRECISION                :: M
!
! Constants
   DOUBLE PRECISION                :: pi
   pi = 3.14159265358979D0
!
! Calculate stress intensity magnification factor M (is Mm or Mb)
   CALL SIMFactorM (StressType, a, c, B, theta, M)
!
! Factor Fw
   IF (StressType .EQ. 1 .OR. StressType .EQ. 2) THEN
      IF (c/W .LE. 0.4D0) THEN
         fw = DSQRT(1.D0 / DCOS(pi * c / W * DSQRT(a / B)))
      ELSE
         STOP 'Error calculating f_w in Subroutine GeometryFactorY: c/b > 0.4'
      END IF
   ELSE
      STOP 'Error in Subroutine GeometryFactorY: Unknown flaw and stress type'
   END IF
!
! Geometry factor Y
   Y = M * fw
!
! End subroutine
   RETURN
   END


      DOUBLE PRECISION FUNCTION PHO_DORGF(X,S,Al,Be,Ak,Bk,Ag,Bg,C,D,E,
     &   Es)
      IMPLICIT NONE
      DOUBLE PRECISION Ag , Ak , Al , Be , Bg , Bk , C , D , E , Es ,
     &                 lx , S , sx , X
      SAVE

      sx = SQRT(X)
      lx = LOG(1./X)
      PHO_DORGF = (X**Ak*(Ag+Bg*sx+C*X**Bk)
     &            +S**Al*EXP(-E+SQRT(Es*S**Be*lx)))*(1.-X)**D

      END FUNCTION


! setup a grid of rho, T, X.  Call the EOS to get the thermodynamic
! quantities.  Store a plotfile with all the information for checking.
! Then invert the results with the EOS to see if we recover the original
! T (i.e. use the different eos_input_* types).

subroutine varden()

  use BoxLib
  use f2kcli
  use ml_boxarray_module
  use layout_module
  use multifab_module
  use ml_cc_restriction_module
  use bl_mem_stat_module
  use bl_timer_module
  use box_util_module
  use bl_IO_module
  use fabio_module
  use variables
  use probin_module, only: prob_lo, prob_hi, &
                           test_set, pmask, max_levs, &
                           small_temp, &
                           temp_min, temp_max, &
                           dens_min, dens_max, &
                           metalicity_max, &
                           run_prefix
  use runtime_init_module
  use geometry, only: initialize_dx
  use bl_constants_module
  use network
  use eos_module, only: eos_input_rt, eos_input_rh, eos_input_tp, &
                        eos_input_rp, eos_input_re, eos_input_ps, eos, eos_init
  use eos_type_module

  implicit none

  integer :: i, n
  integer :: ii, jj, kk

  integer :: nlevs, dm

  type(ml_layout) :: mla

  type(multifab), allocatable :: s(:)

  real(kind=dp_t), pointer :: sp(:,:,:,:)

  real(kind=dp_t), pointer :: dx(:,:)

  integer, allocatable :: lo(:),hi(:)

  type(ml_boxarray) :: mba

  real(kind=dp_t) :: temp_zone, dens_zone, metalicity
  real(kind=dp_t) :: dlogrho, dlogT, dmetal
  real(kind=dp_t) :: xn_zone(nspec)

  integer :: ih1, ihe4

  type (eos_t) :: eos_state

  ! general Maestro initializations
  call runtime_init()

  ! microphysics
  call network_init()
  call eos_init(small_temp=small_temp)

  ! note: custom variables for this problem
  call init_variables()

  ! setup the grid
  call read_a_hgproj_grid(mba, test_set)

  call ml_layout_build(mla,mba,pmask)

  ! check for proper nesting
  if (.not. ml_boxarray_properly_nested(mla%mba, 3, pmask)) then
     call bl_error('ERROR: fixed_grids not properly nested')
  end if

  ! initialize nlevs
  nlevs = mla%nlevel

  if (nlevs .ne. 1) then
     call bl_error('ERROR: only 1 level of refinement supported')
  end if

  ! initialize dm
  dm = mla%dim

  if (dm /= 3) then
     call bl_error('ERROR: grid must be three-dimensional')
  endif

  ! allocate states
  allocate(s(nlevs))

  do n = 1,nlevs
     call multifab_build(s(n), mla%la(n), nscal, 1)
  end do

  ! initialize_dx
  call initialize_dx(dx,mba,nlevs)

  ! other allocations
  allocate(lo(dm))
  allocate(hi(dm))

  ! density, temperature, and metalicity increments
  dlogrho   = (log10(dens_max) - log10(dens_min))/(extent(mla%mba%pd(1),1) - 1)
  dlogT     = (log10(temp_max) - log10(temp_min))/(extent(mla%mba%pd(1),2) - 1)
  dmetal    = (metalicity_max  - ZERO           )/(extent(mla%mba%pd(1),3) - 1)

  ! initialize the thermodynamic cube and do the initial EOS call
  ih1 = network_species_index('hydrogen-1')
  ihe4 = network_species_index('helium-4')

  do n = 1, nlevs
     do i = 1, nfabs(s(n))

        sp => dataptr(s(n), i)

        lo = lwb(get_box(s(n), i))
        hi = upb(get_box(s(n), i))

        !$OMP PARALLEL DO PRIVATE(ii,jj,kk, metalicity, xn_zone, temp_zone, dens_zone, eos_state)
        do kk = lo(3), hi(3)

           ! set the composition -- approximately solar
           metalicity = ZERO + dble(kk)*dmetal
           xn_zone(:) = metalicity/(nspec - 2)   ! all but H, He
           xn_zone(ih1)  = 0.75_dp_t - HALF*metalicity
           xn_zone(ihe4) = 0.25_dp_t - HALF*metalicity

           do jj = lo(2), hi(2)

              ! set the temperature
              temp_zone = 10.0**(log10(temp_min) + dble(jj)*dlogT)

              do ii = lo(1), hi(1)

                 ! set the density
                 dens_zone = 10.0**(log10(dens_min) + dble(ii)*dlogrho)

                 !------------------------------------------------------------
                 ! call the EOS -- rho, T, X directly
                 ! input: eos_input_rt
                 !------------------------------------------------------------
                 eos_state%T     = temp_zone
                 eos_state%rho   = dens_zone
                 eos_state%xn(:) = xn_zone(:)

                 call eos(eos_input_rt, eos_state)

                 ! store the thermodynamic state
                 sp(ii,jj,kk,rho_comp) = dens_zone
                 sp(ii,jj,kk,rhoh_comp) = dens_zone*eos_state%h
                 sp(ii,jj,kk,temp_comp) = temp_zone
                 sp(ii,jj,kk,spec_comp:spec_comp-1+nspec) = xn_zone(:)

                 sp(ii,jj,kk,h_comp) = eos_state%h
                 sp(ii,jj,kk,p_comp) = eos_state%p
                 sp(ii,jj,kk,e_comp) = eos_state%e
                 sp(ii,jj,kk,s_comp) = eos_state%s

                 !------------------------------------------------------------
                 ! call the EOS with rho, h
                 ! input: eos_input_rh
                 !------------------------------------------------------------

                 ! change initial T guess to make the root find do some work
                 eos_state%T     = HALF*temp_zone
                 eos_state%rho   = dens_zone
                 eos_state%h     = sp(ii,jj,kk,h_comp)
                 eos_state%xn(:) = xn_zone(:)

                 call eos(eos_input_rh, eos_state)

                 ! store the thermodynamic state
                 sp(ii,jj,kk,tfromrh_comp) = eos_state%T
                 sp(ii,jj,kk,tfromrh_err_comp) = &
                      (eos_state%T - temp_zone)/temp_zone

                 !------------------------------------------------------------
                 ! call the EOS with T, p
                 ! input: eos_input_tp
                 !------------------------------------------------------------

                 ! change initial rho guess to make the root find do some work
                 eos_state%T     = temp_zone
                 eos_state%rho   = THIRD*dens_zone
                 eos_state%p     = sp(ii,jj,kk,p_comp)
                 eos_state%xn(:) = xn_zone(:)

                 call eos(eos_input_tp, eos_state)

                 ! store the thermodynamic state
                 sp(ii,jj,kk,rfromtp_comp) = eos_state%rho
                 sp(ii,jj,kk,rfromtp_err_comp) = &
                      (eos_state%rho - dens_zone)/dens_zone

                 !------------------------------------------------------------
                 ! call the EOS with rho, p
                 ! input: eos_input_rp
                 !------------------------------------------------------------

                 ! change initial T guess to make the root find do some work
                 eos_state%T     = HALF*temp_zone
                 eos_state%rho   = dens_zone
                 eos_state%p     = sp(ii,jj,kk,p_comp)
                 eos_state%xn(:) = xn_zone(:)

                 call eos(eos_input_rp, eos_state)

                 ! store the thermodynamic state
                 sp(ii,jj,kk,tfromrp_comp) = eos_state%T
                 sp(ii,jj,kk,tfromrp_err_comp) = &
                      (eos_state%T - temp_zone)/temp_zone

                 !------------------------------------------------------------
                 ! call the EOS with rho, e
                 ! input: eos_input_re
                 !------------------------------------------------------------

                 ! change initial T guess to make the root find do some work
                 eos_state%T     = HALF*temp_zone
                 eos_state%rho   = dens_zone
                 eos_state%e     = sp(ii,jj,kk,e_comp)
                 eos_state%xn(:) = xn_zone(:)

                 call eos(eos_input_re, eos_state)

                 ! store the thermodynamic state
                 sp(ii,jj,kk,tfromre_comp) = eos_state%T
                 sp(ii,jj,kk,tfromre_err_comp) = &
                      (eos_state%T - temp_zone)/temp_zone

                 !------------------------------------------------------------
                 ! call the EOS with p, s
                 ! input: eos_input_ps
                 !------------------------------------------------------------

                 ! change initial T and rho guess to make the root find do
                 ! some work
                 eos_state%T     = HALF*temp_zone
                 eos_state%rho   = HALF*dens_zone
                 eos_state%p     = sp(ii,jj,kk,p_comp)
                 eos_state%s     = sp(ii,jj,kk,s_comp)
                 eos_state%xn(:) = xn_zone(:)

                 ! some EOSes don't have physically valid treatments
                 ! of entropy throughout the entire rho-T plane
                 if (eos_state%s > ZERO) then

                    call eos(eos_input_ps, eos_state)

                    ! store the thermodynamic state
                    sp(ii,jj,kk,tfromps_comp) = eos_state%T
                    sp(ii,jj,kk,tfromps_err_comp) = &
                         (eos_state%T - temp_zone)/temp_zone

                 else
                    sp(ii,jj,kk,tfromps_comp) = ZERO
                    sp(ii,jj,kk,tfromps_err_comp) = ZERO

                 endif

              enddo
           enddo
        enddo
        !$OMP END PARALLEL DO

     enddo
  enddo

  ! write out a plotfile that contains the magnitude of the velocity
  ! field
  call fabio_ml_multifab_write_d(s,mla%mba%rr(:,1), &
                                 trim(run_prefix) // "eos_thermo", &
                                 names=varnames)

  ! clean-up
  do n = 1,nlevs
     call destroy(s(n))
  end do

  call destroy(mla)
  call destroy(mba)

  deallocate(s)

  call runtime_close()

end subroutine varden


program P13116
    implicit none
    integer :: t, a, b
    read *, t
    do while (t > 0)
        read *, a, b
        do while (a /= b)
            if (a > b) then
                a = rshift(a, 1)
            else
                b = rshift(b, 1)
            end if
        end do
        write (*, '(I0)') a * 10
        t = t - 1
    end do
end program P13116


program main
	parameter(msize=1000)
	real(kind=8), allocatable :: a(:,:),b(:,:),c(:,:)

	allocate (a(msize,msize), b(msize,msize), c(msize,msize), stat=istat)
	if (istat.ne.0) then
	    stop "*** Allocate() failed."
	endif
	n=msize

    !!	ninit=10
    !!	call f_pm_initialize (ninit)

    !!	call f_pm_start ("A:subinit2d")
	call subinit2d (msize,n,a,b,c)
    !!	call f_pm_stop ("A:subinit2d")

    !!	call f_pm_start ("B:submxm2d")
	call submxm2d (msize,n,dflop,a,b,c)
    !!	call f_pm_stop ("B:submxm2d")

    !!	call f_pm_report ("")
	write(*,*)  'something was computed', c(msize,msize)

	stop
end program

subroutine subinit2d (msize,n,a,b,c)
	real(kind=8) :: a(msize,msize), b(msize,msize), c(msize,msize)
	!!  !$omp parallel do
	do j=1, n
	do i=1, n
	a(i,j)=sin(real(i)/real(n))
	b(i,j)=cos(real(i)/real(n))
	end do
	end do
	return
end subroutine

subroutine submxm2d (msize,n,dflop,a,b,c)
	real(kind=8) :: a(msize,msize), b(msize,msize), c(msize,msize)
	real(kind=8) :: x

	dflop=2.0*dble(n)**3
	!!  !$omp parallel do private(i,j,k,x)
	do j=1, n
	do i=1, n
	x=0
	do k=1, n
	x=x+a(i,k)*b(k,j)
	end do
	c(i,j) = x
	end do
	end do
	return
end subroutine


      double precision function dot(n,x1,inc1,x2,inc2)
c  computes dot product of two d.p. vectors with nonunit
c  incrementing allowed. replacement for blas subroutine sdot.
      implicit double precision (a-h,o-z)
      dimension x1(1),x2(1)
      if(inc2.gt.0)then
        k=1
      else
        k=n*abs(inc2)
      endif
      dot=0.0
      if(inc1.gt.0)then
        do 10 i=1,n,inc1
          dot=dot+x1(i)*x2(k)
          k=k+inc2
   10   continue
      else
        do 20 i=n,1,inc1
          dot=dot+x1(i)*x2(k)
          k=k+inc2
   20   continue
      endif
      return
      end

c $Id$


!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief This module provides a subroutine to find the eigenvalues and eigenvectors
!! of a symmetric tridiagonal matrix by the ql method.
module m_fstr_EIG_tridiag
  use hecmw

  implicit none

  public

  type fstr_eigen_vec
    real(kind=kreal), pointer :: q(:) => null()
  end type fstr_eigen_vec

  type fstr_tri_diag
    real(kind=kreal), allocatable :: alpha(:)
    real(kind=kreal), allocatable :: beta(:)
  end type fstr_tri_diag

contains

  subroutine tridiag(hecMESH, hecMAT, fstrEIG, Q, Tri, iter, is_converge)
    use hecmw
    use m_fstr
    use m_fstr_EIG_lanczos_util
    implicit none
    type(hecmwST_local_mesh) :: hecMESH
    type(hecmwST_matrix)     :: hecMAT
    type(fstr_eigen)         :: fstrEIG
    type(fstr_tri_diag)      :: Tri
    type(fstr_eigen_vec), pointer :: Q(:)

    integer(kind=kint), intent(in) :: iter
    integer(kind=kint) :: N, NP, NDOF, NNDOF, NPNDOF
    integer(kind=kint) :: i, j, k, in, jn, kn, nget
    integer(kind=kint) :: iter2, ierr, maxiter
    real(kind=kreal)   :: resid, chk, sigma, tolerance, max_eigval
    real(kind=kreal), allocatable :: alpha(:), beta(:), temp(:)
    real(kind=kreal), allocatable :: L(:,:)

    integer(kind=kint), allocatable :: iparm(:)
    real(kind=kreal), pointer       :: eigvec(:,:)
    real(kind=kreal), pointer       :: eigval(:)
    logical :: is_converge

    N      = hecMAT%N
    NP     = hecMAT%NP
    NDOF   = hecMESH%n_dof
    NNDOF  = N *NDOF
    NPNDOF = NP*NDOF
    eigval => fstrEIG%eigval
    eigvec => fstrEIG%eigvec
    nget      = fstrEIG%nget
    maxiter   = fstrEIG%maxiter
    tolerance = fstrEIG%tolerance

    allocate( iparm(maxiter) )
    allocate( temp(maxiter)  )
    allocate( alpha(iter)    )
    allocate( beta(iter)     )
    allocate( L(iter, iter)  )

    do j=1, iter
      do i = 1,iter
        L(i,j)  = 0.0d0
      enddo
    enddo

    do i=1, iter
      alpha(i) = Tri%alpha(i)
      L(i,i)   = 1.0d0
    enddo

    beta(1) = 0.0d0
    do i=2, iter
      beta(i) = Tri%beta(i)
    enddo

    call QL_decomposition(iter, iter, alpha, beta, L, ierr)

    is_converge = .true.
    chk = 0.0d0
    max_eigval = maxval(alpha)
    do i = 1, min(nget, iter)
      resid = dabs(Tri%beta(iter+1)*L(iter,i))/max_eigval
      chk = max(chk, resid)
      if(tolerance < resid) is_converge = .false.
    enddo
    if(myrank == 0) write(*,"(i8,1pe12.5)")iter, chk

    if(iter < nget) is_converge = .false.
    if(iter == maxiter-1) is_converge = .true.

    if(is_converge)then
      sigma = 0.0d0
      if(fstrEIG%is_free) sigma = fstrEIG%sigma
      do i = 1, iter
        if(alpha(i) /= 0.0d0)then
          eigval(i) = 1.0d0/alpha(i) + sigma
        endif
      enddo

      call evsort(eigval, iparm, iter)

      temp = eigval

      eigvec = 0.0d0
      do k=1, iter
        in = iparm(k)
        eigval(k) = temp(in)
        do j=1, iter
          do i=1, NPNDOF
            eigvec(i, k) = eigvec(i, k) + Q(j)%q(i) * L(j, in)
          enddo
        enddo
      enddo

      do j=1, iter
        chk = maxval(eigvec(:,j))
        call hecmw_allreduce_R1(hecMESH, chk, hecmw_max)
        if(chk /= 0.0d0)then
          chk = 1.0d0/chk
          do i = 1, NNDOF
            eigvec(i,j) = eigvec(i,j) * chk
          enddo
        endif
      enddo
    endif

    deallocate(iparm)
    deallocate(temp)
    deallocate(alpha)
    deallocate(beta)
    deallocate(L)
  end subroutine tridiag

  !======================================================================!
  !                       Description                                    !
  !======================================================================!
  !>This subroutine has been adapted from the eispack routine tql2, which is
  !!a translation of the algol procedure tql2, num. math. 11, 293-306(1968)
  !!by bowdler, martin, reinsch and wilkinson.
  !!Handbook for auto. cop., vol.ii-linear algebra, 227-240(1971).
  !!This subroutine finds the eigenvalues and eigenvectors
  !!of a symmetric tridiagonal matrix by the ql method.
  !!the eigenvectors of a full symmetric matrix can also
  !!be found if  tred2  has been used to reduce this
  !!full matrix to tridiagonal form.
  !
  !on input
  !
  !nm must be set to the row dimension of two-dimensional
  !array parameters as declared in the calling program
  !dimension statement.
  !
  !is the order of the matrix.
  !
  !contains the diagonal elements of the input matrix.
  !
  !contains the subdiagonal elements of the input matrix
  !in its last n-1 positions.  e(1) is arbitrary.
  !
  !contains the transformation matrix produced in the
  !reduction by  tred2, if performed.  if the eigenvectors
  !of the tridiagonal matrix are desired, z must contain
  !the identity matrix.
  !
  !on output
  !
  !d
  !contains the eigenvalues in ascending order.  if an
  !error exit is made, the eigenvalues are correct but
  !unordered for indices 1,2,...,ierror-1.
  !-----------------------------------------------------
  !GP
  !du
  !contains the unordered eigenvalues.  if an
  !error exit is made, the eigenvalues are correct and
  !unordered for indices 1,2,...,ierror-1.
  !-----------------------------------------------------
  !e
  !has been destroyed.
  !
  !z
  !contains orthonormal eigenvectors of the symmetric
  !tridiagonal (or full) matrix.  if an error exit is made,
  !z contains the eigenvectors associated with the stored
  !eigenvalues.
  !-----------------------------------------------------
  !zu
  !contains unordered eigenvectors of the symm. tridiag. matrix
  !-----------------------------------------------------
  !ierror is set to
  !  zero       for normal return,
  !  j          if the j-th eigenvalue has not been
  !             determined after 30 iterations.
  !
  !calls a2b2 for  dsqrt(a*a + b*b) .
  !=======================================================================

  !call QL_decomposition(iter, iter, alpha, beta, L, ierr)
  subroutine QL_decomposition(nm, n, d, e, z, ierror)
    use hecmw
    implicit none
    integer(kind=kint) :: i, j, k, l, m, n, ii, l1, l2, nm, mml, ierror
    real(kind=kreal)   :: d(n), e(n), z(nm, n)
    real(kind=kreal)   :: c, c2, c3, dl1, el1, f, g, h, p, r, s, s2, tst1, tst2

    ierror = 0
    if (n .eq. 1) go to 1001

    do i = 2, n
      e(i-1) = e(i)
    enddo

    f = 0.0d0
    tst1 = 0.0d0
    e(n) = 0.0d0

    do 240 l = 1, n
      j = 0
      h = dabs(d(l)) + dabs(e(l))
      if (tst1 .lt. h) tst1 = h
      !     .......... look for small sub-diagonal element ..........
      bb:do m = l, n
        tst2 = tst1 + dabs(e(m))
        if (tst2 .eq. tst1) exit bb
        !     .......... e(n) is always zero, so there is no exit
        !                through the bottom of the loop ..........
      enddo bb

      if (m .eq. l)  go to 220

      130    if (j .eq. 30) go to 1000
      j = j + 1
      !     .......... form shift ..........
      l1 = l + 1
      l2 = l1 + 1
      g = d(l)
      p = (d(l1) - g) / (2.0d0 * e(l))
      r = a2b2(p,1.0d0)
      d(l) = e(l) / (p + dsign(r,p))
      d(l1) = e(l) * (p + dsign(r,p))
      dl1 = d(l1)
      h = g - d(l)
      if (l2 .gt. n) go to 145

      do i = l2, n
        d(i) = d(i) - h
      enddo

      145    f = f + h
      !     .......... ql transformation ..........
      p = d(m)
      c = 1.0d0
      c2 = c
      el1 = e(l1)
      s = 0.0d0
      s2 = 0.0d0
      c3 = 0.0d0
      mml = m - l
      !     .......... for i=m-1 step -1 until l do -- ..........
      do ii = 1, mml
        c3 = c2
        c2 = c
        s2 = s
        i = m - ii
        g = c * e(i)
        h = c * p
        r = a2b2(p,e(i))
        e(i+1) = s * r
        s = e(i) / r
        c = p / r
        p = c * d(i) - s * g
        d(i+1) = h + s * (c * g + s * d(i))
        !     .......... form vector ..........
        do k = 1, n
          h = z(k,i+1)
          z(k,i+1) = s * z(k,i) + c * h
          z(k,i) = c * z(k,i) - s * h
        enddo
      enddo

      p = -s * s2 * c3 * el1 * e(l) / dl1
      e(l) = s * p
      d(l) = c * p
      tst2 = tst1 + dabs(e(l))
      if (tst2 .gt. tst1) go to 130
      220    d(l) = d(l) + f
      240 continue

      !     .......... order eigenvalues and eigenvectors ..........
      !GP: Get unordered eigenvalues and eigenvectors----------------

      do 300 ii = 2, n
        i = ii - 1
        k = i
        p = d(i)

        aa:do j = ii, n
          if (d(j) .ge. p) exit aa
          k = j
          p = d(j)
        enddo aa

        if (k .eq. i) go to 300
        d(k) = d(i)
        d(i) = p

        do j = 1, n
          p = z(j,i)
          z(j,i) = z(j,k)
          z(j,k) = p
        enddo

        300 continue

        go to 1001
        !     .......... set error -- no convergence to an
        !                eigenvalue after 30 iterations ..........
        1000 ierror = l
        1001 return
  end subroutine QL_decomposition

  function a2b2(a,b)
    use hecmw
    implicit none

    real(kind=kreal) :: a2b2
    real(kind=kreal) :: a, b
    real(kind=kreal) :: p, q, r, s, t, u

    p = dmax1(dabs(a), dabs(b))
    if (p /= 0.0d0) then
      r = (dmin1(dabs(a),dabs(b))/p) ** 2
      do
        t = 4.0d0 + r
        if (t == 4.0d0) exit
        s = r/t
        u = 1.0d0 + 2.0d0*s
        p = u * p
        q = s/u
        r = q * q * r
      end do
    end if
    a2b2 = p
    return

  end function a2b2

end module m_fstr_EIG_tridiag


! This file is part of mctc-lib.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

module test_math
   use mctc_env_accuracy, only : wp
   use mctc_env_testing, only : new_unittest, unittest_type, error_type, check
   use mctc_io_math
   implicit none
   private

   public :: collect_math

   real(wp), parameter :: thr = sqrt(epsilon(1.0_wp))

contains

!> Collect all exported unit tests
subroutine collect_math(testsuite)

   !> Collection of tests
   type(unittest_type), allocatable, intent(out) :: testsuite(:)

   testsuite = [ &
      & new_unittest("valid-eigval", test_eigval), &
      & new_unittest("valid-eigvec", test_eigvec), &
      & new_unittest("valid-matdet", test_matdet), &
      & new_unittest("valid-matinv", test_matinv) &
      & ]

end subroutine collect_math

subroutine test_matdet(error)

   !> Error handling
   type(error_type), allocatable, intent(out) :: error

   real(wp) :: mat(3, 3), det

   mat = reshape(&
      & [2.0_wp, 1.0_wp, 3.0_wp, 1.0_wp, 3.0_wp, 0.0_wp, 3.0_wp, 0.0_wp, 4.0_wp], &
      & shape(mat))

   det = matdet_3x3(mat)

   call check(error, det, -7.0_wp, thr=thr)

end subroutine test_matdet

subroutine test_matinv(error)

   !> Error handling
   type(error_type), allocatable, intent(out) :: error

   real(wp) :: mat(3, 3), inv(3, 3)

   mat = reshape(&
      & [2.0_wp, 1.0_wp, 3.0_wp, 1.0_wp, 3.0_wp, 0.0_wp, 3.0_wp, 0.0_wp, 4.0_wp], &
      & shape(mat))

   inv = matinv_3x3(mat)

   mat = matmul(mat, inv)

   call check(error, mat(1, 1), 1.0_wp, thr=thr)
   if (allocated(error)) return
   call check(error, mat(2, 2), 1.0_wp, thr=thr)
   if (allocated(error)) return
   call check(error, mat(3, 3), 1.0_wp, thr=thr)
   if (allocated(error)) return
   call check(error, mat(1, 2), 0.0_wp, thr=thr)
   if (allocated(error)) return
   call check(error, mat(1, 3), 0.0_wp, thr=thr)
   if (allocated(error)) return
   call check(error, mat(2, 3), 0.0_wp, thr=thr)
   if (allocated(error)) return

end subroutine test_matinv

subroutine test_eigval(error)

   !> Error handling
   type(error_type), allocatable, intent(out) :: error

   real(wp) :: mat(3, 3), eval(3)

   mat = reshape(&
      & [2.0_wp, 1.0_wp, 3.0_wp, 1.0_wp, 3.0_wp, 0.0_wp, 3.0_wp, 0.0_wp, 4.0_wp], &
      & shape(mat))

   call eigval_3x3(mat, eval)

   call check(error, eval(1),-0.3611775878183057_wp, thr=thr)
   if (allocated(error)) return
   call check(error, eval(2), 3.0909775466663136_wp, thr=thr)
   if (allocated(error)) return
   call check(error, eval(3), 6.2702000411519920_wp, thr=thr)
   if (allocated(error)) return

end subroutine test_eigval

subroutine test_eigvec(error)

   !> Error handling
   type(error_type), allocatable, intent(out) :: error

   real(wp) :: mat(3, 3), eval(3), evec(3, 3)

   mat = reshape(&
      & [2.0_wp, 1.0_wp, 3.0_wp, 1.0_wp, 3.0_wp, 0.0_wp, 3.0_wp, 0.0_wp, 4.0_wp], &
      & shape(mat))

   call eigvec_3x3(mat, eval, evec)

   call check(error, eval(1),-0.3611775878183057_wp, thr=thr)
   if (allocated(error)) return
   call check(error, eval(2), 3.0909775466663136_wp, thr=thr)
   if (allocated(error)) return
   call check(error, eval(3), 6.2702000411519920_wp, thr=thr)
   if (allocated(error)) return

   call check(error, evec(1, 1), 0.80020375200069072_wp, thr=thr)
   if (allocated(error)) return
   call check(error, evec(2, 1),-0.23807244071268843_wp, thr=thr)
   if (allocated(error)) return
   call check(error, evec(3, 1),-0.55045024139982024_wp, thr=thr)
   if (allocated(error)) return
   call check(error, evec(1, 2), 0.08680581175113650_wp, thr=thr)
   if (allocated(error)) return
   call check(error, evec(2, 2), 0.95414544502416110_wp, thr=thr)
   if (allocated(error)) return
   call check(error, evec(3, 2),-0.28648075116117611_wp, thr=thr)
   if (allocated(error)) return
   call check(error, evec(1, 3), 0.59341276219023387_wp, thr=thr)
   if (allocated(error)) return
   call check(error, evec(2, 3), 0.18146069192182893_wp, thr=thr)
   if (allocated(error)) return
   call check(error, evec(3, 3), 0.78417683653434167_wp, thr=thr)
   if (allocated(error)) return

end subroutine test_eigvec

end module test_math


  SUBROUTINE calbrec(a,ai,error)
    REAL(KIND=8)                            :: a(3,3), ai(3,3)
    DO i = 1, 3
       il = 1
       IF (i==1) il = 2
       DO j = 1, 3
          ai(j,i) = (-1.0_8)**(i+j)*det*(a(il,jl)*a(iu,ju)-a(il,ju)*a(iu,jl))
       END DO
    END DO
  END SUBROUTINE calbrec


subroutine regcoil_solve(ilambda)

  use regcoil_variables

  implicit none

  integer, intent(in) :: ilambda
  integer :: iflag, tic, toc, countrate

  call system_clock(tic,countrate)

  ! The scaling of the terms below by 1/(1+lambda) ensures that matrix and RHS are O(1) regardless of whether lambda is >> 1 or << 1.
  matrix = (1 / (1 + lambda(ilambda))) * matrix_B + (lambda(ilambda) / (1 + lambda(ilambda))) * matrix_regularization
  RHS    = (1 / (1 + lambda(ilambda))) *    RHS_B + (lambda(ilambda) / (1 + lambda(ilambda))) *    RHS_regularization

  call system_clock(toc)
  if (verbose) print *,"  Additions: ",real(toc-tic)/countrate," sec."
  call system_clock(tic)

  ! Compute solution = matrix \ RHS.
  ! Use LAPACK's DSYSV since matrix is symmetric.
  ! Note: RHS will be over-written with the solution.
  call DSYSV('U',num_basis_functions, 1, matrix, num_basis_functions, LAPACK_IPIV, RHS, num_basis_functions, LAPACK_WORK, LAPACK_LWORK, LAPACK_INFO)
  if (LAPACK_INFO /= 0) then
     print *, "!!!!!! Error in LAPACK DSYSV: INFO = ", LAPACK_INFO
     !stop
  end if
  solution = RHS

  call system_clock(toc)
  if (verbose) print *,"  DSYSV: ",real(toc-tic)/countrate," sec."
  call system_clock(tic)

  call regcoil_diagnostics(ilambda)

end subroutine regcoil_solve

    ! Here is the LAPACK documentation for solving a symmetric linear system:

!!$
!!$
!!$*> \brief  DSYSV computes the solution to system of linear equations A * X = B for SY matrices
!!$*
!!$*  =========== DOCUMENTATION ===========
!!$*
!!$* Online html documentation available at
!!$*            http://www.netlib.org/lapack/explore-html/
!!$*
!!$*> \htmlonly
!!$*> Download DSYSV + dependencies
!!$*>
!!$*> [TGZ]
!!$*>
!!$*> [ZIP]
!!$*>
!!$*> [TXT]
!!$*> \endhtmlonly
!!$*
!!$*  Definition:
!!$*  ===========
!!$*
!!$*       SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
!!$*                         LWORK, INFO )
!!$*
!!$*       .. Scalar Arguments ..
!!$*       CHARACTER          UPLO
!!$*       INTEGER            INFO, LDA, LDB, LWORK, N, NRHS
!!$*       ..
!!$*       .. Array Arguments ..
!!$*       INTEGER            IPIV( * )
!!$*       DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), WORK( * )
!!$*       ..
!!$*
!!$*
!!$*> \par Purpose:
!!$*  =============
!!$*>
!!$*> \verbatim
!!$*>
!!$*> DSYSV computes the solution to a real system of linear equations
!!$*>    A * X = B,
!!$*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
!!$*> matrices.
!!$*>
!!$*> The diagonal pivoting method is used to factor A as
!!$*>    A = U * D * U**T,  if UPLO = 'U', or
!!$*>    A = L * D * L**T,  if UPLO = 'L',
!!$*> where U (or L) is a product of permutation and unit upper (lower)
!!$*> triangular matrices, and D is symmetric and block diagonal with
!!$*> 1-by-1 and 2-by-2 diagonal blocks.  The factored form of A is then
!!$*> used to solve the system of equations A * X = B.
!!$*> \endverbatim
!!$*
!!$*  Arguments:
!!$*  ==========
!!$*
!!$*> \param[in] UPLO
!!$*> \verbatim
!!$*>          UPLO is CHARACTER*1
!!$*>          = 'U':  Upper triangle of A is stored;
!!$*>          = 'L':  Lower triangle of A is stored.
!!$*> \endverbatim
!!$*>
!!$*> \param[in] N
!!$*> \verbatim
!!$*>          N is INTEGER
!!$*>          The number of linear equations, i.e., the order of the
!!$*>          matrix A.  N >= 0.
!!$*> \endverbatim
!!$*>
!!$*> \param[in] NRHS
!!$*> \verbatim
!!$*>          NRHS is INTEGER
!!$*>          The number of right hand sides, i.e., the number of columns
!!$*>          of the matrix B.  NRHS >= 0.
!!$*> \endverbatim
!!$*>
!!$*> \param[in,out] A
!!$*> \verbatim
!!$*>          A is DOUBLE PRECISION array, dimension (LDA,N)
!!$*>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!!$*>          N-by-N upper triangular part of A contains the upper
!!$*>          triangular part of the matrix A, and the strictly lower
!!$*>          triangular part of A is not referenced.  If UPLO = 'L', the
!!$*>          leading N-by-N lower triangular part of A contains the lower
!!$*>          triangular part of the matrix A, and the strictly upper
!!$*>          triangular part of A is not referenced.
!!$*>
!!$*>          On exit, if INFO = 0, the block diagonal matrix D and the
!!$*>          multipliers used to obtain the factor U or L from the
!!$*>          factorization A = U*D*U**T or A = L*D*L**T as computed by
!!$*>          DSYTRF.
!!$*> \endverbatim
!!$*>
!!$*> \param[in] LDA
!!$*> \verbatim
!!$*>          LDA is INTEGER
!!$*>          The leading dimension of the array A.  LDA >= max(1,N).
!!$*> \endverbatim
!!$*>
!!$*> \param[out] IPIV
!!$*> \verbatim
!!$*>          IPIV is INTEGER array, dimension (N)
!!$*>          Details of the interchanges and the block structure of D, as
!!$*>          determined by DSYTRF.  If IPIV(k) > 0, then rows and columns
!!$*>          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
!!$*>          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
!!$*>          then rows and columns k-1 and -IPIV(k) were interchanged and
!!$*>          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and
!!$*>          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
!!$*>          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
!!$*>          diagonal block.
!!$*> \endverbatim
!!$*>
!!$*> \param[in,out] B
!!$*> \verbatim
!!$*>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
!!$*>          On entry, the N-by-NRHS right hand side matrix B.
!!$*>          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
!!$*> \endverbatim
!!$*>
!!$*> \param[in] LDB
!!$*> \verbatim
!!$*>          LDB is INTEGER
!!$*>          The leading dimension of the array B.  LDB >= max(1,N).
!!$*> \endverbatim
!!$*>
!!$*> \param[out] WORK
!!$*> \verbatim
!!$*>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!!$*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!!$*> \endverbatim
!!$*>
!!$*> \param[in] LWORK
!!$*> \verbatim
!!$*>          LWORK is INTEGER
!!$*>          The length of WORK.  LWORK >= 1, and for best performance
!!$*>          LWORK >= max(1,N*NB), where NB is the optimal blocksize for
!!$*>          DSYTRF.
!!$*>          for LWORK < N, TRS will be done with Level BLAS 2
!!$*>          for LWORK >= N, TRS will be done with Level BLAS 3
!!$*>
!!$*>          If LWORK = -1, then a workspace query is assumed; the routine
!!$*>          only calculates the optimal size of the WORK array, returns
!!$*>          this value as the first entry of the WORK array, and no error
!!$*>          message related to LWORK is issued by XERBLA.
!!$*> \endverbatim
!!$*>
!!$*> \param[out] INFO
!!$*> \verbatim
!!$*>          INFO is INTEGER
!!$*>          = 0: successful exit
!!$*>          < 0: if INFO = -i, the i-th argument had an illegal value
!!$*>          > 0: if INFO = i, D(i,i) is exactly zero.  The factorization
!!$*>               has been completed, but the block diagonal matrix D is
!!$*>               exactly singular, so the solution could not be computed.
!!$*> \endverbatim


program main
implicit none
integer NN
parameter (NN=20)
integer i
real*8 :: a(NN),b(NN)
real*8 :: chsq,prob,df

a=0
b=0
!write(*,*)a(1)
do i=1,NN
	a(i)=1
enddo
!write(*,*)a(1)
do i=1,NN
	b(i)=2
ENDDO

do i=1,NN
	write(*,*)a(i),b(i)
enddo

call chstwo(a,b,NN,0,df,chsq,prob)

write(*,*) 'Chi-squared:',chsq
write(*,*)'Probability:',prob
write(*,*)df

end program main

include 'gser.f90'
include 'gcf.f90'
include 'gammq.f90'
include 'gammln.f90'
include 'chstwo.f90'
include 'expdev.f90'
include 'ran1.f90'


PROGRAM MAIN
    USE csi_mod
    INTEGER(4)::i
    CHARACTER(10)::condition
    REAL(8)::a_condition,b_condition !a and b is the condition of boundary
    REAL(8),ALLOCATABLE::x(:),y(:)
    REAL(8),ALLOCATABLE::M(:),h(:)
    REAL(8),ALLOCATABLE::a(:),b(:),c(:),d(:)
    OPEN(10,file='input')
    READ(10,*) number        !read the total number
    READ(10,'(A10)') condition
    SELECT CASE (condition)
        CASE('first')
            READ(10,*) a_condition,b_condition
        CASE('second')
            READ(10,*) a_condition,b_condition
        CASE('third')
            READ(10,*) ! the third boundary inputfile should have a blank row
            a_condition=0
            b_condition=0
        CASE DEFAULT
            WRITE(*,*) 'ERROR:This problem have no boundary,please choose one boundary'
            STOP
    END SELECT
    ALLOCATE(x(number))
    ALLOCATE(y(number))
    DO i=1,number
        READ(10,*) x(i),y(i) !read the point (x(i),y(i))
    END DO
    CLOSE(10)
    IF (condition=='third'.and.y(1)/=y(number)) THEN
        WRITE(*,*) 'ERROR: the third boundary requires y(0)==y(n),please check out!'
        STOP
    END IF
    ALLOCATE(M(number))
    ALLOCATE(h(number-1))
    CALL CSI(number,x,y,condition,a_condition,b_condition,M,h)
    ALLOCATE(a(number-1))
    ALLOCATE(b(number-1))
    ALLOCATE(c(number-1))
    ALLOCATE(d(number-1))
    OPEN(81,FILE='output')
    DO i=1,number-1
        CALL SIMPLI(x(i),y(i),x(i+1),y(i+1),h(i),&
                    M(i),M(i+1),a(i),b(i),c(i),d(i))
        WRITE(*, "('S(x)=',F9.4'x^3',F9.4,'x^2',F9.4,'x',F9.4,' ,',F5.2'<=x<=',F5.2)") &
                a(i),b(i),c(i),d(i),x(i),x(i+1)
        WRITE(81,"('S(x)=',F9.4'x^3',F9.4,'x^2',F9.4,'x',F9.4,' ,',F5.2'<=x<=',F5.2)") &
                a(i),b(i),c(i),d(i),x(i),x(i+1)
    END DO
    CLOSE(81)
    DEALLOCATE(a)
    DEALLOCATE(b)
    DEALLOCATE(c)
    DEALLOCATE(d)
    DEALLOCATE(h)
    DEALLOCATE(M)
    DEALLOCATE(x)
    DEALLOCATE(y)
CONTAINS
    SUBROUTINE SIMPLI(x1,y1,x2,y2,h,M1,M2,a,b,c,d)
        REAL(8),INTENT(IN)::x1,y1,x2,y2,h,M1,M2
        REAL(8),INTENT(INOUT)::a,b,c,d
        a=0
        b=0
        c=0
        d=0
        a=(M2-M1)/(6*h)
        b=(0-x1*M2+x2*M1)/(2*h)
        c=(x1*x1*M2-x2*x2*M1)/(2*h)-(y1-h*h*M1/6)/h+(y2-h*h*M2/6)/h
        d=(0-x1*x1*x1*M2+x2*x2*x2*M1)/(6*h) &
           +(y1-h*h*M1/6)*x2/h-(y2-h*h*M2/6)*x1/h
    END SUBROUTINE
END PROGRAM


! { dg-do run }
!
! Test for pr52413
!

program test_frac

  real :: y
  y=fraction (-2.0)
  if (fraction (-2.0) /= -0.5) call abort ()
  if (fraction (-0.0) /= 0.0) call abort ()
  if (sign(1.0, fraction(-0.0)) /= -1.0) call abort ()
  if (fraction (-2.0_8) /=  -0.5) call abort ()

end program test_frac


!*****************************************************************************************
!>
!  Original Hairer test case.

    program dop853_example_original

    use dop853_module
    use dop853_constants

    implicit none

    integer,parameter               :: n     = 2                !! dimension of the system
    real(wp),parameter              :: tol   = 1.0e-9_wp        !! integration tolerance
    real(wp),parameter              :: x0    = 0.0_wp           !! initial `x` value
    real(wp),parameter              :: xf    = 2.0_wp           !! endpoint of integration
    real(wp),dimension(n),parameter :: y0    = [2.0_wp,0.0_wp]  !! initial `y` value

    type(dop853_class) :: prop
    real(wp),dimension(n) :: y
    real(wp),dimension(1) :: rtol,atol
    real(wp) :: x
    integer :: idid
    logical :: status_ok

    x = x0
    y = y0
    rtol = tol ! set tolerances
    atol = tol !
    call prop%initialize(   fcn       = fvpol,    &
                            nstiff    = 1, &
                            n         = n,        &
                            status_ok = status_ok )
    if (.not. status_ok) error stop 'initialization error'

    call prop%integrate(x,y,xf,rtol,atol,iout=0,idid=idid)

    write (output_unit,'(1X,A,F6.2,A,2E18.10)') &
                       'x =',x ,'    y =',y(1),y(2)

contains

    subroutine fvpol(me,x,y,f)

    !! Right-hand side of van der Pol's equation

    implicit none

    class(dop853_class),intent(inout) :: me
    real(wp),intent(in)               :: x
    real(wp),dimension(:),intent(in)  :: y
    real(wp),dimension(:),intent(out) :: f

    real(wp),parameter :: eps = 1.0e-3_wp

    f(1) = y(2)
    f(2) = ((1-y(1)**2)*y(2)-y(1))/eps

    end subroutine fvpol

end program dop853_example_original


!!
!! Luke McCulloch
!! solver.f90
!! 8-25-2011
!! Serial Solution Various equations - This will be Inviscid Burgers.
!! Euler Solution Contains the Swaff Tri Diag OFFICIAL Correct Indicies!
!!   Variable Listing - Far from Updated hahah

PROGRAM solver

  use precise, only : defaultp   ! Module to handle precision
  use geo                        ! Module to write the Points on the surface
  !!use Source                     ! Module to compute an arbitrary source term.
  use inv                        ! My tri dag inversion module from Spring 2011
  use Swafftridag                ! Swaffs version

  IMPLICIT NONE

  integer, parameter :: WP=defaultp
  real, parameter :: e=2.718281828459045
  INTEGER, DIMENSION(5), PARAMETER :: it1 = (/ 1, 5, 10, 15, 40 /)   ! GNU output times

  integer::count_0, count1, count2, count_rate, count_max, walltime, tstart, tend

  Integer :: NI, i, t, NT, m, mmax
  Real(WP) :: dx, L, dt, Umx, norm
  Real(WP), DIMENSION(2) :: ux           ! Unit Vectors
  REAL(wp), Allocatable, DIMENSION(:) :: X, ratiodtdx ! X locations
  REAL(wp), Allocatable, DIMENSION(:) :: am, bm, cm ! Diagonal Matrices
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: RHS, Delta, U, Uexact, Aplus, Aminus, L1, L2, fplus, fminus, F, L2norm ! Velocity, scheme components
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: Unm

  !! FV variables
  Integer :: NV
  REAL(wp), Allocatable, DIMENSION(:) :: V
  REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: vU

  ! Simple start up message
  WRITE(6,'(A)') 'CFD Burgers Schemes Code'
  Write(6,*)     ' 10-09-2011 Implementation By Luke McCulloch'
  write(6,*) ''
  Write(6,*)     ' Implicit Solver FV Inviscid Burgers Equation in 1D'
  write(6,*) '--------------------------------------------------------'

  Umx=-1.0e10
  dx=0.05
  L=3.
  NV=int(real(L/dx))   !! NI and NV have been reversed for convienience.
  NV=NV+1
  NI=NV+1
  dt = 0.03333333
  NT=40

  Allocate( X(NI) )
  Allocate( U(NI,0:NT) )
  Allocate( Unm(NI,0:NT) )
  Allocate( Uexact(NI,NT) )
  Allocate( am(NI-3) )
  Allocate( bm(NI-2) )
  Allocate( cm(NI-3) )

  Allocate( L1(NI,NT) )
  Allocate( L2(NI,NT) )
  Allocate( Aplus(NI,NT) )
  Allocate( Aminus(NI,NT) )

  Allocate( Fplus(NI-2,NT) )
  Allocate( Fminus(NI-2,NT) )
  Allocate( F(NI-2,NT) )

  Allocate( Delta(NI-2,NT) )
  Allocate( RHS(NI,NT) )

  Allocate( L2norm(NT,10) )
  !! Allocate the FV variables
  Allocate( vU(NV,0:NT) )
  Allocate( V(NV) )

  Call D1(NV, dx, V )   ! Subroutine to compute the vector of Points.
  Call V1(NI, dx, X)    ! Now, X's will be at Volume Centroids

  !Check Points - Comment this in the full Version
  Write(6,'(AA)') 'Volume Centroids'
  do i=1,NI
     write(*,*) 'I, X(i)', i, X(i)
  end do
  Write(6,*) ''

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

  Write(6,'(AA)') 'Points'
  do i=1,NV
     write(*,*) 'I, V(i)', i, V(i)
  end do
  Write(6,*) ''
  !Get rid of this in the full Version, obv

  !Establish the B.C.'s-------------------------------------------------
  Do i=1,NI
     U(i,0)=0.0  ! U at the Volume centers now
  End Do
  Do i=1,NV
     vU(i,0)=0.0  !specify U at Volume boundaries now
  End do

  write(*,*) '----------------Boundary Conditions on the Boundary Faces--------------'
  write(*,*) '                  0. <= x <= 1.0'
  count1=1
  count2=int(real(1.0/dx))+1
  Do i=count1,count2
     u(i,0)=1.5
     Unm(i,0)=1.5
     write(*,*) 'i, x(0), u(x,0)', i, X(i), U(i,0)
  End do
  write(*,*) '                  1.0 < x <= 3.0'
  count1=int(real(1.0/dx))+2
  count2=int(real(3.0/dx))+2
  Do i=count1,count2
     u(i,0)=0.5
     Unm(i,0)=0.5
     write(*,*) 'i, x(0), u(x,0)', i, X(i), U(i,0)
  End do
  write(*,*) ''

  !End of the B.C. portion------------------------------------------------

  Write (*,*) '------------------Begin Implicit Euler Method--------------------------'
  ! NI is the number of elements in the diagonal
  ! am is the subdiagonal
  ! bm is the diagonal
  ! cm is the superdiagonal
  ! F(:,t-1) is the RHS
  ! delta(:,t) is the Solution at time t
  ! t is indexed from 0 to 30.  NT=30

  Do t=1,NT

     Do i=1,NI-2  !!! Make the Delta matrix which excludes the bc's
        Delta(i,t-1)=0.0
     End do

     ! Compute the Subdiagonal, a, Diagonal, b, And Superdiagonal, c, Terms
     ! Note:  Contains the OFFICIAL Swaff Tridag Correct indicies of the sub, main, and super diagonals!
     !
     !!Do the Newton Iterations from 1-10
     mmax=10
     do m=1,mmax
!        write(*,*)  'Begin m loop'

        norm=0.0
        do i=2,NI-2
           !!am(i)=(-dt/(2.*dx))*Delta(i-1,t-1)
           am(i)=-(dt/dx)*Unm(i,t-1)   !! Range = 3,NI-1
        End do

        do i=1,NI-3
           !!cm(i)=(dt/(2.*dx))*Delta(i+1,t-1)
           cm(i)=0.0    !! Range = 2,NI-2
        End do

        do i=1,NI-2
           Fplus(i,t-1) =((Unm(i+1,t-1))**2.)  !! Range = 2,NI-1
           Fminus(i,t-1)=((Unm(i,t-1))**2.)    !! Range = 1,NI-2
           F(i,t-1)=Unm(i+1,t-1)-U(i+1,t-1)+0.5*dt*(Fplus(i,t-1)-Fminus(i,t-1))/dx
           !write(*,*) 'i, Umn(i,t-1),  Umn(i+1,t-1)', i, Unm(i,t-1),  Unm(i+1,t-1)
           bm(i)=1.0+(dt/dx)*Unm(i+1,t-1)   !! Range = 2,NI-1

        end do

        !! Call my solver
        !Call tlmtri (am(:),bm(:),cm(:),-.5*(dt/dx)*(Fplus(:,t-1)-Fminus(:,t-1)),Delta(:,t),NI-2)

        !! Call Swaff Solver
        Call trid (am,bm,cm,-F(:,t-1),Delta(:,t),NI-2)
        norm=0.0

        Do i=1,NI-2
           Unm(i+1,t-1)=Delta(i,t)+Unm(i+1,t-1)  !!Caareful, Unm range = [1,NI]
           !!Compute the L2 norm whilst you are down here:
           !write(*,*) 'Delta', Delta(i,t)
           norm=Delta(i,t)**2.+norm
        End Do

        L2norm(t,m)=sqrt(norm)/real(NI-2)

     Unm(1,t)=1.5
     Unm(NI,t)=0.5

     End do  !! End the iterative m loop for implicit NM.

     !!Convert to U(:,t)
     Do i=1,NI-2
        U(i+1,t)=Unm(i+1,t-1) !!Updating inner range = [2,NI-1] could try whole domain but this should work...
        Unm(i+1,t)=Unm(i+1,t-1)
     End Do

!! Should be able to include these immediately above since they never change...
     U(1,t)=1.5
     U(NI,t)=0.5
     Unm(1,t)=1.5
     Unm(NI,t)=0.5

    ! write(6,*) 'Timestep', T

  End do    !! End Timestep

  write(6,*) 'End Euler Scheme'
!!----------------------------End Euler Scheme----------------------------------------

write(*,*) 'L2norm(5,m)'
do m=1,10
   write(*,*) L2norm(5,m)
end do
write(*,*)
write(*,*) 'L2norm(10,m)'
do m=1,10
   write(*,*) L2norm(10,m)
end do
write(*,*)
write(*,*) 'L2norm(15,m)'
do m=1,10
   write(*,*) L2norm(15,m)
end do
write(*,*)
write(*,*) 'L2norm(40,m)'
do m=1,10
   write(*,*) L2norm(40,m)
end do
write(*,*)
!!----------------------------Exact Solution----------------------------------------

 t=40*dt
    Do i=1,NI
       Uexact(i,40)=U(i,0)
    End Do
 print*
 Write(6,*) 'solving exact solution at t=40'

!!----------------------------End Exact Solution----------------------------------------

 write(6,*) 'Write x,U'
  ! output Gnuplot file-------------------------Solution---------------------------
  OPEN(UNIT=1, FILE='EulerImplicit_FV.dat',FORM='FORMATTED',STATUS='REPLACE')!,IOSTAT=ios)
  !IF (ios /= 0) THEN
  !  PRINT *, "Error opening Gnu plot file "
  !  STOP
  !END IF
  Do t=1, 5
     DO i=1, NI
        !WRITE(UNIT=1,FMT='(E19.10," ",E19.10," 0.0")') x(i,it1(t)),u(i,it1(t))
        WRITE(UNIT=1,FMT='(E19.10," ",E19.10)') x(i),U(i,it1(t))
     END DO
     WRITE(UNIT=1,FMT='(" ")')
  End Do
  Do i=1,NI
     WRITE(UNIT=1,FMT='(E19.10," ",E19.10)') x(i)+dt*Nt*0.5*(1.5+.5),Uexact(i,40)
  End do
  CLOSE(UNIT=1)

write(6,*) 'Write t,L2norm'
!!-------------------------------------------------------L2NORM----------------------
  ! output Gnuplot file
  OPEN(UNIT=2, FILE='L2norm.dat',FORM='FORMATTED',STATUS='REPLACE')!,IOSTAT=ios)
  Do t=2,5
     DO m=1, 10
        WRITE(UNIT=2,FMT='(I5," ",E19.10)') m,L2norm(it1(t),m)
     END DO
     WRITE(UNIT=2,FMT='(" ")')
  End do
  CLOSE(UNIT=2)

!! Plotting in gnu plot
!! once in the proper directory in terminal, open a second tab
!! type:  gnuplot   to open gnuplot
!! type:  plot "Gnu.dat" w l        to plot

  write(6,*) 'deallocating'

  write(6,*) 'deallocating x'
  IF (ALLOCATED(X)) DEALLOCATE(X)
  write(6,*) 'deallocating U'
  IF (ALLOCATED(U)) DEALLOCATE(U)
  IF (ALLOCATED(Unm)) DEALLOCATE(Unm)
  IF (ALLOCATED(Uexact)) DEALLOCATE(Uexact)
  IF (ALLOCATED(am)) DEALLOCATE(am)
  IF (ALLOCATED(bm)) DEALLOCATE(bm)
  IF (ALLOCATED(cm)) DEALLOCATE(cm)

  write(6,*) 'deallocating L1'
  IF (ALLOCATED(L1)) DEALLOCATE(L1)
  IF (ALLOCATED(L2)) DEALLOCATE(L2)
  IF (ALLOCATED(Aplus)) DEALLOCATE(Aplus)
  IF (ALLOCATED(Aminus)) DEALLOCATE(Aminus)

  write(6,*) 'deallocating Fplus'
  IF (ALLOCATED(Fplus)) DEALLOCATE(Fplus)
  IF (ALLOCATED(Fminus)) DEALLOCATE(Fminus)
  IF (ALLOCATED(F)) DEALLOCATE(F)

  write(6,*) 'deallocating Delta'
  IF (ALLOCATED(Delta)) DEALLOCATE(Delta)
  IF (ALLOCATED(RHS)) DEALLOCATE(RHS)

  write(6,*) 'deallocating L2 norm'
  IF (ALLOCATED(L2norm)) DEALLOCATE(L2norm)
  !!Deallocate FV variables

  write(6,*) 'deallocating V'
  IF (ALLOCATED(vU)) DEALLOCATE(vU)
  IF (ALLOCATED(V)) DEALLOCATE(V)

  write(6,*) 'End Program'
END PROGRAM solver


      program HybridComp15
      integer i
      integer j
      real a(5, 5)
      real cst(5)
      cst (1) = 1.0
      cst (2) = 2.0
      cst (3) = 3.0
      cst (4) = 4.0
      cst (5) = 5.0
      do 10 i = 1, 5
         do j = 1, 5
            a(i,j) = cst(i) * 2.4E5
         enddo
 10   continue
      do i = 1, 5
         do j = 1, 5
            write(*, 100) a(i,j)
 100        format(f10.2)
         enddo
      enddo
      end


!program to test nested forall construct and forall mask
program test
  implicit none
  integer a(4,4)
  integer i, j

  do i=1,4
    do j=1,4
      a(j,i) = j-i
    enddo
  enddo
  forall (i=2:4, a(1,i).GT.-2)
    forall (j=1:4, a(j,2).GT.0)
      a(j,i) = a(j,i-1)
    end forall
  end forall
  if (any (a.ne.reshape ((/0,1,2,3,-1,0,2,3,-2,-1,0,1,-3,-2,-1,0/),&
                          (/4,4/)))) call abort
end


program main
    use plantFEM
    implicit none

    real(real64) :: x(3) = [1.0d0 , 2.0d0 , 3.0d0]

    call print(x)

end program main

! ==
!
! import numpy as np
! x = np.array([1.0, 2.0, 3.0])
! print(x)


c  bcspline -- dmc 30 May 1996
c
c  set up coefficients for bicubic spline with following BC's:
c  FULL BC CONTROL at all bdys
c
c  inhomogeneous explicit BCs -- this means setting of 1st or 2nd
c  derivative at boundary to a non-zero value.
c
c  periodic, not-a-knot, zero derivative, and divided-difference based
c  BCs are "homogeneous"-- i.e. if splines s & t satisfy the BC then
c  the spline (c*s + t) formed as a linear combination of these two
c  splines, also satisfies the BC.
c
c  algorithm note -- handling of inhomogeneous explicit BC's while
c  maintaining full C2 differentiability is delicate.  Basic method:  use
c  a fully C2 method based on the "not-a-knot" BC, and then, correct to
c  meet each user BC by calculating a C2 spline that is zero at all grid
c  points but satisfies a BC which is the difference btw the user spec
c  and the not-a-knot result; add the coeffs of this into the original.
c
c  for this more workspace is needed: nwk .ge. 4*inx*inth +5*max(inx,inth)
c
      subroutine bcspline(x,inx,th,inth,fspl,inf3,
     >                    ibcxmin,bcxmin,ibcxmax,bcxmax,
     >                    ibcthmin,bcthmin,ibcthmax,bcthmax,
     >                    wk,nwk,ilinx,ilinth,ier)
c
      real x(inx),th(inth),fspl(4,4,inf3,inth),wk(nwk)
      real bcxmin(*),bcxmax(*)      ! (inth) if used
      real bcthmin(*),bcthmax(*)    ! (inx) if used
c
c  input:
c    x(1...inx) -- abscissae, first dimension of data
c   th(1...inth) -- abscissae, second dimension of data  f(x,th)
c   fspl(1,1,1..inx,1..inth) -- function values
c   inf3 -- fspl dimensioning, inf3.ge.inx required.
c
c  boundary conditions input:
c   ibcxmin -- indicator for boundary condition at x(1):
c    bcxmin(...) -- boundary condition data
c     =-1 -- periodic boundary condition
c     =0 -- use "not a knot", bcxmin(...) ignored
c     =1 -- match slope, specified at x(1),th(ith) by bcxmin(ith)
c     =2 -- match 2nd derivative, specified at x(1),th(ith) by bcxmin(ith)
c     =3 -- boundary condition is slope=0 (df/dx=0) at x(1), all th(j)
c     =4 -- boundary condition is d2f/dx2=0 at x(1), all th(j)
c     =5 -- match 1st derivative df/dx to 1st divided difference
c     =6 -- match 2nd derivative d2f/dx2 to 2nd divided difference
c     =7 -- match 3rd derivative d3f/dx3 3rd divided difference
c           (for more detailed definition of BCs 5-7, see the
c           comments of subroutine mkspline)
c   NOTE bcxmin(...) referenced ONLY if ibcxmin=1 or ibcxmin=2
c
c   ibcxmax -- indicator for boundary condition at x(nx):
c    bcxmax(...) -- boundary condition data
c     (interpretation as with ibcxmin, bcxmin)
c   NOTE:  if ibcxmin=-1, ibcxmax is ignored! ...and the BC is periodic.
c
c   ibcthmin -- indicator for boundary condition at th(1):
c    bcthmin(...) -- boundary condition data
c     (interpretation as with ibcxmin, bcxmin)
c   ibcthmax -- indicator for boundary condition at th(inth):
c    bcthmax(...) -- boundary condition data
c     (interpretation as with ibcxmin, bcxmin)
c   NOTE:  if ibcthmin=-1, ibcthmax is ignored! ...and the BC is periodic.
c
c   NOTE the bcxmin,bcxmax,bcthmin,bcthmax arrays are only used if the
c     corresponding boundary condition flags are set to 1 or 2.
c     Carefully note the dimensioning of these arrays!
c
c  output:
c   fspl(*,*,1..inx,1..inth) -- bicubic spline coeffs (4x4)
c   ...fspl(1,1,*,*) is not replaced.
c
c   ilinx -- =1 on output if x(inx) pts are nearly evenly spaced (tol=1e-3)
c   ilinth-- =1 on output if th(inth) evenly spaced (tol=1e-3)
c
c   ier -- completion code, 0 for normal
c
c  workspace:
c   wk -- must be at least 5*max(inx,inth) large
c                          5*max(inx,inth) + 4*inx*inth large
c                          if explicit non-zero d/dth or d2/dth2 BC's
c                          are supplied.
c  nwk -- size of workspace of workspace provided
c
c---------------------------------
c  in what follows, "f" is an abbreviation for "fspl"...
c
c  compute bicubic spline of 2d function, given values at the grid
c  grid crossing points, f(1,1,i,j)=f(x(i),th(j)).
c
c  on evaluation:  for point x btw x(i) and x(i+1), dx=x-x(i)
c                       and th btw th(j) and th(j+1), dt=th-th(j),
c
c      spline =
c        f(1,1,i,j) + dx*f(2,1,i,j) + dx**2*f(3,1,i,j) + dx**3*f(4,1,i,j)
c   +dt*(f(1,2,i,j) + dx*f(2,2,i,j) + dx**2*f(3,2,i,j) + dx**3*f(4,2,i,j))
c   +d2*(f(1,3,i,j) + dx*f(2,3,i,j) + dx**2*f(3,3,i,j) + dx**3*f(4,3,i,j))
c   +d3*(f(1,4,i,j) + dx*f(2,4,i,j) + dx**2*f(3,4,i,j) + dx**3*f(4,4,i,j))
c
c      where d2=dt**2 and d3=dt**3.
c
      integer iselect1(10)
      integer iselect2(10)
c
      real zcur(1)
c---------------------------------
c
c  see if 2nd pass is needed due to "non-linear" d/dth bdy cond.
c
      iflg2=0
      if(ibcthmin.ne.-1) then
         if((ibcthmin.eq.1).or.(ibcthmin.eq.2)) then
            do ix=1,inx
               if (bcthmin(ix).ne.0.0) iflg2=1
            enddo
         endif
         if((ibcthmax.eq.1).or.(ibcthmax.eq.2)) then
            do ix=1,inx
               if (bcthmax(ix).ne.0.0) iflg2=1
            enddo
         endif
      endif
c
      ier=0
      itest=5*max(inx,inth)
      if(iflg2.eq.1) then
         itest=itest +4*inx*inth
      endif
c
      if(nwk.lt.itest) then
         write(6,9901) nwk,itest
 9901    format(' ?bcspline:  workspace too small:'/
     >          '  user supplied:  nwk=',i6,'; need at least:  ',i6/
     >          '  nwk=4*nx*ny +5*max(nx,ny) will work for any user'/
     >          '  choice of bdy conditions.')
         ier=1
      endif
      if(inx.lt.2) then
         write(6,'('' ?bcspline:  at least 2 x points required.'')')
         ier=1
      endif
      if(inth.lt.2) then
         write(6,'('' ?bcspline:  need at least 2 theta points.'')')
         ier=1
      endif
c
      call ibc_ck(ibcxmin,'bcspline','xmin',-1,7,ier)
      if(ibcxmin.ge.0) call ibc_ck(ibcxmax,'bcspline','xmax',0,7,ier)
      call ibc_ck(ibcthmin,'bcspline','thmin',-1,7,ier)
      if(ibcthmin.ge.0) call ibc_ck(ibcthmax,'bcspline','thmax',0,7,ier)
c
c  check ilinx & x vector
c
      call splinck(x,inx,ilinx,1.0e-3,ierx)
      if(ierx.ne.0) ier=2
c
      if(ier.eq.2) then
         write(6,'('' ?bcspline:  x axis not strict ascending'')')
      endif
c
c  check ilinth & th vector
c
      call splinck(th,inth,ilinth,1.0e-3,ierth)
      if(ierth.ne.0) ier=3
c
      if(ier.eq.3) then
         write(6,'('' ?bcspline:  th axis not strict ascending'')')
      endif
c
      if(ier.ne.0) return
c
c------------------------------------
c
      xo2=0.5
      xo6=1.0/6.0
c
c  spline in x direction
c
      inxo=4*(inx-1)
      do ith=1,inth
c
c  copy the function in
c
         do ix=1,inx
            wk(4*(ix-1)+1)=fspl(1,1,ix,ith)
         enddo
c
         if(ibcxmin.eq.1) then
            wk(2)=bcxmin(ith)
         else if(ibcxmin.eq.2) then
            wk(3)=bcxmin(ith)
         endif
c
         if(ibcxmax.eq.1) then
            wk(inxo+2)=bcxmax(ith)
         else if(ibcxmax.eq.2) then
            wk(inxo+3)=bcxmax(ith)
         endif
c
c  use Wayne's routine
c
         call v_spline(ibcxmin,ibcxmax,inx,x,wk,wk(4*inx+1))
c
c  copy the coefficients out
c
         do ix=1,inx
            fspl(2,1,ix,ith)=wk(4*(ix-1)+2)
            fspl(3,1,ix,ith)=wk(4*(ix-1)+3)*xo2
            fspl(4,1,ix,ith)=wk(4*(ix-1)+4)*xo6
         enddo
c
      enddo
c
c-----------------------------------
c
c  spline in theta direction
c
      intho=4*(inth-1)
      do ix=1,inx
c
c  spline each x coeff
c
         do ic=1,4
c
c  copy ordinates in
c
            do ith=1,inth
               wk(4*(ith-1)+1)=fspl(ic,1,ix,ith)
            enddo
c
c  first pass:  use a linear BC -- if flag indicates BC correction
c  will be needed, it will be done later
c
            wk(2)=0.0
            wk(3)=0.0
            wk(intho+2)=0.0
            wk(intho+3)=0.0
c
            ibcthmina=ibcthmin
            ibcthmaxa=ibcthmax
            if(iflg2.eq.1) then
               if((ibcthmin.eq.1).or.(ibcthmin.eq.2)) ibcthmina=0
               if((ibcthmax.eq.1).or.(ibcthmax.eq.2)) ibcthmaxa=0
            endif
c
            call v_spline(ibcthmina,ibcthmaxa,inth,th,wk,wk(4*inth+1))
c
c  copy coeffs out
c
            do ith=1,inth
               fspl(ic,2,ix,ith)=wk(4*(ith-1)+2)
               fspl(ic,3,ix,ith)=wk(4*(ith-1)+3)*xo2
               fspl(ic,4,ix,ith)=wk(4*(ith-1)+4)*xo6
            enddo
c
         enddo
c
      enddo
c
c  now make correction for user BC's if needed
c
      if(iflg2.eq.1) then
c
         iasc=1                         ! wk addr for correction splines
         iinc=4*inth                    ! spacing btw correction splines
         iawk=iasc+4*inth*inx
c
c  last grid zone widths
c
         zhxn=x(inx)-x(inx-1)
         jx=inx-1
         zhth=th(inth)-th(inth-1)
         jth=inth-1
c
         do ii=1,10
            iselect1(ii)=0
            iselect2(ii)=0
         enddo
         if(ibcthmin.eq.1) iselect1(3)=1
         if(ibcthmin.eq.2) iselect1(5)=1
         if(ibcthmax.eq.1) iselect2(3)=1
         if(ibcthmax.eq.2) iselect2(5)=1
c
c  loop over BC's
c
         do ix=1,inx
c
c  (a) d/dth @ th(1) difference btw current BC and user request
c
            if(ibcthmin.eq.1) then
               if(ix.lt.inx) then
                  zcur(1)=fspl(1,2,ix,1)   ! 1st deriv.
               else
                  zcur(1)=fspl(1,2,jx,1)+zhxn*(fspl(2,2,jx,1)+zhxn*
     >               (fspl(3,2,jx,1)+zhxn*fspl(4,2,jx,1)))
               endif
               zdiff1=bcthmin(ix)-zcur(1)
            else if(ibcthmin.eq.2) then
               if(ix.lt.inx) then
                  zcur(1)=2.0*fspl(1,3,ix,1) ! 2nd deriv.
               else
                  zcur(1)=2.0*
     >                 (fspl(1,3,jx,1)+zhxn*(fspl(2,3,jx,1)+zhxn*
     >               (fspl(3,3,jx,1)+zhxn*fspl(4,3,jx,1))))
               endif
               zdiff1=bcthmin(ix)-zcur(1)
            else
               zdiff1=0.0
            endif
c
c  (b) d/dth @ th(inth) difference btw current BC and user request
c
            if(ibcthmax.eq.1) then
               if(ix.lt.inx) then
c  1st deriv.
                  zcur(1)=
     >                 fspl(1,2,ix,jth)+zhth*(2.0*fspl(1,3,ix,jth)+
     >                 zhth*3.0*fspl(1,4,ix,jth))
               else
                  call bcspeval(x(inx),th(inth),iselect2,  zcur,
     >               x,inx,th,inth,ilinx,ilinth,fspl,inf3,ier)
                  if(ier.ne.0) return
               endif
               zdiff2=bcthmax(ix)-zcur(1)
            else if(ibcthmax.eq.2) then
               if(ix.lt.inx) then
c  2nd deriv.
                  zcur(1)=2.0*fspl(1,3,ix,jth)+
     >               6.0*zhth*fspl(1,4,ix,jth)
               else
                  call bcspeval(x(inx),th(inth),iselect2,  zcur(1),
     >               x,inx,th,inth,ilinx,ilinth,fspl,inf3,ier)
                  if(ier.ne.0) return
               endif
               zdiff2=bcthmax(ix)-zcur(1)
            else
               zdiff2=0.0
            endif
c
c  ok compute the theta spline with BC's to span the difference(s)
c  these theta "correction splines" are zero at all the grid points
c  but have at least one non-zero 1st or 2nd derivative BC
c
            iadr=iasc+(ix-1)*iinc
            do ith=1,inth
               wk(iadr+4*(ith-1))=0.0
            enddo
c
            wk(iadr+1)=0.0
            wk(iadr+2)=0.0
            wk(iadr+intho+1)=0.0
            wk(iadr+intho+2)=0.0
c
            if(ibcthmin.eq.1) then
               wk(iadr+1)=zdiff1
            else if(ibcthmin.eq.2) then
               wk(iadr+2)=zdiff1
            endif
c
            if(ibcthmax.eq.1) then
               wk(iadr+intho+1)=zdiff2
            else if(ibcthmax.eq.2) then
               wk(iadr+intho+2)=zdiff2
            endif
c
            call v_spline(ibcthmin,ibcthmax,inth,th,wk(iadr),wk(iawk))
         enddo
c
c  add in results to main array -- th spline coef corrections
c
         do ix=1,inx
            iadr=iasc+(ix-1)*iinc
            do ith=1,inth-1
               wk(iadr+4*(ith-1)+2)=wk(iadr+4*(ith-1)+2)*xo2
               wk(iadr+4*(ith-1)+3)=wk(iadr+4*(ith-1)+3)*xo6
               if(ix.lt.inx) then
                  fspl(1,2,ix,ith)=fspl(1,2,ix,ith)+wk(iadr+4*(ith-1)+1)
                  fspl(1,3,ix,ith)=fspl(1,3,ix,ith)+wk(iadr+4*(ith-1)+2)
                  fspl(1,4,ix,ith)=fspl(1,4,ix,ith)+wk(iadr+4*(ith-1)+3)
               endif
            enddo
         enddo
c
c  compute the x splines of the th spline correction coeffs
c
         ia5w=iawk+4*inx
c
         do ith=1,inth-1
            do ic=2,4
               do ix=1,inx
                  iaspl=iasc+iinc*(ix-1)
                  wk(iawk+4*(ix-1))=wk(iaspl+4*(ith-1)+(ic-1))
               enddo
c
c  use zero BCs for this correction spline
c
               wk(iawk+1)=0.0
               wk(iawk+2)=0.0
               wk(iawk+inxo+1)=0.0
               wk(iawk+inxo+2)=0.0
c
c  periodic spline of correction spline higher coeffs (1st coeffs are
c  all zero by defn of the correction spline
c
               call v_spline(ibcxmin,ibcxmax,inx,x,wk(iawk),wk(ia5w))
c
               do ix=1,inx-1
                  fspl(2,ic,ix,ith)=fspl(2,ic,ix,ith)+
     >               wk(iawk+4*(ix-1)+1)
                  fspl(3,ic,ix,ith)=fspl(3,ic,ix,ith)+
     >               wk(iawk+4*(ix-1)+2)*xo2
                  fspl(4,ic,ix,ith)=fspl(4,ic,ix,ith)+
     >               wk(iawk+4*(ix-1)+3)*xo6
               enddo
c
            enddo
         enddo                          ! ith
c
      endif                             ! BC correction needs test
c
      return
      end