      SUBROUTINE MEDFIT(X,Y,NDATA,A,B,ABDEV)
      PARAMETER (NMAX=1000)
      EXTERNAL ROFUNC
      COMMON /ARRAYS/ NDATAT,XT(NMAX),YT(NMAX),ARR(NMAX),AA,ABDEVT
      DIMENSION X(NDATA),Y(NDATA)
      SX=0.
      SY=0.
      SXY=0.
      SXX=0.
      DO 11 J=1,NDATA
        XT(J)=X(J)
        YT(J)=Y(J)
        SX=SX+X(J)
        SY=SY+Y(J)
        SXY=SXY+X(J)*Y(J)
        SXX=SXX+X(J)**2
11    CONTINUE
      NDATAT=NDATA
      DEL=NDATA*SXX-SX**2
      AA=(SXX*SY-SX*SXY)/DEL
      BB=(NDATA*SXY-SX*SY)/DEL
      CHISQ=0.
      DO 12 J=1,NDATA
        CHISQ=CHISQ+(Y(J)-(AA+BB*X(J)))**2
12    CONTINUE
      SIGB=SQRT(CHISQ/DEL)
      B1=BB
      F1=ROFUNC(B1)
      B2=BB+SIGN(3.*SIGB,F1)
      F2=ROFUNC(B2)
1     IF(F1*F2.GT.0.)THEN
        BB=2.*B2-B1
        B1=B2
        F1=F2
        B2=BB
        F2=ROFUNC(B2)
        GOTO 1
      ENDIF
      SIGB=0.01*SIGB
2     IF(ABS(B2-B1).GT.SIGB)THEN
        BB=0.5*(B1+B2)
        IF(BB.EQ.B1.OR.BB.EQ.B2)GOTO 3
        F=ROFUNC(BB)
        IF(F*F1.GE.0.)THEN
          F1=F
          B1=BB
        ELSE
          F2=F
          B2=BB
        ENDIF
        GOTO 2
      ENDIF
