module dcv_cgrad
 use dcv_1D_mod
! implicit none
 private
! integer,parameter      	:: idim=256

 integer,private		:: ncom
 real,private,dimension(idim)	:: pcom,xicom
 public				:: frprmn
 private			:: norm_l2,linmin,df1dim,f1dim,mnbrak,dbrent

contains
!*********************************************************
! Flechter-Reeves-Polak-Ribiere minimization
! Cf "Numerical recipees" Sect. 10.6 (in C p 423, in F77 p 416)
! IN:
! p: first guess
! n = dimension of p
! ftol = tolerance
! OUT:
! p: location of minimum
! iter: nber of iterations
! fret: value of minimum
!
! Given a starting point p that is a vector of length n
! Flechter-Reeves-Polak-Ribiere minimization is performed on
! a function func, using its gradient as calculated by a routine dfunc.
! The convergence tolerance on the function value is input as ftol.
! Return quantities are p (the location of the minimum),
! iter (the number of iterations that were performed)
! and fret (the minimum value of the function).
! The routine linmin is called to perform line minimizations.
!********************************************************
      subroutine frprmn(p,n,ftol,iter,fret)
! itmax: maximum allowed number of iterations
! eps: small number to rectify the special case
! of converging to exactly zero function value
      implicit none
      integer itmax,j,iter,n
      real gam,gg,dgg,fret,ftol,eps,fp,norm_p,norm_p0
      real crit_fp,crit_p
      parameter (itmax=1000,eps=1.e-10)
      real p(n),g(idim),h(idim),xi(idim),p0(idim)
! Before
!      real func
!      external func
!      real norm_l2
!      external norm_l2
! Initializations:
      fp=func(p)
      call dfunc(p,xi)
      do 11 j=1,n
        g(j)=-xi(j)
        h(j)=g(j)
        xi(j)=h(j)
11    continue
      do 14 iter=1,itmax
        do j=1,n
          p0(j) = p(j)
        end do
        call linmin(p,xi,n,fret)
        do j=1,n
          p0(j) = p0(j) - p(j)
        end do
        norm_p0 = norm_l2(p0,n)
        norm_p = norm_l2(p,n)
        crit_p = norm_p0 / (norm_p+eps)
        crit_fp = 2.*abs(fret-fp)/(abs(fret)+abs(fp)+eps)
        if(mod(iter,10).eq.1)then
          write(6,18) iter,crit_p,crit_fp
18	  format('Iter=',I3,' Rel. variation p=',e10.3,' fp=',e10.3)
        endif
! Next statement is normal return:
! Exit criterium is 2 * |fret-fp| < ftol * (|fret| + |fp| + eps)
! i.e. relative variation of fp is small:
! 2 * |fret-fp| / (|fret| + |fp| + eps) < ftol
!  which is nearly: |fret-fp| / |fret| < ftol
!        if(2.*abs(fret-fp).le.ftol*(abs(fret)+abs(fp)+eps))return
! JLP 2001
! I also put a constraint on the variations of p
        if((crit_fp.le.ftol).and.(crit_p.le.ftol)) return
        fp=func(p)
        call dfunc(p,xi)
        gg=0.
        dgg=0.
        do 12 j=1,n
          gg=gg+g(j)**2
! Flechter-Reeves:
!         dgg=dgg+xi(j)**2
! Polak-Ribiere: (better)
          dgg=dgg+(xi(j)+g(j))*xi(j)
12      continue
! Unlikely: if gradient is exactly zero, then we are already done.
        if(gg.eq.0.)then
            write(6,*)'frprmn/return since gradient is null: gg=0'
            return
        endif
        gam=dgg/gg
        do 13 j=1,n
          g(j)=-xi(j)
          h(j)=g(j)+gam*h(j)
          xi(j)=h(j)
13      continue
14    continue
      write(6,*) 'frprmn/maximum iterations exceeded: iter=',iter
      return
      end subroutine frprmn
!************************************************************
! Norm L2
!************************************************************
      real function norm_l2(p,n)
      integer n,j
      real p(n)
      norm_l2 = 0.
      do j=1,n
        norm_l2 = norm_l2 + p(j)*p(j)
      end do
      return
      end function norm_l2
!************************************************************
! Search for minimum along a given direction
!************************************************************
      subroutine linmin(p,xi,n,fret)
      parameter (tol=1.e-4)
!      external f1dim,df1dim
      dimension p(n),xi(n)
!      common /f1com/ ncom,pcom(idim),xicom(idim)
      ncom=n
      do 11 j=1,n
        pcom(j)=p(j)
        xicom(j)=xi(j)
11    continue
      ax=0.
      xx=1.
      bx=2.
      call mnbrak(ax,xx,bx,fa,fx,fb,f1dim)
      fret=dbrent(ax,xx,bx,f1dim,df1dim,tol,xmin)
      do 12 j=1,n
        xi(j)=xmin*xi(j)
        p(j)=p(j)+xi(j)
12    continue
      return
      end subroutine linmin
!**************************************************************
      function df1dim(x)
!      common /f1com/ ncom,pcom(idim),xicom(idim)
      dimension xt(idim),df(idim)
      do 11 j=1,ncom
        xt(j)=pcom(j)+x*xicom(j)
11    continue
      call dfunc(xt,df)
      df1dim=0.
      do 12 j=1,ncom
        df1dim=df1dim+df(j)*xicom(j)
12    continue
      return
      end function df1dim
!**************************************************************
      function f1dim(x)
!      common /f1com/ ncom,pcom(idim),xicom(idim)
      dimension xt(idim)
      do 11 j=1,ncom
        xt(j)=pcom(j)+x*xicom(j)
11    continue
      f1dim=func(xt)
      return
      end function f1dim
!**************************************************************
      subroutine mnbrak(ax,bx,cx,fa,fb,fc,func)
      parameter (gold=1.618034, glimit=100., tiny=1.e-20)
      fa=func(ax)
      fb=func(bx)
      if(fb.gt.fa)then
        dum=ax
        ax=bx
        bx=dum
        dum=fb
        fb=fa
        fa=dum
      endif
      cx=bx+gold*(bx-ax)
      fc=func(cx)
1     if(fb.ge.fc)then
        r=(bx-ax)*(fb-fc)
        q=(bx-cx)*(fb-fa)
        u=bx-((bx-cx)*q-(bx-ax)*r)/(2.*sign(max(abs(q-r),tiny),q-r))
        ulim=bx+glimit*(cx-bx)
        if((bx-u)*(u-cx).gt.0.)then
          fu=func(u)
          if(fu.lt.fc)then
            ax=bx
            fa=fb
            bx=u
            fb=fu
            go to 1
          else if(fu.gt.fb)then
            cx=u
            fc=fu
            go to 1
          endif
          u=cx+gold*(cx-bx)
          fu=func(u)
        else if((cx-u)*(u-ulim).gt.0.)then
          fu=func(u)
          if(fu.lt.fc)then
            bx=cx
            cx=u
            u=cx+gold*(cx-bx)
            fb=fc
            fc=fu
            fu=func(u)
          endif
        else if((u-ulim)*(ulim-cx).ge.0.)then
          u=ulim
          fu=func(u)
        else
          u=cx+gold*(cx-bx)
          fu=func(u)
        endif
        ax=bx
        bx=cx
        cx=u
        fa=fb
        fb=fc
        fc=fu
        go to 1
      endif
      return
      end subroutine mnbrak
!**************************************************************
      function dbrent(ax,bx,cx,ff,dff,tol,xmin)
      parameter (itmax=100,zeps=1.0e-10)
      logical ok1,ok2
      a=min(ax,cx)
      b=max(ax,cx)
      v=bx
      w=v
      x=v
      e=0.
      fx=ff(x)
      fv=fx
      fw=fx
      dx=dff(x)
      dv=dx
      dw=dx
      do 11 iter=1,itmax
        xm=0.5*(a+b)
        tol1=tol*abs(x)+zeps
        tol2=2.*tol1
        if(abs(x-xm).le.(tol2-.5*(b-a))) goto 3
        if(abs(e).gt.tol1) then
          d1=2.*(b-a)
          d2=d1
          if(dw.ne.dx) d1=(w-x)*dx/(dx-dw)
          if(dv.ne.dx) d2=(v-x)*dx/(dx-dv)
          u1=x+d1
          u2=x+d2
          ok1=((a-u1)*(u1-b).gt.0.).and.(dx*d1.le.0.)
          ok2=((a-u2)*(u2-b).gt.0.).and.(dx*d2.le.0.)
          olde=e
          e=d
          if(.not.(ok1.or.ok2))then
            go to 1
          else if (ok1.and.ok2)then
            if(abs(d1).lt.abs(d2))then
              d=d1
            else
              d=d2
            endif
          else if (ok1)then
            d=d1
          else
            d=d2
          endif
          if(abs(d).gt.abs(0.5*olde))go to 1
          u=x+d
          if(u-a.lt.tol2 .or. b-u.lt.tol2) d=sign(tol1,xm-x)
          goto 2
        endif
1       if(dx.ge.0.) then
          e=a-x
        else
          e=b-x
        endif
        d=0.5*e
2       if(abs(d).ge.tol1) then
          u=x+d
          fu=ff(u)
        else
          u=x+sign(tol1,d)
          fu=ff(u)
          if(fu.gt.fx)go to 3
        endif
        du=dff(u)
        if(fu.le.fx) then
          if(u.ge.x) then
            a=x
          else
            b=x
          endif
          v=w
          fv=fw
          dv=dw
          w=x
          fw=fx
          dw=dx
          x=u
          fx=fu
          dx=du
        else
          if(u.lt.x) then
            a=u
          else
            b=u
          endif
          if(fu.le.fw .or. w.eq.x) then
            v=w
            fv=fw
            dv=dw
            w=u
            fw=fu
            dw=du
          else if(fu.le.fv .or. v.eq.x .or. v.eq.w) then
            v=u
            fv=fu
            dv=du
          endif
        endif
11    continue
      print *,'dbrent/Warning: exceeded maximum iterations.'
3     xmin=x
      dbrent=fx
      return
end function dbrent
!
end module dcv_cgrad


       REAL K
       K=1.
       DK=1.
       TOLK=1.E-05
       CALL INTGRT(K,PHIP)
       PHIOLD=PHIP

10     CONTINUE
         K=K+DK
         CALL INTGRT(K,PHIP)
         IF (PHIP*PHIOLD .LT. 0) THEN
             K=K-DK
             DK=DK/2
         END IF
       IF (ABS(DK) .GT. TOLK) GOTO 10

       EXACT=4.*ATAN(1.)
       PRINT *, ' eigenvalue, error =',K,EXACT-K
       STOP
       END

       SUBROUTINE INTGRT(K,PHIP)
       REAL K
       DATA NSTEP/100/

       H=1./NSTEP
       PHIM=0.
       PHIZ=.01
       CONST=(K*H)**2/12.

       DO 10 IX=1,NSTEP-1
          PHIP=2*(1.-5.*CONST)*PHIZ -(1.+CONST)*PHIM
          PHIP=PHIP/(1+CONST)
          PHIM=PHIZ
          PHIZ=PHIP
10     CONTINUE

       PRINT *, K,PHIP
       RETURN
       END


        program main
        use timers
        type(TimerType) :: seriesTime,monteTime,totalTime

        integer npoints,nthreads,maxthreads,i,ierr
        parameter (npoints=300000,maxthreads=16)
        complex*16 c(npoints)
        real*8 r1,r2,halfpi,err1,area,err2
        real rand
        integer numinside,lnuminside(maxthreads)
        integer omp_get_num_threads
        external monte
        external omp_set_num_threads,omp_get_num_threads
C
        call TimerCreate(seriesTime,"series")
        call TimerCreate(monteTime,"monte")
        call TimerCreate(totalTime,"Series+monte")
C
C GENERATE RANDOM NUMBERS
C
      call srand(54321)
      do i=1,npoints
       	 r1=rand()
         r2=rand()
         c(i)=CMPLX(-2.0+2.5*r1,1.125*r2)
      end do
C
      call TimerOn(totalTime)
C
C  CALCULATE PI/2 FROM GREGORY'S FORMULA
C
      call TimerOn(seriesTime)
      call series(halfpi,err1)
      call TimerOff(seriesTime)
C
C  CALCULATE AREA OF MANDELBROT SET BY MONTE CARLO SAMPLING
C
      call TimerOn(monteTime)
C  INVOKE monte in parallel
!$omp parallel
C  GET NUMBER OF THREADS BEING USED
      nthreads = omp_get_num_threads()
C
      call monte(c,lnuminside)
!$omp end parallel
C
C  SUM UP CONTRIBUTIONS FROM EACH THREAD
C
      numinside = 0
      do i=1,nthreads
         numinside = numinside + lnuminside(i)
      end do
C
      call TimerOff(monteTime)
      call TimerOff(totalTime)
C
C  OUTPUT RESULTS
C
      area = 2.0*2.5*1.125 * real(numinside)/real(npoints)
      err2 = area/sqrt(real(npoints))
      print *, "Pi/2 = ", halfpi," +/- ",err1
      print *, "Area of Mandelbrot set = ",area," +/- ",err2
C
C
C  OUTPUT TIMING DATA
C
        call TimerPrint(seriesTime)
        call TimerPrint(monteTime)
        call TimerPrint(totalTime)
C
      stop
      end
C
      subroutine series(halfpi,err)
