!      Ken Klare, LANL P-4      (c)1990,1991
!***********************************************************************
!********************* 3.2 Cubic Spline Evaluation *********************
!-----------------------------------------------------------------------
      Real*8 Function DCSVAL(x,nintv,break,c)
      Real*8      x      !input, the point to evaluate
      Integer nintv      !input, the number of polynomial pieces
      Real*8      break(*)!input, [nintv+1] breakpoints
      Real*8      c(4,*)      !input, [4,nintv+1] polynomial coefficients
!+Cubic spline evaluation.
      Real*8      DPPDER
      DCSVAL = DPPDER(0,x,4,nintv,break,c)
      End
!-----------------------------------------------------------------------
      Real*8 Function DCSDER(ideriv,x,nintv,break,c)
      Integer ideriv      !input, the order of deriavtive to be evaluated
      Real*8      x      !input, the point to evaluate
      Integer nintv      !input, the number of polynomial pieces
      Real*8      break(*)!input, [nintv+1] breakpoints
      Real*8      c(4,*)      !input, [4,nintv+1] polynomial coefficients
!+Cubic spline derivative evaluation.
      Real*8      DPPDER
      DCSDER = DPPDER(ideriv,x,4,nintv,break,c)
      End
!-----------------------------------------------------------------------
      Real*8 Function DCSITG(a,b,nintv,break,c)
      Real*8      a,b      !input, the range to evaluate
      Integer nintv      !input, the number of polynomial pieces
      Real*8      break(*)!input, [nintv+1] breakpoints
      Real*8      c(4,*)      !input, [4,nintv+1] polynomial coefficients
!+Cubic spline evaluation.
      Real*8      DPPITG
      DCSITG = DPPITG(a,b,4,nintv,break,c)
      End
!***********************************************************************
!********************* Vector extensions *******************************
!-----------------------------------------------------------------------
      Subroutine DCSVALV(nx,x,nintv,break,c,y)
      Integer      nx      !input, the number of points
      Real*8      x(*)      !input, the [nx] points to evaluate
      Integer nintv      !input, the number of polynomial pieces
      Real*8      break(*)!input, [nintv+1] breakpoints
      Real*8      c(4,*)      !input, [4,nintv+1] polynomial coefficients
      Real*8      y(*)      !output, the evaluated points
!+Cubic spline evaluation.
      Call DPPDERV(0,nx,x,4,nintv,break,c,y)
      End
!-----------------------------------------------------------------------
      Subroutine DCSDERV(ideriv,nx,x,nintv,break,c,y)
      Integer ideriv      !input, the order of deriavtive to be evaluated
      Integer      nx      !input, the number of points
      Real*8      x(*)      !input, the [nx] points to evaluate
      Integer nintv      !input, the number of polynomial pieces
      Real*8      break(*)!input, [nintv+1] breakpoints
      Real*8      c(4,*)      !input, [4,nintv+1] polynomial coefficients
      Real*8      y(*)      !output, the evaluated points
!+Cubic spline derivative evaluation.
      Call DPPDERV(ideriv,nx,x,4,nintv,break,c,y)
      End
!-----------------------------------------------------------------------
      Subroutine DCSITGV(na,a,nb,b,nintv,break,c,y)
      Integer      na      !input, the number of points
      Real*8      a(*)      !input, the [na] points to evaluate
      Integer      nb      !input, the number of points
      Real*8      b(*)      !input, the [nb] points to evaluate
      Integer nintv      !input, the number of polynomial pieces
      Real*8      break(*)!input, [nintv+1] breakpoints
      Real*8      c(4,*)      !input, [4,nintv+1] polynomial coefficients
      Real*8      y(*)      !output, the evaluated points
!+Cubic spline evaluation.
      Call DPPITGV(na,a,nb,b,4,nintv,break,c,y)
      End


      subroutine util_bcherm2(fherm,idimx1,idimx2,
     >     jbcx1a,jbcx1b,   jbcx2a,jbcx2b,
     >     zbcx1a,zbcx1b,   zbcx2a,zbcx2b,
     >     x1, x2)

C...  insert BCs as needed for Hermite interpolation setup

      implicit NONE

      integer :: idimx1,idimx2  ! array dimensions
      real :: fherm(0:3,idimx1,idimx2)

      integer :: jbcx1a,jbcx1b  ! x1 BC controls
      real :: zbcx1a(idimx2)    ! x1(1) BC data
      real :: zbcx1b(idimx2)    ! x1(idimx1) BC data

      integer :: jbcx2a,jbcx2b  ! x2 BC controls
      real :: zbcx2a(idimx1)    ! x2(1) BC data
      real :: zbcx2b(idimx1)    ! x2(idimx2) BC data

      real :: x1(idimx1),x2(idimx2)

C-------------------------------------------------------------
      integer :: ix
      real :: zdx
C-------------------------------------------------------------

      if((jbcx1a.eq.1).or.(jbcx1b.eq.1)) then

         if(jbcx1a.eq.1) then
            fherm(1,1,1:idimx2)=zbcx1a(1:idimx2)
         else
            zdx = x1(2)-x1(1)
            do ix=1,idimx2
               fherm(1,1,ix)=(fherm(0,2,ix)-fherm(0,1,ix))/zdx
            enddo
         endif

         if(jbcx1b.eq.1) then
            fherm(1,idimx1,1:idimx2)=zbcx1b(1:idimx2)
         else
            zdx = x1(idimx1)-x1(idimx1-1)
            do ix=1,idimx2
               fherm(1,idimx1,ix)=
     >              (fherm(0,idimx1,ix)-fherm(0,idimx1-1,ix))/zdx
            enddo
         endif

      endif

      if((jbcx2a.eq.1).or.(jbcx2b.eq.1)) then

         if(jbcx2a.eq.1) then
            fherm(2,1:idimx1,1)=zbcx2a(1:idimx1)
         else
            zdx=x2(2)-x2(1)
            do ix=1,idimx1
               fherm(2,ix,1)=(fherm(0,ix,2)-fherm(0,ix,1))/zdx
            enddo
         endif

         if(jbcx2b.eq.1) then
            fherm(2,1:idimx1,idimx2)=zbcx2b(1:idimx1)
         else
            zdx=x2(idimx2)-x2(idimx2-1)
            do ix=1,idimx1
               fherm(2,ix,idimx2)=
     >              (fherm(0,ix,idimx2)-fherm(0,ix,idimx2-1))/zdx
            enddo
         endif
      endif

      end subroutine util_bcherm2


      FUNCTION EXPDEV(IDUM)
      EXPDEV=-LOG(RAN1(IDUM))
      RETURN
      END


      subroutine qpot(nb,ddv,c,am,p,q,w,u,du)
      use cdat
      implicit real*8(a-h,o-z)
      integer*4,intent(IN) :: nb
      real*8,intent(IN) :: w(nb),q(nb),am,p(nb),ddv(nb)
      complex*16,intent(in) :: c(nb)
      real*8, intent(OUT) :: u(nb),du(nb)
      complex*16 s,z0,z,psi(np)
      common/wave/al,q0,p0,a0
      common/grid/xmin,xmax,dx,np

      u = 0d0

!      do i=1,nb
!        s = (0d0,0d0)
!        do j=1,nb
!          do k=1,nb
!            dq = q(j) - q(k)
!            z = dq/2d0-im*(p(j)+p(k))/2d0/al
!            z0 = exp(-al*z*conjg(z)+im/2d0*(p(j)+p(k))*dq)
!            s = s+conjg(c(j))*c(k)*(z0*z+(q(k)-q(i))*z0)
!          enddo
!        enddo
!        print *,s
!        du(i) = real(s)*ddv(i)
!      enddo

!--------numerical integration---------------
      do i=1,np
        xi = xmin+dx*(i-1)
        psi(i) = (0d0,0d0)
        do j=1,nb
          psi(i) = psi(i)+c(j)*exp(-al/2d0*(xi-q(j))**2+
     +             im*p(j)*(xi-q(j)))*
     +            dsqrt(dsqrt(al/pi))
        enddo
      enddo

      do k=1,nb
        d = 0d0
        do i=1,np
          xi = xmin+dx*(i-1)
          d = d+abs(psi(i))**2*(xi-q(k))*ddv(k)*dx
        enddo
        du(k) = d
      enddo

      return
      end subroutine