3     A=AA
      B=BB
      ABDEV=ABDEVT/NDATA
      RETURN
      END


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief inter cell interpolation
!>    @param[in] I0 i-dimension
!>    @param[in] J0 j-dimension
!>    @param[in] K0 k-dimension
!>    @param[in] i cell index, direction I0
!>    @param[in] j cell index, direction J0
!>    @param[in] k cell index, direction K0
!>    @param[in] vals state variables (values)
!>    @param[in] px I0-direction interpolation position
!>    @param[in] py J0-direction interpolation position
!>    @param[in] pz K0-direction interpolation position
!>    @param[in] delx I0-direction cell dimensions (delta size)
!>    @param[in] dely J0-direction cell dimensions (delta size)
!>    @param[in] delz K0-direction cell dimensions (delta size)
!>    @param[in] delxa I0-direction absolute cell positions
!>    @param[in] delya J0-direction absolute cell positions
!>    @param[in] delza K0-direction absolute cell positions
!>    @return interpolated value
      DOUBLE PRECISION FUNCTION interpolatelin(i0,j0,k0, i,j,k, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
        IMPLICIT NONE
!       i,j,k cell index (first corner - 3D)
        INTEGER i, j, k, i0, j0, k0
!       neighbours i,j,k cell index (second corner - 3D)
        INTEGER ni, nj, nk
!       state variables (values)
        DOUBLE PRECISION vals(i0,j0,k0)
!       x,y,z cell dimensions (delta size)
        DOUBLE PRECISION delx(i0), dely(j0), delz(k0)
!       x,y,z absolute cell position
        DOUBLE PRECISION delxa(i0), delya(j0), delza(k0)
!       x,y,z interpolation position
        DOUBLE PRECISION px, py, pz
!
        DOUBLE PRECISION d_a0, d_b0, d_a1, d_b1, d_a2, d_b2
        DOUBLE PRECISION lin_interpol
        EXTERNAL lin_interpol
        INTRINSIC min, max, abs

!       get neighbour i-index
        ni = i+1
        IF (px<delxa(i)) ni = i-1
        ni = min(max(ni,1),i0)
!       get neighbour j-index
        nj = j+1
        IF (py<delya(j)) nj = j-1
        nj = min(max(nj,1),j0)
!       get neighbour k-index
        nk = k+1
        IF (pz<delza(k)) nk = k-1
        nk = min(max(nk,1),k0)
!
!       x1
        d_a0 = vals(i,j,k)
!       x2
        d_b0 = vals(ni,j,k)
!       y1
        d_a1 = lin_interpol(d_a0,d_b0,abs(delxa(i)-px),(delx(i)+delx(ni))*0.5d0)
!
!       x1
        d_a0 = vals(i,nj,k)
!       x2
        d_b0 = vals(ni,nj,k)
!       y2
        d_b1 = lin_interpol(d_a0,d_b0,abs(delxa(i)-px),(delx(i)+delx(ni))*0.5d0)
!
!       z1
        d_a2 = lin_interpol(d_a1,d_b1,abs(delya(j)-py),(dely(j)+dely(nj))*0.5d0)
!
!       x1
        d_a0 = vals(i,j,nk)
!       x2
        d_b0 = vals(ni,j,nk)
!       y1
        d_a1 = lin_interpol(d_a0,d_b0,abs(delxa(i)-px),(delx(i)+delx(ni))*0.5d0)
!
!       x1
        d_a0 = vals(i,nj,nk)
!       x2
        d_b0 = vals(ni,nj,nk)
!       y2
        d_b1 = lin_interpol(d_a0,d_b0,abs(delxa(i)-px),(delx(i)+delx(ni))*0.5d0)
!
!       z2
        d_b2 = lin_interpol(d_a1,d_b1,abs(delya(j)-py),(dely(j)+dely(nj))*0.5d0)
!
        interpolatelin = lin_interpol(d_a2,d_b2,abs(delza(k)-pz),(delz(k)+delz(nk))*0.5d0)
!
        RETURN
      END

!>    @brief linear interpolation
!>    @param[in] da value A
!>    @param[in] db value B
!>    @param[in] dp relative position
!>    @param[in] dd (delta) cell size
!>    @return linear interpolated value
      DOUBLE PRECISION FUNCTION lin_interpol(da, db, dp, dd)
        IMPLICIT NONE
!       da: value A; db: value B; dp: relative position; dd: (delta) cell size
        DOUBLE PRECISION da, db, dp, dd
        lin_interpol = (da*(dd-dp) + db*dp)/dd
        RETURN
      END


program circle_test
! PROGRAM circle_test
! This program uses the "circle" module from "circle.f90" to test its functions

  use circle
  implicit none
  real::radius

  write (*,*) "Enter radius of the circle: "
  read (*,*) radius
  write (*,*) "Area = ", circarea(radius)
  write (*,*) "Circumference = ", circperi(radius)

end program circle_test


module constants
    use read_namelist
    implicit none
    save

    real, parameter :: e_ = 1.602176e-19
    real :: mi
    real, parameter :: c = 3.0e8
    real :: q
    real, parameter :: pi = 3.14159265
    integer, parameter :: dbl = selected_real_kind ( p=13, r = 200 )

contains
    subroutine set_constants
        implicit none

        mi = amu * 1.67262e-27
        q = AtomicZ * e_

    end subroutine set_constants

end module constants


      PROGRAM LA_SPBSVX_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_PBSVX
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Parameters" ..
      CHARACTER(LEN=1) :: EQUED
!  .. "Local Scalars" ..
      INTEGER :: KD, I, J, INFO, N, NRHS
      REAL(WP) :: RCOND
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:,:), B(:,:), X(:,:), S(:)
      REAL(WP), ALLOCATABLE :: AA(:,:), BB(:,:), FERR(:), BERR(:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'SPBSVX Example Program Results.'
      N = 7; KD = 3; NRHS = 3
      WRITE(*,'(5H N = , I4, 9H; NRHS = , I4)') N, NRHS
      ALLOCATE ( A(KD+1,N), AA(KD+1,N), B(N,NRHS), BB(N,NRHS) )
      ALLOCATE ( X(N,NRHS), S(N), FERR(NRHS), BERR(NRHS) )

      OPEN(UNIT=21,FILE='pbsv.ma',STATUS='UNKNOWN')
      DO I=1,KD+1
         DO J=1,N
            READ(21,'(F3.0)') A(I,J);
         ENDDO
      ENDDO
      CLOSE(21)

      B(:,1) = 0.0
      DO I = 1, N
         DO J = MAX(1,-N+I+KD+1), KD
            B(I,1) = A(J,I-J+KD+1) + B(I,1)
         ENDDO
         DO J = MAX(1,KD+2-I), KD+1
            B(I,1) = A(J,I) + B(I,1)
         ENDDO
      ENDDO
      DO J = 2, NRHS; B(:,J) = B(:,1)*J; ENDDO
         AA = A; BB = B

      WRITE(*,*) 'AB on entry:'
      DO I = 1, KD+1; WRITE (*,'(7(F9.5))') A(I,:); ENDDO

      WRITE(*,*) 'The RHS matrix B:'
      DO J = 1, N; WRITE (*,'(3(F10.5))') B(J,:); ENDDO

      CALL LA_PBSVX(A, B, X, FACT='E', EQUED=EQUED, S=S, FERR=FERR, BERR=BERR, RCOND=RCOND, INFO=INFO)

      WRITE(*,*)'EQUED = ',EQUED
      WRITE(*,*)'S on exit :'
      DO I=1,N; WRITE(*,"(5(F8.5))") S(I);
      ENDDO
      WRITE(*,*)'X on exit :'
      DO I=1,N; WRITE(*,"(5(F8.5))") X(I,:);
      ENDDO
      WRITE(*,*)'FERR on exit :'
      DO I=1,NRHS; WRITE(*,"(5(E13.6))") FERR(I);
      ENDDO
      WRITE(*,*)'BERR = '
      DO I=1,NRHS; WRITE(*,"(5(E13.6))") BERR(I);
      ENDDO
      WRITE(*,*)'RCOND = ',RCOND

      WRITE(*,*)'INFO = ' ,INFO

      WRITE(*,*) '\noindent'
      WRITE(*,*) 'The solution of the system $ A\,X = B $ is:'
      WRITE(*,*) '$$ X = \left( \begin{array}{rrr}'
      DO I=1,N; WRITE(*,"(2(F9.5,' & '),F9.5,' \\')") X(I,:); ENDDO
      WRITE(*,*) '\end{array} \right). $$'

      END PROGRAM LA_SPBSVX_EXAMPLE


    subroutine trimavg(x,N,xmean,sigx,trim)

! Trimmed average.

    implicit real (a-h,o-z)
    implicit integer (i,n)
    real(4),allocatable :: wt(:)
    real(4) x(N)
    logical notfinished

    notfinished = .true.
    allocate (wt(N))
    wt = 1.

    do while (notfinished)
        xsum = sum(wt*x)
        xsumsq = sum(wt*x*x)
        twt = sum(wt)
	xmean = xsum/twt
	sigx = sqrt((1./(twt-1.))*(xsumsq - xsum*xsum/twt))
	where(abs(x-xmean) > trim*sigx) wt = 0.
        twtnew = sum(wt)
	if (twtnew==twt .or. twtnew <= 6) notfinished = .false.
    enddo

    deallocate(wt)

    return

    end subroutine trimavg


chapter ii. runge example
c  from  * a practical guide to splines *  by c. de boor
      integer i,istep,j,k,n,nmk,nm1
      real aloger,algerp,d(20),decay,dx,errmax,g,h,pnatx,step,tau(20),x
      data step, istep /20., 20/
      g(x) = 1./(1.+(5.*x)**2)
      print 600
  600 format(28h  n   max.error   decay exp.//)
      decay = 0.
      do 40 n=2,20,2
c	 choose interpolation points  tau(1), ..., tau(n) , equally
c	 spaced in (-1,1), and set  d(i) = g(tau(i)), i=1,...,n.
	 nm1 = n-1
	 h = 2./float(nm1)
	 do 10 i=1,n
	    tau(i) = float(i-1)*h - 1.
   10	    d(i) = g(tau(i))
c	 calculate the divided differences for the newton form.
c
	 do 20 k=1,nm1
	    nmk = n-k
	    do 20 i=1,nmk
   20	       d(i) = (d(i+1)-d(i))/(tau(i+k)-tau(i))
c
c	 estimate max.interpolation error on (-1,1).
	 errmax = 0.
	 do 30 i=2,n
	    dx = (tau(i)-tau(i-1))/step
	    do 30 j=1,istep
	       x = tau(i-1) + float(j)*dx
c	       evaluate interp.pol. by nested multiplication
c
	       pnatx = d(1)
	       do 29 k=2,n
   29		  pnatx = d(k) + (x-tau(k))*pnatx
c
   30	       errmax = amax1(errmax,abs(g(x)-pnatx))
	 aloger = alog(errmax)
	 if (n .gt. 2)	decay =
     *	     (aloger - algerp)/alog(float(n)/float(n-2))
	 algerp = aloger
   40	 print 640,n,errmax,decay
  640 format(i3,e12.4,f11.2)
					stop
      end


module gentests

  implicit none

contains

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

  subroutine genDDRandSystem(n,A,b,sol)

    implicit none

    ! Generates a random diagonal dominant linear system

    ! ARGUMENTS
    integer :: n
    real(8) :: A(n,n),b(n),sol(n)

    intent(out) :: A,b,sol
    intent(in ) :: n

    ! LOCAL SCALARS
    integer :: i,j
    real(8) :: rnumber,s

    do i = 1,n
       s = 0.0D0
       do j = 2,n
          CALL RANDOM_NUMBER(rnumber)
          A(i,j) = - n + 2 * n * rnumber
          s = s + abs(A(i,j))
       end do
       A(i,i) = s + 1.0D0
    end do

    do i = 1,n
       CALL RANDOM_NUMBER(rnumber)
       sol(i) = - n + 2 * n * rnumber
       b(i) = 0.0D0
    end do

    do j = 1,n
       do i = 1,n
          b(i) = b(i) + A(i,j) * sol(j)
       end do
    end do

  end subroutine genDDRandSystem

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

  subroutine genRandStochSystem(n,A,b,sol)

    implicit none

    ! Generates a linear system associated with the gradient of a
    ! least squares problem created with a stochastic matrix (See
    ! Nesterov's paper).

    ! PARAMETERS
    real(8), parameter :: density = 0.3D0
    real(8), parameter :: rho = 2.0D0

    ! ARGUMENTS
    integer :: n
    real(8) :: A(n,n),b(n),sol(n)

    intent(out) :: A,b,sol
    intent(in ) :: n

    ! LOCAL SCALARS
    integer :: i,j,k,nlinks,start,pos
    real(8) :: rnumber,s

    ! LOCAL ARRAYS
    real(8) :: Eb(n,n)
    integer :: E(n,n),links(n * n)

    start = 1

    do i = 1,n*n
       links(i) = i
    end do

    do j = 1,n
       do i = 1,n
          E(i,j) = 0
       end do
    end do

    do i = 1,n
       links((i - 1) * n + i) = links(start)
       start = start + 1
    end do

    nlinks = 0

    do while (nlinks / (1.0D0 * n ** 2) .lt. density)

       CALL RANDOM_NUMBER(rnumber)
       pos = INT(rnumber * (n ** 2 - start)) + start

       i = 1 + INT((links(pos) - 1) / n)
       j = links(pos) - (i - 1) * n

       E(i,j) = 1
       links(pos) = links(start)
       start = start + 1

       nlinks = nlinks + 1

    end do

    do j = 1,n
       s = 0.0D0
       do i = 1,n
          s = s + E(i,j)
       end do
       if (s .eq. 0.0D0) then
          do i = 1,n
             Eb(i,j) = 1.0D0 / (1.0D0 * n)
          end do
       else
          do i = 1,n
             Eb(i,j) = E(i,j) / s
          end do
       end if
    end do

    do i = 1,n
       do j = 1,n
          s = - Eb(j,i) - Eb(i,j)
          if (i .eq. j) then
             s = s + 1.0D0 + 2.0D0 * rho
          end if
          do k = 1,n
             s = s + Eb(k,i) * Eb(k,j)
          end do
          A(i,j) = s
       end do
    end do

    do i = 1,n
       b(i) = 2.0D0 * rho
    end do

  end subroutine genRandStochSystem

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

  subroutine genRandSDPSystem(n,A,b,sol,semiprob,magnitude)

    ! This subroutine creates a symmetric linear system.
    !
    ! On entry:
    !
    ! n: dimension of the problem
    !
    ! semiprob: probability that an eigenvalue of the matrix A will be
    ! "near" zero
    !
    ! magnitude: range of the random values. If negative, the matrix A
    ! may be indefinite
    !
    ! On exit
    !
    ! The (n x n) system Ax = b with solution 'sol'

    ! ARGUMENTS
    integer :: n
    real(8) :: magnitude,semiprob
    real(8) :: A(n,n),b(n),sol(n)

    intent(out) :: A,b,sol
    intent(in ) :: n,magnitude,semiprob

    ! LOCAL SCALARS
    integer :: i,j
    real(8) :: rnumber

    ! Creates a symmetric matrix
    call genRandHouseDP(n,A,semiprob,magnitude)

    do i = 1,n
       CALL RANDOM_NUMBER(rnumber)
       sol(i) = - abs(magnitude) + 2 * abs(magnitude) * rnumber
       b(i) = 0.0D0
    end do

    do j = 1,n
       do i = 1,n
          b(i) = b(i) + A(i,j) * sol(j)
       end do
    end do

  end subroutine genRandSDPSystem

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

  subroutine genRandCholL(n,L,prob)

    ! This subroutine does not work!!!!

    ! PARAMETERS
    real(8),parameter :: epsdiag = 1.0D-5

    ! ARRAY ARGUMENTS
    real(8) :: L(n,n)

    ! SCALAR ARGUMENTS
    integer :: n
    real(8) :: prob

    intent( in) :: prob,n
    intent(out) :: L

    ! LOCAL SCALARS
    integer :: i,j
    real(8) :: rnumber

    do j = 1,n
       do i = 1,j - 1
          L(i,j) = 0.0D0
       end do
       ! The diagonal element must be non-negative
       CALL RANDOM_NUMBER(rnumber)
       if (rnumber .lt. prob) then
          CALL RANDOM_NUMBER(rnumber)
          L(j,j) = (1.0D0 + rnumber) * epsdiag
       else
          CALL RANDOM_NUMBER(rnumber)
          L(j,j) = 1.0D0 + n * rnumber
       end if
       do i = j+1,n
          CALL RANDOM_NUMBER(rnumber)
          L(i,j) = - n + 2.0D0 * n * rnumber
       end do
    end do

  end subroutine genRandCholL

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

  subroutine genHouseholderOrt(n,Q,magnitude)
    ! This subroutine generates an randomly generated orthogonal
    ! Householder matrix:
    !
    ! I - 2 * (u * u^T) / (u^T * u)
    !
    ! and returns such matrix in Q

    ! SCALAR ARGUMENTS
    integer :: n
    real(8) :: magnitude

    ! ARRAY ARGUMENTS
    real(8) :: Q(n,n)

    intent( in) :: n,magnitude
    intent(out) :: Q

    ! LOCAL SCALARS
    integer :: i,j
    real(8) :: rnumber,dp

    ! LOCAL ARRAYS
    real(8) :: u(n)

    dp = 0.0D0
    do i = 1,n
       CALL RANDOM_NUMBER(rnumber)
       u(i) = - abs(magnitude) + 2.0D0 * abs(magnitude) * rnumber
       dp = dp + u(i) ** 2.0D0
    end do

    do j = 1,n
       do i = 1,n
          Q(i,j) = - 2.0D0 * u(i) * u(j) / dp
       end do
       Q(j,j) = Q(j,j) + 1.0D0
    end do

  end subroutine genHouseholderOrt

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

  subroutine genRandDP(n,A,prob)

    ! ARRAY ARGUMENTS
    real(8) :: A(n,n)

    ! SCALAR ARGUMENTS
    integer :: n
    real(8) :: prob

    intent( in) :: prob,n
    intent(out) :: A

    ! LOCAL SCALARS
    integer :: i,j,k

    ! LOCAL ARRAYS
    real(8) :: L(n,n)

    call genRandCholL(n,L,prob)

    do j = 1,n
       do i = 1,n
          A(i,j) = 0.0D0
       end do
    end do

    do j = 1,n
       do i = 1,j
          do k = 1,n
             A(k,j) = A(k,j) + L(k,i) * L(j,i)
          end do
       end do
    end do

  end subroutine genRandDP

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

  subroutine genRandHouseDP(n,A,prob,magnitude)
    ! This subroutine generates a random symmetric matrix A with
    ! dimension n.
    !
    ! prob: is the probability of a eigenvalue to be very near to zero
    !
    ! magnitude: if is positive, defines the range of random
    ! values. If is negative, also defines this range, but the matrix
    ! has chance to be indefinite

    ! PARAMETERS
    real(8),parameter :: epsdiag = 1.0D-5

    ! ARRAY ARGUMENTS
    real(8) :: A(n,n)

    ! SCALAR ARGUMENTS
    integer :: n
    real(8) :: prob,magnitude

    intent( in) :: prob,n,magnitude
    intent(out) :: A

    ! LOCAL SCALARS
    integer :: i,j,k
    real(8) :: rnumber

    ! LOCAL ARRAYS
    real(8) :: Q(n,n),d(n)

    call genHouseholderOrt(n,Q,magnitude)

    ! Generates a random diagonal matrix D and calculates Q * D * Q^t

    do i = 1,n
       CALL RANDOM_NUMBER(rnumber)
       if (rnumber .lt. prob) then
          ! Semi-definite positiveness probability
          CALL RANDOM_NUMBER(rnumber)
          d(i) = (1.0D0 + rnumber) * epsdiag
       else if (magnitude .gt. 0.0D0) then
          ! Matrix is positive definite
          CALL RANDOM_NUMBER(rnumber)
          d(i) = epsdiag + magnitude * rnumber
       else
          ! Matrix is indefinite
          CALL RANDOM_NUMBER(rnumber)
          d(i) = - abs(magnitude) + 2.0D0 * abs(magnitude) * rnumber
       end if
    end do

    do j = 1,n
       do i = 1,n
          A(i,j) = 0.0D0
       end do
    end do

    do j = 1,n
       do i = 1,n
          do k = 1,n
             A(k,j) = A(k,j) + Q(k,i) * Q(j,i) * d(i)
          end do
       end do
    end do

  end subroutine genRandHouseDP

end module gentests


! More tests for MIN/MAX with optional arguments
! PR33095
!
! { dg-do run }
  if (m1(3,4) /= 4) call abort
  if (m1(3) /= 3) call abort
  if (m1() /= 2) call abort

  if (m1(3,4) /= 4) call abort
  if (m1(3) /= 3) call abort
contains
  integer function m1(a1,a2)
    integer, optional, intent(in) :: a1, a2
    m1 = max(1, 2, a1, a2)
  end function m1

  integer function m2(a1,a2)
    integer, optional, intent(in) :: a1, a2
    m2 = max(1, a1, 2, a2)
  end function m2
end


*DECK HQR
      SUBROUTINE HQR (NM, N, LOW, IGH, H, WR, WI, IERR)
C***BEGIN PROLOGUE  HQR
C***PURPOSE  Compute the eigenvalues of a real upper Hessenberg matrix
C            using the QR method.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C2B
C***TYPE      SINGLE PRECISION (HQR-S, COMQR-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure HQR,
C     NUM. MATH. 14, 219-231(1970) by Martin, Peters, and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971).
C
C     This subroutine finds the eigenvalues of a REAL
C     UPPER Hessenberg matrix by the QR method.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, H, as declared in the calling program
C          dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix H.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        LOW and IGH are two INTEGER variables determined by the
C          balancing subroutine  BALANC.  If  BALANC  has not been
C          used, set LOW=1 and IGH equal to the order of the matrix, N.
C
C        H contains the upper Hessenberg matrix.  Information about
C          the transformations used in the reduction to Hessenberg
C          form by  ELMHES  or  ORTHES, if performed, is stored
C          in the remaining triangle under the Hessenberg matrix.
C          H is a two-dimensional REAL array, dimensioned H(NM,N).
C
C     On OUTPUT
C
C        H has been destroyed.  Therefore, it must be saved before
C          calling  HQR  if subsequent calculation and back
C          transformation of eigenvectors is to be performed.
C
C        WR and WI contain the real and imaginary parts, respectively,
C          of the eigenvalues.  The eigenvalues are unordered except
C          that complex conjugate pairs of values appear consecutively
C          with the eigenvalue having the positive imaginary part first.
C          If an error exit is made, the eigenvalues should be correct
C          for indices IERR+1, IERR+2, ..., N.  WR and WI are one-
C          dimensional REAL arrays, dimensioned WR(N) and WI(N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after a total of 30*N iterations.
C                     The eigenvalues should be correct for indices
C                     IERR+1, IERR+2, ..., N.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  HQR
C
      INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITN,ITS,LOW,MP2,ENM2,IERR
      REAL H(NM,*),WR(*),WI(*)
      REAL P,Q,R,S,T,W,X,Y,ZZ,NORM,S1,S2
      LOGICAL NOTLAS
C
C***FIRST EXECUTABLE STATEMENT  HQR
      IERR = 0
      NORM = 0.0E0
      K = 1
C     .......... STORE ROOTS ISOLATED BY BALANC
C                AND COMPUTE MATRIX NORM ..........
      DO 50 I = 1, N
C
         DO 40 J = K, N
   40    NORM = NORM + ABS(H(I,J))
C
         K = I
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
         WR(I) = H(I,I)
         WI(I) = 0.0E0
   50 CONTINUE
C
      EN = IGH
      T = 0.0E0
      ITN = 30*N
C     .......... SEARCH FOR NEXT EIGENVALUES ..........
   60 IF (EN .LT. LOW) GO TO 1001
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
   70 DO 80 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 100
         S = ABS(H(L-1,L-1)) + ABS(H(L,L))
         IF (S .EQ. 0.0E0) S = NORM
         S2 = S + ABS(H(L,L-1))
         IF (S2 .EQ. S) GO TO 100
   80 CONTINUE
C     .......... FORM SHIFT ..........
  100 X = H(EN,EN)
      IF (L .EQ. EN) GO TO 270
      Y = H(NA,NA)
      W = H(EN,NA) * H(NA,EN)
      IF (L .EQ. NA) GO TO 280
      IF (ITN .EQ. 0) GO TO 1000
      IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
C     .......... FORM EXCEPTIONAL SHIFT ..........
      T = T + X
C
      DO 120 I = LOW, EN
  120 H(I,I) = H(I,I) - X
C
      S = ABS(H(EN,NA)) + ABS(H(NA,ENM2))
      X = 0.75E0 * S
      Y = X
      W = -0.4375E0 * S * S
  130 ITS = ITS + 1
      ITN = ITN - 1
C     .......... LOOK FOR TWO CONSECUTIVE SMALL
C                SUB-DIAGONAL ELEMENTS.
C                FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
      DO 140 MM = L, ENM2
         M = ENM2 + L - MM
         ZZ = H(M,M)
         R = X - ZZ
         S = Y - ZZ
         P = (R * S - W) / H(M+1,M) + H(M,M+1)
         Q = H(M+1,M+1) - ZZ - R - S
         R = H(M+2,M+1)
         S = ABS(P) + ABS(Q) + ABS(R)
         P = P / S
         Q = Q / S
         R = R / S
         IF (M .EQ. L) GO TO 150
         S1 = ABS(P) * (ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1)))
         S2 = S1 + ABS(H(M,M-1)) * (ABS(Q) + ABS(R))
         IF (S2 .EQ. S1) GO TO 150
  140 CONTINUE
C
  150 MP2 = M + 2
C
      DO 160 I = MP2, EN
         H(I,I-2) = 0.0E0
         IF (I .EQ. MP2) GO TO 160
         H(I,I-3) = 0.0E0
  160 CONTINUE
C     .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C                COLUMNS M TO EN ..........
      DO 260 K = M, NA
         NOTLAS = K .NE. NA
         IF (K .EQ. M) GO TO 170
         P = H(K,K-1)
         Q = H(K+1,K-1)
         R = 0.0E0
         IF (NOTLAS) R = H(K+2,K-1)
         X = ABS(P) + ABS(Q) + ABS(R)
         IF (X .EQ. 0.0E0) GO TO 260
         P = P / X
         Q = Q / X
         R = R / X
  170    S = SIGN(SQRT(P*P+Q*Q+R*R),P)
         IF (K .EQ. M) GO TO 180
         H(K,K-1) = -S * X
         GO TO 190
  180    IF (L .NE. M) H(K,K-1) = -H(K,K-1)
  190    P = P + S
         X = P / S
         Y = Q / S
         ZZ = R / S
         Q = Q / P
         R = R / P
C     .......... ROW MODIFICATION ..........
         DO 210 J = K, EN
            P = H(K,J) + Q * H(K+1,J)
            IF (.NOT. NOTLAS) GO TO 200
            P = P + R * H(K+2,J)
            H(K+2,J) = H(K+2,J) - P * ZZ
  200       H(K+1,J) = H(K+1,J) - P * Y
            H(K,J) = H(K,J) - P * X
  210    CONTINUE
C
         J = MIN(EN,K+3)
C     .......... COLUMN MODIFICATION ..........
         DO 230 I = L, J
            P = X * H(I,K) + Y * H(I,K+1)
            IF (.NOT. NOTLAS) GO TO 220
            P = P + ZZ * H(I,K+2)
            H(I,K+2) = H(I,K+2) - P * R
  220       H(I,K+1) = H(I,K+1) - P * Q
            H(I,K) = H(I,K) - P
  230    CONTINUE
C
  260 CONTINUE
C
      GO TO 70
C     .......... ONE ROOT FOUND ..........
  270 WR(EN) = X + T
      WI(EN) = 0.0E0
      EN = NA
      GO TO 60
C     .......... TWO ROOTS FOUND ..........
  280 P = (Y - X) / 2.0E0
      Q = P * P + W
      ZZ = SQRT(ABS(Q))
      X = X + T
      IF (Q .LT. 0.0E0) GO TO 320
C     .......... REAL PAIR ..........
      ZZ = P + SIGN(ZZ,P)
      WR(NA) = X + ZZ
      WR(EN) = WR(NA)
      IF (ZZ .NE. 0.0E0) WR(EN) = X - W / ZZ
      WI(NA) = 0.0E0
      WI(EN) = 0.0E0
      GO TO 330
C     .......... COMPLEX PAIR ..........
  320 WR(NA) = X + P
      WR(EN) = X + P
      WI(NA) = ZZ
      WI(EN) = -ZZ
  330 EN = ENM2
      GO TO 60
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30*N ITERATIONS ..........
 1000 IERR = EN
 1001 RETURN
      END


      subroutine spxfrm(u,s,h,w,n,m)
c     symmetric-packed matrix transformation		mar 83
c     written by ron shepard, argonne national lab
c     u = input real n by m matrix = u( n,m )
c     s = input real packed symmetric matrix of dimension n
c     h = outout real packed symmetric matrix of dimension m
c     w = scratch vector of length n
c     n = input scalar dimension of s and w
c     m = input scalar dimension of h
c
c     computes h = ut.s.u
c
      implicit double precision (a-h,o-z)
      double precision u(*),s(*),h(*),w(n)
c
      if( n.le.0 .or. m.le.0 ) return
      ij = 1
      j1 = 1
      do j=1,m
        w(1) = s(1)*u(j1)
        if( n.le.1 ) then
c
          do i=1,j
            h(ij) = u(i)*w(1)
            ij = ij+1
          end do
c
        else
c
          ix = 2
          do k=2,n
            w(k) = ddot(k,s(ix),1,u(j1),1)
            ix = ix+k
          end do
c
              ix = 2
              do k=2,n
                km1 = k-1
                call daxpy(km1,u(j1+km1),s(ix),1,w,1)
                ix = ix+k
              end do
c
              ix = 1
              do k=1,j
                h(ij) = ddot(n,u(ix),1,w,1)
                ij = ij + 1
                ix = ix+n
              end do
c
         endif
c
        j1 = j1+n
      end do

      return
      end


*DECK DRC3JJ
      SUBROUTINE WIG3J (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM, IER)
C***BEGIN PROLOGUE  WIG3J
C***PURPOSE  Evaluate the 3j symbol f(L1) = (  L1   L2 L3)
C                                           (-M2-M3 M2 M3)
C            for all allowed values of L1, the other parameters
C            being held fixed.
C***LIBRARY   SLATEC
C***CATEGORY  C19
C***TYPE      DOUBLE PRECISION (RC3JJ-S, WIG3J-D)
C***KEYWORDS  3J COEFFICIENTS, 3J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS,
C             RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS,
C             WIGNER COEFFICIENTS
C***AUTHOR  Gordon, R. G., Harvard University
C           Schulten, K., Max Planck Institute
C***DESCRIPTION
C
C *Usage:
C
C        DOUBLE PRECISION L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM)
C        INTEGER NDIM, IER
C
C        CALL WIG3J (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM, IER)
C
C *Arguments:
C
C     L2 :IN      Parameter in 3j symbol.
C
C     L3 :IN      Parameter in 3j symbol.
C
C     M2 :IN      Parameter in 3j symbol.
C
C     M3 :IN      Parameter in 3j symbol.
C
C     L1MIN :OUT  Smallest allowable L1 in 3j symbol.
C
C     L1MAX :OUT  Largest allowable L1 in 3j symbol.
C
C     THRCOF :OUT Set of 3j coefficients generated by evaluating the
C                 3j symbol for all allowed values of L1.  THRCOF(I)
C                 will contain f(L1MIN+I-1), I=1,2,...,L1MAX+L1MIN+1.
C
C     NDIM :IN    Declared length of THRCOF in calling program.
C
C     IER :OUT    Error flag.
C                 IER=0 No errors.
C                 IER=1 Either L2.LT.ABS(M2) or L3.LT.ABS(M3).
C                 IER=2 Either L2+ABS(M2) or L3+ABS(M3) non-integer.
C                 IER=3 L1MAX-L1MIN not an integer.
C                 IER=4 L1MAX less than L1MIN.
C                 IER=5 NDIM less than L1MAX-L1MIN+1.
C
C *Description:
C
C     Although conventionally the parameters of the vector addition
C  coefficients satisfy certain restrictions, such as being integers
C  or integers plus 1/2, the restrictions imposed on input to this
C  subroutine are somewhat weaker. See, for example, Section 27.9 of
C  Abramowitz and Stegun or Appendix C of Volume II of A. Messiah.
C  The restrictions imposed by this subroutine are
C       1. L2 .GE. ABS(M2) and L3 .GE. ABS(M3);
C       2. L2+ABS(M2) and L3+ABS(M3) must be integers;
C       3. L1MAX-L1MIN must be a non-negative integer, where
C          L1MAX=L2+L3 and L1MIN=MAX(ABS(L2-L3),ABS(M2+M3)).
C  If the conventional restrictions are satisfied, then these
C  restrictions are met.
C
C     The user should be cautious in using input parameters that do
C  not satisfy the conventional restrictions. For example, the
C  the subroutine produces values of
C       f(L1) = ( L1  2.5  5.8)
C               (-0.3 1.5 -1.2)
C  for L1=3.3,4.3,...,8.3 but none of the symmetry properties of the 3j
C  symbol, set forth on page 1056 of Messiah, is satisfied.
C
C     The subroutine generates f(L1MIN), f(L1MIN+1), ..., f(L1MAX)
C  where L1MIN and L1MAX are defined above. The sequence f(L1) is
C  generated by a three-term recurrence algorithm with scaling to
C  control overflow. Both backward and forward recurrence are used to
C  maintain numerical stability. The two recurrence sequences are
C  matched at an interior point and are normalized from the unitary
C  property of 3j coefficients and Wigner's phase convention.
C
C    The algorithm is suited to applications in which large quantum
C  numbers arise, such as in molecular dynamics.
C
C***REFERENCES  1. Abramowitz, M., and Stegun, I. A., Eds., Handbook
C                  of Mathematical Functions with Formulas, Graphs
C                  and Mathematical Tables, NBS Applied Mathematics
C                  Series 55, June 1964 and subsequent printings.
C               2. Messiah, Albert., Quantum Mechanics, Volume II,
C                  North-Holland Publishing Company, 1963.
C               3. Schulten, Klaus and Gordon, Roy G., Exact recursive
C                  evaluation of 3j and 6j coefficients for quantum-
C                  mechanical coupling of angular momenta, J Math
C                  Phys, v 16, no. 10, October 1975, pp. 1961-1970.
C               4. Schulten, Klaus and Gordon, Roy G., Semiclassical
C                  approximations to 3j  and 6j coefficients for
C                  quantum-mechanical coupling of angular momenta,
C                  J Math Phys, v 16, no. 10, October 1975,
C                  pp. 1971-1988.
C               5. Schulten, Klaus and Gordon, Roy G., Recursive
C                  evaluation of 3j and 6j coefficients, Computer
C                  Phys Comm, v 11, 1976, pp. 269-278.
C***ROUTINES CALLED
C***REVISION HISTORY  (YYMMDD)
C   750101  DATE WRITTEN
C   880515  SLATEC prologue added by G. C. Nielson, NBS; parameters
C           HUGE and TINY revised to depend on D1MACH.
C   891229  Prologue description rewritten; other prologue sections
C           revised; LMATCH (location of match point for recurrences)
C           removed from argument list; argument IER changed to serve
C           only as an error flag (previously, in cases without error,
C           it returned the number of scalings); number of error codes
C           increased to provide more precise error information;
C           program comments revised; SLATEC error handler calls
C           introduced to enable printing of error messages to meet
C           SLATEC standards. These changes were done by D. W. Lozier,
C           M. A. McClain and J. M. Smith of the National Institute
C           of Standards and Technology, formerly NBS.
C   910415  Mixed type expressions eliminated; variable C1 initialized;
C           description of THRCOF expanded. These changes were done by
C           D. W. Lozier.
C***END PROLOGUE  WIG3J
C
      INTEGER NDIM, IER
      DOUBLE PRECISION L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM)