c
      real*8 halfpi,err,sum
      integer sign,terms,denom,i
      parameter (terms = 100000000)
c
      sum=0.0d0
      sign=1
      denom=1
c
      do i=1,terms
         sum=sum + sign*(1.0d0/denom)
         sign=(-sign)
         denom=denom + 2
      end do
c
      halfpi = 2.0d0 * sum
      err = 2.0d0/terms
      return
      end

      subroutine monte(c,lnuminside)
c
      integer npoints,maxiter,i,j,num,slice,myid,ilo,ihi
      integer nthreads,maxthreads
      parameter (npoints=300000,maxiter=10000,maxthreads=16)
      complex*16 c(npoints),z
      integer lnuminside(maxthreads)
      integer omp_get_num_threads,omp_get_thread_num
      external omp_get_num_threads,omp_get_thread_num
c
      nthreads = omp_get_num_threads()
      slice = (npoints+nthreads-1)/nthreads
      myid =  omp_get_thread_num()
      ilo = slice * myid + 1
      ihi = min(npoints,(myid+1)*slice)

      num=0
      do i=ilo,ihi
         z=(0.0,0.0)
         do j=1,maxiter
            z = z*z +c(i)
            if (abs(z).gt.2.0) goto 10
         end do
         num = num +1
 10      continue
      end do
C
      lnuminside(myid+1) = num
C
      return
      end


module mod_tests_riemann_flux_roe
  use,intrinsic :: iso_fortran_env
  use mod_wall_clock_time, only : wall_clock_time
  implicit none
  real(real64),parameter :: gmma = 1.4d0
  real(real64),parameter :: gmm1 = gmma-1.0d0
  real(real64),parameter :: gm1i = 1.0d0/gmm1
  private
  public tests_riemann_flux_roe
  contains
    !---
    subroutine tests_riemann_flux_roe(nsize,nloop,nimp,wct,primitives_2d,roeflux_2d)
      integer(int32),intent(in) :: nsize,nloop,nimp
      real(real64),dimension(nimp),intent(out) :: wct
      real(real64),dimension(4,nsize,nsize),intent(in) :: primitives_2d
      real(real64),dimension(4,nsize,nsize),intent(out) :: roeflux_2d
      integer(int32) :: i,j,k,l
      real(real64) :: t1,t2
      real(real64),dimension(5) :: pl,pr,roeflux_3d

      ! implementation 1 "sequential do"
      i = 1
      call wall_clock_time(t1)
      do l=1,nloop
        ! flux (x direction)
        do k=2,nsize-1
          do j=1,nsize-1
            ! left
            pl(1:3) = primitives_2d(1:3,j,k)
            pl(4) = 0.0d0
            pl(5) = primitives_2d(4,j,k)
            ! right
            pr(1:3) = primitives_2d(1:3,j+1,k)
            pr(4) = 0.0d0
            pr(5) = primitives_2d(4,j+1,k)

            call flux_roe(pl,pr,roeflux_3d)

            roeflux_2d(1:3,j,k) = roeflux_3d(1:3)
            roeflux_2d(  4,j,k) = roeflux_3d(5)
          end do
        end do
        ! flux (y direction)
        do j=2,nsize-1
          do k=1,nsize-1
            ! left
            pl(1) = primitives_2d(1,j,k)
            pl(2) = primitives_2d(3,j,k)
            pl(3) = primitives_2d(2,j,k)
            pl(4) = 0.0d0
            pl(5) = primitives_2d(4,j,k)
            ! right
            pr(1) = primitives_2d(1,j,k+1)
            pr(2) = primitives_2d(3,j,k+1)
            pr(3) = primitives_2d(2,j,k+1)
            pr(4) = 0.0d0
            pr(5) = primitives_2d(4,j,k+1)

            call flux_roe(pl,pr,roeflux_3d)

            roeflux_2d(1,j,k) = roeflux_3d(1)
            roeflux_2d(2,j,k) = roeflux_3d(3)
            roeflux_2d(3,j,k) = roeflux_3d(2)
            roeflux_2d(4,j,k) = roeflux_3d(5)
          end do
        end do
      end do
      call wall_clock_time(t2)
      wct(i) = t2-t1

      ! implementation 2 "OpenMP do"
      i = 2
      call wall_clock_time(t1)
      !!$omp parallel
      do l=1,nloop
        !$omp parallel do collapse(2) private(j,k,pl,pr,roeflux_3d) &
        !$omp             shared(nsize,primitives_2d,roeflux_2d)
        do k=2,nsize-1
          do j=1,nsize-1
            ! left
            pl(1:3) = primitives_2d(1:3,j,k)
            pl(4) = 0.0d0
            pl(5) = primitives_2d(4,j,k)
            ! right
            pr(1:3) = primitives_2d(1:3,j+1,k)
            pr(4) = 0.0d0
            pr(5) = primitives_2d(4,j+1,k)

            call flux_roe(pl,pr,roeflux_3d)

            roeflux_2d(1:3,j,k) = roeflux_3d(1:3)
            roeflux_2d(  4,j,k) = roeflux_3d(5)
          end do
        end do
        !$omp end parallel do
        !$omp parallel do collapse(2) private(j,k,pl,pr,roeflux_3d) &
        !$omp             shared(nsize,primitives_2d,roeflux_2d)
        do j=2,nsize-1
          do k=1,nsize-1
            ! left
            pl(1) = primitives_2d(1,j,k)
            pl(2) = primitives_2d(3,j,k)
            pl(3) = primitives_2d(2,j,k)
            pl(4) = 0.0d0
            pl(5) = primitives_2d(4,j,k)
            ! right
            pr(1) = primitives_2d(1,j,k+1)
            pr(2) = primitives_2d(3,j,k+1)
            pr(3) = primitives_2d(2,j,k+1)
            pr(4) = 0.0d0
            pr(5) = primitives_2d(4,j,k+1)

            call flux_roe(pl,pr,roeflux_3d)

            roeflux_2d(1,j,k) = roeflux_3d(1)
            roeflux_2d(2,j,k) = roeflux_3d(3)
            roeflux_2d(3,j,k) = roeflux_3d(2)
            roeflux_2d(4,j,k) = roeflux_3d(5)
          end do
        end do
        !$omp end parallel do
      end do
      call wall_clock_time(t2)
      wct(i) = t2-t1

      ! implementation 3 "do concurrent (single loop)"
      i = 3
      call wall_clock_time(t1)
      do l=1,nloop
        do concurrent(k=2:nsize-1,j=1:nsize-1)
          ! left
          pl(1:3) = primitives_2d(1:3,j,k)
          pl(4) = 0.0d0
          pl(5) = primitives_2d(4,j,k)
          ! right
          pr(1:3) = primitives_2d(1:3,j+1,k)
          pr(4) = 0.0d0
          pr(5) = primitives_2d(4,j+1,k)

          call flux_roe(pl,pr,roeflux_3d)

          roeflux_2d(1:3,j,k) = roeflux_3d(1:3)
          roeflux_2d(  4,j,k) = roeflux_3d(5)
        end do
        do concurrent(j=2:nsize-1,k=1:nsize-1)
          ! left
          pl(1) = primitives_2d(1,j,k)
          pl(2) = primitives_2d(3,j,k)
          pl(3) = primitives_2d(2,j,k)
          pl(4) = 0.0d0
          pl(5) = primitives_2d(4,j,k)
          ! right
          pr(1) = primitives_2d(1,j,k+1)
          pr(2) = primitives_2d(3,j,k+1)
          pr(3) = primitives_2d(2,j,k+1)
          pr(4) = 0.0d0
          pr(5) = primitives_2d(4,j,k+1)

          call flux_roe(pl,pr,roeflux_3d)

          roeflux_2d(1,j,k) = roeflux_3d(1)
          roeflux_2d(2,j,k) = roeflux_3d(3)
          roeflux_2d(3,j,k) = roeflux_3d(2)
          roeflux_2d(4,j,k) = roeflux_3d(5)
        end do
      end do
      call wall_clock_time(t2)
      wct(i) = t2-t1

       ! implementation 4 "do concurrent (double loop)"
      i = 4
      call wall_clock_time(t1)
      do l=1,nloop
        do concurrent(k=2:nsize-1)
          do concurrent(j=1:nsize-1)
            ! left
            pl(1:3) = primitives_2d(1:3,j,k)
            pl(4) = 0.0d0
            pl(5) = primitives_2d(4,j,k)
            ! right
            pr(1:3) = primitives_2d(1:3,j+1,k)
            pr(4) = 0.0d0
            pr(5) = primitives_2d(4,j+1,k)

            call flux_roe(pl,pr,roeflux_3d)

            roeflux_2d(1:3,j,k) = roeflux_3d(1:3)
            roeflux_2d(  4,j,k) = roeflux_3d(5)
          end do
        end do
        do concurrent(j=2:nsize-1)
          do concurrent(k=1:nsize-1)
            ! left
            pl(1) = primitives_2d(1,j,k)
            pl(2) = primitives_2d(3,j,k)
            pl(3) = primitives_2d(2,j,k)
            pl(4) = 0.0d0
            pl(5) = primitives_2d(4,j,k)
            ! right
            pr(1) = primitives_2d(1,j,k+1)
            pr(2) = primitives_2d(3,j,k+1)
            pr(3) = primitives_2d(2,j,k+1)
            pr(4) = 0.0d0
            pr(5) = primitives_2d(4,j,k+1)

            call flux_roe(pl,pr,roeflux_3d)

            roeflux_2d(1,j,k) = roeflux_3d(1)
            roeflux_2d(2,j,k) = roeflux_3d(3)
            roeflux_2d(3,j,k) = roeflux_3d(2)
            roeflux_2d(4,j,k) = roeflux_3d(5)
          end do
        end do
      end do
      call wall_clock_time(t2)
      wct(i) = t2-t1

    end subroutine tests_riemann_flux_roe
    !---
    pure subroutine roe_average(pl,pr,rave)
      real(real64),dimension(5),intent(in) :: pl,pr
      real(real64),dimension(5),intent(out) :: rave
      real(real64) :: sqrtrl,sqrtrr,deno,e,hl,hr,v

      ! left state
      sqrtrl = sqrt(pl(1))
      e = 0.5d0*pl(1)*(pl(2)**2+pl(3)**2+pl(4)**2)+gm1i*pl(5)
      hl = (e+pl(5))/pl(1)
      ! right state
      sqrtrr = sqrt(pr(1))
      e = 0.5d0*pr(1)*(pr(2)**2+pr(3)**2+pr(4)**2)+gm1i*pr(5)
      hr = (e+pr(5))/pr(1)
      ! roe average
      deno = 1.0d0/(sqrtrl+sqrtrr)
      rave(1:3) = (sqrtrl*pl(2:4)+sqrtrr*pr(2:4))*deno  ! velocity
      rave(4)   = (sqrtrl*hl     +sqrtrr*hr     )*deno  ! entropy
      v = 0.5d0*(rave(1)**2+rave(2)**2+rave(3)**2)
      rave(5) = sqrt(gmm1*(rave(4)-v))            ! speed of sound

    end subroutine roe_average
    !---
    pure subroutine flux_roe(pl,pr,f)
      real(real64),dimension(5),intent(in) :: pl,pr
      real(real64),dimension(5),intent(out) :: f
      real(real64),dimension(5) :: fl,fr,ql,qr,dq
      real(real64),dimension(5) :: rave,lmd,k1,k2,k3,k4,k5,alpha

      call conservatives(pl,ql)
      call conservatives(pr,qr)
      dq(1:5) = ql(1:5)-ql(1:5)
      call roe_average(pl,pr,rave)
      call eigenvalues(rave(1),rave(4),lmd)
      call right_eigenvectors(rave,k1,k2,k3,k4,k5)
      call wave_strength(rave,dq,alpha)
      call flux(pl,fl)
      call flux(pr,fr)
      f(1:5) = 0.5d0*(fl(1:5)+fr(1:5))-0.5d0*( alpha(1)*abs(lmd(1))*k1(1:5)  &
      &                                       +alpha(2)*abs(lmd(2))*k2(1:5)  &
      &                                       +alpha(3)*abs(lmd(3))*k3(1:5)  &
      &                                       +alpha(4)*abs(lmd(4))*k4(1:5)  &
      &                                       +alpha(5)*abs(lmd(5))*k5(1:5) )

    end subroutine flux_roe
    !---
    pure subroutine eigenvalues(u,a,lmd)
      real(real64),intent(in) :: u,a
      real(real64),dimension(5),intent(out) :: lmd

      lmd(1) = u-a
      lmd(2) = u
      lmd(3) = u
      lmd(4) = u
      lmd(5) = u+a

    end subroutine eigenvalues
    !---
    pure subroutine right_eigenvectors(rave,k1,k2,k3,k4,k5)
      real(real64),dimension(5),intent(in) :: rave
      real(real64),dimension(5),intent(out) :: k1,k2,k3,k4,k5

      k1(1) = 1.0d0
      k1(2) = rave(1)-rave(5)
      k1(3) = rave(2)
      k1(4) = rave(3)
      k1(5) = rave(4)-rave(1)*rave(5)

      k2(1) = 1.0d0
      k2(2) = rave(1)
      k2(3) = rave(2)
      k2(4) = rave(3)
      k2(5) = 0.5d0*(rave(1)**2+rave(2)**2+rave(3)**2)

      k3(1) = 0.0d0
      k3(2) = 0.0d0
      k3(3) = 1.0d0
      k3(4) = 0.0d0
      k3(5) = rave(2)

      k4(1) = 0.0d0
      k4(2) = 0.0d0
      k4(3) = 0.0d0
      k4(4) = 1.0d0
      k4(5) = rave(3)

      k5(1) = 1.0d0
      k5(2) = rave(1)+rave(5)
      k5(3) = rave(2)
      k5(4) = rave(3)
      k5(5) = rave(4)+rave(1)*rave(5)

    end subroutine right_eigenvectors
    !---
    pure subroutine flux(p,f)
      real(real64),dimension(5),intent(in) :: p
      real(real64),dimension(5),intent(out) :: f
      real(real64) :: e

      e = 0.5d0*p(1)*(p(2)**2+p(3)**2+p(4)**2)+gm1i*p(5)
      f(1) = p(1)*p(2)
      f(2) = f(1)*p(2)+p(5)
      f(3) = f(1)*p(3)
      f(4) = f(1)*p(4)
      f(5) = (e+p(5))*p(2)

    end subroutine flux
    !---
    pure subroutine conservatives(p,q)
      real(real64),dimension(5),intent(in) :: p
      real(real64),dimension(5),intent(out) :: q

      q(1) = p(1)
      q(2:4) = p(1)*p(2:4)
      q(5) = 0.5d0*p(1)*(p(2)**2+p(3)**2+p(4)**2)+gm1i*p(5)

    end subroutine conservatives
    !---
    pure subroutine wave_strength(rave,dq,alpha)
      real(real64),dimension(5),intent(in) :: rave,dq
      real(real64),dimension(5),intent(out) :: alpha
      real(real64) :: dq5bar,ainv

      alpha(3) = dq(3)-rave(2)*dq(1)
      alpha(4) = dq(4)-rave(3)*dq(1)

      dq5bar = dq(5)-(dq(3)-rave(2)*dq(1))*rave(2)&
      &             -(dq(4)-rave(3)*dq(1))*rave(3)
      ainv = 1.0d0/rave(5)
      alpha(2) = gmm1*ainv**2*(dq(1)*(rave(4)-rave(1)**2)+rave(1)*dq(2)-dq5bar)
      alpha(1) = 0.5d0*ainv*(dq(1)*(rave(1)+rave(5))-dq(2)-rave(5)*alpha(2))
      alpha(5) = dq(1)-alpha(1)-alpha(2)

    end subroutine wave_strength
    !---