!CAMB spherical and hyperspherical Bessel function routines
!This version May 2006 - minor changes to bjl (http://cosmocoffee.info/viewtopic.php?t=530)
!Feb 2007: fixed for high l, uses Ranges
!Feb 2009: minor fix for non-flat compiled with non-smart IF evaluation
!Dec 2011: minor tweak to DoRecurs for smoother errors across flat for L~O(30)
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!Flat bessel function module

        module SpherBessels
        use Precision
        use ModelParams
        use Ranges
        implicit none
        private

!     Bessel functions and their second derivatives for interpolation

        real(dl), dimension(:,:), allocatable ::  ajl,ajlpr, ddajlpr

        integer  num_xx, kmaxfile, file_numl,  file_l(lmax_arr)
!      parameters for working out where the flat Bessel functions are small
!      Both should increase for higher accuracy
!        real(dl), parameter :: xlimmin=15._dl  , xlimfrac = 0.05_dl
         real(dl), parameter :: xlimmin=35._dl  , xlimfrac = 0.05_dl

        Type(Regions):: BessRanges

        public ajl, ajlpr, ddajlpr, BessRanges, InitSpherBessels, xlimmin, xlimfrac
        public USpherBesselWithDeriv, phi_recurs,phi_langer, bjl, Bessels_Free

       contains

      subroutine InitSpherBessels
!     This subroutine reads the jl files from disk (or generates them if not on disk)
      use lvalues
      implicit none

      !See if already loaded with enough (and correct) lSamp%l values and k*eta values
      if (allocated(ajl) .and. (lSamp%l0 <= file_numl) .and. all(file_l(1:lSamp%l0)-lSamp%l(1:lSamp%l0)==0) &
                    .and. (int(min(max_bessels_etak,CP%Max_eta_k))+1 <= kmaxfile)) return

      !Haven't made them before, so make them now
      call GenerateBessels

      if (DebugMsgs .and. FeedbackLevel > 0) write(*,*) 'Calculated Bessels'

      end subroutine InitSpherBessels

     subroutine GenerateBessels
       use lvalues
       real(dl) x
       real(dl) xlim
       integer i,j
       integer max_ix
       real(dl), parameter :: bessel_boost =1._dl

        if (DebugMsgs .and. FeedbackLevel > 0) write (*,*) 'Generating flat Bessels...'

        file_numl= lSamp%l0
        file_l(1:lSamp%l0) = lSamp%l(1:lSamp%l0)
        kmaxfile = int(min(CP%Max_eta_k,max_bessels_etak))+1
        if (do_bispectrum) kmaxfile = kmaxfile*2

        call Ranges_Init(BessRanges)

        call Ranges_Add_delta(BessRanges,0._dl, 1._dl,0.01_dl/bessel_boost)
        call Ranges_Add_delta(BessRanges,1._dl, 5._dl,0.1_dl/bessel_boost)
        call Ranges_Add_delta(BessRanges,5._dl, 25._dl,0.2_dl/bessel_boost)
        call Ranges_Add_delta(BessRanges,25._dl, 150._dl,0.5_dl/bessel_boost/AccuracyBoost)
        call Ranges_Add_delta(BessRanges,150._dl, real(kmaxfile,dl),0.8_dl/bessel_boost/AccuracyBoost)

        call Ranges_GetArray(bessRanges, .false.)
        num_xx = BessRanges%npoints

       max_ix = min(max_bessels_l_index,lSamp%l0)

       if (allocated(ajl)) deallocate(ajl)
       if (allocated(ajlpr)) deallocate(ajlpr)
       if (allocated(ddajlpr)) deallocate(ddajlpr)
       Allocate(ajl(1:num_xx,1:max_ix))
       Allocate(ajlpr(1:num_xx,1:max_ix))
       Allocate(ddajlpr(1:num_xx,1:max_ix))

       !$OMP PARALLEL DO DEFAULT(SHARED),SCHEDULE(STATIC), PRIVATE(j,i,x,xlim)
       do j=1,max_ix

         do  i=1,num_xx
            x=BessRanges%points(i)
            xlim=xlimfrac*lSamp%l(j)
            xlim=max(xlim,xlimmin)
            xlim=lSamp%l(j)-xlim
            if (x > xlim) then
               if ((lSamp%l(j)==3).and.(x <=0.2) .or. (lSamp%l(j) > 3).and.(x < 0.5) .or. &
                            (lSamp%l(j)>5).and.(x < 1.0)) then
                   ajl(i,j)=0
                 else
                  !if ( lSamp%l(j) > 40000) then
                  ! ajl(i,j) = phi_langer(lSamp%l(j),0,1._dl,x)
                  !else
                   call bjl(lSamp%l(j),x,ajl(i,j))
                  !end if
               end if
            else
                  ajl(i,j)=0
            end if
         end do

!     get the interpolation matrix for bessel functions
        call spline(BessRanges%points,ajl(1,j),num_xx,spl_large,spl_large,ajlpr(1,j))
        call spline(BessRanges%points,ajlpr(1,j),num_xx,spl_large,spl_large,ddajlpr(1,j))

      end do
     !$OMP END PARALLEL DO

     end subroutine GenerateBessels

     subroutine Bessels_Free

       if (allocated(ajl)) deallocate(ajl)
       if (allocated(ajlpr)) deallocate(ajlpr)
       if (allocated(ddajlpr)) deallocate(ddajlpr)
       call Ranges_Free(BessRanges)

     end  subroutine Bessels_Free

         SUBROUTINE BJL(L,X,JL)
        !!== MODIFIED SUBROUTINE FOR SPHERICAL BESSEL FUNCTIONS.                       ==!!
        !!== CORRECTED THE SMALL BUGS IN PACKAGE CMBFAST&CAMB(for l=4,5, x~0.001-0.002)==!!
        !!== CORRECTED THE SIGN OF J_L(X) FOR X<0 CASE                                 ==!!
        !!== WORKS FASTER AND MORE ACCURATE FOR LOW L, X<<L, AND L<<X cases            ==!!
        !!== zqhuang@astro.utoronto.ca                                                 ==!!
        IMPLICIT NONE
        INTEGER L
        real(dl) X,JL
        real(dl) AX,AX2
        real(dl),PARAMETER::LN2=0.6931471805599453094D0
        real(dl),PARAMETER::ONEMLN2=0.30685281944005469058277D0
        real(dl),PARAMETER::PID2=1.5707963267948966192313217D0
        real(dl),PARAMETER::PID4=0.78539816339744830961566084582D0
        real(dl),parameter::ROOTPI12 = 21.269446210866192327578D0
        real(dl),parameter::GAMMA1 =   2.6789385347077476336556D0 !/* Gamma function of 1/3 */
        real(dl),parameter::GAMMA2 =   1.3541179394264004169452D0 !/* Gamma function of 2/3 */
        real(dl),PARAMETER::PI=3.141592653589793238463D0
        real(dl) NU,NU2,BETA,BETA2,COSB
        real(dl) sx,sx2
        real(dl) cotb,cot3b,cot6b,secb,sec2b
        real(dl) trigarg,expterm,L3

        IF(L.LT.0)THEN
            write(*,*) 'Can not evaluate Spherical Bessel Function with index l<0'
            STOP
        ENDIF
        AX=DABS(X)
        AX2=AX**2
        IF(L.LT.7)THEN
            IF(L.EQ.0)THEN
                IF(AX.LT.1.D-1)THEN
                    JL=1.D0-AX2/6.D0*(1.D0-AX2/20.D0)
                ELSE
                    JL=DSIN(AX)/AX
                ENDIF

            ELSEIF(L.EQ.1)THEN
                IF(AX.LT.2.D-1)THEN
                    JL=AX/3.D0*(1.D0-AX2/10.D0*(1.D0-AX2/28.D0))
                ELSE
                    JL=(DSIN(AX)/AX-DCOS(AX))/AX
                ENDIF
            ELSEIF(L.EQ.2)THEN
                IF(AX.LT.3.D-1)THEN
                    JL=AX2/15.D0*(1.D0-AX2/14.D0*(1.D0-AX2/36.D0))
                ELSE
                    JL=(-3.0D0*DCOS(AX)/AX-DSIN(AX)*(1.D0-3.D0/AX2))/AX
                ENDIF
            ELSEIF(L.EQ.3)THEN
                IF(AX.LT.4.D-1)THEN
                    JL=AX*AX2/105.D0*(1.D0-AX2/18.D0*(1.D0-AX2/44.D0))
                ELSE
                    JL=(DCOS(AX)*(1.D0-15.D0/AX2)-DSIN(AX)*(6.D0-15.D0/AX2)/AX)/AX
                ENDIF
            ELSEIF(L.EQ.4)THEN
                IF(AX.LT.6.D-1)THEN
                    JL=AX2**2/945.D0*(1.D0-AX2/22.D0*(1.D0-AX2/52.D0))
                ELSE
                    JL=(DSIN(AX)*(1.D0-(45.D0-105.D0/AX2)/AX2)+DCOS(AX)*(10.D0-105.D0/AX2)/AX)/AX
                ENDIF
            ELSEIF(L.EQ.5)THEN
                IF(AX.LT.1.D0)THEN
                    JL=AX2**2*AX/10395.D0*(1.D0-AX2/26.D0*(1.D0-AX2/60.D0))
                ELSE
                    JL=(DSIN(AX)*(15.D0-(420.D0-945.D0/AX2)/AX2)/AX-DCOS(AX)*(1.D0-(105.D0-945.0d0/AX2)/AX2))/AX
                ENDIF
            ELSE
                IF(AX.LT.1.D0)THEN
                    JL=AX2**3/135135.D0*(1.D0-AX2/30.D0*(1.D0-AX2/68.D0))
                ELSE
                    JL=(DSIN(AX)*(-1.D0+(210.D0-(4725.D0-10395.D0/AX2)/AX2)/AX2)+ &
                        DCOS(AX)*(-21.D0+(1260.D0-10395.D0/AX2)/AX2)/AX)/AX
                ENDIF
            ENDIF
        ELSE
            NU=0.5D0+L
            NU2=NU**2
            IF(AX.LT.1.D-40)THEN
                JL=0.D0
            ELSEIF((AX2/L).LT.5.D-1)THEN
                JL=DEXP(L*DLOG(AX/NU)-LN2+NU*ONEMLN2-(1.D0-(1.D0-3.5D0/NU2)/NU2/30.D0)/12.D0/NU) &
                   /NU*(1.D0-AX2/(4.D0*NU+4.D0)*(1.D0-AX2/(8.D0*NU+16.D0)*(1.D0-AX2/(12.D0*NU+36.D0))))
            ELSEIF((real(L,dl)**2/AX).LT.5.D-1)THEN
                BETA=AX-PID2*(L+1)
                JL=(DCOS(BETA)*(1.D0-(NU2-0.25D0)*(NU2-2.25D0)/8.D0/AX2*(1.D0-(NU2-6.25)*(NU2-12.25D0)/48.D0/AX2)) &
                   -DSIN(BETA)*(NU2-0.25D0)/2.D0/AX* (1.D0-(NU2-2.25D0)*(NU2-6.25D0)/24.D0/AX2*(1.D0-(NU2-12.25)* &
                       (NU2-20.25)/80.D0/AX2)) )/AX
            ELSE
                L3=NU**0.325
                IF(AX .LT. NU-1.31*L3) then
                    COSB=NU/AX
                    SX = DSQRT(NU2-AX2)
                    COTB=NU/SX
                    SECB=AX/NU
                    BETA=DLOG(COSB+SX/AX)
                    COT3B=COTB**3
                    COT6B=COT3B**2
                    SEC2B=SECB**2
                    EXPTERM=( (2.D0+3.D0*SEC2B)*COT3B/24.D0 &
                       - ( (4.D0+SEC2B)*SEC2B*COT6B/16.D0 &
                       + ((16.D0-(1512.D0+(3654.D0+375.D0*SEC2B)*SEC2B)*SEC2B)*COT3B/5760.D0 &
                       + (32.D0+(288.D0+(232.D0+13.D0*SEC2B)*SEC2B)*SEC2B)*SEC2B*COT6B/128.D0/NU)*COT6B/NU) &
                       /NU)/NU
                    JL=DSQRT(COTB*COSB)/(2.D0*NU)*DEXP(-NU*BETA+NU/COTB-EXPTERM)

                !          /**************** Region 2: x >> l ****************/

                ELSEIF (AX .GT. NU+1.48*L3) then
                    COSB=NU/AX
                    SX=DSQRT(AX2-NU2)
                    COTB=NU/SX
                    SECB=AX/NU
                    BETA=DACOS(COSB)
                    COT3B=COTB**3
                    COT6B=COT3B**2
                    SEC2B=SECB**2
                    TRIGARG=NU/COTB-NU*BETA-PID4 &
                           -((2.0+3.0*SEC2B)*COT3B/24.D0  &
                           +(16.D0-(1512.D0+(3654.D0+375.D0*SEC2B)*SEC2B)*SEC2B)*COT3B*COT6B/5760.D0/NU2)/NU
                    EXPTERM=( (4.D0+sec2b)*sec2b*cot6b/16.D0 &
                           -(32.D0+(288.D0+(232.D0+13.D0*SEC2B)*SEC2B)*SEC2B)*SEC2B*COT6B**2/128.D0/NU2)/NU2
                    JL=DSQRT(COTB*COSB)/NU*DEXP(-EXPTERM)*DCOS(TRIGARG)

                !          /***************** Region 3: x near l ****************/

                ELSE
                    BETA=AX-NU
                    BETA2=BETA**2
                    SX=6.D0/AX
                    SX2=SX**2
                    SECB=SX**0.3333333333333333d0
                    SEC2B=SECB**2
                    JL=( GAMMA1*SECB + BETA*GAMMA2*SEC2B &
                          -(BETA2/18.D0-1.D0/45.D0)*BETA*SX*SECB*GAMMA1 &
                          -((BETA2-1.D0)*BETA2/36.D0+1.D0/420.D0)*SX*SEC2B*GAMMA2   &
                          +(((BETA2/1620.D0-7.D0/3240.D0)*BETA2+1.D0/648.D0)*BETA2-1.D0/8100.D0)*SX2*SECB*GAMMA1 &
                          +(((BETA2/4536.D0-1.D0/810.D0)*BETA2+19.D0/11340.D0)*BETA2-13.D0/28350.D0)*BETA*SX2*SEC2B*GAMMA2 &
                          -((((BETA2/349920.D0-1.D0/29160.D0)*BETA2+71.D0/583200.D0)*BETA2-121.D0/874800.D0)* &
                           BETA2+7939.D0/224532000.D0)*BETA*SX2*SX*SECB*GAMMA1)*DSQRT(SX)/ROOTPI12
                ENDIF
            ENDIF
        ENDIF
        IF(X.LT.0.AND.MOD(L,2).NE.0)JL=-JL
        END SUBROUTINE BJL

 !    end module SpherBessels

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!                                                                      c
! Calculation of ultraspherical Bessel functions.                      c
! Fortran version of the c program hyperjl.c by Arthur Kosowsky.       c
! WKB approx described in astro-ph/9805173                             c
!                                                                      c
! Modifications by Anthony Challinor and Antony Lewis                  c
! Minor modifications to correct K=1 case outside [0,pi],              c
! the small chi approximations for lSamp%l=0 and lSamp%l=1, and                    c
! the quadratic approximation to Q(x) around Q(x)=0.                   c
! Bug fixed in downwards recursion (phi_recurs)                        c
!                                                                      c
! The routine phi_recurs uses recursion relations to calculate         c
! the functions, which is accurate but relatively slow.                c
!   ***NOT STABLE FOR K=1 or for all cases ***                         c
!                                                                      c
! The routine phi_langer uses Langer's formula for a                   c
! uniform first-order asymptotic approximation in the open, closed     c
! and flat cases. This approximation is EXCELLENT for all lSamp%l >= 3.      c
!                                                                      c
! The routine qintegral calculates the closed-form answer              c
! to the eikonal integral used in the WKB approximation.               c
!                                                                      c
! The routine airy_ai returns the Airy function Ai(x) of the argument  c
! passed. It employs a Pade-type approximation away from zero and      c
! a Taylor expansion around zero. Highly accurate.                     c
!                                                                      c
! The routines polevl and p1evl are auxiliary polynomial               c
! evaluation routines used in the airy function calculation.           c
!                                                                      c
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

! module USpherBessels
! use Precision
! implicit none
! private

 !public USpherBesselWithDeriv, phi_recurs,phi_langer

! contains

        subroutine USpherBesselWithDeriv(closed,Chi,l,beta,y1,y2)
          !returns y1=ujl*sinhChi and y2=diff(y1,Chi)
          !aim for accuracy > 1% for all inputs
        real(dl) Chi,beta,y1,y2,sinhChi,cothChi
        real(dl) sin_K, cot_K
        integer l,K
        logical, intent(IN) :: closed
        logical DoRecurs

        if (closed) then
            sin_K = sin(Chi)
            cot_K= 1._dl/tan(Chi)
            K=1
         else
            sin_K=sinh(Chi)
            cot_K = 1._dl/tanh(Chi)
            K=-1
         end if

        sinhChi = sin_K
        cothChi = cot_K

       DoRecurs = ((l<=45*AccuracyBoost).OR.((.not.closed.or.(abs(Chi-pi/2)>0.2d0)).and.(beta*l<750) &
            .or.closed.and.(beta*l<4000)))

!Deep in the tails the closed recursion relation is not stable
!Added July 2003 to prevent problems with very nearly flat models
       if (DoRecurs .and. closed) then
        if  (Chi < asin(sqrt(l*(l+1._dl))/beta) - 2/beta) then
           if (phi_langer(l,K,beta,Chi) < 1e-7) then
             call phi_small_closed_int(l,beta,chi,y1,y2)
             return
           end if
       end if
     end if

     if (DoRecurs) then
             !use recursive evaluation where WKB is poor and recurs is fast anyway.
         y1=phi_recurs(l,K,beta,Chi)*sinhChi
         y2=y1*(l+1)*cothChi
         if (.not.closed.or.(l+1<nint(beta))) y2=y2 - &
              sqrt(beta**2-(K*(l+1)**2))*phi_recurs(l+1,K,beta,Chi)*sinhChi
          !of course we could get y2 much more quickly by modifying
          !phi_recurs to return l and l+1 for each beta,Chi...

         else !WKB approx
         y1=phi_langer(l,K,beta,Chi)*sinhChi
         y2=y1*(l+1)*cothChi
         if (.not.closed.or.(l+1<nint(beta))) y2=y2 - &
              sqrt(beta**2-(K*(l+1)**2))*phi_langer(l+1,K,beta,Chi)*sinhChi

         end if

        end subroutine USpherBesselWithDeriv

!Calculates y1,y2 (noramlized to a value near the turning point)
!by integrating up the differential equation and normalizing to phi_recurs
!in the region in which phi_recurs is stable
!This allows closed functions to be computed where chi << turning point
   subroutine phi_small_closed_int(l,beta,chi,y1,y2)
   integer, intent(IN) :: l
   real(dl), intent(IN) :: beta, chi
   real(dl) y1,y2

   integer nsteps,i

   real(dl) ap1,nu2,dydchi1,dydchi2,yt1,yt2,dyt1,dyt2,dym1,dym2
   real(dl) x0, delchi,sh, h6,x
   real(dl) y1_x,y2_x, tmp,xh,hh

   nsteps = 200
   ap1 = l*(l+1)
   x0 = sqrt(ap1)/beta
   nu2 = beta**2

   if ((beta*chi)**2/l < 0.005) then
 !Series solution

     x = chi
     sh = sin(x)
     tmp=(ap1/sh**2 - nu2)
     y1=1e-20
     y2 = ((l+1)/x - (nu2-ap1/3)/(2*l+3)*x) * y1
   else

   x = max(1d-7,chi - 50._dl/l)
   y1=1e-20
   y2 = (l+1)*y1/x

   delchi = (chi-x)/nSteps
   h6=delchi/6
   hh=delchi/2
   sh = sin(x)
   tmp=(ap1/sh**2 - nu2)

          do i=1,nSteps
! One step in the ujl integration
! fourth-order Runge-Kutta method to integrate equation for ujl

            dydchi1=y2         !deriv y1
            dydchi2=tmp*y1     !deriv y2
            xh=x+hh          !midpoint of step
            yt1=y1+hh*dydchi1  !y1 at midpoint
            yt2=y2+hh*dydchi2  !y2 at midpoint
            dyt1=yt2           !deriv y1 at mid
            tmp=(ap1/sin(xh)**2 - nu2)

            dyt2=tmp*yt1       !deriv y2 at mid

            yt1=y1+hh*dyt1     !y1 at mid
            yt2=y2+hh*dyt2     !y2 at mid

            dym1=yt2           !deriv y1 at mid
            dym2=tmp*yt1       !deriv y2 at mid
            yt1=y1+delchi*dym1 !y1 at end
            dym1=dyt1+dym1
            yt2=y2+delchi*dym2 !y2 at end
            dym2=dyt2+dym2

            x=x+delchi     !end point
            sh=sin(x)
            dyt1=yt2           !deriv y1 at end
            tmp=(ap1/sh**2 - nu2)
            dyt2=tmp*yt1       !deriv y2 at end
            y1=y1+h6*(dydchi1+dyt1+2*dym1) !add up
            y2=y2+h6*(dydchi2+dyt2+2*dym2)
           if (y1 > 1d10 .or. y2> 1d10) then

              y1=y1/1d10
              y2=y2/1d10

           end if
         end do

      end if

       y1_x = y1; y2_x = y2

       delchi = (x0 - chi)/nSteps
       h6=delchi/6
       hh=delchi/2

          do i=1,nSteps
! One step in the ujl integration
! fourth-order Runge-Kutta method to integrate equation for ujl

            dydchi1=y2         !deriv y1
            dydchi2=tmp*y1     !deriv y2
            xh=x+hh          !midpoint of step
            yt1=y1+hh*dydchi1  !y1 at midpoint
            yt2=y2+hh*dydchi2  !y2 at midpoint
            dyt1=yt2           !deriv y1 at mid
            tmp=(ap1/sin(xh)**2 - nu2)

            dyt2=tmp*yt1       !deriv y2 at mid

            yt1=y1+hh*dyt1     !y1 at mid
            yt2=y2+hh*dyt2     !y2 at mid

            dym1=yt2           !deriv y1 at mid
            dym2=tmp*yt1       !deriv y2 at mid
            yt1=y1+delchi*dym1 !y1 at end
            dym1=dyt1+dym1
            yt2=y2+delchi*dym2 !y2 at end
            dym2=dyt2+dym2

            x=x+delchi     !end point
            sh=sin(x)
            dyt1=yt2           !deriv y1 at end
            tmp=(ap1/sh**2 - nu2)
            dyt2=tmp*yt1       !deriv y2 at end
            y1=y1+h6*(dydchi1+dyt1+2*dym1) !add up
            y2=y2+h6*(dydchi2+dyt2+2*dym2)
            if (y1 > 1d10 .or. y2 > 1d10) then
              y1=y1/1d10
              y2=y2/1d10
              y1_x = y1_x/1d10
              y2_x = y2_x/1d10

            end if
         end do

         tmp = phi_recurs(l,1,beta,x0)*sin(x0) / y1
         y1 = y1_x * tmp
         y2 = y2_x * tmp

   end subroutine phi_small_closed_int

!***********************************************************************
!                                                                      *
! Calculates Phi(l,beta,chi) using recursion on l.                     *
! See Abbot and Schaefer, ApJ 308, 546 (1986) for needed               *
! recursion relations and closed-form expressions for l=0,1.           *
! (Note: Their variable y is the same as chi here.)                    *
!                                                                      *
! When the flag direction is negative, downwards recursion on l        *
! must be used because the upwards direction is unstable to roundoff   *
! errors. The downwards recursion begins with arbitrary values and     *
! continues downwards to l=1, where the desired l value is normalized  *
! using the closed form solution for l=1. (See, e.g., Numerical        *
! Recipes of Bessel functions for more detail)                         *
!                                                                      *
!***********************************************************************

  function phi_recurs(l, K, beta, chi)
  !doesn't like values which give exponentially small phi
  integer, intent(IN) :: l, K
  real(dl), intent(IN) :: beta, chi
  real(dl) phi_recurs
  integer j, direction, lstart,ibeta
  real(dl) ell, kay, arg, answer,beta2
  real(dl) root_K
  real(dl) phi0, phi1, phi_plus, phi_zero, phi_minus, b_zero, b_minus
  real(dl), parameter :: ACC=40._dl, BIG=1.d10
  real(dl) sin_K, cot_K

  ell=dble(l)

  ! Test input values

  if(l<0) then
     write(*,*) "Bessel function index ell < 0"
     stop
  endif
  if(beta<0._dl) then
     write(*,*) "Wavenumber beta < 0"
     stop
  endif
  if ((abs(K)/=1).and.(K/=0)) then
     write(*,*) "K must be 1, 0 or -1"
     stop
  end if

  if(K==1) then
     ibeta=nint(beta)
     if(ibeta<3) then
        write(*,*) "Wavenumber beta < 3 for K=1"
        stop
     endif
     if(ibeta<=l) then
        write(*,*) "Wavenumber beta <= l"
        stop
     endif
  endif

  if (chi<1/BIG) then
     phi_recurs=0
     return
  end if

  kay = dble(K)
  arg = beta * chi
  beta2 = beta**2

  if(K == 0) then
     cot_K = 1._dl/chi
     sin_K = chi
     root_K = beta
  else
   root_K = sqrt(beta2 -kay*ell*ell)

    if(K == -1) then
    cot_K = 1._dl/tanh(chi)
    sin_K = sinh(chi)
    else
    cot_K = 1._dl/tan(chi)
    sin_K = sin(chi)
    end if

  endif

  ! Closed form solution for l=0

  if (abs(chi) < 1.d-4) then
    if (abs(arg)<1.d-4) then
     phi0 = 1._dl-chi**2*(beta*beta-kay)/6._dl
    else
     phi0=sin(arg)/arg
    end if
  else
     phi0 = sin(arg) / (beta * sin_K)
  end if

  if (l==0) then
       phi_recurs=phi0
       return
   end if

     ! Closed form solution for l=1

     if((abs(chi) < 1.d-4).and.(K/=0)) then
        if(arg < 1.d-4) then
           phi1 = chi*sqrt(beta*beta-kay)/3._dl
           !beta2 * chi / (3._dl * sqrt(1._dl+ kay * beta2))
        else
           phi1 = (sin(arg)/arg-cos(arg))/(sqrt(beta*beta-kay)*chi)
             !(sin(arg)/arg - cos(arg))/arg
        end if
     elseif ((abs(arg) < 1.d-4).and.(K == 0)) then
        phi1 = arg / 3._dl
     else
        if (K /= 0 ) then
           phi1 = sin(arg) * cot_K / (beta * sin_K) - cos(arg) / sin_K
           phi1 = phi1/sqrt(beta2 - kay)
        else
           phi1 = (sin(arg)/arg - cos(arg))/arg
        end if
     end if
     if(l==1) then
        phi_recurs=phi1
        return
     end if
     ! Find recursion direction
     !  direction = +1 for upward recursion, -1 for downward

     if(abs(cot_K) < root_K / ell) then
        direction = 1
     else
        direction = -1
     end if

     ! For K=1, must do upwards recursion:
     ! NOT STABLE for all values of chi

     if(K==1) direction = 1

     ! Do upwards recursion on l

     if(direction == 1)then
        b_minus = sqrt(beta2 - kay)
        phi_minus = phi0
        phi_zero = phi1

        do j=2,l

           if(K == 0) then
              phi_plus = ((2*j-1) * cot_K * phi_zero - beta*phi_minus)/ beta
           else
              b_zero = sqrt(beta2 - (K*j*j))
              phi_plus = ((2*j-1) * cot_K * phi_zero - b_minus * phi_minus) / b_zero
              b_minus = b_zero
           end if
           phi_minus = phi_zero
           phi_zero = phi_plus
        end do

        phi_recurs=phi_plus

        return

        ! Do downwards recursion on l

     else
        lstart = l + 2 * int(sqrt(ell*ACC))

        b_zero = sqrt(beta2 - dble(K*lstart*lstart))
        phi_plus = 0._dl
        phi_zero = 1._dl
        answer = 0._dl

        do j= lstart - 2,1,-1

           if(K == 0) then
              phi_minus = ((2*j + 3) * cot_K * phi_zero - beta * phi_plus) / beta
           else
              b_minus = sqrt(beta2 - (K*(j+1)**2))
              phi_minus = ((2*j + 3) * cot_K * phi_zero - b_zero * phi_plus) / b_minus
              b_zero = b_minus
           end if
           phi_plus = phi_zero
           phi_zero = phi_minus

           if(j == l) answer = phi_minus
           if((abs(phi_zero) > BIG).and.(j/=1)) then
              phi_plus = phi_plus/BIG
              phi_zero = phi_zero/BIG
              answer = answer/BIG
           end if
        end do

        ! Normalize answer to previously computed phi1

        answer = answer*phi1 / phi_minus
        phi_recurs=answer

     end if

   end function phi_recurs

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!                                                                      c
! Calculates Phi(l,beta,chi) using the Langer uniform approximation    c
! to the first-order WKB approximation.                                c
! See C.M. Bender and S.A. Orszag,  Mathematical Methods for           c
! Scientists and Engineers (McGraw-Hill, 1978; LC QA371.B43),          c
! chapter 10.                                                          c
!                                                                      c
! Differential equation for needed function can be cast into the       c
! Schrodinger form      \epsilon^2 y'' = Q(x) y                        c
! where \epsilon^2 = 1/l(l+1) and Q(x) depends on the parameter        c
! alpha \equiv beta * epsilon.                                         c
!                                                                      c
! In the K= +1 case, the function is                                   c
! determined by its value on the interval [0, pi/2] and the symmetry   c
! conditions Phi(chi + pi) = (-1)^{beta - l - 1} Phi(chi),             c
!            Phi(pi - chi) = (-1)^{beta - l - 1} Phi(chi).             c
! This interval contains one turning point, so the Langer formula      c
! can be used.                                                         c
! Note that the second condition at chi = pi/2 gives an eigenvalue     c
! condition on beta, which  must corrected. For the lowest             c
! eigenvalue(s), the region between the turning points is not large    c
! enough for the asymptotic solution to be valid, so the functions     c
! have a small discontinuity or discontinuous derivative at pi/2;      c
! this behavior is corrected by employing a 4-term asymptotic          c
! series around the regular point chi=pi/2.                            c
! The exact eigenvalue condition requires that beta must be an         c
! integer >= 3 with beta > l. Note this implies alpha > 1.             c
!                                                                      c
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      function phi_langer(l,K,beta,chi)
      integer l,K,ibeta,kay
      real(dl) phi_langer
      real(dl) ell,symm, anu, alpha2
      real(dl) beta,chi,eikonal, wkb, arg, arg2, tmp
      real(dl) epsilon, alpha, chi0, x, a, b,achi

      real(dl) cot_K, sin_K
      real(dl), parameter :: PI=3.1415926536d0,ROOTPI=1.772453851d0,ROOT2PI=2.506628275d0, &
                           PIOVER2=1.570796327d0

      ell=dble(l)
      achi=chi

      symm=1._dl
!
! Test input values
!
      if(l<0) then
         write(*,*) "Bessel function index ell < 0"
         stop
      endif
      if(beta<0._dl) then
         write(*,*) "Wavenumber beta < 0"
         stop
      endif
      if ((abs(K)/=1).and.(K/=0)) then
        write(*,*) "K must be 1, 0 or -1"
        stop
      end if

      if(K == 1) then
         ibeta=nint(beta)
         if(ibeta<3) then
            write(*,*) "Wavenumber beta < 3 for K=1"
            stop
         endif
         if(ibeta<=l) then
            write(*,*) "Wavenumber beta <= l"
            stop
         endif
      endif

      kay=K

! For closed case, find equivalent chi in [0,pi/2]
!
      if(K==1) then
         achi=achi-2._dl*Pi*int(achi/2._dl/PI)
         if(achi>PI) then
            achi=2._dl*PI-achi
            if(2*(l/2).eq.l) then
               symm=symm
            else
               symm=-symm
            endif
         endif
         if(achi>PI/2._dl) then
            achi=PI-achi
            if(2*((ibeta-l-1)/2).eq.(ibeta-l-1)) then
               symm=symm
            else
               symm=-symm
            endif
         endif
      endif

! Definitions
      if(K == 0) then
          sin_K = achi
      else
            if(K == -1) then
               sin_K = sinh(achi)
             else
               sin_K = sin(achi)
            end if
      endif

! Closed form solution for l=0
!
      if(l == 0) then
         arg=beta*achi

         if((abs(achi)<1.d-4).and.(K/=0)) then
            if(abs(arg)<1.d-4) then
               wkb=1._dl-achi*achi*(beta*beta-kay)/6._dl
            else
               wkb=sin(arg)/arg
            endif
         else if((abs(arg)<1.d-4).and.(K==0)) then
            wkb=1._dl-arg*arg/6._dl
         else
            wkb=sin(arg)/(beta*sin_K)
         endif
         phi_langer=symm*wkb
         return
      endif
!
! Closed form solution for l=1
!
      if(l==1) then
         arg=beta*achi

         if((abs(achi)<1.d-4).and.(K/=0)) then
            if(abs(arg)<1.d-4) then
               wkb=achi*sqrt(beta*beta-kay)/3._dl
            else
               wkb=(sin(arg)/arg-cos(arg))/(sqrt(beta*beta-kay)*achi)
            endif
         else if((abs(arg)<1.d-4).and.(K==0)) then
            wkb=arg/3._dl
         else
          if(K/=0) then
            if(K==1) then
               cot_K=1._dl/tan(achi)
            else
               cot_K=1._dl/tanh(achi)
            endif
            wkb=sin(arg)*cot_K/(beta*sin_K)-cos(arg)/sin_K
            wkb=wkb/sqrt(beta*beta-kay)
         else
            wkb=(sin(arg)/arg-cos(arg))/arg
         endif
         end if
         phi_langer=symm*wkb
         return
      endif
!
! Closed form solution for K=1 and beta = l+1 (lowest eigenfunction)
!
      if((K==1).and.(ibeta == (l+1))) then
         wkb=(sin_K**ell)* &
              sqrt(sqrt(2._dl*PI/(2._dl*ell+1._dl))*ell/((ell+1._dl)*(2._dl*ell+1._dl)))
         wkb=wkb*(1+0.1875d0/ell-0.013671875/(ell*ell))
         phi_langer=symm*wkb
         return
      endif

! Very close to 0, return 0 (exponentially damped)
!
      if(abs(achi)<1.d-8) then
         phi_langer=0._dl
         return
      endif

! For closed case, find corrected eigenvalue beta
!
      if(K==1) then
         anu=dble(ibeta)-1._dl/(8._dl*ell)+1._dl/(16._dl*ell*ell)
      else
         anu=beta
      endif
!
! Evaluate epsilon using asymptotic form for large l
!
      if(l<20) then
         epsilon=1._dl/sqrt(ell*(ell+1._dl))
      else
         epsilon=1._dl/ell-0.5d0/(ell*ell)+0.375d0/(ell*ell*ell)
      endif

      alpha=epsilon*anu
!
! Calculate the turning point where Q(x)=0.
! Function in question has only a single simple turning point.
!
      if(K==-1) chi0=log((1._dl+sqrt(1._dl+alpha*alpha))/alpha)
      if(K==0) chi0=1._dl/alpha
      if(K==1) chi0=asin(1._dl/alpha)

! Very close to chi0, use usual wkb form to avoid dividing by zero
!
      if(abs(achi-chi0)<1.d-5) then

! Calculate coefficients of linear and quadratic terms in Q(x) expansion
! in the neighborhood of the turning point
! Q(chi)=a*(chi0-chi)+b*(chi0-chi)**2
         alpha2=alpha*alpha

         if(K==-1) then
            a=2._dl*alpha2*sqrt(alpha2+1._dl)
            b=3._dl*alpha2**2+2._dl*alpha2
         endif
         if(K==0) then
            a=2._dl*alpha2*alpha
            b=3._dl*alpha2**2
         endif
         if(K==1) then
            a=2._dl*alpha2*sqrt(alpha2-1._dl)
            b=3._dl*alpha2**2-2._dl*alpha2
         endif

! Dependent variable x for which Q(x)=0 at x=0
! x>0 is the evanescent region
!
         x=chi0-achi
!
! Argument of Airy function
!
         arg=(x+b*x*x/(5._dl*a))/(epsilon*epsilon/a)**(0.333333333d0)
!
! Evaluate Airy function
!
         wkb=airy_ai(arg)
!
! Rest of functional dependence
!
         wkb=wkb*(1._dl-b*x/(5._dl*a))/sin_K
!  Normalization factor:

         wkb=wkb*symm*ROOTPI*((a*epsilon)**(-0.1666667d0))*sqrt(epsilon/anu)
         phi_langer=wkb

         return
      endif

! Langer approximation.
!
! Transport factor:
!
      tmp=sqrt(abs(1._dl/(sin_K*sin_K)-alpha*alpha))

! Eikonal factor
!
      eikonal=qintegral(sin_K,alpha,K)

      arg=(1.5d0*eikonal/epsilon)**(1._dl/3._dl)

      arg2=arg*arg
      if(achi>chi0) arg2=-arg2

! Multiply factors together

      wkb=airy_ai(arg2)*symm*ROOTPI*sqrt(arg*epsilon/anu/tmp)/Sin_K
      phi_langer=wkb

      end function phi_langer

!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!                                                                       c
! Evaluates the exact solution to  the integral giving the WKB          c
! eikonal solution,   \int^x sqrt(abs(Q(x))) dx                         c
!                                                                       c
! In the open case, this integral costs 1 or 2 square roots, an atan    c
! and a log; its evaluation will be roughly as expensive as the rest    c
! of the Phi routine. An analytic fit cannot be substantially faster    c
! because the dependence on alpha of the y-intercept of the linear      c
! region of the integrand contains a log and an atan, so at best a fit  c
! can only save the computation of the square roots.                    c
!                                                                       c
! The integrals are very bland functions of chi and alpha and could     c
! be precomputed and cached to save computation time; interpolation     c
! on a relatively small number of points should be very accurate        c
!                                                                       c
! Note that for the closed case, the variable arg must be between 0     c
! and alpha; for arg > alpha, symmetry properties reduce the needed     c
! integral to this case.                                                c
!                                                                       c
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      function qintegral(sin_K,alpha, K)
      implicit none
      real(dl) qintegral, sin_K
      integer K
      real(dl) alpha,exact,arg, root1, root2, dummyarg

      real(dl), parameter :: PI=3.1415926536d0,ROOTPI=1.772453851d0,ROOT2PI=2.506628275d0, &
                           PIOVER2=1.570796327d0

      arg=alpha*sin_K

      if(K==0) then
         if(arg>1._dl) then
            exact=sqrt(arg*arg-1._dl)-acos(1._dl/arg)
            qintegral=exact
            return
         else
            root1=sqrt(1._dl-arg*arg)
            exact=log((1._dl+root1)/arg)-root1
            qintegral=exact
            return
         endif
      else if(K==-1) then
         if(arg>1._dl) then
            root1=sqrt(arg*arg-1._dl)
            root2=sqrt(arg*arg+alpha*alpha)
            exact=alpha/2._dl*log((2._dl*arg*arg+alpha*alpha-1._dl+ &
                  2._dl*root1*root2)/(1._dl+alpha*alpha))+atan(root2/ &
                  (alpha*root1))-PIOVER2
            qintegral=exact
            return
         else
            root1=sqrt((1._dl-arg*arg)*(arg*arg+alpha*alpha))
            exact=alpha/2._dl*atan(-2._dl*root1/(2*arg*arg+alpha*alpha- &
                  1._dl))+0.5d0*log((2._dl*alpha*root1+2._dl*alpha*alpha+ &
                  arg*arg*(1._dl-alpha*alpha))/(arg*arg*(1._dl+ &
                  alpha*alpha)))
            if(2._dl*arg*arg+alpha*alpha-1._dl<0._dl) then
               exact=exact-alpha*PIOVER2
            endif
            qintegral=exact
            return
         endif
      else
         if(arg>1._dl) then
            root1=sqrt(arg*arg-1._dl)
            root2=sqrt(alpha*alpha-arg*arg)
            exact=alpha/2._dl*atan(-2._dl*root1*root2/ &
               (2._dl*arg*arg-alpha*alpha-1._dl))- &
               atan(-root2/(root1*alpha))-PIOVER2
            if(2._dl*arg*arg-alpha*alpha-1._dl>0._dl) then
               exact=exact+alpha*PIOVER2
            endif
         else
            root1=sqrt((1._dl-arg*arg)*(alpha*alpha-arg*arg))
            dummyarg=alpha*(1._dl-arg*arg)/root1
            exact=0.5d0*log((1._dl+dummyarg)/(1._dl-dummyarg))- &
             alpha/2._dl*log((alpha*alpha-2._dl*arg*arg+1._dl+2._dl*root1)/ &
             (alpha*alpha-1._dl))
         endif
         qintegral=exact
         return
      endif

      end function qintegral

!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!                                                                      c
!       Airy function                                                  c
!                                                                      c
! Modified from original routine by Stephen Moshier, available         c
! as part of the Cephes library at www.netlib.com                      c
! Modifications: eliminates calculation of Bi(x), Ai'(x), Bi'(x)       c
! and translation to Fortran                                           c
!                                                                      c
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
! DESCRIPTION:
!
! Solution of the differential equation
!
!       y"(x) = xy.
!
! The function returns the two independent solutions Ai, Bi
! and their first derivatives Ai'(x), Bi'(x).
!
! Evaluation is by power series summation for small x,
! by rational minimax approximations for large x.
!
!
!
! ACCURACY:
! Error criterion is absolute when function <= 1, relative
! when function > 1, except * denotes relative error criterion.
! For large negative x, the absolute error increases as x^1.5.
! For large positive x, the relative error increases as x^1.5.
!
! Arithmetic  domain   function  # trials      peak         rms
! IEEE        -10, 0     Ai        10000       1.6e-15     2.7e-16
! IEEE          0, 10    Ai        10000       2.3e-14*    1.8e-15*
! IEEE        -10, 0     Ai'       10000       4.6e-15     7.6e-16
! IEEE          0, 10    Ai'       10000       1.8e-14*    1.5e-15*
! IEEE        -10, 10    Bi        30000       4.2e-15     5.3e-16
! IEEE        -10, 10    Bi'       30000       4.9e-15     7.3e-16
! DEC         -10, 0     Ai         5000       1.7e-16     2.8e-17
! DEC           0, 10    Ai         5000       2.1e-15*    1.7e-16*
! DEC         -10, 0     Ai'        5000       4.7e-16     7.8e-17
! DEC           0, 10    Ai'       12000       1.8e-15*    1.5e-16*
! DEC         -10, 10    Bi        10000       5.5e-16     6.8e-17
! DEC         -10, 10    Bi'        7000       5.3e-16     8.7e-17
!
!
! Cephes Math Library Release 2.1:  January, 1989
! Copyright 1984, 1987, 1989 by Stephen lSamp%l. Moshier
! Direct inquiries to 30 Frost Street, Cambridge, MA 02140
!

      function airy_ai(x)
      implicit none
      real(dl) airy_ai
      real(dl) x,z, zz, t, f, g, uf, ug, zeta, theta
      real(dl) ak
      real(dl) AN(8),AD(8),AFN(9),AFD(9),AGN(11),AGD(10)
      real(dl), parameter :: AMAXAIRY=25.77d0,ACC=1.d-8,PI=3.1415926536d0
      real(dl), parameter :: c1=0.35502805388781723926d0, c2=0.258819403792806798405d0
      real(dl), parameter :: sqrt3=1.732050807568877293527d0,sqpii=5.64189583547756286948d-1

      AN(1)=3.46538101525629032477d-1
      AN(2)=1.20075952739645805542d1
      AN(3)=7.62796053615234516538d1
      AN(4)=1.68089224934630576269d2
      AN(5)=1.59756391350164413639d2
      AN(6)=7.05360906840444183113d1
      AN(7)=1.40264691163389668864d1
      AN(8)=9.99999999999999995305d-1

      AD(1)=5.67594532638770212846d-1
      AD(2)=1.47562562584847203173d1
      AD(3)=8.45138970141474626562d1
      AD(4)=1.77318088145400459522d2
      AD(5)=1.64234692871529701831d2
      AD(6)=7.14778400825575695274d1
      AD(7)=1.40959135607834029598d1
      AD(8)=1.00000000000000000470d0

      AFN(1)=-1.31696323418331795333d-1
      AFN(2)=-6.26456544431912369773d-1
      AFN(3)=-6.93158036036933542233d-1
      AFN(4)=-2.79779981545119124951d-1
      AFN(5)=-4.91900132609500318020d-2
      AFN(6)=-4.06265923594885404393d-3
      AFN(7)=-1.59276496239262096340d-4
      AFN(8)=-2.77649108155232920844d-6
      AFN(9)=-1.67787698489114633780d-8

      AFD(1)=1.33560420706553243746d1
      AFD(2)=3.26825032795224613948d1
      AFD(3)=2.67367040941499554804d1
      AFD(4)=9.18707402907259625840d0
      AFD(5)=1.47529146771666414581d0
      AFD(6)=1.15687173795188044134d-1
      AFD(7)=4.40291641615211203805d-3
      AFD(8)=7.54720348287414296618d-5
      AFD(9)=4.51850092970580378464d-7

      AGN(1)=1.97339932091685679179d-2
      AGN(2)=3.91103029615688277255d-1
      AGN(3)=1.06579897599595591108d0
      AGN(4)=9.39169229816650230044d-1
      AGN(5)=3.51465656105547619242d-1
      AGN(6)=6.33888919628925490927d-2
      AGN(7)=5.85804113048388458567d-3
      AGN(8)=2.82851600836737019778d-4
      AGN(9)=6.98793669997260967291d-6
      AGN(10)=8.11789239554389293311d-8
      AGN(11)=3.41551784765923618484d-10

      AGD(1)=9.30892908077441974853d0
      AGD(2)=1.98352928718312140417d1
      AGD(3)=1.55646628932864612953d1
      AGD(4)=5.47686069422975497931d0
      AGD(5)=9.54293611618961883998d-1
      AGD(6)=8.64580826352392193095d-2
      AGD(7)=4.12656523824222607191d-3
      AGD(8)=1.01259085116509135510d-4
      AGD(9)=1.17166733214413521882d-6
      AGD(10)=4.91834570062930015649d-9
!
! Exponentially tiny for large enough argument
!
      if(x>AMAXAIRY) then
         airy_ai=0._dl
         return
      endif
!
! Pade fit for large negative arguments
!
      if(x<-2.09d0) then
         t=sqrt(-x)
         zeta=-2._dl*x*t/3._dl
         t=sqrt(t)
         ak=sqpii/t
         z=1._dl/zeta
         zz=z*z
         uf=1._dl+zz*polevl(zz,AFN,8)/p1evl(zz,AFD,9)
         ug=z*polevl(zz,AGN,10)/p1evl(zz,AGD,10)
         theta=zeta+0.25d0*PI
         f=sin(theta)
         g=cos(theta)
         airy_ai=ak*(f*uf-g*ug)
         return
      endif
!
! Pade fit for large positive arguments
!
      if(x>=2.09) then
         t=sqrt(x)
         zeta=2._dl*x*t/3._dl
         g=exp(zeta)
         t=sqrt(t)
         ak=2._dl*t*g
         z=1._dl/zeta
         f=polevl(z,AN,7)/polevl(z,AD,7)
         airy_ai=sqpii*f/ak
         return
      endif
!
! Taylor series for region around x=0
!

      f=1._dl
      g=x
      t=1._dl
      uf=1._dl
      ug=x
      ak=1._dl
      z=x*x*x
     do while (t>ACC)
         uf=uf*z
         ak=ak+1._dl
         uf=uf/ak
         ug=ug*z
         ak=ak+1._dl
         ug=ug/ak
         uf=uf/ak
         f=f+uf
         ak=ak+1._dl
         ug=ug/ak
         g=g+ug
         t=abs(uf/f)
      end do

      airy_ai=c1*f-c2*g

      end function airy_ai

!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!  Evaluate polynomial                                          c
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
! DESCRIPTION:
!
! Evaluates polynomial of degree N:
!
!                     2          N
! y  =  C  + C x + C x  +...+ C x
!        0    1     2          N
!
! Coefficients are stored in reverse order:
!
! coef(1) = C  , ..., coef(N+1) = C  .
!            N                     0
!
! The function p1evl() assumes that C = 1.0 and is
!                                    N
! omitted from the array.  Its calling arguments are
! otherwise the same as polevl().
!
!
! SPEED:
!
! In the interest of speed, there are no checks for out
! of bounds arithmetic.  This routine is used by most of
! the functions in the library.  Depending on available
! equipment features, the user may wish to rewrite the
! program in microcode or assembly language.
!
! Cephes Math Library Release 2.1:  December, 1988
! Copyright 1984, 1987, 1988 by Stephen lSamp%l. Moshier
! Direct inquiries to 30 Frost Street, Cambridge, MA 02140
!
      function polevl(x,coef,N)
      implicit none
      real(dl) polevl
      real(dl) x,ans
      real(dl) coef
      integer N,i

      dimension coef(N+1)

      ans=coef(1)
      do i=2,N+1
         ans=ans*x+coef(i)
      end do
      polevl=ans

      end function polevl

!
!
! Evaluate polynomial when coefficient of x  is 1.0.
! Otherwise same as polevl.
!
      function p1evl(x,coef,N)
      implicit none
      real(dl) p1evl
      real(dl) x,coef,ans
      integer N,i
      dimension coef(N)

      ans=x+coef(1)
      do i=2,N
         ans=ans*x+coef(i)
      end do
      p1evl=ans

      end function p1evl

  end module SpherBessels !USpherBessels

        SUBROUTINE BJL_EXTERNAL(L,X,JL)
        use SpherBessels
        use Precision
        !!== MODIFIED SUBROUTINE FOR SPHERICAL BESSEL FUNCTIONS.                       ==!!
        !!== CORRECTED THE SMALL BUGS IN PACKAGE CMBFAST&CAMB(for l=4,5, x~0.001-0.002)==!!
        !!== CORRECTED THE SIGN OF J_L(X) FOR X<0 CASE                                 ==!!
        !!== WORKS FASTER AND MORE ACCURATE FOR LOW L, X<<L, AND L<<X cases            ==!!
        !!== zqhuang@astro.utoronto.ca                                                 ==!!
        IMPLICIT NONE
        INTEGER L
        real(dl) X,JL

        call BJL(L,X,JL)

        END SUBROUTINE BJL_EXTERNAL


MODULE local_routines
    !!
    !! Setup uniform channel problem (aligned to grid)
    !!
    USE global_mod, only: dp, ip, wall_elevation
    USE domain_mod, only: domain_type
    USE which_mod, only: which
    IMPLICIT NONE

    REAL(dp), PARAMETER:: bed_slope = 0.01_dp, channel_width=20.0_dp, channel_depth=2.0_dp

    CONTAINS

    SUBROUTINE set_initial_conditions_uniform_channel(domain)
        CLASS(domain_type), TARGET, INTENT(INOUT):: domain
        INTEGER(ip):: i,j
        REAL(dp):: x, y, cx, cy, slope

        ! Set elevation
        slope = bed_slope

        cx = (domain%lw(1))*0.5
        cy = (domain%lw(2))*0.5
        DO i = 1,domain%nx(1)
            DO j = 1, domain%nx(2)
                x = (i-0.5_dp)*domain%dx(1) - cx
                y = (j-0.5_dp)*domain%dx(2) - cy
                domain%U(i,j,4) = y*slope
                IF(x > -channel_width/2.0_dp .AND. x < channel_width/2.0_dp) THEN
                    domain%U(i,j,4) = domain%U(i,j,4) - channel_depth
                END IF
            END DO
        END DO
        ! Wall boundaries along the sides and top
        domain%U(1,:,4) = wall_elevation
        domain%U(domain%nx(1),:,4) = wall_elevation
        domain%U(:,domain%nx(2),4) = wall_elevation
        domain%U(:,1,4) = wall_elevation

        ! Stage
        domain%U(:,:,1) = domain%U(:,:,4)

        ! Ensure stage >= elevation
        domain%U(:,:,1 ) = max(domain%U(:,:,1), domain%U(:,:,4))

        domain%manning_squared = 0.03_dp**2

    END SUBROUTINE

END MODULE

!@!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

PROGRAM uniform_channel
    !!
    !! Steady uniform flow in a grid-aligned channel.
    !!
    USE global_mod, only: ip, dp, charlen
    USE domain_mod, only: domain_type
    USE file_io_mod, only: read_csv_into_array
    USE local_routines
    IMPLICIT NONE

    INTEGER(ip):: i, j
    REAL(dp):: last_write_time
    TYPE(domain_type):: domain

    ! Approx timestep between outputs
    REAL(dp), PARAMETER :: approximate_writeout_frequency = 60.0_dp
    REAL(dp), PARAMETER :: final_time = 600.0_dp

    ! Length/width
    REAL(dp), PARAMETER, DIMENSION(2):: global_lw = [50._dp, 1000._dp]
    ! Lower-left corner coordinate
    REAL(dp), PARAMETER, DIMENSION(2):: global_ll = [0._dp, 0._dp]
    ! grid size (number of x/y cells)
    INTEGER(ip), PARAMETER, DIMENSION(2):: global_nx = [50, 1000] ! [400, 400]

    ! Discharge of 1 cubic meter / second per metre width
    REAL(dp) :: discharge_per_unit_width = 1.0_dp
    REAL(dp) :: Qin, model_vd, model_d, model_v, theoretical_d, theoretical_v, theoretical_vol, model_vol

    INTEGER(ip), ALLOCATABLE:: channel_x_indices(:)

    ! This gives the inflow discharge per cell, where it is applied
    Qin = discharge_per_unit_width * (global_lw(1)/global_nx(1))

    domain%theta = 1.0_dp
    domain%timestepping_method = 'rk2'

    ! Prevent dry domain from causing enormous initial step
    domain%maximum_timestep = 5.0_dp

    ! Allocate domain
    CALL domain%allocate_quantities(global_lw, global_nx, global_ll)

    ! Call local routine to set initial conditions
    CALL set_initial_conditions_uniform_channel(domain)

    ! Find channel indices
    ! This corresponds to the lowest points on a horizontal cross-section
    CALL which(domain%U(:,2,4) < (minval(domain%U(:,2,4)) + 1.0e-06), channel_x_indices)
    print*, channel_x_indices

    ! Trick to get the code to write out just after the first timestep
    last_write_time = -approximate_writeout_frequency

    ! Evolve the code
    DO WHILE (.TRUE.)

        IF(domain%time - last_write_time >= approximate_writeout_frequency) THEN

            last_write_time = last_write_time + approximate_writeout_frequency

            CALL domain%print()
            CALL domain%write_to_output_files()

            IF (domain%time > final_time) THEN
                EXIT
            END IF

        END IF

        CALL domain%evolve_one_step()

        ! Add discharge inflow
        domain%U(channel_x_indices, domain%nx(2)-1, 1) = &
            domain%U(channel_x_indices, domain%nx(2)-1, 1) + Qin*domain%evolve_step_dt/product(domain%dx)

    END DO

    call domain%write_max_quantities()

    call domain%timer%print()

    theoretical_vol = Qin * domain%time * channel_width
    model_vol = sum(domain%U(:,:,1) - domain%U(:,:,4)) * domain%dx(1) * domain%dx(2)

    ! Analytical solution for uniform slope
    ! vd = discharge_per_unit_width
    ! bed_slope = manning_squared * v * abs(v) / d^(4/3)
    ! bed_slope = manning_squared * discharge_per_unit_width**2 / (d^(10/3))
    ! d = (manning_squared * discharge_per_unit_width**2 / bed_slope )**(3/10)

    i = domain%nx(1)/2
    j = domain%nx(2)/2
    model_vd = -1.0_dp * domain%U(i,j,3)
    model_d = domain%U(i,j,1) - domain%U(i,j,4)
    model_v = model_vd/model_d

    theoretical_d = (domain%manning_squared(i,j) * discharge_per_unit_width**2 / bed_slope)**(3.0_dp/10.0_dp)

    print*, '## Testing ##'
    print*, ''
    print*, '    Theoretical volume: ', theoretical_vol
    print*, '    Model volume: ', model_vol
    print*, '      error: ', theoretical_vol - model_vol
    IF( abs(theoretical_vol - model_vol) < 1.0e-06_dp * theoretical_vol) THEN
        print*, 'PASS'
    ELSE
        stop 'FAIL: Mass conservation error'
    END IF

    print*, ' '
    print*, '   Theoretical vd: ', discharge_per_unit_width
    print*, '   Model vd (near centre): ', model_vd
    IF( abs(discharge_per_unit_width - model_vd) < 1.0e-03_dp*discharge_per_unit_width) THEN
        print*, 'PASS'
    ELSE
        stop 'FAIL: Flux error'
    END IF

    print*, ' '
    print*, '   Theoretical d: ', theoretical_d
    print*, '   Model d: ', model_d
    IF( abs(theoretical_d - model_d) < 1.0e-02_dp*theoretical_d) THEN
        print*, 'PASS'
    ELSE
        stop 'FAIL: Friction or steady flow error'
    END IF

    CALL domain%finalise()

END PROGRAM


!-----------------------------------------------------------------------
!     Module:        spec_background
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          04/09/2011
!     Description:   This module contains the background coordinate
!                    variables used by SPEC.
!-----------------------------------------------------------------------
      MODULE spec_background
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds
!-----------------------------------------------------------------------
!     Module Variables
!          nfp        Number of Field Periods
!          m          Number of Poloidal Modes
!          n          Number of Toroidal Modes
!          k          Number of Radial Surfaces
!          mnmax      Total number of Fourier Modes
!          xm         Poloidal Mode Number Array
!          xn         Toroidal Mode Number Array
!          iotamn     Minimum value of iota
!          iotamx     Maximum value of iota
!          rho        Radial Points Array [0,1]
!          rmnc       Even R Fourier Modes (cos)
!          rmns       Odd R Fourier Modes (sin)
!          zmnc       Even Z Fourier Modes (cos)
!          zmns       Odd Z Fourier Modes (sin)
!----------------------------------------------------------------------
      IMPLICIT NONE

      INTEGER, PARAMETER       :: nvol_mx = 100
      INTEGER                  :: nfp, m, n, k, mnmax, signgs, nvol
      INTEGER                  :: ni(1:nvol_mx), pl(0:nvol_mx), &
                                  ql(0:nvol_mx), pr(0:nvol_mx), &
                                  qr(0:nvol_mx)
      INTEGER, ALLOCATABLE     :: xm(:), xn(:)
      REAL                     :: iotamn,iotamx,rbtor_pies
      REAL(rprec)              :: tflux(0:nvol_mx), pflux(0:nvol_mx), &
                                  mu(1:nvol_mx), iota(0:nvol_mx)
      REAL(rprec), ALLOCATABLE :: rho(:)
      REAL(rprec), ALLOCATABLE :: rmnc(:,:), rmns(:,:), zmnc(:,:), zmns(:,:)

      END MODULE spec_background


module NumberKindsModule
!------------------------------------------------------------------------------
! Lagrangian Particle Method
!------------------------------------------------------------------------------
!
!> @author
!> Peter Bosler, Sandia National Laboratories Center for Computing Research
!
! > @class NumberKinds
! > @brief Sets global numerical constants for use by all LPPM modules and executables.
! >
! > Sets compiler-dependent kind variables for primitive data types
!
!
! DESCRIPTION:
!> @file
!> Defines global numerical constants for use by all LPPM modules and executables.
!
!------------------------------------------------------------------------------
	implicit none
	public
!> @defgroup NumberKinds NumberKinds
!> Sets global numerical constants for use by all LPPM modules and executables.
!> @{
	integer, parameter :: KREAL = kind(0.d0)   !< compiler generated kind for double precision reals @ingroup TypeConstants
	integer, parameter :: KINT = kind(1)	   !< compiler generated kind for default integer @ingroup TypeConstants
	integer, parameter :: KLOG = kind(.TRUE.)  !< compiler generated kind logical @ingroup TypeConstants

	real(KREAL), parameter :: ZERO_TOL = 1.0d-10 !< zero tolerance for real numbers @ingroup TypeConstants

	real(KREAL), parameter :: PI = 3.1415926535897932384626433832795027975_KREAL !< Pi @ingroup PhysicalConstants
	real(KREAL), parameter :: RAD_2_DEG = 180.0_kreal/PI !<  convert radians to degrees @ingroup PhysicalConstants
	real(KREAL), parameter :: DEG_2_RAD = PI / 180.0_kreal !< convert degress to radians @ingroup PhysicalConstants
	real(KREAL), parameter :: GRAV = 9.80616 !< acceleration due to gravity {m s^(-2)} @ingroup PhysicalConstants
	real(KREAL), parameter :: ONE_DAY = 86140.0_kreal !< Earth's sidereal day {s} @ingroup PhysicalConstants
	real(KREAL), parameter :: EARTH_RADIUS = 6371220_kreal !< mean radius of the Earth { m } @ingroup PhysicalConstants
    real(KREAL), parameter :: EARTH_OMEGA = 2.0_kreal*PI / ONE_DAY  !< rotation rate of sphere {s^(-1)} @ingroup PhysicalConstants
    real(KREAL), parameter :: EARTH_SURFACE_AREA = 4.0_kreal * PI * EARTH_RADIUS * EARTH_RADIUS

    real(kreal), parameter :: FILL_VALUE=999.0d20 !< indicates a garbage value or undefined variable

	integer(KINT), parameter :: STD_ERR = 0
	integer(KINT), parameter :: STD_IN  = 5
	integer(KINT), parameter :: STD_OUT = 6
	integer(KINT), parameter :: READ_UNIT = 11
	integer(KINT), parameter :: WRITE_UNIT_1 = 12
	integer(KINT), parameter :: WRITE_UNIT_2 = 13
	integer(KINT), parameter :: WRITE_UNIT_3 = 14
	integer(KINT), parameter :: MAX_STRING_LENGTH = 256

	integer(KINT), parameter ::	QUAD_PANEL = 4 !< panelKind parameter for quadrilateral panels @ingroup MeshConstants
	integer(KINT), parameter ::	TRI_PANEL = 3 !< panelKind parameter for triangular panels @ingroup MeshConstants
	integer(KINT), parameter :: QUAD_CUBIC_PANEL = 16 !< panelKind parameter for cubic quadrilateral panels @ingroup MeshConstants
	integer(KINT), parameter :: PLANAR_GEOM = 81 !< geomKind parameter for R2 @ingroup MeshConstants
	integer(KINT), parameter :: SPHERE_GEOM = 82 !< geomKind parameter for S embedded in R3 @ingroup MeshConstants
	integer(KINT), parameter :: EUCLIDEAN_3D = 83 !< geomKind parameter for R3 @ingroup MeshConstants
	integer(KINT), parameter ::	MAX_VERTEX_DEGREE = 10 !< panelKind parameter for triangular panels @ingroup MeshConstants
	integer(KINT), parameter ::	ADVECTION_SOLVER = 90 !< problemKind parameter for spherical advection @ingroup MeshConstants
	integer(KINT), parameter ::	BVE_SOLVER = 91 !< problemKind parameter for quadrilateral panels @ingroup MeshConstants
	integer(KINT), parameter ::	SWE_SOLVER = 92	!< problemKind parameter for quadrilateral panels @ingroup MeshConstants
	integer(KINT), parameter :: PLANE_SOLVER = 99 !< problemKind parameter for quadrilateral panels @ingroup MeshConstants
	integer(KINT), parameter ::	MAX_POLYGON_SIDES = 20 !< defines maximum allowable polygon size in a Voronoi mesh @ingroup MeshConstants
	integer(KINT), parameter ::	FREE_BOUNDARIES = 101 !< boundary condition parameter for planar meshes @ingroup MeshConstants
	integer(KINT), parameter ::	PERIODIC_BOUNDARIES = 102 !< boundary condition parameter for planar meshes @ingroup MeshConstants

	integer(KINT), parameter :: TRI_HEX_SEED = 201 !< seed identifier
	integer(KINT), parameter :: QUAD_RECT_SEED = 202 !< seed identifier
	integer(KINT), parameter :: POLAR_DISC_SEED = 203 !< seed identifier
	integer(KINT), parameter :: QUAD_RECT_PERIODIC_SEED = 204 !< seed identifier
	integer(KINT), parameter :: ICOS_TRI_SPHERE_SEED = 205 !< seed identifier
	integer(KINT), parameter :: CUBED_SPHERE_SEED = 206!< seed identifier
	integer(KINT), parameter :: BETA_PLANE_SEED = 207 !< seed identifier
	integer(KINT), parameter :: CUBIC_PLANE_SEED = 208!< seed identifier
	real(KREAL), save :: SphereRadius = 1.0_kreal

	integer(KINT), save :: numProcs = 1 !< number of processess @ingroup MPIVariables
	integer(KINT), save :: procRank = 0 !< process rank @ingroup MPIVariables
!> @}
end module NumberKindsModule


      subroutine shanph(diag,n,nt,np,y,s,ys,scal,index,io,imp)
c     mise a l echelle de diag par la methode de shanno-phua
c     calcul du facteur d echelle scal
c      diag=(y,(diag-1)y)/(y,s)*diag
c
      implicit double precision (a-h,o-z)
      dimension diag(n),y(nt,n),s(nt,n),ys(nt),index(nt)
      inp=index(np)
      cof=0.
      do 203 i=1,n
203   cof=cof + y(inp,i)**2/diag(i)
      cof=cof/ys(inp)
      if(imp.gt.3)write(io,1203)cof
1203  format(' gcbd. facteur d echelle=',d15.7)
      do 205 i=1,n
205   diag(i)=cof*diag(i)
      scal=0.
      do 206 i=1,n
206   scal=scal + diag(i)
      scal=n/scal
      return
      end


C    %W% %G%
      real function tzlead (t2, t1, dt, x0, x1, y0, ndivs)
      implicit none
      real t2, t1, dt, x0, x1, y0
      integer ndivs

c     -  solves a first order lead block:
c              sT2
c            -------
c            1 + sT1
c
c     -  Uses sub-time step logic if ndivs > 1
c
c     -   subscript 0 means value at start of interval
c             "     1  "      "   "   end  "     "
c     -   x is input var
c         y is output var
c
      real aa,bb,v0,v1,w0,w1
      real rdivs,r0wt,r1wt,va,vb,wa,wb,dts
      integer la

c     -     begin     begin     begin     begin     begin     begin

      if (t1 .eq. 0.0) then
        tzlead = x1
        return
      endif
      if (dt .eq. 0.0) then
        tzlead = y0 + ((x1 - x0) * t2 / t1)
        return
      endif

c     -  No time step subdivisions

      if (ndivs .le. 1) then
        aa = dt / 2.0 / t1
        bb = t2 * (x0 + x1) / t1
        v0 = (x0 * t2 / t1) - y0
        v1 = ( v0 - aa * v0 + aa * bb) / (aa + 1.0)
        tzlead = (x1 * t2 / t1) - v1
        return
      endif
c     -  Using time step subdivisions.  Find v1 = F (w0,w1,v0)
      rdivs = ndivs
      r0wt = rdivs
      r1wt = 0.0
      dts = dt / rdivs
      aa = dts / 2.0 / t1
      w0 = x0 * t2 / t1
      w1 = x1 * t2 / t1
      wa = w0
      va = w0 - y0
      do la = 1,ndivs
        r0wt = r0wt - 1.0
        r1wt = r1wt + 1.0
        wb = ((r0wt * w0) + (r1wt * w1)) / rdivs
        bb = wa + wb
        vb = ( va - aa * va + aa * bb) / (aa + 1.0)
        wa = wb
        va = vb
      enddo
      tzlead = wb - vb
c
      return
      end


      MODULE fbal
      USE stel_kinds, ONLY: dp
      REAL(dp), DIMENSION(:), ALLOCATABLE :: rzu_fac, rru_fac,
     1  frcc_fac, fzsc_fac

      CONTAINS

      SUBROUTINE calc_fbal(bsubu, bsubv)
      USE vmec_main, ONLY: buco, bvco, equif,
     1                     jcurv, jcuru, chipf, vp, pres,
     2                     phipf, vpphi, presgrad, ohs
      USE vmec_params, ONLY: signgs
      USE vmec_dim, ONLY: ns, nrzt
      USE vmec_input, ONLY: lrfp
      USE realspace, ONLY: wint, phip
C-----------------------------------------------
      REAL(dp), INTENT(in) :: bsubu(1:nrzt), bsubv(1:nrzt)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  :: js, ns1
C-----------------------------------------------
      DO js = 2, ns
         buco(js) = SUM(bsubu(js:nrzt:ns)*wint(js:nrzt:ns))
         bvco(js) = SUM(bsubv(js:nrzt:ns)*wint(js:nrzt:ns))
      END DO

!     FROM AMPERE'S LAW, JcurX are angle averages of jac*JsupX, so
!                        JcurX = (dV/ds)/twopi**2 <JsupX> where <...> is flux surface average
      ns1 = ns-1
      DO js = 2, ns1
         jcurv(js) = (signgs*ohs)*(buco(js+1) - buco(js))
         jcuru(js) =-(signgs*ohs)*(bvco(js+1) - bvco(js))
!FOR RFP         vpphi(js) = (vp(js+1)/phip(js+1) + vp(js)/phip(js))/2
         vpphi(js) = (vp(js+1) + vp(js))/2
         presgrad(js) = (pres(js+1) - pres(js))*ohs
         equif(js) = (-phipf(js)*jcuru(js) + chipf(js)*jcurv(js))
     1                /vpphi(js) + presgrad(js)
      END DO

      equif(1) = 0
      equif(ns) = 0

!      IF ((fsqr+fsqz+fsql).gt.1.E-08_dp .and. ictrl_prec2d.eq.0) RETURN
!      IF (lRFP) RETURN

!      equif(2:ns1) = (-jcuru(2:ns1) + iotaf(2:ns1)*jcurv(2:ns1))
!     1             /vpphi(2:ns1)  + presgrad(2:ns1)

      END SUBROUTINE calc_fbal

      END MODULE fbal


! Copyright 2021 Ivan Pribec
! SPDX-License-Identifier: Apache-2.0

!> Semi-implicit Runge-Kutta method of third order
!>
!> This is a modernized version of the code originally given in
!>
!>   Villadsen, J., & Michelsen, M. L. (1978). Solution of differential
!>   equation models by polynomial approximation. Prentice-Hall, Inc.,
!>   1978.
!>
module stiff3_solver

  use stiff3_linalg, only: lu, back

  implicit none
  private

  public :: stiff3, stiff3_wp
  public :: rhs_sub, jacobian_sub, output_sub

  !> Kind parameter for working precision of stiff3 reals
  integer, parameter :: stiff3_wp = kind(1.0d0)

  !> Working precision with short name for internal use
  integer, parameter :: wp = stiff3_wp

  abstract interface
    !> Function to evaluate the right-hand side of a system of ODEs.
    !> It is assumed the system of ODEs is autonomous, meaning that
    !> the independent variable x, does not appear explicitly.
    subroutine rhs_sub(n,y,f)
      import wp
      integer, intent(in) :: n
      real(wp), intent(in) :: y(n)
      real(wp), intent(inout) :: f(n)
    end subroutine

    !> User supplied subprogram for evaluation of the Jacobian.
    subroutine jacobian_sub(n,y,df)
      import wp
      integer, intent(in) :: n
      real(wp), intent(in) :: y(n)
      real(wp), intent(inout) :: df(n,n)
    end subroutine

    !> User supplied subprogram for output.
    subroutine output_sub(x,y,iha,qa)
      import wp
      real(wp), intent(in) :: x
        !! Current value of the independent variable
      real(wp), intent(in) :: y(:)
        !! Current value of the dependent variable vector
      integer, intent(in) :: iha
        !! Number of bisections (unsuccesful integrations) in
        !! the current step
      real(wp), intent(in) :: qa
        !! Step-length acceleration factor
    end subroutine

  end interface

contains

  ! TODO: Check if the the statement `h0 = h` should appear before
  !       or after exiting the routine.

  !> Semi-implicit Runge-Kutta integrator routine
  !
  subroutine stiff3(n,fun,dfun,out,nprint,x0,x1,h0,eps,w,y)
    integer, intent(in) :: n
      !! Number of equations to be integrated.
    procedure(rhs_sub) :: fun
      !! User supplied subprogram for function evaluation.
    procedure(jacobian_sub) :: dfun
      !! User supplied subprogram for evaluation of the Jacobian.
    procedure(output_sub) :: out
      !! User supplied subprogram for output.
    integer, intent(in) :: nprint
      !! Printing interval. For `nprint = k` the solution is only printed.
      !! at every kth step.
    real(wp), intent(in) :: x0, x1
      !! Limits of the independent variable between which the differential
      !! equation is solved.
    real(wp), intent(inout) :: h0
      !! Suggested initial half-step length. On exit `h0` contains suggested
      !! value of half-step length for continued integration beyond `x1`.
    real(wp), intent(in) :: eps, w(n)
      !! Tolerance parameters.
    real(wp), intent(inout) :: y(n)
      !! Vector of dependent variables at `x0`. On exit `y` is the vector of
      !! dependent variables at `x1`.

    real(wp), dimension(n) :: yk1, yk2, ya, yold, yold1, f, fold
      !! Workspace for solution vector and right-hand side
    real(wp), dimension(n,n) :: df, dfold
      !! Workspace for jacobian arrays
    integer :: ip(n)
      !! Workspace for the pivot array

    integer :: icon, iha, i, j, nout
    real(wp) :: x, h, e, es, q, qa

  ! icon = 0 except for last step which ends exactly at x1
    icon = 0

    nout = 0
    x = x0
    h = h0

    outer: do

    ! last step - or first step longer than interval

      if (x + 2.0_wp*h >= x1) then
        h = (x1 - x)/2.0_wp
        icon = 1
      end if

    ! other steps - limit to one quarter of remaining interval

      if ((icon == 0) .and. (x + 4.0_wp*h > x1)) then
        h = (x1 - x)/4.0_wp
      end if

    ! evaluate function and jacobian

      call fun(n,y,f)
      call dfun(n,y,df)

    ! keep values which are used in half-step integration

      do i = 1, n
        yold(i) = y(i)
        fold(i) = f(i)
        do j = 1, n
          dfold(i,j) = df(i,j)
        end do
      end do

    ! perform full integration step

      call sirk3(n,fun,ip,f,y,yk1,yk2,df,2*h)

      do i = 1, n
        ya(i) = y(i)
        y(i) = yold(i)
        f(i) = fold(i)
        do j = 1, n
          df(i,j) = dfold(i,j)
        end do
      end do

    ! full step finished, start half-step integration
    ! iha counts number of steplength bisections

      iha = -1
      inner: do
        iha = iha + 1

        call sirk3(n,fun,ip,f,y,yk1,yk2,df,h)
        call fun(n,y,f)
        call dfun(n,y,df)

        yold1 = y

        call sirk3(n,fun,ip,f,y,yk1,yk2,df,h)

      ! half step integration finished
      ! compute deviation and compare with tolerance

        e = 0.0_wp
        do i = 1, n
          es = w(i)*abs(ya(i)-y(i))/(1.0_wp+abs(y(i)))
          e = max(e,es)
        end do
        q = e/eps
        qa = (4.0_wp*q)**0.25_wp
        if (q <= 1.0_wp) then
          exit inner
        end if

      ! deviation too large- return to half-step with smaller h

        do i = 1, n
          ya(i) = yold1(i)
          y(i) = yold(i)
          f(i) = fold(i)
          do j = 1, n
            df(i,j) = dfold(i,j)
          end do
        end do

        h = h/2.0_wp
        icon = 0

      end do inner

    ! adjust y-vector

      do i = 1, n
        y(i) = y(i) + (y(i) - ya(i))/7.0_wp
      end do
      x = x + 2*h

    !  compute new stepsize

      qa = 1.0_wp/(qa+1.0e-10_wp)
      if (qa > 3.0_wp) qa = 3.0_wp
      h = qa*h

    ! perform output if appropriate

      nout = nout + 1
      if (mod(nout,nprint) == 0 .or. icon == 1) then
        call out(x,y,iha,qa)
      end if

    ! exit main loop

      if (icon == 1) then
        h0 = h
        return
      end if

    end do outer

  end subroutine

  !> Single-step semi-implicit integration
  !
  subroutine sirk3(n,fun,ipiv,f,y,yk1,yk2,df,h)
    integer, intent(in) :: n
      !! Size of the system of ODEs
    procedure(rhs_sub) :: fun
      !! Function to evaluate the right hand side
    integer, intent(inout) :: ipiv(n)
      !! Integer workspace used to store pivots in the LU factorization
    real(wp), intent(inout) :: f(n)
      !! On input, array of rhs values at beginning of step
    real(wp), intent(inout) :: y(n)
      !! On input contains the current approximation of the dependent variables.
      !! On output contains the approximation at the new time.
    real(wp), intent(inout) :: yk1(n),yk2(n)
      !! Real workspace arrays used in the implicit Runge-Kutta rule
    real(wp), intent(inout) :: df(n,n)
      !! On input contains the Jacobian values J,
      !! On output contains the factorized matrix (I - h a J) = LU
    real(wp), intent(in) :: h
      !! Step size of the independent variable

    integer :: i

    real(wp), parameter :: a  =  0.4358665215084589_wp
    real(wp), parameter :: r1 =  1.037609496131859_wp
    real(wp), parameter :: r2 =  0.8349304838526377_wp
    real(wp), parameter :: r3 = -0.6302020887244523_wp
    real(wp), parameter :: r4 = -0.2423378912600452_wp

    real(wp), parameter :: DF_TOL = 1.0e-12_wp
      !! Jacobian cutoff (elements smaller than DF_TOL are set to zero)

    !
    ! form matrix (I - h a J)
    !
    where (abs(df) > DF_TOL)
      df = -h*a*df
    elsewhere
      df = 0.0_wp
    end where

    do i = 1, n
      df(i,i) = df(i,i) + 1.0_wp
    end do

    !
    ! perform triangular decomposition and evaluate k1
    !
    call lu(df,ipiv)
    call back(df,f,ipiv)

    do i = 1, n
      yk1(i) = h*f(i)
      yk2(i) = y(i) + 0.75_wp * yk1(i)
    end do
    call fun(n,yk2,f)
    call back(df,f,ipiv)

    !
    ! evaluate k2
    !
    do i = 1, n
      yk2(i) = h*f(i)
      y(i) = y(i) + r1 * yk1(i) + r2 * yk2(i)
      yk2(i) = r3 * yk1(i) + r4 * yk2(i)
    end do

    !
    ! evaluate k3
    ! for convenience stored in yk2
    !
    call back(df,yk2,ipiv)
    do i = 1, n
      y(i) = y(i) + yk2(i)
    end do

  end subroutine

end module


module Mod_tem_SigmaTerm
contains
subroutine tem_SigmaTerm(e,sig,grvel,dens,sph,elext,term)
   !Computes the source term from the three field problem sigma:grad_sym(u)
   use Mod_Element
   use typre
   implicit none
   class(FiniteElement) :: e
   real(rp) :: sig((e%ndime-1)*(e%ndime-1)+2), grvel(e%ndime,e%ndime), visco
   real(rp) :: sigcomp(e%ndime,e%ndime)
   real(rp), intent(out) :: elext,term, dens,sph
   integer(ip) :: idime, jdime

   term=0.0_rp

   call tem_SigmaMatrix(e,sig,sigcomp)

   do idime=1,e%ndime
     do jdime=1,e%ndime
         term= term+sigcomp(idime,jdime)*0.5*(grvel(idime,jdime) &
               +grvel(jdime,idime))
     end do
   end do

   term=term/(dens*sph)

   elext=term+elext

end subroutine

subroutine tem_SigmaMatrix(e,sig,sigmatrix)
   !This subroutine convert the vector sigma=(sig_x, sig_y, sig_xy)
   !in a symmetric matrix.
   use Mod_Element
   use typre
   implicit none
   class(FiniteElement) :: e
   real(rp) :: sigmatrix(e%ndime,e%ndime), sig((e%ndime-1)*(e%ndime-1)+2)
   integer(ip) :: idime, jdime, cont

   if(e%ndime==2) then
      cont=0
   else
       cont=e%ndime
   endif

   do idime=1,e%ndime
     do jdime=1,e%ndime
        if (idime==jdime) then
            sigmatrix(idime,jdime)=sig(idime)
         elseif(idime<jdime) then
                sigmatrix(idime,jdime)=sig(3+cont)
                sigmatrix(jdime,idime)=sig(3+cont)
             if(e%ndime==3) cont=cont-1
         endif
     end do
   end do

end subroutine

end module