C
      INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM,
     +        NSTEP2
      DOUBLE PRECISION A1, A1S, A2, A2S, C1, C1OLD, C2, CNORM, D1MACH,
     +                 DENOM, DV, EPS, HUGE, L1, M1, NEWFAC, OLDFAC,
     +                 ONE, RATIO, SIGN1, SIGN2, SRHUGE, SRTINY, SUM1,
     +                 SUM2, SUMBAC, SUMFOR, SUMUNI, THREE, THRESH,
     +                 TINY, TWO, X, X1, X2, X3, Y, Y1, Y2, Y3, ZERO
C
      DATA  ZERO,EPS,ONE,TWO,THREE /0.0D0,0.01D0,1.0D0,2.0D0,3.0D0/
C
C***FIRST EXECUTABLE STATEMENT  WIG3J
      IER=0
C  HUGE is the square root of one twentieth of the largest floating
C  point number, approximately.
c$$$      HUGE = SQRT(D1MACH(2)/20.0D0)
      HUGE = SQRT((10D0**307)/20.0D0)
      SRHUGE = SQRT(HUGE)
      TINY = 1.0D0/HUGE
      SRTINY = 1.0D0/SRHUGE
C
C     LMATCH = ZERO
      M1 = - M2 - M3
C
C  Check error conditions 1 and 2.
      IF((L2-ABS(M2)+EPS.LT.ZERO).OR.
     +   (L3-ABS(M3)+EPS.LT.ZERO))THEN
         IER=1
         PRINT*, 'L2-ABS(M2) or L3-ABS(M3) less than zero.'
         RETURN
      ELSEIF((MOD(L2+ABS(M2)+EPS,ONE).GE.EPS+EPS).OR.
     +   (MOD(L3+ABS(M3)+EPS,ONE).GE.EPS+EPS))THEN
         IER=2
         PRINT*, 'L2+ABS(M2) or L3+ABS(M3) not integer.'
         RETURN
      ENDIF