end module mod_tests_riemann_flux_roe


SUBROUTINE DiffYEven(var,varY,order,Nx,Ny,Nz,DiffStencils,beta)
!
! Explicit order differentiation in Y-direction.
!
! By Allan P. Engsig-Karup.
USE Precision
USE DataTypes
IMPLICIT NONE
TYPE (Diff_def) :: DiffStencils
INTEGER :: Nx, Ny, Nz, rank, order, beta,i,j,k
REAL(KIND=long), DIMENSION(Nz,Nx,Ny) :: var, varY
REAL(KIND=long), DIMENSION(2*beta+1) :: Stencil
rank = 2*beta+1
DO j = 1, beta
	Stencil = DiffStencils%StencilY(j,:,order)
	DO i = 1, Nx
		DO k = 1, Nz
			varY(k,i,j) = DOT_PRODUCT(Stencil,var(k,i,1:rank))
		END DO
	END DO
END DO
DO j = beta+1, Ny-beta
	Stencil = DiffStencils%StencilY(j,:,order)
	DO i = 1, Nx
		DO k = 1, Nz
			varY(k,i,j) = DOT_PRODUCT(Stencil,var(k,i,j-beta:j+beta))
		END DO
	END DO
END DO
DO j = Ny-beta+1, Ny
	Stencil = DiffStencils%StencilY(j,:,order)
	DO i = 1, Nx
		DO k = 1, Nz
			varY(k,i,j) = DOT_PRODUCT(Stencil,var(k,i,Ny+1-rank:Ny))
		END DO
	END DO
END DO
END SUBROUTINE DiffYEven


      MODULE CONSTANT
!@sum  CONSTANT definitions for physical constants and useful numbers
!@auth G. Schmidt
!@ver  1.0
      IMPLICIT NONE
      SAVE
C**** Conventions: 'by' implies reciprocal, 'rt' implies square root

C**** Numerical constants

      real*8,parameter :: pi = 3.1415926535897932d0 !@param pi    pi
      real*8,parameter :: twopi = 2d0*pi           !@param twopi 2*pi
      real*8,parameter :: radian = pi/180d0        !@param radian pi/180
!@param zero,one 0 and 1 for occasional use as arguments
      real*8,parameter :: zero = 0d0, one=1d0
!@param rt2,byrt2   sqrt(2), 1/sqrt(2)
      real*8,parameter :: rt2 = 1.4142135623730950d0
      real*8,parameter :: byrt2 = 1./rt2
!@param rt3,byrt3   sqrt(3), 1/sqrt(3)
      real*8,parameter :: rt3 = 1.7320508075688772d0
      real*8,parameter :: byrt3 = 1./rt3
!@param rt12,byrt12   sqrt(12), 1/sqrt(12)
      real*8,parameter :: rt12 = 3.4641016151377546d0
      real*8,parameter :: byrt12 = 1./rt12
      real*8,parameter :: by3 =1./3d0  !@param by3  1/3
      real*8,parameter :: by6 =1./6d0  !@param by6  1/6
      real*8,parameter :: by9 =1./9d0  !@param by9  1/9
      real*8,parameter :: by12=1./12d0 !@param by12 1/12
!@param undef Missing value
      real*8,parameter :: undef=-1.d30
!@param teeny  small positive value used in num/(den+teeny) to avoid 0/0
      real*8,parameter :: teeny=1.d-30

C**** Physical constants

!@param stbo Stefan-Boltzmann constant (W/m^2 K^4)
      real*8,parameter :: stbo =5.67051d-8 !current best estimate

c**** Latent heats:
c**** Note that for energy conservation the efective latent heat at any
c**** temperature must follow these formulae (assuming a reference
c**** temperature of 0 Celcius, and constant specific heats).
c**** If specific heats vary as a function of temperature, the extra
c**** term becomes an integral
c**** lhe(T) = lhe(0) + (shv-shw) T (in C)
c**** lhm(T) = lhm(0) + (shw-shi) T (in C)
c**** lhs(T) = lhs(0) + (shv-shi) T (in C)
!@param lhe   latent heat of evap at 0 C (2.5008d6 J/kg)
      real*8,parameter :: lhe = 2.5d6
!@param lhm   latent heat of melt at 0 C (334590 J/kg)
      real*8,parameter :: lhm = 3.34d5
!@param bylhm  1/lhm
      real*8,parameter :: bylhm = 1./lhm
!@param lhs  latent heat of sublimation at 0 C (J/kg)
      real*8,parameter :: lhs = lhe+lhm

!@param rhow density of pure water (1000 kg/m^3)
      real*8,parameter :: rhow = 1d3
!@param rhows density of average sea water (1030 kg/m^3)
      real*8,parameter :: rhows = 1030d0
!@param rhoi density of pure ice (916.6 kg/m^3)
      real*8,parameter :: rhoi = 916.6d0
!@param byrhoi 1/rhoi (m^3/kg)
      real*8,parameter :: byrhoi = 1d0/rhoi

!@param tf freezing point of water at 1 atm (273.16 K)
      real*8,parameter :: tf = 273.16d0
!@param bytf 1/tf (K^-1)
      real*8,parameter :: bytf = 1d0/tf

!@param shw heat capacity of water (at 20 C) (4185 J/kg C)
      real*8,parameter :: shw  = 4185.
!@param byshw 1/shw
      real*8,parameter :: byshw = 1d0/shw

!@param shi heat capacity of pure ice (at 0 C) (2060 J/kg C)
      real*8,parameter :: shi  = 2060.
!@param byshi 1/shi
      real*8,parameter :: byshi = 1d0/shi

c**** RGAS = R/M_A = 1000* 8.314510 J/mol K /28.9655 g/mol
c**** For values of CO2 much larger than present day (> 4x conc)
c**** the molecular weight of dry air M_A could change.
c**** Assume that M_O2 = 31.9988 and M_CO2 = 44.00995
c**** and current percentages 20.946% and 0.0350% (US Stand. Atm.)
c**** Assuming CO2 displaces other gases equally M_A=28.9602 + n*0.00527
c**** where n is multiple of present day CO2 conc (350 ppm)
c**** For 4xCO2  M_A = 28.9813  => rgas = 286.89
c**** For 10xCO2 M_A = 29.0129  => rgas = 286.58
!@param gasc  gas constant (8.314510 J/mol K)
      real*8,parameter :: gasc = 8.314510d0
!@param bygasc  1/gasc
      real*8,parameter :: bygasc = 1./gasc
!@param mair molecular weight of dry air (28.9655 g/mol)
      real*8,parameter :: mair = 28.9655d0
!@param rgas gas constant (287.05 J/K kg)
      real*8,parameter :: rgas = 1d3 * gasc / mair ! = 287.05...

!@param mwat molecular weight of water vapour
      real*8,parameter :: mwat = 18.015d0
!@param rvap  gas constant for water vapour (461.5 J/K kg)
c**** defined as R/M_W = 1000* 8.314510 J/mol K /18.015 g/mol
      real*8,parameter :: rvap = 1d3 * gasc / mwat ! = 461.5...

!@param mrat  mass ratio of air to water vapour (0.62197)
      real*8,parameter :: mrat = mwat/mair    ! = 0.62197....
!@param bymrat 1/mrat (1.6078)
      real*8,parameter :: bymrat = 1./mrat    ! = 1.6078....
!@param deltx coeff. of humidity in virtual temperature defn. (0.6078)
      real*8,parameter :: deltx = bymrat-1.   ! = 0.6078....

!@param srat ratio of specific heats at const. press. and vol. (=1.401)
      real*8,parameter :: srat = 1.401d0
!@param kapa ideal gas law exponent for dry air (.2862)
c**** kapa = (g-1)/g where g=1.401 = c_p/c_v
      real*8,parameter :: kapa = (srat - 1.)/srat  ! =.2862....
!@param bykapa,bykapap1,bykapap2 various useful reciprocals of kapa
      real*8,parameter :: bykapa = 1./kapa
      real*8,parameter :: bykapap1 = 1./(kapa+1.)
      real*8,parameter :: bykapap2 = 1./(kapa+2.)

!@param sha specific heat of dry air (const. pres.) (rgas/kapa J/kg C)
      real*8,parameter :: sha = rgas/kapa
!@param bysha 1/sha
      real*8,parameter :: bysha = 1./sha

!@param shv specific heat of water vapour (const. pres.) (J/kg C)
c**** shv is currently assumed to be zero to aid energy conservation in
c**** the atmosphere. Once the heat content associated with water
c**** vapour is included, this can be set to the standard value
c**** Literature values are 1911 (Arakawa), 1952 (Wallace and Hobbs)
c**** Smithsonian Met Tables = 4*rvap + delta = 1858--1869 ????
c     real*8,parameter :: shv = 4.*rvap  ????
      real*8,parameter :: shv = 0.

!@var visc_air dynamic viscosity of air (kg/m s)
      real*8,parameter :: visc_air = 1.7d-5

C**** Astronomical constants

!@param sday  sec per day (s)
      real*8,parameter :: sday = 86400.

!@param hrday  hours in a day (hrs)
      real*8,parameter :: hrday = sday/3600.

!@param omega earth's rotation rate (7.29 s^-1)
c      real*8,parameter :: omega = 7.2921151467d-5 ! NOVAS value
      real*8,parameter :: EDPERD = 1.
      real*8,parameter :: EDPERY = 365.
      real*8,parameter :: omega = TWOPI*(EDPERD+EDPERY)/
     *                            (EDPERD*EDPERY*SDAY)
!@param omega2 2*omega
      real*8,parameter :: omega2 = 2.*omega

!@param radius radius of the earth (6371000 m)
c**** radius of spherical earth, same volume = 6371000 m
      real*8,parameter :: radius = 6375000.
!@param grav gravitaional accelaration (9.80665 m/s^2)
c**** SI reference gravity (at 45 deg) = 9.80665
      real*8,parameter :: grav = 9.80665d0
!@param bygrav 1/grav
      real*8,parameter :: bygrav = 1d0/grav

C**** lapse rate related variables
!@param GAMD dry adiabatic lapse rate (=0.0098 K/m)
      real*8, parameter :: gamd = grav*kapa/rgas
!@param BMOIST moist adiabatic lapse rate (K/m)
      real*8, parameter :: bmoist = 0.0065d0
!@param BBYG moist adiabatic lapse rate divided by grav
      real*8, parameter :: bbyg = bmoist*bygrav
!@param GBYRB grav divided by rgas and bmoist
      real*8, parameter :: gbyrb = grav/(rgas*bmoist)

C**** Useful conversion factors

!@param kg2mb,mb2kg conversion from milli-bars to kg/m^2
      real*8,parameter :: kg2mb = 1d-2*grav, mb2kg = 1d2*bygrav