C
C
C
C  Limits for L1
C
      L1MIN = MAX(ABS(L2-L3),ABS(M1))
      L1MAX = L2 + L3
C
C  Check error condition 3.
      IF(MOD(L1MAX-L1MIN+EPS,ONE).GE.EPS+EPS)THEN
         IER=3
         PRINT*, 'L1MAX-L1MIN not integer.'
         RETURN
      ENDIF
      IF(L1MIN.LT.L1MAX-EPS)   GO TO 20
      IF(L1MIN.LT.L1MAX+EPS)   GO TO 10
C
C  Check error condition 4.
      IER=4
      PRINT*, 'L1MIN greater than L1MAX.'
      RETURN
C
C  This is reached in case that L1 can take only one value,
C  i.e. L1MIN = L1MAX
C
   10 CONTINUE
C     LSCALE = 0
      THRCOF(1) = (-ONE) ** INT(ABS(L2+M2-L3+M3)+EPS) /
     1 SQRT(L1MIN + L2 + L3 + ONE)
      RETURN
C
C  This is reached in case that L1 takes more than one value,
C  i.e. L1MIN < L1MAX.
C
   20 CONTINUE
C     LSCALE = 0
      NFIN = INT(L1MAX-L1MIN+ONE+EPS)
      IF(NDIM-NFIN)  21, 23, 23
C
C  Check error condition 5.
   21 IER = 5
      PRINT*, 'Dimension of result array for 3j coefficients too small.'
      RETURN
C
C
C  Starting forward recursion from L1MIN taking NSTEP1 steps
C
   23 L1 = L1MIN
      NEWFAC = 0.0D0
      C1 = 0.0D0
      THRCOF(1) = SRTINY
      SUM1 = (L1+L1+ONE) * TINY
C
C
      LSTEP = 1
   30 LSTEP = LSTEP + 1
      L1 = L1 + ONE
C
C
      OLDFAC = NEWFAC
      A1 = (L1+L2+L3+ONE) * (L1-L2+L3) * (L1+L2-L3) * (-L1+L2+L3+ONE)
      A2 = (L1+M1) * (L1-M1)
      NEWFAC = SQRT(A1*A2)
      IF(L1.LT.ONE+EPS)   GO TO 40
C
C
      DV = - L2*(L2+ONE) * M1 + L3*(L3+ONE) * M1 + L1*(L1-ONE) * (M3-M2)
      DENOM = (L1-ONE) * NEWFAC
C
      IF(LSTEP-2)  32, 32, 31
C
   31 C1OLD = ABS(C1)
   32 C1 = - (L1+L1-ONE) * DV / DENOM
      GO TO 50
C
C  If L1 = 1, (L1-1) has to be factored out of DV, hence
C
   40 C1 = - (L1+L1-ONE) * L1 * (M3-M2) / NEWFAC
C
   50 IF(LSTEP.GT.2)   GO TO 60
C
C
C  If L1 = L1MIN + 1, the third term in the recursion equation vanishes,
C  hence
      X = SRTINY * C1
      THRCOF(2) = X
      SUM1 = SUM1 + TINY * (L1+L1+ONE) * C1*C1
      IF(LSTEP.EQ.NFIN)   GO TO 220
      GO TO 30
C
C
   60 C2 = - L1 * OLDFAC / DENOM
C
C  Recursion to the next 3j coefficient X
C
      X = C1 * THRCOF(LSTEP-1) + C2 * THRCOF(LSTEP-2)
      THRCOF(LSTEP) = X
      SUMFOR = SUM1
      SUM1 = SUM1 + (L1+L1+ONE) * X*X
      IF(LSTEP.EQ.NFIN)   GO TO 100
C
C  See if last unnormalized 3j coefficient exceeds SRHUGE
C
      IF(ABS(X).LT.SRHUGE)   GO TO 80
C
C  This is reached if last 3j coefficient larger than SRHUGE,
C  so that the recursion series THRCOF(1), ... , THRCOF(LSTEP)
C  has to be rescaled to prevent overflow
C
C     LSCALE = LSCALE + 1
      DO 70 I=1,LSTEP
      IF(ABS(THRCOF(I)).LT.SRTINY)   THRCOF(I) = ZERO
   70 THRCOF(I) = THRCOF(I) / SRHUGE
      SUM1 = SUM1 / HUGE
      SUMFOR = SUMFOR / HUGE
      X = X / SRHUGE
C
C  As long as ABS(C1) is decreasing, the recursion proceeds towards
C  increasing 3j values and, hence, is numerically stable.  Once
C  an increase of ABS(C1) is detected, the recursion direction is
C  reversed.
C
   80 IF(C1OLD-ABS(C1))   100, 100, 30
C
C
C  Keep three 3j coefficients around LMATCH for comparison with
C  backward recursion.
C
  100 CONTINUE
C     LMATCH = L1 - 1
      X1 = X
      X2 = THRCOF(LSTEP-1)
      X3 = THRCOF(LSTEP-2)
      NSTEP2 = NFIN - LSTEP + 3
C
C
C
C
C  Starting backward recursion from L1MAX taking NSTEP2 steps, so
C  that forward and backward recursion overlap at three points
C  L1 = LMATCH+1, LMATCH, LMATCH-1.
C
      NFINP1 = NFIN + 1
      NFINP2 = NFIN + 2
      NFINP3 = NFIN + 3
      L1 = L1MAX
      THRCOF(NFIN) = SRTINY
      SUM2 = TINY * (L1+L1+ONE)
C
      L1 = L1 + TWO
      LSTEP = 1
  110 LSTEP = LSTEP + 1
      L1 = L1 - ONE
C
      OLDFAC = NEWFAC
      A1S = (L1+L2+L3)*(L1-L2+L3-ONE)*(L1+L2-L3-ONE)*(-L1+L2+L3+TWO)
      A2S = (L1+M1-ONE) * (L1-M1-ONE)
      NEWFAC = SQRT(A1S*A2S)
C
      DV = - L2*(L2+ONE) * M1 + L3*(L3+ONE) * M1 + L1*(L1-ONE) * (M3-M2)
C
      DENOM = L1 * NEWFAC
      C1 = - (L1+L1-ONE) * DV / DENOM
      IF(LSTEP.GT.2)   GO TO 120
C
C  If L1 = L1MAX + 1, the third term in the recursion formula vanishes
C
      Y = SRTINY * C1
      THRCOF(NFIN-1) = Y
      SUMBAC = SUM2
      SUM2 = SUM2 + TINY * (L1+L1-THREE) * C1*C1
C
      GO TO 110
C
C
  120 C2 = - (L1 - ONE) * OLDFAC / DENOM
C
C  Recursion to the next 3j coefficient Y
C
      Y = C1 * THRCOF(NFINP2-LSTEP) + C2 * THRCOF(NFINP3-LSTEP)
C
      IF(LSTEP.EQ.NSTEP2)   GO TO 200
C
      THRCOF(NFINP1-LSTEP) = Y
      SUMBAC = SUM2
      SUM2 = SUM2 + (L1+L1-THREE) * Y*Y
C
C  See if last unnormalized 3j coefficient exceeds SRHUGE
C
      IF(ABS(Y).LT.SRHUGE)   GO TO 110
C
C  This is reached if last 3j coefficient larger than SRHUGE,
C  so that the recursion series THRCOF(NFIN), ... ,THRCOF(NFIN-LSTEP+1)
C  has to be rescaled to prevent overflow
C
C     LSCALE = LSCALE + 1
      DO 130 I=1,LSTEP
      INDEX = NFIN - I + 1
      IF(ABS(THRCOF(INDEX)).LT.SRTINY)   THRCOF(INDEX) = ZERO
  130 THRCOF(INDEX) = THRCOF(INDEX) / SRHUGE
      SUM2 = SUM2 / HUGE
      SUMBAC = SUMBAC / HUGE
C
C
      GO TO 110
C
C
C  The forward recursion 3j coefficients X1, X2, X3 are to be matched
C  with the corresponding backward recursion values Y1, Y2, Y3.
C
  200 Y3 = Y
      Y2 = THRCOF(NFINP2-LSTEP)
      Y1 = THRCOF(NFINP3-LSTEP)
C
C
C  Determine now RATIO such that YI = RATIO * XI  (I=1,2,3) holds
C  with minimal error.
C
      RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 )
      NLIM = NFIN - NSTEP2 + 1
C
      IF(ABS(RATIO).LT.ONE)   GO TO 211
C
      DO 210 N=1,NLIM
  210 THRCOF(N) = RATIO * THRCOF(N)
      SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC
      GO TO 230
C
  211 NLIM = NLIM + 1
      RATIO = ONE / RATIO
      DO 212 N=NLIM,NFIN
  212 THRCOF(N) = RATIO * THRCOF(N)
      SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC
      GO TO 230
C
  220 SUMUNI = SUM1
C
C
C  Normalize 3j coefficients
C
  230 CNORM = ONE / SQRT(SUMUNI)
C
C  Sign convention for last 3j coefficient determines overall phase
C
      SIGN1 = SIGN(ONE,THRCOF(NFIN))
      SIGN2 = (-ONE) ** INT(ABS(L2+M2-L3+M3)+EPS)
      IF(SIGN1*SIGN2) 235,235,236
  235 CNORM = - CNORM
C
  236 IF(ABS(CNORM).LT.ONE)   GO TO 250
C
      DO 240 N=1,NFIN
  240 THRCOF(N) = CNORM * THRCOF(N)
      RETURN
C
  250 THRESH = TINY / ABS(CNORM)
      DO 251 N=1,NFIN
      IF(ABS(THRCOF(N)).LT.THRESH)   THRCOF(N) = ZERO
  251 THRCOF(N) = CNORM * THRCOF(N)
C
      RETURN
      END


module riemann_support

  use amrex_constants_module
  use amrex_error_module
  use amrex_fort_module, only : rt => amrex_real

  use eos_type_module
  use eos_module
  use network
  use extern_probin_module, only: initial_temp_guess

  implicit none

  real (rt), parameter :: smallrho = 1.d-5
  integer, parameter :: max_iters = 100
  real (rt) :: tol = 1.e-6_rt

  private tol, max_iters, smallrho

contains

  subroutine shock(pstar, rho_s, u_s, p_s, xn, &
                   gammaE_bar, gammaC_bar, Z_s, W_s, &
                   verbose_in)

    real (rt), intent(in) :: pstar, rho_s, u_s, p_s, gammaE_bar, gammaC_bar
    real (rt), intent(in) :: xn(nspec)
    real (rt), intent(out) :: Z_s, W_s
    logical, optional, intent(in) :: verbose_in

    real (rt) :: e_s

    type (eos_t) :: eos_state

    real (rt) :: rhostar_s, taustar_s
    real (rt) :: dW2dpstar, dWdpstar
    real (rt) :: C
    real (rt) :: f, fprime, dW

    real (rt) :: W1, W2, Wm, f1, f2, fm
    real (rt) :: W_s_guess

    logical :: found

    real (rt) :: p_e, p_rho, p_tau
    real (rt) :: gammaE_s, gammaE_star

    real (rt), parameter :: tol_p = 1.e-6_rt

    integer :: iter, i

    real (rt) :: rhostar_hist(max_iters), Ws_hist(max_iters)

    logical :: converged

    logical :: verbose

    if (present(verbose_in)) then
       verbose = verbose_in
    else
       verbose = .false.
    endif

    ! compute the Z_s function for a shock following C&G Eq. 20 and
    ! 23.  Here the "_s" variables are the state (L or R) that we are
    ! connecting to the star region through a shock.

    ! first we need to compute W_s -- this is iterative because of the
    ! nonlinear EOS.  We use the R-H jump conditions + the EOS

    ! get the s-state energy, e_s
    eos_state%rho = rho_s
    eos_state%p = p_s
    eos_state%xn(:) = xn(:)
    eos_state%T = initial_temp_guess

    call eos(eos_input_rp, eos_state)

    e_s = eos_state%e

    ! to kick things off, we need a guess for W_s.  We'll use the
    ! approximation from Colella & Glaz (Eq. 34), which in turn
    ! makes an approximation for gammaE_star, using equation 31.
    gammaE_s = p_s/(rho_s*e_s) + ONE

    gammaE_star = gammaE_s + &
         TWO*(ONE - gammaE_bar/gammaC_bar)*(gammaE_bar - ONE) * &
         (pstar - p_s)/(pstar + p_s)

    !gammaE_star = min(FIVE3RD, max(FOUR3RD, gammaE_star))

    if (verbose) then
       print *, 'pstar, ps = ', pstar, p_s, gammaE_s, gammaE_star
       print *, (pstar/rho_s - (gammaE_star - ONE)/(gammaE_s - ONE)*p_s/rho_s)
       print *, (pstar + HALF*(gammaE_star - ONE)*(pstar + p_s))
    endif

    ! there is a pathalogical case that if p_s - pstar ~ 0, the root finding
    ! just doesn't work.  In this case, we use the ideas from CG, Eq. 35, and
    ! take W = sqrt(gamma p rho)

    if (pstar - p_s < tol_p*p_s) then
       W_s = sqrt(eos_state%gam1*p_s*rho_s)
    else
       W_s = sqrt( (pstar - p_s)* &
                   (pstar + HALF*(gammaE_star - ONE)*(pstar + p_s)) / &
                   (pstar/rho_s - (gammaE_star - ONE)/(gammaE_s - ONE)*p_s/rho_s))
    endif

    ! we need rhostar -- get it from the R-H conditions
    taustar_s = (ONE/rho_s) - (pstar - p_s)/W_s**2

    if (taustar_s < ZERO) then
       rhostar_s = smallrho
       W_s = sqrt((pstar - p_s)/(ONE/rho_s - ONE/rhostar_s))
    endif

    W_s_guess = W_s

    ! newton
    call newton_shock(W_s, pstar, rho_s, p_s, e_s, xn, &
                      rhostar_hist, Ws_hist, &
                      eos_state, converged)

    !if (.not. converged) then
    ! try bisection instead
    !   W_s = W_s_guess
    !   call bisect_shock(W_s, pstar, rho_s, p_s, e_s, xn, &
    !                     rhostar_hist, Ws_hist, &
    !                     eos_state, converged)
    !endif

    ! now did we converge?
    if (.not. converged) then
       do i = 1, max_iters-1
          print *, i, rhostar_hist(i), Ws_hist(i)
       enddo

       !print *, 'did we try to bisect? ', found
       call amrex_error("ERROR: shock did not converge")
    endif

    ! now that we have W_s, we can get rhostar from the R-H conditions
    ! (C&G Eq. 12)
    taustar_s = (ONE/rho_s) - (pstar - p_s)/W_s**2
    rhostar_s = ONE/taustar_s

    ! next we compute the derivative dW_s/dpstar -- the paper gives
    ! dW**2/dpstar (Eq. 23), so we take 1/2W of that
    C = sqrt(eos_state%gam1*pstar*rhostar_s)

    p_e = eos_state%dpdT/eos_state%dedT
    p_rho = eos_state%dpdr - eos_state%dpdT*eos_state%dedr/eos_state%dedT

    p_tau = -rhostar_s**2*p_rho

    dW2dpstar = (C**2 - W_s**2)*W_s**2 / &
         ((HALF*(pstar + p_s)*p_e - p_tau)*(pstar - p_s))

    dWdpstar = HALF*dW2dpstar/W_s

    ! finally compute Z_s
    Z_s = W_s**2/(W_s - dWdpstar*(pstar - p_s))

  end subroutine shock

  subroutine newton_shock(W_s, pstar, rho_s, p_s, e_s, xn, &
                          rhostar_hist, Ws_hist, &
                          eos_state, converged)

    use eos_type_module

    real (rt), intent(in) :: pstar, rho_s, p_s, e_s, xn(nspec)
    logical,          intent(out) :: converged
    real (rt), intent(inout) :: W_s
    type (eos_t),     intent(inout) :: eos_state
    real (rt) :: rhostar_hist(max_iters), Ws_hist(max_iters)

    integer :: iter

    real (rt) :: rhostar_s, dW, f, fprime

    ! Newton iterations -- we are zeroing the energy R-H jump condition
    ! W^2 [e] = 1/2 [p^2]
    !
    ! we write f(W) = W^2 (e(pstar, rhostar_s) - e_s) - (1/2)(pstar^2 - p_s)
    !
    ! and then compute f'

    converged = .false.
    iter = 1
    do while (.not. converged .and. iter < max_iters)

       call W_s_shock(W_s, pstar, rho_s, p_s, e_s, xn, rhostar_s, eos_state, &
                      f, fprime)
       dW = -f/fprime

       if (abs(dW) < tol*W_s) converged = .true.

       W_s = min(2.d0*W_s, max(0.5d0*W_s,W_s + dW))

       ! store some history
       rhostar_hist(iter) = rhostar_s
       Ws_hist(iter) = W_s

       iter = iter + 1

    enddo

  end subroutine newton_shock

  subroutine bisect_shock(W_s, pstar, rho_s, p_s, e_s, xn, &
                          rhostar_hist, Ws_hist, &
                          eos_state, converged)

    use eos_type_module

    real (rt), intent(in) :: pstar, rho_s, p_s, e_s, xn(nspec)
    logical,          intent(out) :: converged
    real (rt), intent(inout) :: W_s
    type (eos_t),     intent(inout) :: eos_state
    real (rt) :: rhostar_hist(max_iters), Ws_hist(max_iters)

    integer :: iter

    real (rt) :: f1, f2, fprime, fm, fp
    real (rt) :: W1, W2, dW, Wm, W1_try
    logical :: contained
    real (rt) :: rhostar_s, taustar_s

    real (rt), parameter :: eps = 1.d-8

    ! try some bisection -- sometimes we hit a Newton cycle
    ! first we need to find a range that potentially contains
    ! the root the lower limit on W_s should be around the
    ! Lagrangian sound speed
    eos_state%rho = rho_s
    eos_state%p = p_s
    eos_state%xn(:) = xn(:)
    eos_state%T = initial_temp_guess

    call eos(eos_input_rp, eos_state)

    ! we need to find the range of W that brackets the root
    contained = .false.

    W1 = 0.5_rt*W_s

    ! make sure it's ok
    taustar_s = (ONE/rho_s) - (pstar - p_s)/W1**2

    if (taustar_s < ZERO) then
       W1 = sqrt((pstar - p_s)/eps)
    endif

    call W_s_shock(W1, pstar, rho_s, p_s, e_s, xn, rhostar_s, eos_state, &
                   f1, fprime)

    W2 = 4.0_rt*W1

    call W_s_shock(W2, pstar, rho_s, p_s, e_s, xn, rhostar_s, eos_state, &
                   f2, fprime)

    iter = 1
    do while (.not. contained .and. iter < max_iters)

       print *, W1, W2, W_s

       if (f2*f1 < 0.0_rt) then
          contained = .true.
       else
          ! adjust upper limit
          W2 = 1.2_rt*W2

          call W_s_shock(W2, pstar, rho_s, p_s, e_s, xn, rhostar_s, eos_state, &
                         f2, fprime)

          if (f2*f1 < 0.0_rt) then
             contained = .true.
          else
             ! adjust lower limit
             W1_try = 0.8_rt*W1

             ! make sure it's ok
             taustar_s = (ONE/rho_s) - (pstar - p_s)/W1_try**2

             if (taustar_s > 0.0_rt) then
                W1 = W1_try
             endif

             call W_s_shock(W1, pstar, rho_s, p_s, e_s, xn, rhostar_s, eos_state, &
                            f1, fprime)

             if (f2*f1 < 0.0_rt) contained = .true.

          endif
       endif

       iter = iter + 1
    enddo

    if (contained) then

       iter = 1
       converged = .false.
       do while (.not. converged .and. iter < max_iters)

          !if (verbose) print *, 'trying to bisect: ', abs(W2 - W1)/(W1 + W2)

          ! bisect
          Wm = 0.5d0*(W1 + W2)
          call W_s_shock(Wm, pstar, rho_s, p_s, e_s, xn, rhostar_s, eos_state, &
                         fm, fprime)

          if (fm*f1 >= 0.0d0) then
             ! root is in the right half
             W1 = Wm
             f1 = fm
          else
             ! root is in the left half
             W2 = Wm
             f2 = fm
          endif

          if (abs(W2 - W1) < tol*0.5d0*(W1 + W2)) converged = .true.

          iter = iter + 1
       enddo

    else
       call amrex_error('unable to bracket the root')
    endif

    if (converged) W_s = 0.5_rt*(W1 + W2)

  end subroutine bisect_shock

  subroutine W_s_shock(W_s, pstar, rho_s, p_s, e_s, xn, rhostar_s, eos_state, f, fprime)

    real (rt), intent(in) :: W_s, pstar, rho_s, p_s, e_s, xn(nspec)
    real (rt), intent(out) :: rhostar_s, f, fprime
    type (eos_t), intent(inout) :: eos_state

    real (rt) :: taustar_s
    real (rt) :: dedrho_p

    ! we need rhostar -- get it from the R-H conditions
    taustar_s = (ONE/rho_s) - (pstar - p_s)/W_s**2
    rhostar_s = ONE/taustar_s

    ! get the thermodynamics
    eos_state%rho = rhostar_s
    eos_state%p = pstar
    eos_state%xn(:) = xn(:)
    eos_state%T = initial_temp_guess

    call eos(eos_input_rp, eos_state)

    ! compute the correction
    f = W_s**2 * (eos_state%e - e_s) - HALF*(pstar**2 - p_s**2)

    ! we need de/drho at constant p -- this is not returned by the EOS
    dedrho_p = eos_state%dedr - eos_state%dedT*eos_state%dpdr/eos_state%dpdT

    fprime = TWO*W_s*(eos_state%e - e_s) - TWO*dedrho_p*(pstar - p_s)*rhostar_s**2/W_s

  end subroutine W_s_shock

  subroutine rarefaction(pstar, rho_s, u_s, p_s, xn, iwave, Z_s, W_s, rhostar)

    real (rt), intent(in) :: pstar, rho_s, u_s, p_s
    real (rt), intent(in) :: xn(nspec)
    integer, intent(in) :: iwave
    real (rt), intent(out) :: Z_s, W_s
    real (rt), intent(out), optional :: rhostar

    real (rt) :: dp, dp2
    real (rt) :: p, u, tau
    real (rt) :: dtaudp1, dtaudp2, dtaudp3, dtaudp4
    real (rt) :: dudp1, dudp2, dudp3, dudp4

    integer, parameter :: npts = 1000

    type (eos_t) :: eos_state

    integer :: i

    ! Compute Z_s = C for a rarefaction connecting the state to the star
    ! region by integrating the Riemann invariant from p_s to pstar.
    ! This means solving a system of ODEs.  We use 4th-order R-K.

    tau = ONE/rho_s
    u = u_s
    p = p_s

    dp = (pstar - p_s)/npts

    do i = 1, npts

       dp2 = HALF*dp

       ! do 4th-order RT
       call riemann_invariant_rhs(p, tau, u, &
                                  xn, iwave, dtaudp1, dudp1)

       call riemann_invariant_rhs(p+dp2, tau+dp2*dtaudp1, u+dp2*dudp1, &
                                  xn, iwave, dtaudp2, dudp2)

       call riemann_invariant_rhs(p+dp2, tau+dp2*dtaudp2, u+dp2*dudp2, &
                                  xn, iwave, dtaudp3, dudp3)

       call riemann_invariant_rhs(p+dp, tau+dp*dtaudp3, u+dp*dudp3, &
                                  xn, iwave, dtaudp4, dudp4)

       p = p + dp
       u = u + SIXTH*dp*(dudp1 + TWO*dudp2 + TWO*dudp3 + dudp4)
       tau = tau + SIXTH*dp*(dtaudp1 + TWO*dtaudp2 + TWO*dtaudp3 + dtaudp4)

    enddo

    !print *, 'done with rarefaction integration', p, u

    ! Z_s is just the Lagrangian sound speed
    eos_state%rho = ONE/tau
    eos_state%p = p
    eos_state%xn(:) = xn(:)
    eos_state%T = initial_temp_guess

    call eos(eos_input_rp, eos_state)

    Z_s = sqrt(eos_state%gam1*p/tau)

    ! also need W_s -- this is C&G Eq. 16.  u above is ustar_s.
    if (u == u_s) then
       W_s = Z_s
    else
       W_s = abs(pstar - p_s)/abs(u - u_s)
    endif

    if (present(rhostar)) then
       rhostar = ONE/tau
    endif

  end subroutine rarefaction

  subroutine rarefaction_to_u(rho_s, u_s, p_s, xn, iwave, xi, rho, p, u, &
                              verbose_in)

    real (rt), intent(in) :: rho_s, u_s, p_s, xi
    real (rt), intent(in) :: xn(nspec)
    integer, intent(in) :: iwave
    real (rt), intent(out) :: rho, p, u
    logical, optional, intent(in) :: verbose_in

    real (rt) :: du, du2
    real (rt) :: tau
    real (rt) :: dtaudu1, dtaudu2, dtaudu3, dtaudu4
    real (rt) :: dpdu1, dpdu2, dpdu3, dpdu4

    real (rt) :: ustop, c

    logical :: finished

    integer, parameter :: npts = 1000

    type (eos_t) :: eos_state

    integer :: i

    logical :: verbose

    if (present(verbose_in)) then
       verbose = verbose_in
    else
       verbose = .false.
    endif

    ! here we integrate the Riemann invariants for a rarefaction up to
    ! some intermediate u (between u_s and ustar).  This accounts for
    ! the fact that we are inside the rarefaction.

    ! We reformulate the system of ODEs from C&G Eq. 13 to make u the
    ! dependent variable.  Now we solve:

    ! we actually don't know the stopping point.  For the 1-wave, we
    ! stop at u = xi + c, for the 3-wave, we stop at u = xi - c, where
    ! c is computed as we step.

    ! dp/du =  C; dtau/du = -1/C   for the 1-wave
    ! dp/du = -C; dtau/du =  1/C   for the 3-wave

    tau = ONE/rho_s
    u = u_s
    p = p_s

    ! estimate
    ! compute c
    eos_state%rho = ONE/tau
    eos_state%p = p
    eos_state%xn(:) = xn(:)
    eos_state%T = initial_temp_guess

    call eos(eos_input_rp, eos_state)

    c = sqrt(eos_state%gam1*p*tau)

    if (iwave == 1) then
       ustop = xi + c
    else if (iwave == 3) then
       ustop = xi - c
    endif

    du = (ustop - u_s)/npts

    finished = .false.

    if (verbose) print *, 'integrating from u: ', u, ustop, xi, c

    do while (.not. finished)

       du2 = HALF*du

       ! do 4th-order RT
       call riemann_invariant_rhs2(u, tau, p, &
                                   xn, iwave, dtaudu1, dpdu1)

       call riemann_invariant_rhs2(u+du2, tau+du2*dtaudu1, p+du2*dpdu1, &
                                   xn, iwave, dtaudu2, dpdu2)

       call riemann_invariant_rhs2(u+du2, tau+du2*dtaudu2, p+du2*dpdu2, &
                                   xn, iwave, dtaudu3, dpdu3)

       call riemann_invariant_rhs2(u+du, tau+du*dtaudu3, p+du*dpdu3, &
                                   xn, iwave, dtaudu4, dpdu4)

       u = u + du
       p = p + SIXTH*du*(dpdu1 + TWO*dpdu2 + TWO*dpdu3 + dpdu4)
       tau = tau + SIXTH*du*(dtaudu1 + TWO*dtaudu2 + TWO*dtaudu3 + dtaudu4)

       ! compute c
       eos_state%rho = ONE/tau
       eos_state%p = p
       eos_state%xn(:) = xn(:)
       eos_state%T = initial_temp_guess

       !print *, 'calling EOS:',  tau, p, xn
       call eos(eos_input_rp, eos_state)

       c = sqrt(eos_state%gam1*p*tau)

       ! check the step size
       if (iwave == 1) then
          ustop = xi + c
       else if (iwave == 3) then
          ustop = xi - c
       endif

       if (du*u > 0.0d0) then
          do while (abs(u + du) > abs(ustop) .and. du /= ZERO)
             du = 0.5d0*du
          enddo
       else
          if (u > 0.0d0) then
             do while (u + du < ustop .and. du /= ZERO)
                du = 0.5d0*du
             enddo

          else
             do while (u + du > ustop .and. du /= ZERO)
                du = 0.5d0*du
             enddo
          endif
       endif

       if (abs(du) < tol*abs(u)) then
          finished = .true.
       endif

    enddo

    rho = ONE/tau

  end subroutine rarefaction_to_u

  subroutine riemann_invariant_rhs(p, tau, u, xn, iwave, dtaudp, dudp)

    ! here, p is out independent variable, and tau, u are the
    ! dependent variables.  We return the derivatives of these
    ! wrt p for integration.

    real (rt), intent(in) :: tau, u, p, xn(nspec)
    real (rt), intent(out) :: dtaudp, dudp
    integer, intent(in) :: iwave

    type (eos_t) :: eos_state
    real (rt) :: C

    ! get the thermodynamics
    eos_state%rho = ONE/tau
    eos_state%p = p
    eos_state%xn(:) = xn(:)
    eos_state%T = initial_temp_guess

    call eos(eos_input_rp, eos_state)

    C = sqrt(eos_state%gam1*p/tau)

    dtaudp = -ONE/C**2

    if (iwave == 1) then
       dudp = -ONE/C
    else if (iwave == 3) then
       dudp = ONE/C
    endif

  end subroutine riemann_invariant_rhs

  subroutine riemann_invariant_rhs2(u, tau, p, xn, iwave, dtaudu, dpdu)

    ! here, u is out independent variable, and tau, p are the
    ! dependent variables.  We return the derivatives of these
    ! wrt u for integration.

    real (rt), intent(in) :: tau, u, p, xn(nspec)
    real (rt), intent(out) :: dtaudu, dpdu
    integer, intent(in) :: iwave

    type (eos_t) :: eos_state
    real (rt) :: C

    ! get the thermodynamics
    eos_state%rho = ONE/tau
    eos_state%p = p
    eos_state%xn(:) = xn(:)
    eos_state%T = initial_temp_guess

    call eos(eos_input_rp, eos_state)

    C = sqrt(eos_state%gam1*p/tau)

    if (iwave == 3) then
       dpdu = C
       dtaudu = -ONE/C

    else if (iwave == 1) then
       dpdu = -C
       dtaudu = ONE/C
    endif

  end subroutine riemann_invariant_rhs2