!@param kgpa2mm,mm2kgpa conversion from kg/m^2 water to mm
      real*8,parameter :: kgpa2mm = 1d0, mm2kgpa = 1d0

      END MODULE CONSTANT


      SUBROUTINE MB03RD( JOBX, SORT, N, PMAX, A, LDA, X, LDX, NBLCKS,
     $                   BLSIZE, WR, WI, TOL, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reduce a matrix A in real Schur form to a block-diagonal form
C     using well-conditioned non-orthogonal similarity transformations.
C     The condition numbers of the transformations used for reduction
C     are roughly bounded by PMAX*PMAX, where PMAX is a given value.
C     The transformations are optionally postmultiplied in a given
C     matrix X. The real Schur form is optionally ordered, so that
C     clustered eigenvalues are grouped in the same block.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBX    CHARACTER*1
C             Specifies whether or not the transformations are
C             accumulated, as follows:
C             = 'N':  The transformations are not accumulated;
C             = 'U':  The transformations are accumulated in X (the
C                     given matrix X is updated).
C
C     SORT    CHARACTER*1
C             Specifies whether or not the diagonal blocks of the real
C             Schur form are reordered, as follows:
C             = 'N':  The diagonal blocks are not reordered;
C             = 'S':  The diagonal blocks are reordered before each
C                     step of reduction, so that clustered eigenvalues
C                     appear in the same block;
C             = 'C':  The diagonal blocks are not reordered, but the
C                     "closest-neighbour" strategy is used instead of
C                     the standard "closest to the mean" strategy
C                     (see METHOD);
C             = 'B':  The diagonal blocks are reordered before each
C                     step of reduction, and the "closest-neighbour"
C                     strategy is used (see METHOD).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A and X.  N >= 0.
C
C     PMAX    (input) DOUBLE PRECISION
C             An upper bound for the infinity norm of elementary
C             submatrices of the individual transformations used for
C             reduction (see METHOD).  PMAX >= 1.0D0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A to be block-diagonalized, in real
C             Schur form.
C             On exit, the leading N-by-N part of this array contains
C             the computed block-diagonal matrix, in real Schur
C             canonical form. The non-diagonal blocks are set to zero.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
C             On entry, if JOBX = 'U', the leading N-by-N part of this
C             array must contain a given matrix X.
C             On exit, if JOBX = 'U', the leading N-by-N part of this
C             array contains the product of the given matrix X and the
C             transformation matrix that reduced A to block-diagonal
C             form. The transformation matrix is itself a product of
C             non-orthogonal similarity transformations having elements
C             with magnitude less than or equal to PMAX.
C             If JOBX = 'N', this array is not referenced.
C
C     LDX     INTEGER
C             The leading dimension of array X.
C             LDX >= 1,        if JOBX = 'N';
C             LDX >= MAX(1,N), if JOBX = 'U'.
C
C     NBLCKS  (output) INTEGER
C             The number of diagonal blocks of the matrix A.
C
C     BLSIZE  (output) INTEGER array, dimension (N)
C             The first NBLCKS elements of this array contain the orders
C             of the resulting diagonal blocks of the matrix A.
C
C     WR,     (output) DOUBLE PRECISION arrays, dimension (N)
C     WI      These arrays contain the real and imaginary parts,
C             respectively, of the eigenvalues of the matrix A.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in the ordering of the diagonal
C             blocks of the real Schur form matrix.
C             If the user sets TOL > 0, then the given value of TOL is
C             used as an absolute tolerance: a block i and a temporarily
C             fixed block 1 (the first block of the current trailing
C             submatrix to be reduced) are considered to belong to the
C             same cluster if their eigenvalues satisfy
C
C               | lambda_1 - lambda_i | <= TOL.
C
C             If the user sets TOL < 0, then the given value of TOL is
C             used as a relative tolerance: a block i and a temporarily
C             fixed block 1 are considered to belong to the same cluster
C             if their eigenvalues satisfy, for j = 1, ..., N,
C
C               | lambda_1 - lambda_i | <= | TOL | * max | lambda_j |.
C
C             If the user sets TOL = 0, then an implicitly computed,
C             default tolerance, defined by TOL = SQRT( SQRT( EPS ) )
C             is used instead, as a relative tolerance, where EPS is
C             the machine precision (see LAPACK Library routine DLAMCH).
C             If SORT = 'N' or 'C', this parameter is not referenced.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (N)
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     METHOD
C
C     Consider first that SORT = 'N'. Let
C
C            ( A    A   )
C            (  11   12 )
C        A = (          ),
C            ( 0    A   )
C            (       22 )
C
C     be the given matrix in real Schur form, where initially A   is the
C                                                              11
C     first diagonal block of dimension 1-by-1 or 2-by-2. An attempt is
C     made to compute a transformation matrix X of the form
C
C            ( I   P )
C        X = (       )                                               (1)
C            ( 0   I )
C
C     (partitioned as A), so that
C
C                 ( A     0  )
C         -1      (  11      )
C        X  A X = (          ),
C                 ( 0    A   )
C                 (       22 )
C
C     and the elements of P do not exceed the value PMAX in magnitude.
C     An adaptation of the standard method for solving Sylvester
C     equations [1], which controls the magnitude of the individual
C     elements of the computed solution [2], is used to obtain matrix P.
C     When this attempt failed, an 1-by-1 (or 2-by-2) diagonal block of
C     A  , whose eigenvalue(s) is (are) the closest to the mean of those
C      22
C     of A   is selected, and moved by orthogonal similarity
C         11
C     transformations in the leading position of A  ; the moved diagonal
C                                                 22
C     block is then added to the block A  , increasing its order by 1
C                                       11
C     (or 2). Another attempt is made to compute a suitable
C     transformation matrix X with the new definitions of the blocks A
C                                                                     11
C     and A  . After a successful transformation matrix X has been
C          22
C     obtained, it postmultiplies the current transformation matrix
C     (if JOBX = 'U'), and the whole procedure is repeated for the
C     matrix A  .
C             22
C
C     When SORT = 'S', the diagonal blocks of the real Schur form are
C     reordered before each step of the reduction, so that each cluster
C     of eigenvalues, defined as specified in the definition of TOL,
C     appears in adjacent blocks. The blocks for each cluster are merged
C     together, and the procedure described above is applied to the
C     larger blocks. Using the option SORT = 'S' will usually provide
C     better efficiency than the standard option (SORT = 'N'), proposed
C     in [2], because there could be no or few unsuccessful attempts
C     to compute individual transformation matrices X of the form (1).
C     However, the resulting dimensions of the blocks are usually
C     larger; this could make subsequent calculations less efficient.
C
C     When SORT = 'C' or 'B', the procedure is similar to that for
C     SORT = 'N' or 'S', respectively, but the block of A   whose
C                                                        22
C     eigenvalue(s) is (are) the closest to those of A   (not to their
C                                                     11
C     mean) is selected and moved to the leading position of A  . This
C                                                             22
C     is called the "closest-neighbour" strategy.
C
C     REFERENCES
C
C     [1] Bartels, R.H. and Stewart, G.W.  T
C         Solution of the matrix equation A X + XB = C.
C         Comm. A.C.M., 15, pp. 820-826, 1972.
C
C     [2] Bavely, C. and Stewart, G.W.
C         An Algorithm for Computing Reducing Subspaces by Block
C         Diagonalization.
C         SIAM J. Numer. Anal., 16, pp. 359-367, 1979.
C
C     [3] Demmel, J.
C         The Condition Number of Equivalence Transformations that
C         Block Diagonalize Matrix Pencils.
C         SIAM J. Numer. Anal., 20, pp. 599-610, 1983.
C
C     NUMERICAL ASPECTS
C                                       3                     4
C     The algorithm usually requires 0(N ) operations, but 0(N ) are
C     possible in the worst case, when all diagonal blocks in the real
C     Schur form of A are 1-by-1, and the matrix cannot be diagonalized
C     by well-conditioned transformations.
C
C     FURTHER COMMENTS
C
C     The individual non-orthogonal transformation matrices used in the
C     reduction of A to a block-diagonal form have condition numbers
C     of the order PMAX*PMAX. This does not guarantee that their product
C     is well-conditioned enough. The routine can be easily modified to
C     provide estimates for the condition numbers of the clusters of
C     eigenvalues.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, June 1998.
C     Partly based on the RASP routine BDIAG by A. Varga, German
C     Aerospace Center, DLR Oberpfaffenhofen.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003.
C
C     KEYWORDS
C
C     Diagonalization, orthogonal transformation, real Schur form,
C     Sylvester equation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBX, SORT
      INTEGER           INFO, LDA, LDX, N, NBLCKS
      DOUBLE PRECISION  PMAX, TOL
C     .. Array Arguments ..
      INTEGER           BLSIZE(*)
      DOUBLE PRECISION  A(LDA,*), DWORK(*), WI(*), WR(*), X(LDX,*)
C     .. Local Scalars ..
      LOGICAL           LJOBX, LSORN, LSORS, LSORT
      CHARACTER         JOBV
      INTEGER           DA11, DA22, I, IERR, J, K, L, L11, L22, L22M1
      DOUBLE PRECISION  C, CAV, D, EDIF, EMAX, RAV, SAFEMN, SC, THRESH
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLAPY2, DNRM2
      EXTERNAL          DLAMCH, DLAPY2, DNRM2, LSAME
C     .. External Subroutines ..
      EXTERNAL          DGEMM, DLABAD, DLASET, DSCAL, MA02AD, MB03QX,
     $                  MB03RX, MB03RY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, SQRT
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO  = 0
      LJOBX = LSAME( JOBX, 'U' )
      LSORN = LSAME( SORT, 'N' )
      LSORS = LSAME( SORT, 'S' )
      LSORT = LSAME( SORT, 'B' ) .OR. LSORS
      IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LSORN .AND. .NOT.LSORT .AND.
     $         .NOT.LSAME( SORT, 'C' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( PMAX.LT.ONE ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( ( LDX.LT.1 ) .OR. ( LJOBX .AND. LDX.LT.N ) ) THEN
         INFO = -8
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB03RD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      NBLCKS = 0
      IF( N.EQ.0 )
     $   RETURN
C
C     Set the "safe" minimum positive number with representable
C     reciprocal, and set JOBV parameter for MB03RX routine.
C
      SAFEMN = DLAMCH( 'Safe minimum' )
      SC = ONE / SAFEMN
      CALL DLABAD( SAFEMN, SC )
      SAFEMN = SAFEMN / DLAMCH( 'Precision' )
      JOBV = JOBX
      IF ( LJOBX )
     $   JOBV = 'V'
C
C     Compute the eigenvalues of A and set the tolerance for reordering
C     the eigenvalues in clusters, if needed.
C
      CALL MB03QX( N, A, LDA, WR, WI, INFO )
C
      IF ( LSORT ) THEN
         THRESH = ABS( TOL )
         IF ( THRESH.EQ.ZERO ) THEN
C
C           Use the default tolerance in ordering the blocks.
C
            THRESH = SQRT( SQRT( DLAMCH( 'Epsilon' ) ) )
         END IF
C
         IF ( TOL.LE.ZERO ) THEN
C
C           Use a relative tolerance. Find max | lambda_j |, j = 1 : N.
C
            EMAX = ZERO
            L = 1
C           WHILE ( L.LE.N ) DO
   10       IF ( L.LE.N ) THEN
               IF ( WI(L).EQ.ZERO ) THEN
                  EMAX = MAX( EMAX, ABS( WR(L) ) )
                  L = L + 1
               ELSE
                  EMAX = MAX( EMAX, DLAPY2( WR(L), WI(L) ) )
                  L = L + 2
               END IF
               GO TO 10
            END IF
C           END WHILE 10
            THRESH = THRESH * EMAX
         END IF
      END IF
C
C     Define the following submatrices of A:
C     A11, the DA11-by-DA11 block in position (L11,L11);
C     A22, the DA22-by-DA22 block in position (L22,L22);
C     A12, the DA11-by-DA22 block in position (L11,L22);
C     A21, the DA22-by-DA11 block in position (L22,L11) (null initially
C                                                        and finally).
C     The following loop uses L11 as loop variable and try to separate a
C     block in position (L11,L11), with possibly clustered eigenvalues,
C     separated by the other eigenvalues (in the block A22).
C
      L11 = 1
C     WHILE ( L11.LE.N ) DO
   20 IF ( L11.LE.N ) THEN
         NBLCKS = NBLCKS + 1
         IF ( WI(L11).EQ.ZERO ) THEN
            DA11 = 1
         ELSE
            DA11 = 2
         END IF
C
         IF ( LSORT ) THEN
C
C           The following loop, using K as loop variable, finds the
C           blocks whose eigenvalues are close to those of A11 and
C           moves these blocks (if any) to the leading position of A22.
C
            L22 = L11 + DA11
            K = L22
C           WHILE ( K.LE.N ) DO
   30       IF ( K.LE.N ) THEN
               EDIF = DLAPY2( WR(L11) - WR(K), WI(L11) - WI(K) )
               IF ( EDIF.LE.THRESH ) THEN
C
C                 An 1x1 or a 2x2 block of A22 has been found so that
C
C                    abs( lambda_1 - lambda_k ) <= THRESH
C
C                 where lambda_1 and lambda_k denote an eigenvalue
C                 of A11 and of that block in A22, respectively.
C                 Try to move that block to the leading position of A22.
C
                  CALL MB03RX( JOBV, N, L22, K, A, LDA, X, LDX, WR, WI,
     $                         DWORK )
C
C                 Extend A11 with the leading block of A22.
C
                  IF ( WI(L22).EQ.ZERO ) THEN
                     DA11 = DA11 + 1
                  ELSE
                     DA11 = DA11 + 2
                  END IF
                  L22 = L11 + DA11
               END IF
               IF ( WI(K).EQ.ZERO ) THEN
                  K = K + 1
               ELSE
                  K = K + 2
               END IF
               GO TO 30
            END IF
C           END WHILE 30
         END IF
C
C        The following loop uses L22 as loop variable and forms a
C        separable DA11-by-DA11 block A11 in position (L11,L11).
C
         L22   = L11 + DA11
         L22M1 = L22 - 1
C        WHILE ( L22.LE.N ) DO
   40    IF ( L22.LE.N ) THEN
            DA22  = N - L22M1
C
C           Try to separate the block A11 of order DA11 by using a
C           well-conditioned similarity transformation.
C
C           First save A12' in the block A21.
C
            CALL MA02AD( 'Full', DA11, DA22, A(L11,L22), LDA,
     $                   A(L22,L11), LDA )
C
C           Solve  -A11*P + P*A22 = A12.
C
            CALL MB03RY( DA11, DA22, PMAX, A(L11,L11), LDA, A(L22,L22),
     $                   LDA, A(L11,L22), LDA, IERR )
C
            IF ( IERR.EQ.1 ) THEN
C
C              The annihilation of A12 failed. Restore A12 and A21.
C
               CALL MA02AD( 'Full', DA22, DA11, A(L22,L11), LDA,
     $                      A(L11,L22), LDA )
               CALL DLASET( 'Full', DA22, DA11, ZERO, ZERO, A(L22,L11),
     $                      LDA )
C
               IF ( LSORN .OR. LSORS ) THEN
C
C                 Extend A11 with an 1x1 or 2x2 block of A22 having the
C                 nearest eigenvalues to the mean of eigenvalues of A11
C                 and resume the loop.
C                 First compute the mean of eigenvalues of A11.
C
                  RAV = ZERO
                  CAV = ZERO
C
                  DO 50 I = L11, L22M1
                     RAV = RAV + WR(I)
                     CAV = CAV + ABS( WI(I) )
   50             CONTINUE
C
                  RAV = RAV/DA11
                  CAV = CAV/DA11
C
C                 Loop to find the eigenvalue of A22 nearest to the
C                 above computed mean.
C
                  D = DLAPY2( RAV-WR(L22), CAV-WI(L22) )
                  K = L22
                  IF ( WI(L22).EQ.ZERO ) THEN
                     L = L22 + 1
                  ELSE
                     L = L22 + 2
                  END IF
C                 WHILE ( L.LE.N ) DO
   60             IF ( L.LE.N ) THEN
                     C = DLAPY2( RAV-WR(L), CAV-WI(L) )
                     IF ( C.LT.D ) THEN
                        D = C
                        K = L
                     END IF
                     IF ( WI(L).EQ.ZERO ) THEN
                        L = L + 1
                     ELSE
                        L = L + 2
                     END IF
                     GO TO 60
                  END IF
C                 END WHILE 60
C
               ELSE
C
C                 Extend A11 with an 1x1 or 2x2 block of A22 having the
C                 nearest eigenvalues to the cluster of eigenvalues of
C                 A11 and resume the loop.
C
C                 Loop to find the eigenvalue of A22 of minimum distance
C                 to the cluster.
C
                  D = SC
                  L = L22
                  K = L22
C                 WHILE ( L.LE.N ) DO
   70             IF ( L.LE.N ) THEN
                     I = L11
C                    WHILE ( I.LE.L22M1 ) DO
   80                IF ( I.LE.L22M1 ) THEN
                        C = DLAPY2( WR(I)-WR(L), WI(I)-WI(L) )
                        IF ( C.LT.D ) THEN
                           D = C
                           K = L
                        END IF
                        IF ( WI(I).EQ.ZERO ) THEN
                           I = I + 1
                        ELSE
                           I = I + 2
                        END IF
                        GO TO 80
                     END IF
C                    END WHILE 80
                     IF ( WI(L).EQ.ZERO ) THEN
                        L = L + 1
                     ELSE
                        L = L + 2
                     END IF
                     GO TO 70
                  END IF
C                 END WHILE 70
               END IF
C
C              Try to move block found to the leading position of A22.
C
               CALL MB03RX( JOBV, N, L22, K, A, LDA, X, LDX, WR, WI,
     $                      DWORK )
C
C              Extend A11 with the leading block of A22.
C
               IF ( WI(L22).EQ.ZERO ) THEN
                  DA11 = DA11 + 1
               ELSE
                  DA11 = DA11 + 2
               END IF
               L22   = L11 + DA11
               L22M1 = L22 - 1
               GO TO 40
            END IF
         END IF
C        END WHILE 40
C
         IF ( LJOBX ) THEN
C
C           Accumulate the transformation in X.
C           Only columns L22, ..., N are modified.
C
            IF ( L22.LE.N )
     $         CALL DGEMM( 'No transpose', 'No transpose', N, DA22,
     $                     DA11, ONE, X(1,L11), LDX, A(L11,L22), LDA,
     $                     ONE, X(1,L22), LDX )
C
C           Scale to unity the (non-zero) columns of X which will be
C           no more modified and transform A11 accordingly.
C
            DO 90 J = L11, L22M1
               SC = DNRM2( N, X(1,J), 1 )
               IF ( SC.GT.SAFEMN ) THEN
                  CALL DSCAL( DA11, SC, A(J,L11), LDA )
                  SC = ONE/SC
                  CALL DSCAL( N, SC, X(1,J), 1 )
                  CALL DSCAL( DA11, SC, A(L11,J), 1 )
               END IF
   90       CONTINUE
C
         END IF
         IF ( L22.LE.N ) THEN
C
C           Set A12 and A21 to zero.
C
            CALL DLASET( 'Full', DA11, DA22, ZERO, ZERO, A(L11,L22),
     $                   LDA )
            CALL DLASET( 'Full', DA22, DA11, ZERO, ZERO, A(L22,L11),
     $                   LDA )
         END IF
C
C        Store the orders of the diagonal blocks in BLSIZE.
C
         BLSIZE(NBLCKS) = DA11
         L11 = L22
         GO TO 20
      END IF
C     END WHILE 20
C
      RETURN
C *** Last line of MB03RD ***
      END


       SUBROUTINE W3FB02(ALAT, ALONG, XMESHL, XI, XJ)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FB02         CONVERT S. HEMISPHERE LAT/LON TO I AND J
C   AUTHOR: JONES,R.E.       ORG: W342       DATE: 85-09-13
C
C ABSTRACT: COMPUTES I AND J COORDINATES FOR A LATITUDE/LONGITUDE
C   POINT ON THE SOUTHERN HEMISPHERE POLAR STEREOGRAPHIC MAP
C   PROJECTION.
C
C PROGRAM HISTORY LOG:
C   85-09-13  R.E.JONES   CONVERT TO FORTRAN 77
C   90-08-31  R.E.JONES   CONVERT TO CRAY CFT77 FORTRAN
C
C USAGE:  CALL W3FB02 (ALAT, ALONG, XMESHL, XI, XJ)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     ALAT   ARG LIST  REAL*4 LATITUDE (S.H. LATITUDES ARE NEGATIVE)
C     ALONG  ARG LIST  REAL*4 WEST LONGITUDE
C     XMESHL ARG LIST  REAL*4 GRID INTERVAL IN KM.
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     XI     ARG LIST  REAL*4 I COORDINATE
C     XJ     ARG LIST  REAL*4 J COORDINATE
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     COS  SIN                                                SYSLIB
C
C
C   EXIT STATES: *
C
C   EXTERNAL REFERENCES: NONE
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP8/832
C
C$$$
C
C     ...GIVEN ... ALAT   SRN HEMI LATS ARE NEGATIVE VALUED
C                  ALONG   IN DEGREES  WEST LONGITUDE
C                  XMESHL= GRID INTERVAL IN KM,  E.G., 381.0 KM
C     ...TO COMPUTE XI,XJ FOR A PT ON THE SRN HEMI POLAR STEREOGRAPHIC
C     ...   PROJECTION, WITH 80W LONGITUDE VERTICAL AT THE TOP OF  MAP,
C     ...   AND 100E LONGITUDE VERTICAL AT THE BOTTOM OF THE MAP.
C     ...THE RESULTING XI AND XJ ARE RELATIVE TO  (0,0) AT SOUTH POLE.
C
       DATA  ADDLNG/80.0/
C
C     ...WHICH IS DIFFERENCE BETWEEN 180 DEGREES AND VERTICAL MERIDIAN.
C     ...   THE VERTICAL BEING 100 WEST AFTER CHANGING THE SENSE
C
       DATA  TINY  /0.00001/
       DATA  EARTHR/6371.2/
       DATA  CONVT /0.017453293/
C
C     ...WHICH CONVERTS DEGREES TO RADIANS
C
      RE   = (EARTHR * 1.86603) / XMESHL
C
C     ...WHICH IS DISTANCE IN GRID INTERVALS FROM POLE TO  EQUATOR
C
      XLAT = -ALAT * CONVT
C
C     ...WHERE NEGATIVE ALATS WERE GIVEN FOR SRN HEMI
C
      WLONG = 360.0 - ALONG
      WLONG = (WLONG + ADDLNG) * CONVT
      R     = (RE * COS(XLAT))/(1.0 + SIN(XLAT))
      XI    = R * SIN(WLONG)
      IF (ABS(XI) .LT. TINY) XI = 0.0
      XJ    = R * COS (WLONG)
      IF (ABS(XJ) .LT. TINY) XJ = 0.0
      RETURN
      END


module radiative
	use constants
	implicit none

contains

	subroutine trapezium(value, x, f, N)
		integer, intent(in) 			    :: N
		real(dbl), dimension(N), intent(in)	:: x, f
		real(dbl), intent(out)				:: value

		integer		:: i
		real(dbl)	:: width, tmp
		value = 0d0
		do i=1, N-1
			width = x(i+1) - x(i)
			tmp = 0.5 * width * (f(i) + f(i+1))
			value = value + tmp
		end do
	end subroutine trapezium

	subroutine calculate_rate(value, filename, eunits)
		real(dbl), intent(out)			:: value
		character(len=*), intent(in)	:: filename, eunits

		integer 	:: nlines, nvalues, firstline, ios, line, i
		real(dbl)	:: x, f, norm, unit_conversion
		real(dbl), allocatable, dimension(:)  :: xvals, fvals
		character(len=100)	:: iom, unit_format

		write(*, *) 'Calculating radiative rate'
		write(*, *) 'Reading spectral data from ', filename

		select case(eunits)
		case ('kj')
			unit_conversion = KJ_TO_EV
			unit_format = 'kJ/mol'
		case ('ha')
			unit_conversion = HA_TO_EV
			unit_format = 'Ha'
		case ('kcal')
			unit_conversion = KCAL_TO_EV
			unit_format = 'kcal/mol'
		case ('cm')
			unit_conversion = CM_TO_EV
			unit_format = 'cm-1'
		case default
			unit_conversion = 1d0 ! assume in eV already
			unit_format = 'eV'
		end select

		write(*, *) 'Assuming energy units of ', trim(unit_format)

		open(radiative_unit, file=filename, iostat=ios)
		firstline = 0
		f = 0d0
		nlines = -1
		do while (ios == 0)
			nlines = nlines + 1
			if (firstline == 0) then
				if (abs(f) > tolint) firstline = nlines
			end if
			read(radiative_unit, *, iostat=ios, iomsg=iom) x, f
		end do
		nvalues = nlines - firstline + 1
		if (nvalues < 1) then
			write(*, '(3A)') 'File ', filename, ' is empty or all zero'
		else
			rewind(radiative_unit)
			allocate(xvals(nvalues))
			allocate(fvals(nvalues))

			i = 1
			do line = 1, nlines
				read(radiative_unit, *, iostat=ios, iomsg=iom) x, f
				if (line .ge. firstline) then
					xvals(i) = x * unit_conversion ! make sure in eV
					fvals(i) = f
					i = i + 1
				end if
			end do

			call trapezium(norm, xvals, fvals, nvalues)
			write(*, *) 'Spectral density norm:', norm
			if (norm .gt. tolint) then
				fvals = fvals / norm
				do i = 1, nvalues
					fvals(i) = fvals(i) * (xvals(i)**3)
				end do
				call trapezium(value, xvals, fvals, nvalues)
			else
				write(*, *) 'Aborting radiative calculation, spectral density has negligible norm'
			end if

			deallocate(xvals)
			deallocate(fvals)
		end if
		close(radiative_unit)

	end subroutine
end module radiative


      PROGRAM LA_SSYSVX_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_SYSVX
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Parameters" ..
      REAL(WP), PARAMETER :: ONE = 1.0_WP, ZERO = 0.0_WP
!  .. "Local Scalars" ..
      INTEGER :: I, J, INFO, N, NRHS
      REAL(WP) :: RCOND
!  .. "Local Arrays" ..
      INTEGER, ALLOCATABLE :: IPIV(:)
      REAL(WP), ALLOCATABLE :: A(:,:), B(:,:), X(:,:), FERR(:), BERR(:)
!  .. "Intrinsic Functions" ..
      INTRINSIC  SUM
!  .. "Executable Statements" ..
      WRITE (*,*) 'SSYSVX Example Program Results'
      N = 5; NRHS = 3
      WRITE(*,'(5H N = , I4, 9H; NRHS = , I4)') N, NRHS
      ALLOCATE ( A(N,N), B(N,NRHS), X(N,NRHS), IPIV(N), FERR(NRHS), BERR(NRHS) )

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

      WRITE(*,*) 'The array A :'
      DO I=1,N
      WRITE(*,'(10(I3,1X,1X),I3,1X)') INT(A(I,1:N));
      ENDDO

      DO J = 1, NRHS;
         DO I = 1, N
            B(I,J) = (SUM(A(I,I:N)) + SUM(A(1:I,I)) - A(I,I))*J
         ENDDO;
      ENDDO

      WRITE(*,*) 'The array B :'
      DO I=1,N
            WRITE(*,'(3(I3,1X,1X))') INT(B(I,1:NRHS));
      ENDDO

      WRITE(*,*)'CALL LA_SYSVX(A, B, X, IPIV=IPIV, FERR=FERR, BERR=BERR, RCOND=RCOND, INFO=INFO)'
      CALL LA_SYSVX(A, B, X, IPIV=IPIV, FERR=FERR, BERR=BERR, RCOND=RCOND, INFO=INFO)

      WRITE(*,*) 'FERR on exit :'
      DO I = 1, NRHS; WRITE (*,'(E13.5)') FERR(I);
      ENDDO
      WRITE(*,*)'BERR on exit :'
      DO I = 1, NRHS; WRITE (*,'(E13.5)') BERR(I);
      ENDDO
      WRITE(*,*) 'RCOND =', RCOND
      WRITE(*,*)'INFO = ' ,INFO

      END PROGRAM LA_SSYSVX_EXAMPLE


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!DESCRIPTION:                                                               !
!'quadsolveplot' is a program that solves and graphs quadratic functions    !
!depending on user entered coefficients a, b, and c of the general form     !
!being ax^2 + bx + c = 0. The program will work with the function even if   !
!coefficients equalling zero make the function linear. However, the program !
!will NOT work with unsolvable forms or ones where all real numbers         !
!are the solutions to x.                                                    !
!                                                                           !
!ORIGIN INFO:                                                               !
!Code written in gedit (pseudocode) and emacs (hard code)                   !
!Created Monday, September 13, 2013                                         !
!Author: Michael Conroy                                                     !
!Contact: sietekk@gmail.com                                                 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program quadsolvplot
use quadsolvplotmodule !Graphing module
implicit none

!DECLARE VARIABLES, ARRAYS, AND CONSTANTS
!The integers hold single bit values corresponding to choices made by queries
integer :: varcheck !Holds integer values from 1 to 4 according to
integer :: discrim !Holds value for discriminant
integer :: redoentry !If unsolvable, redoentry will be 1 = new vars, 0 = quit program
integer :: datfilecreate !For creating a graphable data file, either yes = 1 or no = 0
integer :: graphoption !For graphing query, either yes = 1 or no = 0
integer, parameter :: n=101 !For incremented values in x and y data/graphing arrays; 51 => extra place for 0.0 in arrays

!Variables to hold the entered coefficients, real roots, linear roots, and complex roots, and the discriminant (external function)
!a, b, c: user coefficiets; root1, root2: real roots; complex1, complex2: complex roots; linroot (a=0), linroot2 (a=c=0): linear roots
real :: a, b, c, root1, root2, linroot1, linroot2
complex :: comproot1, comproot2
real, external :: discrimcalcfunc !Computes the determinant

!Declare arrays for data file creation and graphing
real, dimension(n) :: x, y !2D arrays that hold x- and y-axis data

!!Subroutines (Not declared like functions => listed here only for my own benefit)
!!varentrysub(a,b,c)
!!realrootsub(a,b,discrim,root1,root2)
!!complexrootsub(a,b,discrim,complex1,complex2)
!!datafilesub(a,b,c,varcheck,n,x,y)

!DATA ENTRY
!Subroutine varentrysub is called on to prompt user to enter coefficients
10 call varentrysub(a,b,c) !10 is the goto location for the COEFFICIENT CHECK section

!COEFFICIENT CHECK
!1) Depending on coefficient values entered and the combinations of those values, a value of 1-7 is
!   given to 'varcheck', which will tell the program how to solve the function
!2) Detailed description of 'varcheck' values
!   If 1, then a=0 (linear); or 2, then b=0 (quadratic, double root); or 3, then c=0 (quadratic);
!   or 4, then a=b=0 (Unsolvable); or 5, then a=c=0 (linear); or 6, then b=c=0 (quadratic, double root);
!   or 7, then a=b=c=0 (all real numbers are roots)
if (a==0) then !Linear, one root at x=(-c)/b
	varcheck = 1
else if (b==0) then !Quadratic, double root at x=(+/-)sqrt((-c)/a)
	varcheck = 2
else if (c==0) then !Quadratic
	varcheck = 3
else if (a==0.and.b==o) then !Unsolvable, ASK TO RE-ENTER
	varcheck = 4
else if (a==0.and.c==0) then !Linear, one root at x=(-b)
	varcheck = 5
else if (b==0.and.c==0) then !Quadratic, double root at x=0
	varcheck = 6
else !For condition: a==0.and.b==0.and.c==0 = true, where a=b=c=0 (all are roots)
	varcheck = 7
end if

!CALL TO SOLUTION STRUCTURES AND PRINT ROOT(S)
!A case statement calls on a function or subroutine to solve for the discriminant, linear roots,
!real roots, and/or the complex roots. The quadratic function entered according to the
!coefficients is displayed along with the number of and the values of the root(s).
select case (varcheck)
	case (1) !a=0 (linear)
		print *, 'Equation is linear if a=0!'
		print *, 'Solving as a linear equation...'
		linroot1 = (-c)/b
		print *, 'You entered coefficients for the linear function ', b, 'x', ' + ', c, ' = 0,'
		print *, 'and this function has one real root at x = ', linroot1, '.'
11 	case (4) !a=b=0 (unsolvable)
		print *, 'Equation is unsolvable if a=b=0!'
		print *, 'Do you want to re-enter coefficients or quit? ('1'=re-entry, '0'=quit program):'
		read *, redoentry
		if (redoentry==0) then
			print *, 'Quitting now...'
			stop
		else if (redoentry==1) then
			goto 10 !Returns program back to varentrysub() subroutine to re-enter variables
		else !For condition: redoentry/=1.or.redoentry/=0
			print *, 'WARNING: INVALID INPUT! Please try again...'
			goto 11
		end if
	case (5) !a=c=0 (linear)
		print *, 'Equation is linear if a=c=0!'
		print *, 'Solving as a linear equation...'
		linroot1 = (-b)
		print *, 'You entered coefficients for the linear function ', b, 'x', ' + ', c, ' = 0,'
		print *, 'and this function has one real root at x = ', linroot2, '.'
	case (7) !a=b=c=0 (all are roots)
		print *, 'All real numbers are solutions!'
	case default !All quadratic options: cases (2, 3, and 6)
		print *, 'Equation is quadratic!'
		print *, 'Solving as a quadratic equation...'
		discrim = discrimcalcfunc(a,b,c)
		if (discrim>0) then !Real roots
			call realrootsub(a,b,discrim,root1,root2)
			print *, 'You entered coefficients for the quadratic function ', a, 'x^2 + ', b, 'x', ' + ', c, ' = 0,'
			print *, 'and this function has two real roots at x = ', root1, ' and x = ', root2, '.'
		else if (discrim==0) !Works for both b=0 and b=c=0
			call realrootsub(a,b,discrim,root1,root2)
			print *, 'You entered coefficients for the quadratic function ', a, 'x^2 + ', b, 'x', ' + ', c, ' = 0,'
			print *, 'and this function has a double real root at x = ', root1, ' and x = ', root2, '.'
		else !For condition: discrim<0
			call complexrootsub(a,b,discrim,complex1,complex2)
			print *, 'You entered coefficients for the linear function ', a, 'x^2 + ', b, 'x', ' + ', c, ' = 0,'
			print *, 'and this function has two complex roots at x = ', complex1, ' and x = ', complex2, '.'
end select

!DATA FILE CREATION
!Data file creation query
if (varcheck==1.or.varcheck==5) then !Linear
	print *, 'Your function is linear! Do you wish to save graphable data for your function? ('1'=re-entry, '0'=quit program):'
	read *, datfilecreate
12 	if (datfilecreate==0) then
		print *, 'Exiting data file creation...'
		stop
	else if (datfilecreate==1) then
		call datafilesub(a,b,c,varcheck,n,x,y)
	else !For condition: datfilecreate/=1.or.datfile/=0
		print *, 'WARNING: INVALID INPUT! Please try again...'
		goto 12
	end if
else if (varcheck==2.or.varcheck==3.or.varcheck==6) then
	print *, 'Your function is quadratic! Do you wish to save graphable data for your function? ('1'=re-entry, '0'=quit program):'
	read *, datfilecreate
13 	if (datfilecreate==0) then
		print *, 'Exiting data file creation...'
		stop
	else if (datfilecreate==1) then
		print *, 'Creating data file...'
		call datafilesub(a,b,c,varcheck,n,x,y)
	else !For condition: datfilecreate/=1.or.datfile/=0
		print *, 'WARNING: INVALID INPUT! Please try again...'
		goto 13
	end if
else !For condition: varcheck==4.or.varcheck==7
	print *, 'Sorry, your function is neither quadratic nor linear, so data cannot be generated for you.'
	print *, 'Exiting data file creation...'
end if

!GRAPHING THE FUNCTION
14 print *, 'Graph the function with the new data file?  ('1'= yes, '0'= no):'
read *, graphoption
if (graphoption==0) then
	print *, 'Exiting the graphing module...'
	stop
else if (graphoption==1) then
	print *, 'Graphing data...'
	call graph(x,y,n)
else !For condition: datfilecreate/=1.or.datfile/=0
	print *, 'WARNING: INVALID INPUT! Please try again...'
	goto 14
end if

!END OF THE MAIN PROGRAM
end program quadsolveplot

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

!SUBROUTINES
subroutine varentrysub(a,b,c)
	implicit none

	!DEFINE VARIANLES
	real,intent(inout) :: a,b,c

	!BODY OF SUBROUTINE
	print *, 'This program solves for the roots of a quadratic equation of the form ax^2 + bx + c = 0,'
	print *, 'and will solve for real and complex roots. It will also identify if the equation is'
	print *, 'unsolvable or the roots are all real numbers. The option to save a file with graphable'
	print *, 'data will be presented along with the option to graph the functioned entered.'
	print *, '...'
	print *, 'Please enter the values of the coefficients a, b, and c separated by commas or spaces:'
	read *, a,b,c
	print *, 'You entered the values a = ', a, ', b = ', b, ', c = ', c, '.' !Not sure if this prints variable values inside text
end subroutine varentrysub

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

subroutine datafilesub(a,b,c,varcheck,n,x,y)
	implicit none

	!DEFINE VARIANLES
	real, intent(in) :: a, b, c
	integer, intent(in) :: varcheck, n
	real, dimension(n) intent(inout) :: x,y
	integer :: bitcheck !For internal select case statement
	integer :: i !x,y populator do loop counters

	!BODY OF SUBROUTINE
	if (varcheck==1.or.varcheck==5) checkbit=1
	if (varcheck==2.or.varcheck==3.or.varcheck==6) checkbit=2
	print *, 'Initializing data file creation...'
	do i=-50,50 !Do loop to populate rest of x array
		x(i) = i
	end do
	y(i)=0.0 !Define zero for y values in y array population
	select case (bitcheck)
		case (1) !Linear, data will be constructed accordingly
			do i=-50,50
				y(i)=b*i+c
			end do

		case (2) !Quadratic, data will be constructed accordingly
			do i=-50,50
				y(i)=a(i-root1)(i-root2)
			end do
	end select
	open(unit=99,file='quadsolvplot.data',status='replace')
	do i=-50,50
		write(99,*) x(i), ' ', y(i)
	end do
	close(unit=99)
	print *, 'Data arrays generated and saved!'
end subroutine datafilesub

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


/*
vim:syntax=sml
*/

let MININT = 0 - 32768;;
let MAXINT = 32767;;

datatype List (lo:Int) =
  Null
| Cons of (h:Int) (t:(List lo));;

datatype Pair (S:*) (T:*) =
  MkPair of (fst:S) (snd:T);;

/* (OrderedList n) <: (OrderedList m) iff n >= m */
datatype OrderedList (lo:Int) =
  ONull
| OCons of (h:Int.(lo <= h)) (t:(OrderedList h));;

let l : (OrderedList 0) = OCons 0 0 (OCons 1 1 (ONull 2));;

let exact (d:Int) : (e:Int.e=d) = d+0;;

let min (a:Int) (b:Int) : (c:Int.(a>=c) && (b>=c)) =
  if[(c:Int.(a>=c) && (b>=c))] (a >= b)
  then exact b
  else exact a;;

let Above (x:Int):* = (y:Int.x<=y);;

let rec merge (lo:Int)
              (lo1:Above lo)
              (l1:OrderedList lo1)
              (lo2:Above lo)
              (l2:OrderedList lo2) :
              (OrderedList lo) =
  caseOrderedList lo1 l1 (OrderedList lo)
    (fn u => l2)
    (fn h1 t1 =>
      caseOrderedList lo2 l2 (OrderedList lo)
        (fn u => l1)
        (fn h2 t2 =>
          if[OrderedList lo] h1 < h2 then
            (OCons lo h1
              (merge h1 h1 t1 h2 (OCons h2 h2 t2)))
          else
            (OCons lo h2
              (merge h1 h2 t2 h1 (OCons h1 h1 t1))) /* BUG: wrong arg */
        )
    )
;;

let rec length (lo:Int) (l:(List lo)) : Int =
  caseList lo l Int
    (fn u => 0)
    (fn h t => 1 + (length lo t));;

let partition (lo:Int) (l:(List lo)) : (Pair (List lo) (List lo)) =
  let rec helper (firsthalf:(List lo)) (secondhalf:(List lo)) :
                 (Pair (List lo) (List lo)) =
    caseList lo firsthalf (Pair (List lo) (List lo))
      (fn u => (MkPair (List lo) (List lo) firsthalf secondhalf))
      (fn h t =>
          if[Pair (List lo) (List lo)]
            ((length lo t) >= ((length lo secondhalf) + 1))
          then
            helper t (Cons lo h secondhalf)
          else
            MkPair (List lo) (List lo) firsthalf secondhalf)
  in
    helper l (Null lo)
;;

let rec merge_sort (lmin:Int) (l:(List lmin)) : (OrderedList lmin) =
  casePair (List lmin) (List lmin) (partition lmin l) (OrderedList lmin)
    (fn fst snd =>
      let sorted1 = merge_sort lmin fst in
      let sorted2 = merge_sort lmin snd in
        merge lmin lmin sorted1 lmin sorted2);;


module mathability

  implicit none
  public square

contains

  function square(array) result (squared)
    integer, intent (in) :: array(:)
    integer :: squared(size(array))
    integer :: i

    do i = 1, size(array)
       squared(i) = array(i)*array(i)
    enddo
  end function square

end module mathability


! Specify kinds/types for the input array in select and arg_select
! The index arrays are of all INT_KINDS_TYPES

module stdlib_selection
!! Quickly find the k-th smallest value of an array, or the index of the k-th smallest value.
!! ([Specification](../page/specs/stdlib_selection.html))
!
! This code was modified from the "Coretran" implementation "quickSelect" by
! Leon Foks, https://github.com/leonfoks/coretran/tree/master/src/sorting
!
! Leon Foks gave permission to release this code under stdlib's MIT license.
! (https://github.com/fortran-lang/stdlib/pull/500#commitcomment-57418593)
!

use stdlib_kinds

implicit none

private

public :: select, arg_select

interface select
    !! version: experimental
    !! ([Specification](..//page/specs/stdlib_selection.html#select-find-the-k-th-smallest-value-in-an-input-array))

      module procedure select_1_iint32_int32
      module procedure select_1_rdp_int32
end interface

interface arg_select
    !! version: experimental
    !! ([Specification](..//page/specs/stdlib_selection.html#arg_select-find-the-index-of-the-k-th-smallest-value-in-an-input-array))
      module procedure arg_select_1_iint32_int32
      module procedure arg_select_1_rdp_int32
end interface

contains

      subroutine select_1_iint32_int32(a, k, kth_smallest, left, right)
          !! select - select the k-th smallest entry in a(:).
          !!
          !! Partly derived from the "Coretran" implementation of
          !! quickSelect by Leon Foks, https://github.com/leonfoks/coretran
          !!
          integer(int32), intent(inout) :: a(:)
              !! Array in which we seek the k-th smallest entry.
              !! On output it will be partially sorted such that
              !! `all(a(1:(k-1)) <= a(k)) .and. all(a(k) <= a((k+1):size(a)))`
              !! is true.
          integer(int32), intent(in) :: k
              !! We want the k-th smallest entry. E.G. `k=1` leads to
              !! `kth_smallest=min(a)`, and `k=size(a)` leads to
              !! `kth_smallest=max(a)`
          integer(int32), intent(out) :: kth_smallest
              !! On output contains the k-th smallest value of `a(:)`
          integer(int32), intent(in), optional :: left, right
              !! If we know that:
              !!    the k-th smallest entry of `a` is in `a(left:right)`
              !! and also that:
              !!    `maxval(a(1:(left-1))) <= minval(a(left:right))`
              !! and:
              !!    `maxval(a(left:right))) <= minval(a((right+1):size(a)))`
              !! then one or both bounds can be specified to narrow the search.
              !! The constraints are available if we have previously called the
              !! subroutine with different `k` (because of how `a(:)` becomes
              !! partially sorted, see documentation for `a(:)`).

          integer(int32) :: l, r, mid, iPivot
          integer, parameter :: ip = int32

          l = 1_ip
          if(present(left)) l = left
          r = size(a, kind=ip)
          if(present(right)) r = right

          if(l > r .or. l < 1_ip .or. r > size(a, kind=ip) &
              .or. k < l .or. k > r                        & !i.e. if k is not in the interval [l; r]
              ) then
              error stop "select must have  1 <= left <= k <= right <= size(a)";
          end if

          searchk: do
              mid = l + ((r-l)/2_ip) ! Avoid (l+r)/2 which can cause overflow

              call medianOf3(a, l, mid, r)
              call swap(a(l), a(mid))
              call partition(a, l, r, iPivot)

              if (iPivot < k) then
                l = iPivot + 1_ip
              elseif (iPivot > k) then
                r = iPivot - 1_ip
              elseif (iPivot == k) then
                kth_smallest = a(k)
                return
              end if
          end do searchk

          contains
              pure subroutine swap(a, b)
                  integer(int32), intent(inout) :: a, b
                  integer(int32) :: tmp
                  tmp = a; a = b; b = tmp
              end subroutine

              pure subroutine medianOf3(a, left, mid, right)
                  integer(int32), intent(inout) :: a(:)
                  integer(int32), intent(in) :: left, mid, right
                  if(a(right) < a(left)) call swap(a(right), a(left))
                  if(a(mid)   < a(left)) call swap(a(mid)  , a(left))
                  if(a(right) < a(mid) ) call swap(a(mid)  , a(right))
              end subroutine

              pure subroutine partition(array,left,right,iPivot)
                  integer(int32), intent(inout) :: array(:)
                  integer(int32), intent(in) :: left, right
                  integer(int32), intent(out) :: iPivot
                  integer(int32) :: lo,hi
                  integer(int32) :: pivot

                  pivot = array(left)
                  lo = left
                  hi=right
                  do while (lo <= hi)
                    do while (array(hi) > pivot)
                      hi=hi-1_ip
                    end do
                    inner_lohi: do while (lo <= hi )
                       if(array(lo) > pivot) exit inner_lohi
                      lo=lo+1_ip
                    end do inner_lohi
                    if (lo <= hi) then
                      call swap(array(lo),array(hi))
                      lo=lo+1_ip
                      hi=hi-1_ip
                    end if
                  end do
                  call swap(array(left),array(hi))
                  iPivot=hi
              end subroutine
      end subroutine
      subroutine select_1_rdp_int32(a, k, kth_smallest, left, right)
          !! select - select the k-th smallest entry in a(:).
          !!
          !! Partly derived from the "Coretran" implementation of
          !! quickSelect by Leon Foks, https://github.com/leonfoks/coretran
          !!
          real(dp), intent(inout) :: a(:)
              !! Array in which we seek the k-th smallest entry.
              !! On output it will be partially sorted such that
              !! `all(a(1:(k-1)) <= a(k)) .and. all(a(k) <= a((k+1):size(a)))`
              !! is true.
          integer(int32), intent(in) :: k
              !! We want the k-th smallest entry. E.G. `k=1` leads to
              !! `kth_smallest=min(a)`, and `k=size(a)` leads to
              !! `kth_smallest=max(a)`
          real(dp), intent(out) :: kth_smallest
              !! On output contains the k-th smallest value of `a(:)`
          integer(int32), intent(in), optional :: left, right
              !! If we know that:
              !!    the k-th smallest entry of `a` is in `a(left:right)`
              !! and also that:
              !!    `maxval(a(1:(left-1))) <= minval(a(left:right))`
              !! and:
              !!    `maxval(a(left:right))) <= minval(a((right+1):size(a)))`
              !! then one or both bounds can be specified to narrow the search.
              !! The constraints are available if we have previously called the
              !! subroutine with different `k` (because of how `a(:)` becomes
              !! partially sorted, see documentation for `a(:)`).

          integer(int32) :: l, r, mid, iPivot
          integer, parameter :: ip = int32

          l = 1_ip
          if(present(left)) l = left
          r = size(a, kind=ip)
          if(present(right)) r = right

          if(l > r .or. l < 1_ip .or. r > size(a, kind=ip) &
              .or. k < l .or. k > r                        & !i.e. if k is not in the interval [l; r]
              ) then
              error stop "select must have  1 <= left <= k <= right <= size(a)";
          end if

          searchk: do
              mid = l + ((r-l)/2_ip) ! Avoid (l+r)/2 which can cause overflow

              call medianOf3(a, l, mid, r)
              call swap(a(l), a(mid))
              call partition(a, l, r, iPivot)

              if (iPivot < k) then
                l = iPivot + 1_ip
              elseif (iPivot > k) then
                r = iPivot - 1_ip
              elseif (iPivot == k) then
                kth_smallest = a(k)
                return
              end if
          end do searchk

          contains
              pure subroutine swap(a, b)
                  real(dp), intent(inout) :: a, b
                  real(dp) :: tmp
                  tmp = a; a = b; b = tmp
              end subroutine

              pure subroutine medianOf3(a, left, mid, right)
                  real(dp), intent(inout) :: a(:)
                  integer(int32), intent(in) :: left, mid, right
                  if(a(right) < a(left)) call swap(a(right), a(left))
                  if(a(mid)   < a(left)) call swap(a(mid)  , a(left))
                  if(a(right) < a(mid) ) call swap(a(mid)  , a(right))
              end subroutine

              pure subroutine partition(array,left,right,iPivot)
                  real(dp), intent(inout) :: array(:)
                  integer(int32), intent(in) :: left, right
                  integer(int32), intent(out) :: iPivot
                  integer(int32) :: lo,hi
                  real(dp) :: pivot

                  pivot = array(left)
                  lo = left
                  hi=right
                  do while (lo <= hi)
                    do while (array(hi) > pivot)
                      hi=hi-1_ip
                    end do
                    inner_lohi: do while (lo <= hi )
                       if(array(lo) > pivot) exit inner_lohi
                      lo=lo+1_ip
                    end do inner_lohi
                    if (lo <= hi) then
                      call swap(array(lo),array(hi))
                      lo=lo+1_ip
                      hi=hi-1_ip
                    end if
                  end do
                  call swap(array(left),array(hi))
                  iPivot=hi
              end subroutine
      end subroutine

      subroutine arg_select_1_iint32_int32(a, indx, k, kth_smallest, left, right)
          !! arg_select - find the index of the k-th smallest entry in `a(:)`
          !!
          !! Partly derived from the "Coretran" implementation of
          !! quickSelect by Leon Foks, https://github.com/leonfoks/coretran
          !!
          integer(int32), intent(in) :: a(:)
              !! Array in which we seek the k-th smallest entry.
          integer(int32), intent(inout) :: indx(:)
              !! Array of indices into `a(:)`. Must contain each integer
              !! from `1:size(a)` exactly once. On output it will be partially
              !! sorted such that
              !! `all( a(indx(1:(k-1)))) <= a(indx(k)) ) .AND.
              !!  all( a(indx(k))  <= a(indx( (k+1):size(a) )) )`.
          integer(int32), intent(in) :: k
              !! We want index of the k-th smallest entry. E.G. `k=1` leads to
              !! `a(kth_smallest) = min(a)`, and `k=size(a)` leads to
              !! `a(kth_smallest) = max(a)`
          integer(int32), intent(out) :: kth_smallest
              !! On output contains the index with the k-th smallest value of `a(:)`
          integer(int32), intent(in), optional :: left, right
              !! If we know that:
              !!  the k-th smallest entry of `a` is in `a(indx(left:right))`
              !! and also that:
              !!  `maxval(a(indx(1:(left-1)))) <= minval(a(indx(left:right)))`
              !! and:
              !!  `maxval(a(indx(left:right))) <= minval(a(indx((right+1):size(a))))`
              !! then one or both bounds can be specified to reduce the search
              !! time. These constraints are available if we have previously
              !! called the subroutine with a different `k` (due to the way that
              !! `indx(:)` becomes partially sorted, see documentation for `indx(:)`).

          integer(int32) :: l, r, mid, iPivot
          integer, parameter :: ip = int32

          l = 1_ip
          if(present(left)) l = left
          r = size(a, kind=ip)
          if(present(right)) r = right

          if(size(a) /= size(indx)) then
              error stop "arg_select must have size(a) == size(indx)"
          end if

          if(l > r .or. l < 1_ip .or. r > size(a, kind=ip) &
              .or. k < l .or. k > r                        & !i.e. if k is not in the interval [l; r]
              ) then
              error stop "arg_select must have 1 <= left <= k <= right <= size(a)";
          end if

          searchk: do
              mid = l + ((r-l)/2_ip) ! Avoid (l+r)/2 which can cause overflow

              call arg_medianOf3(a, indx, l, mid, r)
              call swap(indx(l), indx(mid))
              call arg_partition(a, indx, l, r, iPivot)

              if (iPivot < k) then
                l = iPivot + 1_ip
              elseif (iPivot > k) then
                r = iPivot - 1_ip
              elseif (iPivot == k) then
                kth_smallest = indx(k)
                return
              end if
          end do searchk

          contains
              pure subroutine swap(a, b)
                  integer(int32), intent(inout) :: a, b
                  integer(int32) :: tmp
                  tmp = a; a = b; b = tmp
              end subroutine

              pure subroutine arg_medianOf3(a, indx, left, mid, right)
                  integer(int32), intent(in) :: a(:)
                  integer(int32), intent(inout) :: indx(:)
                  integer(int32), intent(in) :: left, mid, right
                  if(a(indx(right)) < a(indx(left))) call swap(indx(right), indx(left))
                  if(a(indx(mid))   < a(indx(left))) call swap(indx(mid)  , indx(left))
                  if(a(indx(right)) < a(indx(mid)) ) call swap(indx(mid)  , indx(right))
              end subroutine

              pure subroutine arg_partition(array, indx, left,right,iPivot)
                  integer(int32), intent(in) :: array(:)
                  integer(int32), intent(inout) :: indx(:)
                  integer(int32), intent(in) :: left, right
                  integer(int32), intent(out) :: iPivot
                  integer(int32) :: lo,hi
                  integer(int32) :: pivot

                  pivot = array(indx(left))
                  lo = left
                  hi = right
                  do while (lo <= hi)
                    do while (array(indx(hi)) > pivot)
                      hi=hi-1_ip
                    end do
                    inner_lohi: do while (lo <= hi )
                      if(array(indx(lo)) > pivot) exit inner_lohi
                      lo=lo+1_ip
                    end do inner_lohi
                    if (lo <= hi) then
                      call swap(indx(lo),indx(hi))
                      lo=lo+1_ip
                      hi=hi-1_ip
                    end if
                  end do
                  call swap(indx(left),indx(hi))
                  iPivot=hi
              end subroutine
      end subroutine
      subroutine arg_select_1_rdp_int32(a, indx, k, kth_smallest, left, right)
          !! arg_select - find the index of the k-th smallest entry in `a(:)`
          !!
          !! Partly derived from the "Coretran" implementation of
          !! quickSelect by Leon Foks, https://github.com/leonfoks/coretran
          !!
          real(dp), intent(in) :: a(:)
              !! Array in which we seek the k-th smallest entry.
          integer(int32), intent(inout) :: indx(:)
              !! Array of indices into `a(:)`. Must contain each integer
              !! from `1:size(a)` exactly once. On output it will be partially
              !! sorted such that
              !! `all( a(indx(1:(k-1)))) <= a(indx(k)) ) .AND.
              !!  all( a(indx(k))  <= a(indx( (k+1):size(a) )) )`.
          integer(int32), intent(in) :: k
              !! We want index of the k-th smallest entry. E.G. `k=1` leads to
              !! `a(kth_smallest) = min(a)`, and `k=size(a)` leads to
              !! `a(kth_smallest) = max(a)`
          integer(int32), intent(out) :: kth_smallest
              !! On output contains the index with the k-th smallest value of `a(:)`
          integer(int32), intent(in), optional :: left, right
              !! If we know that:
              !!  the k-th smallest entry of `a` is in `a(indx(left:right))`
              !! and also that:
              !!  `maxval(a(indx(1:(left-1)))) <= minval(a(indx(left:right)))`
              !! and:
              !!  `maxval(a(indx(left:right))) <= minval(a(indx((right+1):size(a))))`
              !! then one or both bounds can be specified to reduce the search
              !! time. These constraints are available if we have previously
              !! called the subroutine with a different `k` (due to the way that
              !! `indx(:)` becomes partially sorted, see documentation for `indx(:)`).

          integer(int32) :: l, r, mid, iPivot
          integer, parameter :: ip = int32

          l = 1_ip
          if(present(left)) l = left
          r = size(a, kind=ip)
          if(present(right)) r = right

          if(size(a) /= size(indx)) then
              error stop "arg_select must have size(a) == size(indx)"
          end if

          if(l > r .or. l < 1_ip .or. r > size(a, kind=ip) &
              .or. k < l .or. k > r                        & !i.e. if k is not in the interval [l; r]
              ) then
              error stop "arg_select must have 1 <= left <= k <= right <= size(a)";
          end if

          searchk: do
              mid = l + ((r-l)/2_ip) ! Avoid (l+r)/2 which can cause overflow

              call arg_medianOf3(a, indx, l, mid, r)
              call swap(indx(l), indx(mid))
              call arg_partition(a, indx, l, r, iPivot)

              if (iPivot < k) then
                l = iPivot + 1_ip
              elseif (iPivot > k) then
                r = iPivot - 1_ip
              elseif (iPivot == k) then
                kth_smallest = indx(k)
                return
              end if
          end do searchk

          contains
              pure subroutine swap(a, b)
                  integer(int32), intent(inout) :: a, b
                  integer(int32) :: tmp
                  tmp = a; a = b; b = tmp
              end subroutine

              pure subroutine arg_medianOf3(a, indx, left, mid, right)
                  real(dp), intent(in) :: a(:)
                  integer(int32), intent(inout) :: indx(:)
                  integer(int32), intent(in) :: left, mid, right
                  if(a(indx(right)) < a(indx(left))) call swap(indx(right), indx(left))
                  if(a(indx(mid))   < a(indx(left))) call swap(indx(mid)  , indx(left))
                  if(a(indx(right)) < a(indx(mid)) ) call swap(indx(mid)  , indx(right))
              end subroutine

              pure subroutine arg_partition(array, indx, left,right,iPivot)
                  real(dp), intent(in) :: array(:)
                  integer(int32), intent(inout) :: indx(:)
                  integer(int32), intent(in) :: left, right
                  integer(int32), intent(out) :: iPivot
                  integer(int32) :: lo,hi
                  real(dp) :: pivot

                  pivot = array(indx(left))
                  lo = left
                  hi = right
                  do while (lo <= hi)
                    do while (array(indx(hi)) > pivot)
                      hi=hi-1_ip
                    end do
                    inner_lohi: do while (lo <= hi )
                      if(array(indx(lo)) > pivot) exit inner_lohi
                      lo=lo+1_ip
                    end do inner_lohi
                    if (lo <= hi) then
                      call swap(indx(lo),indx(hi))
                      lo=lo+1_ip
                      hi=hi-1_ip
                    end if
                  end do
                  call swap(indx(left),indx(hi))
                  iPivot=hi
              end subroutine
      end subroutine

end module


module rbf

  implicit none

  private

  public :: get_rbf_weights, get_rbf_interp

contains

  subroutine get_rbf_weights(nspace, ndata, xdata, r0, fdata, w)

    use kinddefs, only : dp
    use phi,      only : phi_tps,  phi_imq
    use svd,      only : solve_svd

    integer,  intent(in)  :: nspace
    integer,  intent(in)  :: ndata
    real(dp), intent(in)  :: xdata(nspace,ndata)
    real(dp), intent(in)  :: r0
    real(dp), intent(in)  :: fdata(ndata)
    real(dp), intent(out) :: w(ndata)

    integer  :: i, j
    real(dp) :: a(ndata,ndata), r(ndata), v(ndata)

    do i = 1, ndata
      do j = 1, ndata
        r(j) = sqrt(sum((xdata(:,i)-xdata(:,j))**2))
      end do
      call phi_tps(ndata, r, r0, v)
      !call phi_imq(ndata, r, r0, v)
      a(i,:) = v(:)
    end do
    call solve_svd(ndata, ndata, a, fdata, w)

  end subroutine get_rbf_weights

  subroutine get_rbf_interp(nspace, ndata, xdata, r0, weights, ninterp,       &
                            xinterp, finterp)

    use phi,      only : phi_tps, phi_imq
    use kinddefs, only : dp

    integer,  intent(in)  :: nspace
    integer,  intent(in)  :: ndata
    real(dp), intent(in)  :: xdata(nspace,ndata)
    integer,  intent(in)  :: ninterp
    real(dp), intent(in)  :: xinterp(nspace,ninterp)
    real(dp), intent(in)  :: r0
    real(dp), intent(in)  :: weights(ndata)
    real(dp), intent(out) :: finterp(ninterp)

    integer :: i, j
    real(dp) :: r(ndata), v(ndata)

    do i = 1, ninterp
      do j = 1, ndata
        r(j) = sqrt(sum((xinterp(:,i) - xdata(:,j))**2))
      end do
      call phi_tps(ndata, r, r0, v)
      !call phi_imq(ndata, r, r0, v)
      finterp(i) = dot_product(v, weights)
    end do

  end subroutine get_rbf_interp

end module rbf


      double complex function A52(j1,j2,j3,j4,j5,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      include 'scale.f'
      include 'epinv.f'
      integer j1,j2,j3,j4,j5
      double complex Vcc,Fcc,Vsc,Fsc,l12,l45,L0,L1,Lsm1,A5lom
      double complex lnrat

      l12=lnrat(musq,-s(j1,j2))
      l45=lnrat(musq,-s(j4,j5))
C    -i * A5tree
      A5lom=za(j2,j4)**2/(za(j2,j3)*za(j3,j1)*za(j4,j5))
      Vcc=-(epinv**2+epinv*l12+0.5d0*l12**2)
     . -2d0*(epinv+l45)-4d0

C--subleading N
      Fcc=-za(j2,j4)**2/(za(j2,j3)*za(j3,j1)*za(j4,j5))
     . *Lsm1(-s(j1,j2),-s(j4,j5),-s(j1,j3), -s(j4,j5))
     . +za(j2,j4)*(za(j1,j2)*za(j3,j4)-za(j1,j4)*za(j2,j3))
     .  /(za(j2,j3)*za(j1,j3)**2*za(j4,j5))
     . *Lsm1(-s(j1,j2),-s(j4,j5),-s(j2,j3),-s(j4,j5))
     . +2d0*zb(j1,j3)*za(j1,j4)*za(j2,j4)/(za(j1,j3)*za(j4,j5))
     . *L0(-s(j2,j3),-s(j4,j5))/s(j4,j5)

      Vsc=0.5d0*(epinv+l45)+0.5d0
      Fsc=za(j1,j4)**2*za(j2,j3)/(za(j1,j3)**3*za(j4,j5))
     . *Lsm1(-s(j1,j2),-s(j4,j5),-s(j2,j3),-s(j4,j5))
     . -0.5d0*(za(j4,j1)*zb(j1,j3))**2*za(j2,j3)/(za(j1,j3)*za(j4,j5))
     . *L1(-s(j4,j5),-s(j2,j3))/s(j2,j3)**2
     . +za(j1,j4)**2*za(j2,j3)*zb(j3,j1)/(za(j1,j3)**2*za(j4,j5))
     . *L0(-s(j4,j5),-s(j2,j3))/s(j2,j3)
     . -za(j2,j1)*zb(j1,j3)*za(j4,j3)*zb(j3,j5)/za(j1,j3)
     . *L1(-s(j4,j5),-s(j1,j2))/s(j1,j2)**2
     . -za(j2,j1)*zb(j1,j3)*za(j3,j4)*za(j1,j4)/(za(j1,j3)**2*za(j4,j5))
     . *L0(-s(j4,j5),-s(j1,j2))/s(j1,j2)
     . -0.5d0*zb(j3,j5)*(zb(j1,j3)*zb(j2,j5)+zb(j2,j3)*zb(j1,j5))
     . /(zb(j1,j2)*zb(j2,j3)*za(j1,j3)*zb(j4,j5))

      A52=(Vcc+Vsc)*A5lom+Fcc+Fsc

      return
      end


      REAL*8 FUNCTION PFAC(A,Z)

*       Precession factor for hierarchy.
*       --------------------------------
*
*       Maths by Douglas Heggie; function by Rosemary Mardling (11/96).
*       @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
*
      REAL*8  m,m1,A,Z,C,C1,C2,C3,D1,D2,D3,Z1

*The function is singular for m1=0, but the following holds:
*For 0 < m1 <=1 (m1 never > 1),  \infty > PFAC(m1) > 1.6, with P(0.01)=3.6.
*So taking it as 1 isn't too bad for an order of magnitude estimate.

      C1 = 0.5*(Z + A**2)
      Z1 = 5.0 - Z + 4*A**2
      C2 = (Z1 + SQRT(Z1))/6.0
      C3 = (Z1 - SQRT(Z1))/6.0
      IF (C1.GE.C2) THEN
          D1 = C1
          D2 = C2
          D3 = C3
      ELSE IF (C2.GE.C1.AND.C1.GE.C3) THEN
          D1 = C2
          D2 = C1
          D3 = C3
      ELSE
          D1 = C2
          D2 = C3
          D3 = C1
      END IF
*
      C = 1.0/SQRT(D1 - D3)
      m = (D2 - D3)/(D1 - D3)
*
*       Evaluate elliptic integral by approximate expression.
      a0=1.3862944
      a1=0.1119723
      a2=0.0725296
      b0=0.5
      b1=0.1213478
      b2=0.0288729
      m1 = 1.0 - m
      m1 = MAX(m1,1.0D-10)

      PFAC = (a0+a1*m1+a2*m1**2)+(b0+b1*m1+b2*m1**2)*log(1.0/m1)
*
*       Include the square root of (D1 - D3).
      PFAC = C*PFAC

      END