end module riemann_support


subroutine eigenvectors(A, lambda, V)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!********************************************************************
! SUBROUTINE eigenvectors                                           *
!                                                                   *
! Accepts as input a symmetric 3x3 tridiagonal matrix A and a       *
! vector of eigenvalues lambda and computes the eigenvectors        *
! corresponding to each eigenvalue. The eigenvalues are sorted      *
! during the computation in increasing order.                       *
!                                                                   *
! Author : Sai Rapaka                                               *
!                                                                   *
!********************************************************************

implicit none
double precision, dimension(3,3)       :: A, V, E, B
double precision, dimension(3)         :: lambda
double precision                       :: tmp, theta, phi

double precision, parameter            :: cut_off = 1.0d-4
double precision, parameter            :: zero = 0.0d0
integer i,j
logical e1used, e3used

! E is the identity matrix
E = reshape((/1.0d0, 0.0d0, 0.0d0, 0.0d0, 1.0d0, 0.0d0, 0.0d0, 0.0d0, 1.0d0/), SHAPE=(/3,3/))

V = 0.0d0
e1used = .false.
e3used = .false.

! First deal with the smallest eigenvalue
B = A - lambda(1)*E
! Make sure that numerically small values in B are truncated to 0.0d0
! Needed to ensure robustness of calls to atan2
do i=1,3
  do j=1,3
    if(abs(B(i,j)).lt.cut_off) then
      B(i,j) = zero
    endif
  enddo
enddo

if((B(2,3).eq.zero).and.(B(3,3).eq.zero)) then
  V(1,1) = 0.0d0
  V(2,1) = 0.0d0
  V(3,1) = 1.0d0
  e3used = .true.
elseif((B(1,1).eq.zero).and.(B(1,2).eq.zero)) then
  V(1,1) = 1.0d0
  V(2,1) = 0.0d0
  V(3,1) = 0.0d0
  e1used = .true.
else
  phi = datan2(-B(1,1), B(1,2))
  theta = datan2(-B(3,2)*dsin(phi), B(3,3))
  V(1,1) = dcos(theta)*dcos(phi)
  V(2,1) = dcos(theta)*dsin(phi)
  V(3,1) = dsin(theta)
endif

! Now deal with the largest eigenvalue
B = A - lambda(3)*E
! Make sure that numerically small values in B are truncated to 0.0d0
! Needed to ensure robustness of calls to atan2
do i=1,3
  do j=1,3
    if(abs(B(i,j)).lt.cut_off) then
      B(i,j) = zero
    endif
  enddo
enddo
if((B(2,3).eq.zero).and.(B(3,3).eq.zero)) then
  if(.not.e3used) then
    V(1,3) = 0.0d0
    V(2,3) = 0.0d0
    V(3,3) = 1.0d0
  else
    theta = datan2(-B(1,1), B(1,2))
    V(1,3) = dcos(theta)
    V(2,3) = dsin(theta)
    V(3,3) = 0.0d0
  endif
elseif((B(1,1).eq.zero).and.(B(1,2).eq.zero)) then
  if(.not.e1used) then
    V(1,3) = 1.0d0
    V(2,3) = 0.0d0
    V(3,3) = 0.0d0
  else
    theta = datan2(-B(3,2), B(3,3))
    V(1,3) = 0.0d0
    V(2,3) = dcos(theta)
    V(3,3) = dsin(theta)
  endif
else
  phi = datan2(-B(1,1), B(1,2))
  theta = datan2(-B(3,2)*dsin(phi), B(3,3))
  V(1,3) = dcos(theta)*dcos(phi)
  V(2,3) = dcos(theta)*dsin(phi)
  V(3,3) = dsin(theta)
endif

! Obtain the eigenvector for the intermediate eigenvalue using
! cross product of the other two eigenvectors
V(1,2) = V(2,1)*V(3,3) - V(3,1)*V(2,3)
V(2,2) = V(3,1)*V(1,3) - V(1,1)*V(3,3)
V(3,2) = V(1,1)*V(2,3) - V(2,1)*V(1,3)

end subroutine eigenvectors


!*******************************************************************************
!>
!  Basic Newton solver.

    module newton_module

    use kind_module,    only: wp
    use numbers_module

    implicit none

    private

    public :: newton

    abstract interface
        subroutine func(x,f)
        !! interface for the function and derivative
        import :: wp
        implicit none
        real(wp),intent(in)  :: x
        real(wp),intent(out) :: f
        end subroutine func
    end interface

    contains
!*******************************************************************************

!*******************************************************************************
!>
!  Newton's method for root finding of scalar function f(x)

    subroutine newton(x,f,dfdx,ftol,xtol,max_iter,xs,fx,iflag)

    implicit none

    real(wp),intent(in)    :: x         !! initial point (initial guess)
    procedure(func)        :: f         !! function f(x)
    procedure(func)        :: dfdx      !! first derivative function f'(x)
    real(wp),intent(in)    :: ftol      !! convergence tolerance for f(x)
    real(wp),intent(in)    :: xtol      !! convergence tolerance for x
    integer,intent(in)     :: max_iter  !! the maximum number of iterations
    real(wp),intent(out)   :: xs        !! the value where f(x) is zero
    real(wp),intent(out)   :: fx        !! the value of f(x) at the root xs
    integer,intent(out)    :: iflag     !! status flag:
                                        !!  0 : absolute convergence in f
                                        !!  1 : relative convergence in x
                                        !! -1 : Error: derivative is zero
                                        !! -2 : Error: max iterations exceeded

    real(wp)  :: f1,df1,x1,x1_prev
    integer   :: iter
    real(wp),parameter :: alpha = one !! step factor

    x1 = x

    do iter = 1,max_iter

        call f(x1, f1)
        if (abs(f1)<=ftol) then
            iflag = 0
            exit
        end if

        call dfdx(x1, df1)
        if (df1==zero) then
            iflag = -1
            exit
        end if

        x1_prev = x1
        x1 = x1 - alpha * ( f1 / df1 )

        if (abs(x1_prev-x1)<=xtol) then
            iflag = 1
            exit
        end if

    end do

    ! max iterations exceeded
    if (iter>max_iter) iflag = -2

    !return results:
    xs  = x1
    fx  = f1

    end subroutine newton
!*******************************************************************************

!*******************************************************************************
    end module newton_module
!*******************************************************************************


      program reduction
      integer i, n
      parameter (n=10)
      real s, a(n), p
      s = 1.0
      s = s - 2.0
      s = s + s
      s = 3.0 + s
      do i=1, n
         a(i) = real(i)
      enddo

      do i=1, n
         s = s + a(i)
         s = s - a(i)
      enddo
      print *, 'sum is ', s

      p = 1.0
      do i=1, n
         if (MOD(i,2).eq.0) then
            p = a(i) * p
         else
            p = p / a(i)
         endif
      enddo
      print *, 'p is ', p

      end
!tps$ echo REDUCTION validation script
!tps$ activate PRINT_CODE_PROPER_REDUCTIONS
!tps$ display PRINTED_FILE
!tps$ activate PRINT_CODE_CUMULATED_REDUCTIONS
!tps$ display PRINTED_FILE


module Standard_Collection
implicit none

real(8),parameter :: PI = 4.0d0*atan(1.0d0) , R = 287.1d0 , ganma = 1.4d0

real(8),parameter :: Re = 6356766.0d0 , GT = 0.0065d0 !-------気温減衰率K/m--------

contains

function deg2rad (x)
  real(8) :: deg2rad,x
  deg2rad = x*PI / 180.0d0
end function

function rad2deg (x)
  real(8) :: rad2deg,x
  rad2deg = x*180.0d0 / PI
end function

function deg2kelvin (x)
  real(8) :: deg2kelvin,x
  deg2kelvin = x + 273.15
end function

subroutine maxcheck(array,max)
  real(8),intent(in) :: array(:)
  integer,intent(out) :: max
  integer :: i,arraysize
  real(8) :: max_temp

  arraysize = size(array)
  max_temp = 0.0d0

  do i = 1,arraysize
    if (array(i) > max_temp) then
      max_temp = array(i)
      max = i
    end if
  end do

end subroutine maxcheck

function Integral_3D(x,x_pre,dt)
  real(8) :: Integral_3D(3)
  real(8),intent(in) :: x(:),x_pre(:),dt

  Integral_3D(1) = 0.5d0*(x(1) + x_pre(1))*dt
  Integral_3D(2) = 0.5d0*(x(2) + x_pre(2))*dt
  Integral_3D(3) = 0.5d0*(x(3) + x_pre(3))*dt

end function Integral_3D

!-----------------------------------------------------------------------------!
!Construct cubic spline interpolation from a given data set yp(xp)
!yp(i): given data values
!xp(i): given points
!     where i=0,1,2,...nd
!     np: maximum number of data point (total number of points is np+1)
!
!
!y: interpolated value
!x: interpolation location
!
!mode == 0: initial setting
!mode == 1: spline interpolation
!-----------------------------------------------------------------------------!

subroutine spline(xp,yp,np,x,y,mode)
  integer,intent(in) :: np !data number
  integer :: mode,i,i1,i2
  real(8) :: x,y
  real(8),intent(in) :: xp(0:np),yp(0:np)
  real(8),allocatable :: h(:),a_mat(:),b_mat(:),c_mat(:),d_mat(:)
  real(8),allocatable,save :: a(:),b(:),c(:)!,x_save(:),y_save(;)

  ! Coefficient determination
  ! mode == 0

  if (mode == 0) then
    allocate(h(0:np),a_mat(0:np),b_mat(0:np),c_mat(0:np),d_mat(0:np))
    allocate(a(0:np-1),b(0:np-1),c(0:np))

    do i = 0,np-1
      h(i) = xp(i+1) - xp(i)
    end do
    h(np) = xp(np) - xp(np-1)

    b_mat(0) = 2.0d0*h(0)
    c_mat(0) = h(0)
    d_mat(0) = 3.0d0*(yp(1) - yp(0))
    do i = 1,np-1
      a_mat(i) = h(i)
      b_mat(i) = 2.0d0*(xp(i+1) - xp(i-1))
      c_mat(i) = h(i-1)
      d_mat(i) = (3.0d0*(yp(i) - yp(i-1))*h(i) / h(i-1)) + (3.0d0*(yp(i+1) - yp(i))*h(i-1) / h(i))
    end do
    a_mat(np) = h(np)
    b_mat(np) = 2.0d0*(h(np))
    d_mat(np) = 3.0d0*(yp(np) - yp(np-1))

    call tdma(a_mat,b_mat,c_mat,d_mat,np+1,c)

    do i = 0,np-1
      b(i) = (3.0d0*(yp(i+1) - yp(i)) - h(i)*(c(i+1) + 2.0d0*c(i))) / h(i)**2
      a(i) = (c(i+1) - c(i) - 2.0d0*b(i)*h(i)) / (3.0d0*h(i)**2)
    end do
    return
  end if

  ! spline interpolation
  ! mode == 0

  if (x <= xp(1)) then ! outside of the domain - lower
    i1 = 0
  else
    if (x >= xp(np-1)) then ! outside of the domain - upper
      i1 = np - 1
    else
      i1 = 1 ; i2 = np - 1
      do while (i2 - i1 > 1)
        i = (i1 + i2) / 2
        if (x < xp(i)) then
          i2 = i
        else
          i1 = i
        end if
      end do
    end if
  end if

  y = (a(i1)*(x - xp(i1))**2 + b(i1)*(x - xp(i1)) + c(i1))*(x - xp(i1)) + yp(i1)

end subroutine spline

!------------------------------------------------------------------!
!Tridiagonal matrix algorithm (TDMA)
!Thomas algorithm
!solution tridiagonal systems
!a: lower diagonal
!b: main diagonal
!c: upper diagonal
!d: source vector
!x: solution vector
!
!------------------------------------------------------------------!

subroutine tdma(a,b,c,d,n,x)
  real(8),intent(in) :: a(:),b(:),c(:),d(:)
  real(8),intent(out) :: x(:)
  real(8),allocatable :: G(:),H(:)
  real(8) :: temp
  integer,intent(in) :: n
  integer :: i

  allocate(G(n),H(n))

  !forward elimination
  G(1) = -c(1) / b(1)
  H(1) = d(1) / b(1)
  do i = 2,n
    temp = b(i) + a(i)*G(i-1)
    G(i) = -c(i) / temp
    H(i) = (d(i) - a(i)*H(i-1)) / temp
  end do

  !backward substitution
  x(n) = H(n)
  do i = n-1,1,-1
    x(i) = G(i)*x(i+1) + H(i)
  end do
end subroutine tdma

end module Standard_Collection


program internal_io ! code and tip from urbanjost: use internal I/O to
implicit none       ! convert from character to real and the reverse
character (len=80) :: text
real               :: value
integer            :: ios
character(len=256) :: message
text = "123.4e2"
read (text,*,iostat=ios,iomsg=message) value ! convert character to real
if (ios /= 0) then
   write(*,*) "ERROR: could not obtain numeric value from " // trim(text)
   write(*,*) "     : " // trim(message)
else
   write(*,*) "value = ",value
end if
write (text,"(3g0)") "'", 1.0d0/3.0d0, "'" ! convert real to character
write (*,*) "text = ",trim(text)
end program internal_io
! gfortran output:
!  value =    12340.0000
!  text = '0.33333333333333331'


subroutine plot(ch, p, v)
  integer, dimension(:,:), intent(out) :: ch
  type(point), intent(in) :: p
  integer, intent(in) :: v

  integer :: cx, cy
  ! I've kept the default 1-based array, but top-left corner pixel
  ! is labelled as (0,0).
  cx = p%x + 1
  cy = p%y + 1

  if ( (cx > 0) .and. (cx <= ubound(ch,1)) .and. &
       (cy > 0) .and. (cy <= ubound(ch,2)) ) then
     ch(cx,cy) = v
  end if
end subroutine plot

subroutine draw_circle_toch(ch, c, radius, v)
  integer, dimension(:,:), intent(out) :: ch
  type(point), intent(in) :: c
  integer, intent(in) :: radius, v

  integer :: f, ddf_x, ddf_y, x, y

  f = 1 - radius
  ddf_x = 0
  ddf_y = -2 * radius
  x = 0
  y = radius

  call plot(ch, point(c%x, c%y + radius), v)
  call plot(ch, point(c%x, c%y - radius), v)
  call plot(ch, point(c%x + radius, c%y), v)
  call plot(ch, point(c%x - radius, c%y), v)

  do while ( x < y )
     if ( f >= 0 ) then
        y = y - 1
        ddf_y = ddf_y + 2
        f = f + ddf_y
     end if
     x = x + 1
     ddf_x = ddf_x + 2
     f = f + ddf_x + 1
     call plot(ch, point(c%x + x, c%y + y), v)
     call plot(ch, point(c%x - x, c%y + y), v)
     call plot(ch, point(c%x + x, c%y - y), v)
     call plot(ch, point(c%x - x, c%y - y), v)
     call plot(ch, point(c%x + y, c%y + x), v)
     call plot(ch, point(c%x - y, c%y + x), v)
     call plot(ch, point(c%x + y, c%y - x), v)
     call plot(ch, point(c%x - y, c%y - x), v)
  end do

end subroutine draw_circle_toch

subroutine draw_circle_rgb(img, c, radius, color)
  type(rgbimage), intent(out) :: img
  type(point), intent(in) :: c
  integer, intent(in) :: radius
  type(rgb), intent(in) :: color

  call draw_circle_toch(img%red, c, radius, color%red)
  call draw_circle_toch(img%green, c, radius, color%green)
  call draw_circle_toch(img%blue, c, radius, color%blue)
end subroutine draw_circle_rgb

subroutine draw_circle_sc(img, c, radius, lum)
  type(scimage), intent(out) :: img
  type(point), intent(in) :: c
  integer, intent(in) :: radius, lum

  call draw_circle_toch(img%channel, c, radius, lum)
end subroutine draw_circle_sc


      PROGRAM LA_SSYEVX_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_SYEVX
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, M, N
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:,:), AA(:,:), W(:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_SYEVX Example Program Results'
      N = 5
      ALLOCATE( A(N,N), AA(N,N), W(N) )

      OPEN(UNIT=21,FILE='syev.ma',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,N
            READ(21,*) A(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      AA=A

      WRITE(*,*)'Matrix A:'
      DO I=1,N;
         WRITE(*,"(5(F9.5))") A(I,:);
      ENDDO

      WRITE(*,*) 'CALL LA_SYEVX( A, W, VL=-7.0_WP, VU=7.0_WP, M=M, ABSTOL=1.0E-4_WP )'
      CALL LA_SYEVX( A, W, VL=-7.0_WP, VU=7.0_WP, M=M, ABSTOL=1.0E-4_WP )
      WRITE(*,*) 'W on exit'
      DO I=1,N
      WRITE(*,"(5(F9.5))") W(I)
      ENDDO
      WRITE(*,*)' M =',M

      END PROGRAM LA_SSYEVX_EXAMPLE


module stencil_test_module

  implicit none

  private

  public :: lapleb_MSD, lapl_MSD, init_phi

contains

  subroutine lapleb_MSD(&
       lph,lph_l1,lph_l2,lph_l3,lph_h1,lph_h2,lph_h3, &
       phi,phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3, &
       fd0,fd0_l1,fd0_l2,fd0_l3,fd0_h1,fd0_h2,fd0_h3, &
       fd1,fd1_l1,fd1_l2,fd1_l3,fd1_h1,fd1_h2,fd1_h3, &
       fd2,fd2_l1,fd2_l2,fd2_l3,fd2_h1,fd2_h2,fd2_h3, &
       lo, hi, dx) bind(C,name="lapleb_MSD")

    integer, intent(in) :: lph_l1,lph_l2,lph_l3,lph_h1,lph_h2,lph_h3
    integer, intent(in) :: phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3
    integer, intent(in) :: fd0_l1,fd0_l2,fd0_l3,fd0_h1,fd0_h2,fd0_h3
    integer, intent(in) :: fd1_l1,fd1_l2,fd1_l3,fd1_h1,fd1_h2,fd1_h3
    integer, intent(in) :: fd2_l1,fd2_l2,fd2_l3,fd2_h1,fd2_h2,fd2_h3

    integer, intent(in) :: lo(3),hi(3)

    double precision, intent(inout) :: lph(lph_l1:lph_h1,lph_l2:lph_h2,lph_l3:lph_h3)
    double precision, intent(in   ) :: phi(phi_l1:phi_h1,phi_l2:phi_h2,phi_l3:phi_h3)
    double precision, intent(in   ) :: fd0(fd0_l1:fd0_h1,fd0_l2:fd0_h2,fd0_l3:fd0_h3,4)
    double precision, intent(in   ) :: fd1(fd1_l1:fd1_h1,fd1_l2:fd1_h2,fd1_l3:fd1_h3,4)
    double precision, intent(in   ) :: fd2(fd2_l1:fd2_h1,fd2_l2:fd2_h2,fd2_l3:fd2_h3,4)
    double precision, intent(in   ) :: dx

    integer :: i,j,k,ip,im,jp,jm,kp,km, in, jn, kn, ii, jj, kk, iface, jface, kface, is, js, ks
    double precision :: fac, c0, c1, f00, f01, f10, f11, Fx(0:1), Fy(0:1), Fz(0:1)

    fac = 1.d0 / (dx*dx)

    do k=lo(3),hi(3)
       do j=lo(2),hi(2)
          do i=lo(1),hi(1)

             do ii=0,1
                iface = i+ii

                jn = j + SIGN(1.d0, fd0(iface,j,k,3))
                kn = k + SIGN(1.d0, fd0(iface,j,k,4))

                f00 = fac*(phi(iface,j ,k ) - phi(iface-1,j ,k ))
                f10 = fac*(phi(iface,jn,k ) - phi(iface-1,jn,k ))
                f01 = fac*(phi(iface,j ,kn) - phi(iface-1,j ,kn))
                f11 = fac*(phi(iface,jn,kn) - phi(iface-1,jn,kn))

                c0 = ABS(fd0(iface,j,k,3))
                c1 = ABS(fd0(iface,j,k,4))

                Fx(ii) = (f00*(1.d0-c0)*(1.d0-c1) + f10*c0*(1.d0-c1) &
                     + f01*(1.d0-c0)*c1 + f11*c0*c1)*fd0(iface,j,k,1)
             enddo

             do jj=0,1
                jface = j+jj

                in = i + SIGN(1.d0, fd1(i,jface,k,2))
                kn = k + SIGN(1.d0, fd1(i,jface,k,4))

                f00 = fac*(phi(i ,jface,k ) - phi(i ,jface-1,k ))
                f10 = fac*(phi(in,jface,k ) - phi(in,jface-1,k ))
                f01 = fac*(phi(i ,jface,kn) - phi(i ,jface-1,kn))
                f11 = fac*(phi(in,jface,kn) - phi(in,jface-1,kn))

                c0 = ABS(fd1(i,jface,k,2))
                c1 = ABS(fd1(i,jface,k,4))

                Fy(jj) = (f00*(1.d0-c0)*(1.d0-c1) + f10*c0*(1.d0-c1) &
                     + f01*(1.d0-c0)*c1 + f11*c0*c1)*fd1(i,jface,k,1)
             enddo

             do kk=0,1
                kface = k+kk

                in = i + SIGN(1.d0, fd2(i,j,kface,2))
                jn = j + SIGN(1.d0, fd2(i,j,kface,3))

                f00 = fac*(phi(i ,j ,kface) - phi(i ,j ,kface-1))
                f10 = fac*(phi(in,j ,kface) - phi(in,j ,kface-1))
                f01 = fac*(phi(i ,jn,kface) - phi(i ,jn,kface-1))
                f11 = fac*(phi(in,jn,kface) - phi(in,jn,kface-1))

                c0 = ABS(fd2(i,j,kface,2))
                c1 = ABS(fd2(i,j,kface,3))

                Fz(kk) = (f00*(1.d0-c0)*(1.d0-c1) + f10*c0*(1.d0-c1) &
                     + f01*(1.d0-c0)*c1 + f11*c0*c1)*fd2(i,j,kface,1)
             enddo

             lph(i,j,k) = Fx(1) - Fx(0) + Fy(1) - Fy(0) + Fz(1) - Fz(0)

          enddo
       enddo
    enddo

  end subroutine lapleb_MSD

  subroutine lapl_MSD(&
       lph,lph_l1,lph_l2,lph_l3,lph_h1,lph_h2,lph_h3, &
       phi,phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3, &
       lo, hi, dx) bind(C,name="lapl_MSD")

    integer, intent(in) :: lph_l1,lph_l2,lph_l3,lph_h1,lph_h2,lph_h3
    integer, intent(in) :: phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3

    integer, intent(in) :: lo(3),hi(3)

    double precision, intent(inout) :: lph(lph_l1:lph_h1,lph_l2:lph_h2,lph_l3:lph_h3)
    double precision, intent(in   ) :: phi(phi_l1:phi_h1,phi_l2:phi_h2,phi_l3:phi_h3)
    double precision, intent(in   ) :: dx

    integer :: i,j,k
    double precision :: fac

    fac = 1.d0 / (dx*dx)

    do k=lo(3),hi(3)
       do j=lo(2),hi(2)
          do i=lo(1),hi(1)
             lph(i,j,k) = fac*(phi(i+1,j,k) + phi(i-1,j,k) - 2*phi(i,j,k)) &
                  +       fac*(phi(i,j+1,k) + phi(i,j-1,k) - 2*phi(i,j,k)) &
                  +       fac*(phi(i,j,k+1) + phi(i,j,k-1) - 2*phi(i,j,k))
          enddo
       enddo
    enddo

  end subroutine lapl_MSD

  subroutine init_phi(&
       phi,phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3, &
       lo, hi, plo, dx) bind(C,name="init_phi")

    integer, intent(in) :: phi_l1,phi_l2,phi_l3,phi_h1,phi_h2,phi_h3

    integer, intent(in) :: lo(3),hi(3)

    double precision, intent(inout) :: phi(phi_l1:phi_h1,phi_l2:phi_h2,phi_l3:phi_h3)
    double precision, intent(in   ) :: plo(3), dx

    integer :: i,j,k
    double precision :: x,y,z

    do k=lo(3),hi(3)
       z = plo(3) + (k+0.5d0)*dx
       do j=lo(2),hi(2)
          y = plo(2) + (j+0.5d0)*dx
          do i=lo(1),hi(1)
             x = plo(1) + (i+0.5d0)*dx
             phi(i,j,k) = 0.5d0 * (z-0.5d0)**2
          enddo
       enddo
    enddo

  end subroutine init_phi

end module stencil_test_module


      SUBROUTINE MB03QV( N, S, LDS, T, LDT, ALPHAR, ALPHAI, BETA, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the eigenvalues of an upper quasi-triangular matrix
C     pencil.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices S and T.  N >= 0.
C
C     S       (input) DOUBLE PRECISION array, dimension(LDS,N)
C             The upper quasi-triangular matrix S.
C
C     LDS     INTEGER
C             The leading dimension of the array S.  LDS >= max(1,N).
C
C     T       (input) DOUBLE PRECISION array, dimension(LDT,N)
C             The upper triangular matrix T.
C
C     LDT     INTEGER
C             The leading dimension of the array T.  LDT >= max(1,N).
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
C     BETA    (output) DOUBLE PRECISION array, dimension (N)
C             On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N,
C             are the generalized eigenvalues.
C             ALPHAR(j) + ALPHAI(j)*i, and  BETA(j),j=1,...,N, are the
C             diagonals of the complex Schur form (S,T) that would
C             result if the 2-by-2 diagonal blocks of the real Schur
C             form of (A,B) were further reduced to triangular form
C             using 2-by-2 complex unitary transformations.
C             If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
C             positive, then the j-th and (j+1)-st eigenvalues are a
C             complex conjugate pair, with ALPHAI(j+1) negative.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen,
C     October 2002.
C
C     REVISIONS
C
C     V. Sima, Dec. 2016.
C
C     ******************************************************************
C     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER          INFO, LDS, LDT, N
C     .. Array Arguments ..
      DOUBLE PRECISION ALPHAI(*), ALPHAR(*), BETA(*), S(LDS,*), T(LDT,*)
C     .. Local Scalars ..
      INTEGER          I, INEXT
      DOUBLE PRECISION SAFMIN
C     .. External Functions ..
      EXTERNAL         DLAMCH
      DOUBLE PRECISION DLAMCH
C     .. External Subroutines ..
      EXTERNAL         DLAG2, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        MAX
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
         INFO = -3
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB03QV', -INFO )
         RETURN
      END IF
C
      SAFMIN = DLAMCH( 'S' )
      INEXT  = 1
      DO 10 I = 1, N
         IF( I.LT.INEXT )
     $      GO TO 10
         IF( I.NE.N ) THEN
            IF( S(I+1,I).NE.ZERO ) THEN
C
C              A pair of eigenvalues.
C
               INEXT = I + 2
               CALL DLAG2( S(I,I), LDS, T(I,I), LDT, SAFMIN, BETA(I),
     $                     BETA(I+1), ALPHAR(I), ALPHAR(I+1),
     $                     ALPHAI(I) )
               ALPHAI(I+1) = -ALPHAI(I)
               GO TO 10
            END IF
         END IF
C
C        Simple eigenvalue.
C
         INEXT = I + 1
         ALPHAR(I) = S(I,I)
         ALPHAI(I) = ZERO
         BETA(I)   = T(I,I)
   10 CONTINUE
C
      RETURN
C *** Last line of MB03QV ***
      END


SUBROUTINE p102(input_file,output_file)
!-------------------------------------------------------------------------
! Program 10.2 Eigenvalue analysis of an elastic solid in plane strain
!              using 4- or 8-node rectangular quadrilaterals. Lumped mass.
!              Mesh numbered in x- or y-direction.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::i,idiag,iel,ifail,j,k,nband,ndim=2,ndof,nels,neq,nmodes,nn,nod, &
   nodof=2,nlen,nprops=3,np_types,nr,nxe,nye
 REAL(iwp)::area,etol=1.e-30_iwp,one=1.0_iwp,penalty=1.e20_iwp,zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element='quadrilateral'
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g (:,:),g_num(:,:),kdiag(:),nf(:,:),&
   num(:)
 REAL(iwp),ALLOCATABLE::coord(:,:),diag(:),g_coord(:,:),kh(:),km(:,:),    &
   ku(:,:),kv(:),mm(:,:),prop(:,:),rrmass(:),udiag(:),x_coords(:),        &
   y_coords(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,nod,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ndof=nod*nodof
 ALLOCATE(nf(nodof,nn),g_coord(ndim,nn),coord(nod,ndim),mm(ndof,ndof),    &
   g_num(nod,nels),num(nod),km(ndof,ndof),g(ndof),g_g(ndof,nels),         &
   prop(nprops,np_types),x_coords(nxe+1),y_coords(nye+1),etype(nels))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)x_coords,y_coords
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(diag(0:neq),udiag(0:neq),kdiag(neq),rrmass(0:neq))
!-----------------------loop the elements to find global array sizes------
 nband=0
 kdiag=0
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'y')
   CALL num_to_g(num,nf,g)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
   CALL fkdiag(kdiag,g)
   IF(nband<bandwidth(g))nband=bandwidth(g)
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 WRITE(11,'(A,I5,A,/,A,I5,/,A,I5)')" There are",neq," equations",         &
   " The half-bandwidth (including diagonal) is",nband+1,                 &
   " The skyline storage is",kdiag(neq)
!-----------------------global stiffness and mass matrix assembly---------
 ALLOCATE(ku(neq,nband+1),kv(kdiag(neq)),kh(kdiag(neq)))
 diag=zero
 ku=zero
 elements_2: DO iel=1,nels
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   CALL rect_km(km,coord,prop(1,etype(iel)),prop(2,etype(iel)))
   CALL formku(ku,km,g)
   area=(MAXVAL(coord(:,1))-MINVAL(coord(:,1)))*                          &
        (MAXVAL(coord(:,2))-MINVAL(coord(:,2)))
   CALL elmat(area,prop(3,etype(iel)),mm)
   CALL formlump(diag,mm,g)
 END DO elements_2
!-----------------------reduce to standard eigenvalue problem-------------
 rrmass(1:)=one/SQRT(diag(1:))
 DO i=1,neq
 IF(i<=neq-nband)THEN
   k=nband+1
 ELSE
   k=neq-i+1
 END IF
   DO j=1,k
     ku(i,j)=ku(i,j)*rrmass(i)*rrmass(i+j-1)
   END DO
 END DO
!-----------------------convert to skyline form---------------------------
 kh(1)=ku(1,1)
 k=1
 DO i=2,neq
   idiag=kdiag(i)-kdiag(i-1)
   DO j=1,idiag
     k=k+1
     kh(k)=ku(i+j-idiag,1-j+idiag)
   END DO
 END DO
!-----------------------extract the eigenvalues---------------------------
 CALL bandred(ku,diag,udiag)
 ifail=1
 CALL bisect(diag,udiag,etol,ifail)
 WRITE(11,'(/A)')" The eigenvalues are:"
 WRITE(11,'(6E12.4)')diag(1:)
!-----------------------extract the eigenvectors--------------------------
 READ(10,*)nmodes
 DO i=1,nmodes
   kv=kh;kv(kdiag)=kv(kdiag)-diag(i)
   kv(1)=kv(1)+penalty
   udiag=zero
   udiag(1)=kv(1)
   CALL sparin_gauss(kv,kdiag)
   CALL spabac_gauss(kv,udiag,kdiag)
   udiag=rrmass*udiag
   WRITE(11,'(A,I3,A)')" Eigenvector number",i," is:"
   WRITE(11,'(6E12.4)')udiag(1:)/MAXVAL(ABS(udiag(1:)))
   IF(i==1)CALL dismsh(udiag,nf,0.1_iwp,g_coord,g_num,argv,nlen,13)
 END DO
END SUBROUTINE p102