      SUBROUTINE seva2d(bkx,lx,bky,ly,cs,nx,ny,xl,yl,fs,ier,icalc)
c------------------------------------------------------------------------------
c--  S.Thompson  92/05/18                                                    --
c--    Bicubic spline routines.                                              --
c--    Put together with routines from E.Solano.                             --
c--  SMWolfe     93/12/17                                                    --
c--    Modifed to avoid over-writing the original array.                     --
c--              94/04/28                                                    --
c--    Updated.                                                              --
c------------------------------------------------------------------------------
c  Inputs:
c
c      cs       - array of spline coefficients of dimension (kubicx,
c                 lubicx,kubicy,lubicy) from sets2d.
c
c      bkx, bky - interval coefficients of length lubicx+1 and lubicy+1 from
c                 sets2d.
c
c      lx, ly   - number of terms in bkx and bky from sets2d.
c
c      xl, yl   - the point at which interpolations are desired.
c
c      nx, ny   - grid dimensions
c
c  Outputs:
c
c      fs       - vector containing results depending on icalc:
c                 icalc              fs
c                   1                f
c                   2                fx
c                   3                fy
c                   4                fxy
c                   5                fxx
c                   6                fyy
c
c      ier      - error parameter.
c
c-------------------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
      USE spline_parm
      IMPLICIT NONE
c
      INTEGER :: ier, lx, ly, nx, ny, icalc
      INTEGER :: lef, ibk, jj, mflag, ndummy
c      real*8 cs(kubicx,lubicx,kubicy,lubicy),xl,yl,fs(6),bkx(1),bky(1)
      REAL(rprec) :: xl,yl,fs(6),bkx(lx),bky(ly)
      REAL(rprec) :: cs(kubicx,nx-kubicx+1,kubicy,ny-kubicy+1)
      REAL(rprec) :: ppvalw
c
c  Local Variable Specifications:
c
      REAL(rprec) :: work0(4),work1(4),work2(4), h
      INTEGER, PARAMETER :: n00 = 0, n11 = 1, n22 = 2
c
c  Evaluate function and its partial derivatives at (XL, YL):
c
c
c  First do all the lookup and interpolation stuff.
c  This is the most time consuming part of the evaluation, so
c  don't do more than needed.
c
      CALL interv(bky,ly,yl,lef,mflag)
      CALL interv(bkx,lx,xl,ibk,ndummy)
      h = xl - bkx(ibk)
      DO 41 jj=1,4
         work0(jj) = ppvalw(cs(1,ibk,jj,lef),h,n00)
         IF (icalc.eq.1) GOTO41
         work1(jj) = ppvalw(cs(1,ibk,jj,lef),h,n11)
         IF (icalc.le.4) GOTO41
         work2(jj) = ppvalw(cs(1,ibk,jj,lef),h,n22)
 41   CONTINUE
      h = yl - bky(lef)
      fs(1) = ppvalw(work0,h,n00)
      IF (icalc.eq.1) RETURN
      fs(2) = ppvalw(work1,h,n00)
      IF (icalc.eq.2) RETURN
      fs(3) = ppvalw(work0,h,n11)
      IF (icalc.eq.3) RETURN
      fs(4) = ppvalw(work1,h,n11)
      IF (icalc.eq.4) RETURN
      fs(5) = ppvalw(work2,h,n00)
      IF (icalc.eq.5) RETURN
      fs(6) = ppvalw(work0,h,n22)
C
      RETURN
      END

      SUBROUTINE sets2d(s,cs,x,nx,bkx,lx,y,ny,bky,ly,wk,ier)
c------------------------------------------------------------------------------
c--  S.Thompson  92/05/18                                                    --
c--    Bicubic spline routines.                                              --
c--    Put together with routines from E.Solano.                             --
c--  SMWolfe     93/12/17                                                    --
c--    Modifed to avoid over-writing the original array.                     --
c--              94/04/28                                                    --
c--    Updated.                                                              --
c------------------------------------------------------------------------------
c  Inputs:
c
c      s     - nx by ny array containing the function values at (x,y).
c              This is a 1-d array, k=k=(i-1)*ny+j.
c              Modified ordering k = (j-1)*nx+i
c
c      x, y  - (x,y) location, arrays of length nx and ny.
c
c  Outputs:
c
c      cs    - array of spline coefficients of dimension (kubicx,
c              lubicx,kubicy,lubicy).
c
c      bkx, bky - interval coefficients of length lubicx+1 and lubicy+1.
c
c      lx, ly -   number of terms in bkx and bky.
c
c      ier   - rror parameter.
c
c  Work arrays:
c
c      wk    - of dimension at least nx by ny.
c------------------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
      USE spline_parm
c
c      DIMENSION s(1), x(nx), y(ny), wk(nx,ny),
c     .          xknot(kubicx + nw), yknot(kubicy + nh),
c     .          cs(kubicx, lubicx, kubicy, lubicy),
c     .          bkx(lubicx + 1), bky(lubicy + 1)
      INTEGER :: i, j, k, lx, nx, ny, ly, ier
      REAL(rprec) :: s(nx*ny), x(nx), y(ny), wk(nx,ny),
     .          xknot(kubicx + nx), yknot(kubicy + ny),
     .          cs(kubicx, nx-kubicx+1, kubicy, ny-kubicy+1),
     .          bkx(nx-kubicx + 2), bky(ny-kubicy + 2)
c
c  Set up knots:
c
c     WRITE (6,*) x(38),y(42),s(41*nx+38)*x(38)
      CALL eknot (nx, x, kubicx, xknot)
      CALL eknot (ny, y, kubicy, yknot)
c
c  Save the original, use the work array
c
      DO 10 I=1,NX
      DO 10 j=1,ny
c        k=(i-1)*ny+j
         k=(j-1)*nx+i
  10     wk(i,j) = s(k)
c
c  Calculate spline coefficients:
c
      CALL spl2bc (x, y, nx, ny,xknot, yknot, wk)
c
c  Coefficients stored in bkx, bky, and c:
c
      CALL spl2pp (nx, ny, xknot, yknot, wk, bkx, lx, bky, ly, cs)
c
      RETURN
      END

      SUBROUTINE spl2bc(rgrid,zgrid,mw,mh,rknot,zknot,copy)
calculates the b-spline coeficients
      USE stel_kinds, ONLY: rprec
      IMPLICIT INTEGER*4 (i-n), REAL(rprec) (a-h, o-z)
      PARAMETER (nw=257,nh=257,krord=4,kzord=4)
      REAL(rprec) :: rgrid(mw),zgrid(mh)
c      DIMENSION rknot(nw+krord),zknot(nh+kzord),copy(mw,mh)
      REAL(rprec) :: rknot(mw+krord),zknot(mh+kzord),copy(mw,mh)
c------------------------------------------------------------------
c-- change DIMENSION of work2 and work3 from nw to nh            --
c-- to ensure the cases when nh > nw     ll, 93/04/01            --
c------------------------------------------------------------------
      DIMENSION work1(mw,mh),work2(mh),work3(mh,2*krord-1)
      CALL spli2d(rgrid,copy,rknot,mw,krord,mh,work2,work3,work1,iflag)
      IF (iflag.ne.1) PRINT *,' error in first spli2d, iflag=',iflag
      CALL spli2d(zgrid,work1,zknot,mh,kzord,mw,work2,work3,copy,iflag)
      IF (iflag.ne.1) PRINT *,' error in second spli2d, iflag=',iflag
      RETURN
      END

      SUBROUTINE spl2pp(mw,mh,rknot,zknot,copy,breakr,lr,breakz,lz,coef)
c translates to pp representation
      USE stel_kinds, ONLY: rprec
      IMPLICIT INTEGER*4 (i-n), REAL(rprec) (a-h, o-z)
      PARAMETER (nw=257,nh=257,krord=4,kzord=4)
c      PARAMETER  (lr0=nw-krord+1,lz0=nh-kzord+1)
c      DIMENSION rknot(nw+krord),zknot(nh+kzord)
c      DIMENSION copy(mw,mh),coef(krord,lr0,kzord,lz0)
c      DIMENSION breakr(lr0+1),breakz(lz0+1)
c      DIMENSION work4(krord,nw,nh), work5(nh,krord,lr0)
c     *         ,work6(kzord,kzord,nw,krord)
      DIMENSION rknot(mw+krord),zknot(mh+kzord)
      DIMENSION copy(mw,mh),coef(krord,mw-krord+1,kzord,mh-kzord+1)
      DIMENSION breakr(mw-krord+2),breakz(mh-kzord+2)
      DIMENSION work4(krord,nw,nh), work5(mh,krord,mw-krord+1)
     *         ,work6(kzord,kzord,nw,krord)
      EQUIVALENCE (work4,work6)
      CALL bspp2d(rknot,copy,mw,krord,mh,work4,breakr,work5,lr)
      ndum=lr*krord
      CALL bspp2d(zknot,work5,mh,kzord,ndum    ,work6,breakz,coef,lz)
      RETURN
      END

      SUBROUTINE eknot(n,x,k,xk)
c given the ordered data points x(1)<...<x(n), this SUBROUTINE generates
c a knot sequence with not-a-knot end conditions (like BSNAK from IMSL)
c Some of this is discussed in de Boor(1978), page 211.
      USE stel_kinds, ONLY: rprec
      IMPLICIT INTEGER*4 (i-n), REAL(rprec) (a-h, o-z)
        DIMENSION x(n),xk(n+k)
        INTEGER kh
c
        DO i=1,k
        xk(i)=x(1)
        ii=i+n
        xk(ii)= x(n)+1.e-5
        END DO
        kh=k/2
        k2=kh+kh
        IF (k2.eq.k) THEN
c even k, place knots at data points
        DO i=k+1,n
        xk(i)=x(i-kh)
        END DO
        ELSE
c odd k, place knots in between data points
        DO i=k+1,n
        xk(i)=.5*(x(i-kh)+x(i-1-kh))
        END DO
        END IF
        RETURN
        END

      SUBROUTINE spli2d ( tau, gtau, t, n, k, m, work, q, bcoef, iflag )
calls bsplvb, banfac/slv
c  this is an extended version of  splint , for the use in tensor prod-
c  uct interpolation.
c
c   spli2d  produces the b-spline coeff.s  bcoef(j,.)  of the spline of
c   order  k  with knots  t (i), i=1,..., n + k , which takes on the
c   value  gtau (i,j)  at  tau (i), i=1,..., n ; j=1,..., m .
c
c******  i n p u t  ******
c  tau   array of length  n , containing data point abscissae.
c  a s s u m p t i o n . . .  tau  is strictly increasing
c  gtau(.,j)  corresponding array of length  n , containing data point
c        ordinates, j=1,...,m
c  t     knot sequence, of length  n+k
c  n     number of data points and dimension of spline space  s(k,t)
c  k     order of spline
c  m     number of data sets
c
c******  w o r k   a r e a  ******
c  work  a vector of length  n
c
c******  o u t p u t  ******
c  q     array of order  (n,2*k-1), containing the triangular factoriz-
c        ation of the coefficient matrix of the linear system for the b-
c        coefficients of the spline interpolant.
c           the b-coeffs for the interpolant of an additional data set
c        (tau(i),htau(i)), i=1,...,n  with the same data abscissae can
c        be obtained without going through all the calculations in this
c        routine, simply by loading  htau  into  bcoef  and then execut-
c        ing the    call banslv ( q, n, n, 2*k-1, k, bcoef )
c  bcoef the b-coefficients of the interpolant, of length  n
c  iflag an integer indicating success (= 1)  or failure (= 2)
c        the linear system to be solved is (theoretically) invertible if
c        and only if
c              t(i) .lt. tau(i) .lt. tau(i+k),    all i.
c        violation of this condition is certain to lead to  iflag = 2 .
c
c******  m e t h o d  ******
c     the i-th equation of the linear system  a*bcoef = b  for the b-co-
c  effs of the interpolant enforces interpolation at  tau(i), i=1,...,n.
c  hence,  b(i) = gtau(i), all i, and  a  is a band matrix with  2k-1
c  bands (if it is invertible).
c     the matrix  a  is generated row by row and stored, diagonal by di-
c  agonal, in the  c o l u m n s  of the array  q , with the main diag-
c  onal going into column  k .  see comments in the program below.
c     the banded system is then solved by a call to  banfac (which con-
c  structs the triangular factorization for  a  and stores it again in
c   q ), followed by a call to  banslv (which then obtains the solution
c   bcoef  by substitution).
c     banfac  does no pivoting, since the total positivity of the matrix
c  a  makes this unnecessary.
c
c      integer iflag,k,m,n,i,ilp1mx,j,jj,kpkm1,left,np1
c      real*8 bcoef(m,n),gtau(n,m),q(n,7),t(n+k),tau(n),work(n),taui
      USE stel_kinds, ONLY: rprec
      IMPLICIT INTEGER*4 (i-n), REAL(rprec) (a-h, o-z)
      DIMENSION bcoef(m,n),gtau(n,m),q(n,2*k-1),t(n+k),tau(n),work(n)
c
      nnn=1
      np1 = n + 1
      kpkm1 = 2*k - 1
      left = k
c
c  ***   loop over  i  to construct the  n  interpolation equations
      DO 30 i=1,n
         iindex=i
         taui = tau(iindex)
         ilp1mx = MIN(iindex+k,np1)
c        *** zero out all entries in row  i  of  a (in the 2k-1 bands)
         DO 13 j=1,kpkm1
   13       q(iindex,j) = 0.
c        *** find  left  in the closed interval (i,i+k-1) such that
c                t(left) .le. tau(i) .lt. t(left+1)
c        matrix is singular if this is not possible
         left = MAX(left,i)
         IF (taui .lt. t(left))         GOTO 998
   15       IF (taui .lt. t(left+1))    GOTO 16
            left = left + 1
            IF (left .lt. ilp1mx)       GOTO 15
         left = left - 1
         IF (taui .gt. t(left+1))       GOTO 998
c        *** the i-th equation enforces interpolation at taui, hence
c        a(i,j) = b(j,k,t)(taui), all j. only the  k  entries with  j =
c        left-k+1,...,left actually might be nonzero. these  k  numbers
c        are returned, in  work  (used for temp.storage here), by the
c        following
   16    CALL bsplvb ( t, k, nnn, taui, left, work )
c        we therefore want  work(j) = b(left-k+j)(taui) to go into
c        a(i,left-k+j), i.e., into  q(i,left-i+j), since the i-th row of
c        a  is so stored in the i-th row of  q  that the (i,i)-entry of
c        a  goes into the  k-th  entry of  q.
         jj = left - iindex
         DO 29 j=1,k
            jj = jj+1
            q(iindex,jj) = work(j)
   29    CONTINUE
   30    CONTINUE
c
c     ***obtain factorization of  a  , stored again in  q.
      CALL banfac ( q, n, n, kpkm1, k, iflag )
                                        GOTO (40,999), iflag
c     *** solve  a*bcoef = gtau  by backsubstitution
   40 DO 50 j=1,m
         DO 41 i=1,n
   41       work(i) = gtau(i,j)
         CALL banslv ( q, n, n, kpkm1, k, work )
         DO 50 i=1,n
   50    bcoef(j,i) = work(i)
                                        RETURN
  998 iflag = 2
  999 PRINT 699
  699 FORMAT(41h linear system in  splint  not invertible)
                                        RETURN
      END

      SUBROUTINE bspp2d ( t, bcoef, n, k, m, scrtch, break, coef, l )
calls  bsplvb
c  this is an extended version of  bsplpp  for use with tensor products
c
converts the b-representation  t, bcoef(.,j), n, k  of some spline into
c  its pp-representation  break, coef(j,.,.), l, k ; j=1, ..., m  .
c
c******  i n p u t  ******
c  t     knot sequence, of length  n+k
c  bcoef(.,j) b-spline coefficient sequence, of length  n ;j=1,...,m
c  n     length of  bcoef  and  dimension of spline space  s(k,t)
c  k     order of the spline
c  m     number of data sets
c
c******  w o r k   a r e a  ******
c  scrtch   of size  (k,k,m), needed to contain bcoeffs of a piece of
c        the spline and its  k-1  derivatives   for each of the m sets
c
c******  o u t p u t  ******
c  break breakpoint sequence, of length  l+1, contains (in increasing
c        order) the distinct points in the sequence  t(k), ..., t(n+1)
c  coef(mm,.,.)  array of size (k,n), with  coef(mm,i,j) = (i-1)st der-
c        ivative of  mm-th  spline at break(j) from the right, mm=1,.,m
c  l     number of polynomial pieces which make up the spline in the
c        interval  (t(k), t(n+1))
c
c******  m e t h o d  ******
c     for each breakpoint interval, the  k  relevant b-coeffs of the
c  spline are found and then differenced repeatedly to get the b-coeffs
c  of all the derivatives of the spline on that interval. the spline and
c  its first  k-1  derivatives are then evaluated at the left end
c  point of that interval, using  bsplvb  repeatedly to obtain the val-
c  ues of all b-splines of the appropriate order at that point.
c
      USE stel_kinds, ONLY: rprec
      IMPLICIT INTEGER*4 (i-n), REAL(rprec) (a-h, o-z)
      PARAMETER (kmax=4)
      INTEGER k,l,m,n,   i,j,jp1,kmj,left
      REAL(rprec) :: bcoef(n,m), break(*), coef(m,k,*),scrtch(k,k,m),
     *     t(n+k), biatx(kmax)
      REAL(rprec) :: diff,fkmj,sum
c
      n11=1
      n22=2
      l = 0
      break(1) = t(k)
      DO 50 left=k,n
c        find the next nontrivial knot interval.
         IF (t(left+1) .eq. t(left))    GOTO 50
         l = l + 1
         break(l+1) = t(left+1)
         IF (k .gt. 1)                  GOTO 9
         DO 5 mm=1,m
    5       coef(mm,1,l) = bcoef(left,mm)
                                        GOTO 50
c        store the k b-spline coeff.s relevant to current knot interval
c        in  scrtch(.,1) .
    9    DO 10 i=1,k
            DO 10 mm=1,m
   10          scrtch(i,1,mm) = bcoef(left-k+i,mm)
c        for j=1,...,k-1, compute the k-j b-spline coeff.s relevant to
c        current knot interval for the j-th derivative by differencing
c        those for the (j-1)st derivative, and store in scrtch(.,j+1) .
         DO 20 jp1=2,k
            j = jp1 - 1
            kmj = k - j
            fkmj = REAL(kmj, rprec)
            DO 20 i=1,kmj
               diff = (t(left+i) - t(left+i - kmj))/fkmj
               IF (diff .le. 0.)         GOTO 20
               DO 15 mm=1,m
   15             scrtch(i,jp1,mm) =
     *            (scrtch(i+1,j,mm) - scrtch(i,j,mm))/diff
   20          CONTINUE
c        starting with the one b-spline of order 1 not zero at t(left),
c        find the values at t(left) of the j+1 b-splines of order j+1
c        not identically zero there from those of order j, then combine
c        with the b-spline coeff.s found earlier to compute the (k-j)-
c        th derivative at t(left) of the given spline.
         CALL bsplvb ( t, n11, n11, t(left), left, biatx )
         DO 25 mm=1,m
   25       coef(mm,k,l) = scrtch(1  ,k,mm)
         DO 30 jp1=2,k
            CALL bsplvb ( t, jp1, n22, t(left), left, biatx )
            kmj = k+1 - jp1
            DO 30 mm=1,m
               sum = 0.
               DO 28 i=1,jp1
   28             sum = biatx(i)*scrtch(i,kmj,mm) + sum
   30          coef(mm,kmj,l) = sum
   50    CONTINUE
         RETURN
      END

      SUBROUTINE bsplvb ( t, jhigh, index, x, left, biatx )
calculates the value of all possibly nonzero b-splines at  x  of order
c
c               jout  =  max( jhigh , (j+1)*(index-1) )
c
c  with knot sequence  t .
c
c******  i n p u t  ******
c  t.....knot sequence, of length  left + jout  , assumed to be nonde-
c        creasing.  a s s u m p t i o n . . . .
c                       t(left)  .lt.  t(left + 1)   .
c   d i v i s i o n  b y  z e r o  will result if  t(left) = t(left+1)
c  jhigh,
c  index.....integers which determine the order  jout = max(jhigh,
c        (j+1)*(index-1))  of the b-splines whose values at  x  are to
c        be returned.  index  is used to avoid recalculations when seve-
c        ral columns of the triangular array of b-spline values are nee-
c        ded (e.g., in  bvalue  or in  bsplvd ). precisely,
c                     if  index = 1 ,
c        the calculation starts from scratch and the entire triangular
c        array of b-spline values of orders 1,2,...,jhigh  is generated
c        order by order , i.e., column by column .
c                     if  index = 2 ,
c        only the b-spline values of order  j+1, j+2, ..., jout  are ge-
c        nerated, the assumption being that  biatx , j , deltal , deltar
c        are, on entry, as they were on exit at the previous call.
c           in particular, if  jhigh = 0, then  jout = j+1, i.e., just
c        the next column of b-spline values is generated.
c
c  w a r n i n g . . .  the restriction   jout .le. jmax (= 20)  is im-
c        posed arbitrarily by the dimension statement for  deltal  and
c        deltar  below, but is  n o w h e r e  c h e c k e d  for .
c
c  x.....the point at which the b-splines are to be evaluated.
c  left.....an integer chosen (usually) so that
c                  t(left) .le. x .le. t(left+1)  .
c
c******  o u t p u t  ******
c  biatx.....array of length  jout , with  biatx(i)  containing the val-
c        ue at  x  of the polynomial of order  jout  which agrees with
c        the b-spline  b(left-jout+i,jout,t)  on the interval (t(left),
c        t(left+1)) .
c
c******  m e t h o d  ******
c  the recurrence relation
c
c                       x - t(i)              t(i+j+1) - x
c     b(i,j+1)(x)  =  -----------b(i,j)(x) + ---------------b(i+1,j)(x)
c                     t(i+j)-t(i)            t(i+j+1)-t(i+1)
c
c  is used (repeatedly) to generate the (j+1)-vector  b(left-j,j+1)(x),
c  ...,b(left,j+1)(x)  from the j-vector  b(left-j+1,j)(x),...,
c  b(left,j)(x), storing the new values in  biatx  over the old. the
c  facts that
c            b(i,1) = 1  if  t(i) .le. x .lt. t(i+1)
c  and that
c            b(i,j)(x) = 0  unless  t(i) .le. x .lt. t(i+j)
c  are used. the particular organization of the calculations follows al-
c  gorithm  (8)  in chapter x of the text.
c
      USE stel_kinds, ONLY: rprec
      IMPLICIT INTEGER*4 (i-n), REAL(rprec) (a-h, o-z)
      PARAMETER(jmax = 4)
      INTEGER :: index, jhigh, left, i, j=1, jp1
      REAL(rprec) :: x,saved,term
c      real*8 biatx(jhigh),t(1),x,
      DIMENSION deltal(jmax),deltar(jmax)
      DIMENSION biatx(jhigh), t(left+jhigh)
current fortran standard makes it impossible to specify the length of
c  t  and of  biatx  precisely without the introduction of otherwise
c  superfluous additional arguments.
      SAVE deltal,deltar  ! (valid in fortran 77)
c
                                        GOTO (10,20), index
   10 j = 1
      biatx(1) = 1.
      IF (j .ge. jhigh)                 GOTO 99
c
   20    jp1 = j + 1
         deltar(j) = t(left+j) - x
         deltal(j) = x - t(left+1-j)
         saved = 0.
         DO 26 i=1,j
            term = biatx(i)/(deltar(i) + deltal(jp1-i))
            biatx(i) = saved + deltar(i)*term
   26       saved = deltal(jp1-i)*term
         biatx(jp1) = saved
         j = jp1
         IF (j .lt. jhigh)              GOTO 20
c
   99                                   RETURN
      END

      FUNCTION ppvalw (coef, x, jd )
C-----------------------------------------------------------------------
C  Modified for optimization by S.J. Thompson, 30-Aug-1993
c  Revised to eliminate call to interv by S.M.Wolfe, 17-Dec-1993
c          and to use ASF's for evaluation
c  This routine performs only the innermost guts of the spline evaluation
c  Assumes k=4 (cubic spline only). No other cases considered.
c does not call  interv
calculates value at  x  of  jd-th derivative of pp fct from pp-repr
c
c******  i n p u t  ****** to PPVALU, on which this is based.
c  break, coef, l, k.....forms the pp-representation of the function  f
c        to be evaluated. specifically, the j-th derivative of  f  is
c        given by
c
c     (d**j)f(x) = coef(j+1,i) + h*(coef(j+2,i) + h*( ... (coef(k-1,i) +
c                             + h*coef(k,i)/(k-j-1))/(k-j-2) ... )/2)/1
c
c        with  h = x - break(i),  and
c
c       i  =  max( 1 , max( j ;  break(j) .le. x , 1 .le. j .le. l ) ).
c
c  x.....the point at which to evaluate.
c        as used here, x is the distance from the break, not the absolute
c        position.
c  jd.....integer*4 giving the order of the derivative to be evaluat-
c        ed.  a s s u m e d  to be zero or positive.
c
c******  o u t p u t  ******
c  ppvalw.....the value of the (jd)-th derivative of  f  at  x.
c
c******  m e t h o d  ******
c     the interval index  i , appropriate for  x , is found through a
c  call to  interv . the formula above for the  jd-th derivative
c  of  f  is then evaluated (by nested multipication).
c
C-----------------------------------------------------------------------
C   Variable declarations.
C-----------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
      IMPLICIT INTEGER*4 (i-n), REAL(rprec) (a-h, o-z)
      INTEGER, INTENT(in) :: jd
      REAL(rprec) :: ppvalw,x
      REAL(rprec) :: coef(4)
c----------------------------------------------------------------------
c ASF's may be slightly more efficient than the alternative
c----------------------------------------------------------------------
      d2(xx) = coef(4)*xx + coef(3)
      d1(xx) = (coef(4)*xx/2 + coef(3))*xx + coef(2)
      d0(xx) = ((coef(4)*xx/3 + coef(3))*xx/2 +
     .           coef(2))*xx + coef(1)
C-----------------------------------------------------------------------
C   Derivatives of order k or higher are identically zero.
C-----------------------------------------------------------------------
C   Evaluate jd-th derivative of i-th polynomial piece at x .
C-----------------------------------------------------------------------
      GOTO(1,2,3) jd+1
      ppvalw = 0.
      PRINT *, 'Error (ppvalw): JD must be 0, 1, or 2.'
      PRINT *, 'Execution terminated.'
      RETURN
 1    ppvalw = d0(x)	! k = 4 , jd = 0
      RETURN
 2    ppvalw = d1(x)	! k = 4 , jd = 1
      RETURN
 3    ppvalw = d2(x)	! k = 4 , jd = 2
      RETURN
      END
C
      SUBROUTINE banslv ( a, nrow, n, ndiag, middle, b )
      USE stel_kinds, ONLY: rprec
      IMPLICIT INTEGER*4 (i-n), REAL(rprec) (a-h, o-z)
      DIMENSION a(nrow,ndiag),b(n)
      IF (n .eq. 1)                     GOTO 21
      ilo = middle - 1
      IF (ilo .lt. 1)                   GOTO 21
      DO 19 i=2,n
         jmax = MIN(i-1,ilo)
         DO 19 j=1,jmax
   19       b(i) = b(i) - b(i-j)*a(i,middle-j)
c
   21 ihi = ndiag-middle
      DO 30 i=n,1,-1
         jmax = MIN(n-i,ihi)
         IF (jmax .lt. 1)               GOTO 30
         DO 25 j=1,jmax
   25       b(i) = b(i) - b(i+j)*a(i,middle+j)
   30    b(i) = b(i)/a(i,middle)
                                        RETURN
      END

      SUBROUTINE banfac ( a, nrow, n, ndiag, middle, iflag )
      USE stel_kinds, ONLY: rprec
      IMPLICIT INTEGER*4 (i-n), REAL(rprec) (a-h, o-z)
      DIMENSION a(nrow,ndiag)
      iflag = 1
      ilo = middle - 1
      IF (ilo)                          999,10,19
   10 DO 11 i=1,n
         IF(a(i,1) .eq. 0.)             GOTO 999
   11    CONTINUE
                                        RETURN
   19 ihi = ndiag - middle
      IF (ihi)                          999,20,29
   20 DO 25 i=1,n
         IF (a(i,middle) .eq. 0.)       GOTO 999
         jmax = MIN(ilo,n-i)
         IF (jmax .lt. 1)               GOTO 25
         DO 23 j=1,jmax
   23       a(i+j,middle-j) = a(i+j,middle-j)/a(i,middle)
   25    CONTINUE
                                        RETURN
   29 DO 50 i=1,n
         diag = a(i,middle)
         IF (diag .eq. 0.)              GOTO 999
         jmax = MIN(ilo,n-i)
         IF(jmax .lt. 1)                GOTO 50
         kmax = MIN(ihi,n-i)
         DO 33 j=1,jmax
            mmj = middle-j
            a(i+j,mmj) = a(i+j,mmj)/diag
            DO 33 k=1,kmax
   33          a(i+j,mmj+k) = a(i+j,mmj+k) - a(i+j,mmj)*a(i,middle+k)
   50    CONTINUE
                                        RETURN
  999 iflag = 2
                                        RETURN
      END

      SUBROUTINE interv ( xt, lxt, x, left, mflag )
computes  left = max( i ; 1 .le. i .le. lxt  .and.  xt(i) .le. x )  .
c
c******  i n p u t  ******
c  xt.....a real*8 sequence, of length  lxt , assumed to be nondecreasing
c  lxt.....number of terms in the sequence  xt .
c  x.....the point whose location with respect to the sequence  xt  is
c        to be determined.
c
c******  o u t p u t  ******
c  left, mflag.....both integers, whose value is
c
c   1     -1      if               x .lt.  xt(1)
c   i      0      if   xt(i)  .le. x .lt. xt(i+1)
c  lxt     1      if  xt(lxt) .le. x
c
c        in particular,  mflag = 0 is the 'usual' case.  mflag .ne. 0
c        indicates that  x  lies outside the halfopen interval
c        xt(1) .le. y .lt. xt(lxt) . the asymmetric treatment of the
c        interval is due to the decision to make all pp functions cont-
c        inuous from the right.
c
c******  m e t h o d  ******
c  the program is designed to be efficient in the common situation that
c  it is called repeatedly, with  x  taken from an increasing or decrea-
c  sing sequence. this will happen, e.g., when a pp function is to be
c  graphed. the first guess for  left  is therefore taken to be the val-
c  ue returned at the previous call and stored in the  l o c a l  varia-
c  ble  ilo . a first check ascertains that  ilo .lt. lxt (this is nec-
c  essary since the present call may have nothing to do with the previ-
c  ous call). then, if  xt(ilo) .le. x .lt. xt(ilo+1), we set  left =
c  ilo  and are done after just three comparisons.
c     otherwise, we repeatedly double the difference  istep = ihi - ilo
c  while also moving  ilo  and  ihi  in the direction of  x , until
c                      xt(ilo) .le. x .lt. xt(ihi) ,
c  after which we use bisection to get, in addition, ilo+1 = ihi .
c  left = ilo  is then returned.
c
      USE stel_kinds, ONLY: rprec
      IMPLICIT INTEGER*4 (i-n), REAL(rprec) (a-h, o-z)
      INTEGER left,lxt,mflag,   ihi,ilo,istep,middle
      REAL(rprec) :: x
      DIMENSION xt(lxt)
      DATA ilo /1/
c     save ilo  (a valid fortran statement in the new 1977 standard)
      ihi = ilo + 1
      IF (ihi .lt. lxt)                 GOTO 20
         IF (x .ge. xt(lxt))            GOTO 110
         IF (lxt .le. 1)                GOTO 90
         ilo = lxt - 1
         ihi = lxt
c
   20 IF (x .ge. xt(ihi))               GOTO 40
      IF (x .ge. xt(ilo))               GOTO 100
c
c              **** now x .lt. xt(ilo) . decrease  ilo  to capture  x .
   30 istep = 1
   31    ihi = ilo
         ilo = ihi - istep
         IF (ilo .le. 1)                GOTO 35
         IF (x .ge. xt(ilo))            GOTO 50
         istep = istep*2
                                        GOTO 31
   35 ilo = 1
      IF (x .lt. xt(1))                 GOTO 90
                                        GOTO 50
c              **** now x .ge. xt(ihi) . increase  ihi  to capture  x .
   40 istep = 1
   41    ilo = ihi
         ihi = ilo + istep
         IF (ihi .ge. lxt)              GOTO 45
         IF (x .lt. xt(ihi))            GOTO 50
         istep = istep*2
                                        GOTO 41
   45 IF (x .ge. xt(lxt))               GOTO 110
      ihi = lxt
c
c           **** now xt(ilo) .le. x .lt. xt(ihi) . narrow the interval.
   50 middle = (ilo + ihi)/2
      IF (middle .eq. ilo)              GOTO 100
c     note. it is assumed that middle = ilo in case ihi = ilo+1 .
      IF (x .lt. xt(middle))            GOTO 53
         ilo = middle
                                        GOTO 50
   53    ihi = middle
                                        GOTO 50
c**** set output and return.
   90 mflag = -1
      left = 1
                                        RETURN
  100 mflag = 0
      left = ilo
                                        RETURN
  110 mflag = 1
      left = lxt
                                        RETURN
      END
c
c   This routine is required IF the CVS revision numbers are to
c   survive an optimization.
c
c
c   $Date: 2005/08/10 15:39:26 $ $Author: hirshman $
c
      SUBROUTINE spline_rev(i)
      character*10 s
      IF( i .eq. 0) s =
     .'@(#)$RCSfile: spline.f,v $ $Revision: 1.18 $\000'
      RETURN
      END


      DOUBLE PRECISION FUNCTION ANGVEC(VEC1,VEC2)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  FIND THE ANGLE BETWEEN TWO 3-VECTORS.
C
C  VAR  DIM  TYPE  I/O  DESCRIPTION
C  ---  ---  ----  ---  -----------
C
C  VEC1  3   R*8    I   ONE OF THE TWO VECTORS. MAY HAVE ANY MAGNITUDE.
C
C  VEC2  3   R*8    I   THE OTHER VECTOR. ANY MAGNITUDE.
C
C  ANGVEC    R*8    O   THE ANGLE BETWEEN THE VECTORS. IN RADIANS.
C                       IF A VECTOR HAS ZERO MAGNITUDE, THE ANGLE IS
C                       RETURNED AS ZERO.
C
C                       THIS IS A FUNCTION SUBROUTINE AND IS USED AS:
C                                  SEP=ANGVEC(VEC1,VEC2)
C
C*******************************************************************
C
C  CODED BY CHARLIE PETRUZZO 6/81.
C
C  MODIFIED........
C
C*******************************************************************
C
C
      REAL*8 VEC1(3),VEC2(3)
C
C  GET THE PRODUCT OF THE MAGNITUDES OF THE VECTORS.
      V1SQ=VEC1(1)**2 + VEC1(2)**2 + VEC1(3)**2
      V2SQ=VEC2(1)**2 + VEC2(2)**2 + VEC2(3)**2
      V1V2=DSQRT(V1SQ*V2SQ)
C
C  GET THE ANGLE. TEMP=COS(ANGLE).
      TEMP=1.D0
      IF(V1V2.NE.0.D0) TEMP=DOT(VEC1,VEC2)/V1V2
C     DABS(TEMP) MAY BE >1.D0 BECAUSE OF ROUNDING. MAKE IT +/- 1.D0
      IF(DABS(TEMP).GE.1.D0) TEMP=DSIGN(1.D0,TEMP)
      ANGVEC=DACOS(TEMP)
C
      RETURN
      END


!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_FUNC_H

    USE MR_KINDS

    USE MR_DEF_CONSTS_N_REF_PARS

    USE MR_MOC_BED_STOR

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_FUNC_H

!***********************************************************************************************************************************

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_FUNC_H( HSTOR , ZS , ZB ) RESULT( H )

   !DIR$ ATTRIBUTES VECTOR :: MR_FUNC_H

    IMPLICIT NONE

    REAL(FDRD_KIND) , INTENT(IN ) :: HSTOR , ZS , ZB

    REAL(FDRD_KIND) :: HBELOW

    REAL(FDRD_KIND) :: H

    HBELOW = HSTOR * ( 1.0 - 2.0 * CFACTSTOR * CBASESTOR / (1.0-CBASESTOR) )

    IF( ZS * SURPAR <= ZB - CFACTSTOR*HSTOR ) THEN
      H = EPSILON(H)
    ELSE IF( ZS * SURPAR <= ZB - HBELOW ) THEN
      H = CBASESTOR * ( ZS * SURPAR - ZB + CFACTSTOR*HSTOR )
    ELSE IF( ZS * SURPAR <= ZB + HSTOR  ) THEN
      H = CBASESTOR * ( ZS * SURPAR - ZB + CFACTSTOR*HSTOR )   &
      & + 0.5 * (1.0-CBASESTOR) * ( ZS * SURPAR - ZB + HBELOW )**2 / MAX( HSTOR + HBELOW , EPSILON(H) )
    ELSE
      H = ZS * SURPAR - ZB
    END IF

  END FUNCTION MR_FUNC_H

  END MODULE MR_MOD_FUNC_H


! Module that exposes the initial (physical) parameters after parsing them from a file

module mod_read_parameters
  use mod_constants

  implicit none

  type(parameters) :: params  ! Contains the initial parameters of the black hole accretion disk (see mod_constants.f90 for details)
  type(adim_state) :: x_state ! Contains the x and Omega tables
  type(dim_state)  :: r_state ! Contains the r and Omega_r tables
  type(state_zero) :: state_0
  type(state_ic)   :: IC      ! Contains the initial parmaters for Temparature end Sigma

  private

  public :: get_parameters, params, x_state, r_state, state_0, IC

contains

  ! Read parameter from the input file: ./input_parameter.dat
  subroutine get_parameters()
    implicit none

    ! Internal variables
    real(x_precision) :: X,Y,Z   ! Chemical composition : X+Y+Z = 1
    real(x_precision) :: mu      ! Mean molecular mass
    real(x_precision) :: rmax    ! Maximum considered radius (in rs)
    real(x_precision) :: rmin    ! Minimal radius (in rs)
    real(x_precision) :: mp      ! Proton mass in cgs
    real(x_precision) :: Ledd    ! Eddington luminosity
    real(x_precision) :: c2      ! Light speed to the square
    real(x_precision) :: rs      ! Schwarzschild radius
    real(x_precision) :: t_dyn   ! Dynamic time
    real(x_precision) :: falpha, fMdot, fM
    real(x_precision), dimension(n_cell) :: f10, fr
    integer(kind=4)   :: ios     ! I/O test variable
    integer           :: i       ! Cells iteration variable
    character(len=50) :: line    ! String reading variable

    ! Open file
    open(unit=11, file="./input_parameter.dat", action="read", status="old", iostat=ios)
    if (ios /= 0) stop "OPENING input_parameter.dat ERROR"

    ! Read parameters
    read(11,fmt=*) line, params%M
    read(11,fmt=*) line, rmax
    read(11,fmt=*) line, params%Mdot
    read(11,fmt=*) line, params%alpha
    read(11,fmt=*) line, X
    read(11,fmt=*) line, Y

    ! Close the file
    close(11)

    ! Compute mp
    mp = kb / R

    ! Compute Ledd
    Ledd = 4._x_precision * pi * G * mp * c / thomson

    ! Process M and M_dot in cgs, M_dot_crit = 12 * Ledd * M / c^2
    params%M         = params%M * M_sun
    params%Mdot_crit =  12._x_precision * Ledd * params%M / c**2
    params%Mdot      = params%Mdot * params%Mdot_crit

    ! Compute c2 and rs
    c2 = c**2
    rs = 2._x_precision * G * params%M / c2

    ! Compute T_0 and Omega_0
    state_0%T_0     = (params%Mdot * c2 / (sqrt(27.0) * 48._x_precision * pi * rs**2 * stefan))**0.25_x_precision
    state_0%Omega_0 = sqrt(G * params%M / rs**3)

    ! Compute mu
    Z  = 1._x_precision - X - Y
    mu = 1._x_precision / (2._x_precision*X + 3._x_precision*Y/4._x_precision + Z/2._x_precision)

    ! Process RTM
    params%RTM = R * state_0%T_0 / mu

    ! Process kappa_e
    params%kappa_e = 0.2_x_precision * (1._x_precision + X)

    ! Process dx
    rmin      = 3._x_precision
    params%dx = (sqrt(rmax) - sqrt(rmin)) / n_cell

    ! Process x_state, r_state
    do i = 1, n_cell
      x_state%x(i)       = sqrt(rmin) + i * params%dx
      r_state%r(i)       = x_state%x(i)**2 * rs
      x_state%Omega(i)   = 1._x_precision / x_state%x(i)**3
      r_state%Omega_r(i) = x_state%Omega(i) * state_0%Omega_0
    end do

    ! Process t_nu
    params%t_nu = 0.28 * params%alpha**(-0.8_x_precision) * (params%Mdot / params%Mdot_crit)**(-.3_x_precision) * &
                  (params%M / M_sun)**1.2_x_precision * (r_state%r(n_cell) / (3*rs))**1.25_x_precision * &
                  (1 - (r_state%r(n_cell)/(3 * rs))**(-0.5_x_precision))**(-1.2_x_precision)

    ! Process t_dyn
    t_dyn       = 7.2 * 10**(-5._x_precision) * (params%M / M_sun) * (r_state%r(n_cell) / (3 * rs))**1.5_x_precision

    ! Process t_T
    params%t_T  = t_dyn / params%alpha

    !-----------------------------------------------------------
    !--Process of initial parmameter for Temperature and Sigma--
    !-----------------------------------------------------------
    ! Process terms needed to compute T_ci and Sig_ci
    falpha = params%alpha**(-0.2_x_precision)
    fMdot  = (1.e-1_x_precision * params%Mdot / 1.e16_x_precision)**0.1_x_precision
    fM     = (params%M / M_sun)**0.25_x_precision
    fr     = (r_state%r / 1.e10_x_precision)**(-0.75_x_precision)
    f10    = (1._x_precision - sqrt(3._x_precision) / x_state%x)**0.1_x_precision

    ! Process initial condition for T
    IC%T     = 1.4e4_x_precision * falpha * (fMdot * f10)**3 * fM * fr

    ! Process initial condition for Sigma
    IC%Sigma = 5.2_x_precision * falpha**4 * (fMdot * f10)**7 * fM * fr

    ! Process initial condition for H
    IC%H     = 1.7e8_x_precision * falpha**0.5_x_precision * (fMdot / (fr * fM))**1.5_x_precision * f10**6

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

    ! Compute the initial variables needed for dimensionless variables
    !state_0%Omega_0 = sqrt(G * params%M / rs**3)
    state_0%temps_0 = 2._x_precision / state_0%Omega_0
    state_0%nu_0    = 2._x_precision * state_0%Omega_0 * rs**2 / 3._x_precision
    state_0%v_0     = state_0%Omega_0 * rs
    state_0%cs_0    = state_0%v_0
    state_0%S_0     = params%Mdot / (3._x_precision * pi * state_0%nu_0)
    state_0%H_0     = rs
    state_0%Mdot_0  = params%Mdot
    state_0%rho_0   = state_0%S_0 / (2._x_precision * rs)
    !state_0%T_0     = (params%Mdot * c2 / (sqrt(27.0) * 48._x_precision * pi * rs**2 * stefan))**0.25_x_precision
    state_0%Fz_0    = state_0%S_0 * state_0%Omega_0 / 4._x_precision
    state_0%Cv_0    = 1._x_precision / state_0%T_0
    state_0%Pgaz_0  = state_0%rho_0 * params%RTM
    state_0%Prad_0  = cst_rad * state_0%T_0**4 / 3._x_precision
    state_0%beta_0  = state_0%Prad_0 / state_0%Pgaz_0
    state_0%Q_0     = 1._x_precision / state_0%temps_0

    ! Display parameters
    write(*,"('#           Input Parameters             ')")
    write(*,"('#****************************************')")
    write(*,"('# BH_mass     =',1p,E12.4)") params%M
    write(*,"('# r_s         =',1p,E12.4)") rs
    write(*,"('# r_min       =',1p,E12.4)") rmin * state_0%H_0
    write(*,"('# r_max       =',1p,E12.4)") rmax * state_0%H_0
    write(*,"('# L_edd       =',1p,E12.4)") Ledd
    write(*,"('# Mdot_crit   =',1p,E12.4)") params%Mdot_crit
    write(*,"('# fdot        =',1p,E12.4)") params%Mdot / params%Mdot_crit
    write(*,"('# alpha       =',1p,E12.4)") params%alpha
    write(*,"('# X           =',1p,E12.4)") X
    write(*,"('# Y           =',1p,E12.4)") Y
    write(*,"('# mu          =',1p,E12.4)") mu
    write(*,"('# t_nu        =',1p,E12.4)") params%t_nu
    write(*,"('# t_T         =',1p,E12.4)") params%t_T
    write(*,"('#****************************************')")
    write(*,"('#           Initial Variables            ')")
    write(*,"('#****************************************')")
    write(*,"('# Omega_0     =',1p,E12.4)") state_0%Omega_0
    write(*,"('# t_0         =',1p,E12.4)") state_0%temps_0
    write(*,"('# nu_0        =',1p,E12.4)") state_0%nu_0
    write(*,"('# v_0         =',1p,E12.4)") state_0%v_0
    write(*,"('# cs_0        =',1p,E12.4)") state_0%cs_0
    write(*,"('# Sigma_0     =',1p,E12.4)") state_0%S_0
    write(*,"('# H_0         =',1p,E12.4)") state_0%H_0
    write(*,"('# Mdot_0      =',1p,E12.4)") state_0%Mdot_0
    write(*,"('# rho_0       =',1p,E12.4)") state_0%rho_0
    write(*,"('# T_0         =',1p,E12.4)") state_0%T_0
    write(*,"('# Fz_0        =',1p,E12.4)") state_0%Fz_0
    write(*,"('# Cv_0        =',1p,E12.4)") state_0%Cv_0
    write(*,"('# P_gaz_0     =',1p,E12.4)") state_0%Pgaz_0
    write(*,"('# P_rad_0     =',1p,E12.4)") state_0%Prad_0
    write(*,"('# Q_0         =',1p,E12.4)") state_0%Q_0
    write(*,"('#****************************************')")

  end subroutine get_parameters

end module mod_read_parameters


!-------------------------------------------------------------------------------
! Copyright (c) 2021, Whitman T. Dailey
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
! 1. Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
! 3. Neither the name of the copyright holder nor the names of its
!    contributors may be used to endorse or promote products derived from
!    this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!-------------------------------------------------------------------------------
Module PlanckFs

    Implicit None
    Private
    Public :: Sx
    Public :: Planck
    Public :: PlanckCDF
    Public :: PlanckGroups_byArea
    Public :: PlanckGroups_byWidth
    Public :: PlanckGroups_byList

Contains

Function Sx(hv,kT,Yx)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: Sx
    Real(dp), Intent(In) :: hv
    Real(dp), Intent(In) :: kT
    Real(dp), Intent(In) :: Yx

    !Bridgman 5-6 (generalized)
    Sx = Yx * Planck(hv,kT)
End Function Sx

Function Planck(hv,kT) Result(p)
    !Returns the intensity at E [keV] of a normalized Plankian blackbody with temperature kT [keV]
    Use Kinds, Only: dp
    Use Global, Only: Pi
    Implicit None
    Real(dp) :: p
    Real(dp), Intent(In) :: hv
    Real(dp), Intent(In) :: kT
    Real(dp):: b,b_sq
    Real(dp), Parameter :: c1 =  1._dp / 47900160._dp
    Real(dp), Parameter :: c2 = -1._dp / 1209600._dp
    Real(dp), Parameter :: c3 =  1._dp / 30240._dp
    Real(dp), Parameter :: c4 = -1._dp / 720._dp
    Real(dp), Parameter :: c5 =  1._dp / 12._dp
    Real(dp), Parameter :: c6 = -1._dp / 2._dp

    b = hv / kT
    If (b .LE. 0._dp) Then
        p = 0._dp
        Return
    Else If (b .LT. 0.1_dp) Then
        !for small values of z use a series expansion approximation
        !No doubt, a more compact or recursive form exists, but the following correctly accumulates ~20 digits of precision
        b_sq = b**2
        p = b_sq * c1 + c2
        p = p * b_sq + c3
        p = p * b_sq + c4
        p = p * b_sq + c5
        p = p * b + c6
        p = p * b + 1._dp
        p = p * b_sq * 15._dp / (kT*(Pi**4))
    Else
        !Bridgman 5-7
        p = 15._dp * hv**3 / ((Exp(b) - 1._dp) * (kT*pi)**4)
    End If
End Function Planck

Function PlanckCDF(hv,kT) Result(P)
    !Returns the cumulative density from zero to E [keV] of the normalized Plankian blackbody with temperature kT [keV]
    Use Kinds, Only: dp
    Use Quadratures, Only: Romberg_Quad
    Implicit None
    Real(dp) :: P
    Real(dp), Intent(In) :: hv
    Real(dp), Intent(In) :: kT

    If (hv .LE. 0._dp) Then
        P = 0._dp
    Else
        P = Romberg_Quad(PlanckkT,0._dp,hv,rTol=1.E-14_dp,aTol=0._dp)
    End If
Contains
    Function PlanckkT(hv) Result(p)
    !Returns the intensity at E [keV] of a normalized Plankian blackbody with temperature kT [keV]
    !(uses the LOCAL value of kT from the scope of the containing function)
        Use Kinds, Only: dp
        Implicit None
        Real(dp) :: p
        Real(dp), Intent(In) :: hv

        p = Planck(hv,kT)
    End Function PlanckkT
End Function PlanckCDF

Subroutine PlanckGroups_byWidth(kT,Emin,Emax,n,Eb,Ea)
    Use Kinds, Only: dp
    Use Quadratures, Only: Romberg_Quad
    Implicit None
    Real(dp), Intent(In) :: kT
    Real(dp), Intent(In) :: Emin,Emax
    Integer, Intent(In) :: n
    Real(dp), Allocatable, Intent(Out) :: Eb(:) !list of energy boundaries
    Real(dp), Allocatable, Intent(Out) :: Ea(:) !list of bin areas
    Real(dp) :: dE
    Integer :: i

    Allocate(Eb(0:n))
    Eb = -1._dp
    Allocate(Ea(1:n))
    Ea = -1._dp
    dE = (Emax - Emin) / Real(n,dp)
    Eb(0) = Emin
    Do i = 1,n-1
        Eb(i) = Emin + Real(i,dp) * dE
        Ea(i) = Romberg_Quad(PlanckkT,Eb(i-1),Eb(i),rTol=1.E-14_dp,aTol=0._dp)
    End Do
    Eb(n) = Emax
    Ea(n) = Romberg_Quad(PlanckkT,Eb(n-1),Eb(n),rTol=1.E-14_dp,aTol=0._dp)
    Ea = Ea / Sum(Ea)
Contains
    Function PlanckkT(hv) Result(p)
    !Returns the intensity at E [keV] of a normalized Plankian blackbody with temperature kT [keV]
    !(uses the LOCAL value of kT from the scope of the containing function)
        Use Kinds, Only: dp
        Implicit None
        Real(dp) :: p
        Real(dp), Intent(In) :: hv

        p = Planck(hv,kT)
    End Function PlanckkT
End Subroutine PlanckGroups_byWidth

Subroutine PlanckGroups_byList(kT,n,E_list,Eb,Ea,lists_centers)
    Use Kinds, Only: dp
    Use Quadratures, Only: Romberg_Quad
    Implicit None
    Real(dp), Intent(In) :: kT
    Integer, Intent(InOut) :: n
    Real(dp), Intent(In) :: E_list(1:n) !list of energies of interest
    Real(dp), Allocatable, Intent(Out) :: Eb(:) !list of energy boundaries
    Real(dp), Allocatable, Intent(Out) :: Ea(:) !list of bin areas
    Logical, Optional, Intent(In) :: lists_centers
    Integer :: i
    Logical :: put_bounds

    put_bounds = .TRUE.  !by default, default assume we were passed a list of boundaries
    If (Present(lists_centers)) put_bounds = .NOT.lists_centers
    If (put_bounds) Then !E_list contains a list of boundaries
        !adjust n, and transcribe into the boundary list
        n = n - 1
        Allocate(Eb(0:n))
        Eb(0:n) = E_list(1:n+1)
    Else !E_list contains a list of bin centers
        !compute bin boundaries off from the list of centers
        Allocate(Eb(0:n))
        Eb = -1._dp
        Eb(0) = E_list(1) - 0.5_dp * (E_list(2) - E_list(1))
        If(Eb(0) .LT. 0._dp) Eb(0) = 0._dp !no negative energies
        Do i = 1,n-1
            Eb(i) = E_list(i) + 0.5_dp * (E_list(i+1) - E_list(i))
        End Do
        Eb(n) = E_list(n) + 0.5_dp * (E_list(n) - E_list(n-1))
    End If
    Allocate(Ea(1:n))
    Ea = -1._dp
    Do i = 1,n
        Ea(i) = Romberg_Quad(PlanckkT,Eb(i-1),Eb(i),rTol=1.E-14_dp,aTol=0._dp)
    End Do
    Ea = Ea / Sum(Ea)
Contains
    Function PlanckkT(hv) Result(p)
    !Returns the intensity at E [keV] of a normalized Plankian blackbody with temperature kT [keV]
    !(uses the LOCAL value of kT from the scope of the containing function)
        Use Kinds, Only: dp
        Implicit None
        Real(dp) :: p
        Real(dp), Intent(In) :: hv

        p = Planck(hv,kT)
    End Function PlanckkT
End Subroutine PlanckGroups_byList

Subroutine PlanckGroups_byArea(kT,Emin,Emax,n,Eb,Ea)
    Use Kinds, Only: dp
    Use Quadratures, Only: Romberg_Quad
    Use Root_Solvers, Only: RootIllinois
    Implicit None
    Real(dp), Intent(In) :: kT
    Real(dp), Intent(In) :: Emin,Emax
    Integer, Intent(In) :: n
    Real(dp), Allocatable, Intent(Out) :: Eb(:) !list of energy boundaries
    Real(dp), Allocatable, Intent(Out) :: Ea(:) !list of bin areas
    Real(dp) :: dA
    Real(dp) :: E1,E2
    Integer :: i

    Allocate(Eb(0:n))
    Eb = -1._dp
    Allocate(Ea(1:n))
    Ea = -1._dp
    dA = Romberg_Quad(PlanckkT,Emin,Emax,rTol=1.E-14_dp,aTol=0._dp) / Real(n,dp)
    Eb(0) = Emin
    Do i = 1,n-1
        E1 = Eb(i-1)
        E2 = Emax
        Eb(i) = RootIllinois(PlanckArea,E1,E2,rTol=1.E-15_dp,aTol=1.E-15_dp)
    End Do
    Eb(n) = Emax
    Ea = dA
    Ea = Ea / Sum(Ea)
Contains
    Function PlanckkT(hv) Result(p)
    !Returns the intensity at E [keV] of a normalized Plankian blackbody with temperature kT [keV]
    !(uses the LOCAL value of kT from the scope of the containing function)
        Use Kinds, Only: dp
        Implicit None
        Real(dp) :: p
        Real(dp), Intent(In) :: hv

        p = Planck(hv,kT)
    End Function PlanckkT
    Function PlanckArea(hv) Result(A)
        Use Kinds, Only: dp
        Implicit None
        Real(dp) :: A
        Real(dp), Intent(In) :: hv

        A = Romberg_Quad(PlanckkT,Eb(i-1),hv,rTol=1.E-14_dp,aTol=0._dp) - dA
    End Function PlanckArea
End Subroutine PlanckGroups_byArea

End Module PlanckFs


      subroutine CAUCHY_PPART2(X, NX, XRES, FX, PINT)

!     -----------------------------------------------
!     Returns principal part of int(x,fx/(x-xres))
!     -----------------------------------------------

      implicit none

      integer, intent(IN):: NX
      real, dimension(NX), intent(IN):: X, FX
      real, intent(IN):: XRES
      real, intent(OUT):: PINT

      real:: CXP,CXM,FXP,FXM,LLOGF,XMAX,XMIN
      real:: CXF,DXF,DX
      real, dimension(NX):: LXF,INTGD,FXPP
      integer:: IX, IXM1, IXP1

      integer lx
      real fxa(1000), xa(1000)

!     ----------------
!     input parameters
!     ----------------
	external df_dv !function
      real :: a,b !uper, lower limits
	real :: c !location of singular value
      real :: epsabs = 0.1 !absolute accuracy
      real :: epsrel = 0.1  !relative accuracy\
      integer, parameter :: limit = 2000  !max number of function evaluations

!     ------------------
!     return parameters
!     ------------------
      real :: result !approximation to integral
      real :: abserr !estimate of modulus of the absolute error
	integer :: neval !number of integrand evaluations
      integer :: ier  !error code on return 0 = normal
	real, dimension(limit) ::  alist, blist, rlist, elist  !integral stuff
      integer, dimension(limit) :: iord !pointer to error stuff
	integer :: last !actual number of subintervals

      real cauchy_cb(2002)

      lx = nx
      cauchy_cb(2002) = nx
!dir$ concurrent
      do ix = 1, nx
         cauchy_cb(1000+ix) = x(ix)
         cauchy_cb(ix) = fx(ix)
      end do

      a = x(1)
      b = x(nx)
      c = xres

      dx = (b - a) / (lx - 1)
      cauchy_cb(2001) = dx
      call qawce(cauchy_cb, a, b, c, epsabs, epsrel, limit,
     &           pint, abserr, neval, ier, alist, blist, rlist,
     &           elist, iord, last)

      end subroutine CAUCHY_PPART2

!
!*************************************************************************
!

      function df_dv(x,cauchy_cb)

      implicit none

      real :: df_dv
      real :: x

      integer lx, i
      real  dx
      real a1, a2, a3, p, p2
      real :: cauchy_cb(2002)
      integer,parameter:: ifxa=0, ixa=1000, idx=2001, ilx=2002

      dx=cauchy_cb(idx)
      lx = cauchy_cb(ilx)

      i = int((x-cauchy_cb(ixa+1)) / dx) + 1
      p = (x - cauchy_cb(ixa+i)) / dx
c       go to 2
*      -----------------------
*      quadradic interpolation
*      -----------------------
c       call winterp1d_2(xa, lx, fxa, x, df_dv)

      p2 = p * p

      if(i .ne. 1 .and. i .ne. lx)then
        a1 = 0.5 * (p2 - p)
        a2 = 1. - p2
        a3 = 0.5 * (p2 + p)
        df_dv=  a1*cauchy_cb(ifxa+i-1) +
     &          a2*cauchy_cb(ifxa+i) +
     &          a3*cauchy_cb(ifxa+i+1)

      else
        if(i .eq. lx) then
           df_dv = cauchy_cb(ifxa+i)
        endif
        if(i .eq. 1) then
           df_dv = cauchy_cb(ifxa+i)+
     &            (cauchy_cb(ifxa+i+1) -
     &             cauchy_cb(ifxa+i))*p
        endif
      end if

      return

 2    continue
*      --------------------
*      linear interpolation
*      --------------------
      if(i .eq. lx)then
        df_dv = cauchy_cb(ifxa+lx)
      else
        df_dv = cauchy_cb(ifxa+i)+
     &         (cauchy_cb(ifxa+i+1)-
     &          cauchy_cb(ifxa+i))*p
      end if

      return

      end function df_dv
*
*-----------------------------------------------------------------------
*
      subroutine qawce(f_cb,a,b,c,epsabs,epsrel,limit,result,
     &   abserr,neval,ier,alist,blist,rlist,elist,iord,last)
c***begin prologue  qawce
c***date written   800101   (yymmdd)
c***revision date  830518   (yymmdd)
c***category no.  h2a2a1,j4
c***keywords  automatic integrator, special-purpose,
c             cauchy principal value, clenshaw-curtis method
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***  purpose  the routine calculates an approximation result to a
c              cauchy principal value i = integral of f*w over (a,b)
c              (w(x) = 1/(x-c), (c.ne.a, c.ne.b), hopefully satisfying
c              following claim for accuracy
c              abs(i-result).le.max(epsabs,epsrel*abs(i))
c***description
c
c        computation of a cauchy principal value
c        standard fortran subroutine
c        real version
c
c        parameters
c         on entry
c            f      - real
c                     function subprogram defining the integrand
c                     function f(x). the actual name for f needs to be
c                     declared e x t e r n a l in the driver program.
c
c            a      - real
c                     lower limit of integration
c
c            b      - real
c                     upper limit of integration
c
c            c      - real
c                     parameter in the weight function, c.ne.a, c.ne.b
c                     if c = a or c = b, the routine will end with
c                     ier = 6.
c
c            epsabs - real
c                     absolute accuracy requested
c            epsrel - real
c                     relative accuracy requested
c                     if  epsabs.le.0
c                     and epsrel.lt.max(50*rel.mach.acc.,0.5d-28),
c                     the routine will end with ier = 6.
c
c            limit  - integer
c                     gives an upper bound on the number of subintervals
c                     in the partition of (a,b), limit.ge.1
c
c         on return
c            result - real
c                     approximation to the integral
c
c            abserr - real
c                     estimate of the modulus of the absolute error,
c                     which should equal or exceed abs(i-result)
c
c            neval  - integer
c                     number of integrand evaluations
c
c            ier    - integer
c                     ier = 0 normal and reliable termination of the
c                             routine. it is assumed that the requested
c                             accuracy has been achieved.
c                     ier.gt.0 abnormal termination of the routine
c                             the estimates for integral and error are
c                             less reliable. it is assumed that the
c                             requested accuracy has not been achieved.
c            error messages
c                     ier = 1 maximum number of subdivisions allowed
c                             has been achieved. one can allow more sub-
c                             divisions by increasing the value of
c                             limit. however, if this yields no
c                             improvement it is advised to analyze the
c                             the integrand, in order to determine the
c                             the integration difficulties. if the
c                             position of a local difficulty can be
c                             determined (e.g. singularity,
c                             discontinuity within the interval) one
c                             will probably gain from splitting up the
c                             interval at this point and calling
c                             appropriate integrators on the subranges.
c                         = 2 the occurrence of roundoff error is detec-
c                             ted, which prevents the requested
c                             tolerance from being achieved.
c                         = 3 extremely bad integrand behaviour
c                             occurs at some interior points of
c                             the integration interval.
c                         = 6 the input is invalid, because
c                             c = a or c = b or
c                             (epsabs.le.0 and
c                              epsrel.lt.max(50*rel.mach.acc.,0.5d-28))
c                             or limit.lt.1.
c                             result, abserr, neval, rlist(1), elist(1),
c                             iord(1) and last are set to zero. alist(1)
c                             and blist(1) are set to a and b
c                             respectively.
c
c            alist   - real
c                      vector of dimension at least limit, the first
c                       last  elements of which are the left
c                      end points of the subintervals in the partition
c                      of the given integration range (a,b)
c
c            blist   - real
c                      vector of dimension at least limit, the first
c                       last  elements of which are the right
c                      end points of the subintervals in the partition
c                      of the given integration range (a,b)
c
c            rlist   - real
c                      vector of dimension at least limit, the first
c                       last  elements of which are the integral
c                      approximations on the subintervals
c
c            elist   - real
c                      vector of dimension limit, the first  last
c                      elements of which are the moduli of the absolute
c                      error estimates on the subintervals
c
c            iord    - integer
c                      vector of dimension at least limit, the first k
c                      elements of which are pointers to the error
c                      estimates over the subintervals, so that
c                      elist(iord(1)), ..., elist(iord(k)) with k = last
c                      if last.le.(limit/2+2), and k = limit+1-last
c                      otherwise, form a decreasing sequence
c
c            last    - integer
c                      number of subintervals actually produced in
c                      the subdivision process
c
c***references  (none)
c***routines called  qc25c,qpsrt,r1mach
c***end prologue  qawce
c
      real a,aa,abserr,alist,area,area1,area12,area2,a1,a2,b,bb,blist,
     *  b1,b2,c,r1mach,elist,epmach,epsabs,epsrel,errbnd,errmax,error1,
     *  error2,errsum,f,result,rlist,uflow
      integer ier,iord,iroff1,iroff2,k,krule,last,limit,maxerr,nev,
     *  neval,nrmax
c
      dimension alist(limit),blist(limit),rlist(limit),elist(limit),
     *  iord(limit)
c
      real f_cb(2002)
c
c            list of major variables
c            -----------------------
c
c           alist     - list of left end points of all subintervals
c                       considered up to now
c           blist     - list of right end points of all subintervals
c                       considered up to now
c           rlist(i)  - approximation to the integral over
c                       (alist(i),blist(i))
c           elist(i)  - error estimate applying to rlist(i)
c           maxerr    - pointer to the interval with largest
c                       error estimate
c           errmax    - elist(maxerr)
c           area      - sum of the integrals over the subintervals
c           errsum    - sum of the errors over the subintervals
c           errbnd    - requested accuracy max(epsabs,epsrel*
c                       abs(result))
c           *****1    - variable for the left subinterval
c           *****2    - variable for the right subinterval
c           last      - index for subdivision
c
c
c            machine dependent constants
c            ---------------------------
c
c           epmach is the largest relative spacing.
c           uflow is the smallest positive magnitude.
c
c***first executable statement  qawce
c      epmach = r1mach(4)
      epmach = 1.0e-30
c      uflow = r1mach(1)
      uflow = 1.0e-30
c
c
c           test on validity of parameters
c           ------------------------------
c
      ier = 6
      neval = 0
      last = 0
      alist(1) = a
      blist(1) = b
      rlist(1) = 0.0e+00
      elist(1) = 0.0e+00
      iord(1) = 0
      result = 0.0e+00
      abserr = 0.0e+00
      if(c.eq.a.or.c.eq.b.or.(epsabs.le.0.0e+00.and
     *  .epsrel.lt.amax1(0.5e+02*epmach,0.5e-14))) go to 999
c
c           first approximation to the integral
c           -----------------------------------
c
      aa=a
      bb=b
      if (a.le.b) go to 10
      aa=b
      bb=a
10    ier=0
      krule = 1
      call qc25c(f_cb,aa,bb,c,result,abserr,krule,neval)
      last = 1
      rlist(1) = result
      elist(1) = abserr
      iord(1) = 1
      alist(1) = a
      blist(1) = b
c
c           test on accuracy
c
      errbnd = amax1(epsabs,epsrel*abs(result))
      if(limit.eq.1) ier = 1
      if(abserr.lt.amin1(0.1e-01*abs(result),errbnd)
     *  .or.ier.eq.1) go to 70
c
c           initialization
c           --------------
c
      alist(1) = aa
      blist(1) = bb
      rlist(1) = result
      errmax = abserr
      maxerr = 1
      area = result
      errsum = abserr
      nrmax = 1
      iroff1 = 0
      iroff2 = 0
c
c           main do-loop
c           ------------
c
      do 40 last = 2,limit
c
c           bisect the subinterval with nrmax-th largest
c           error estimate.
c
        a1 = alist(maxerr)
        b1 = 0.5e+00*(alist(maxerr)+blist(maxerr))
        b2 = blist(maxerr)
        if(c.le.b1.and.c.gt.a1) b1 = 0.5e+00*(c+b2)
        if(c.gt.b1.and.c.lt.b2) b1 = 0.5e+00*(a1+c)
        a2 = b1
        krule = 2
        call qc25c(f_cb,a1,b1,c,area1,error1,krule,nev)
        neval = neval+nev
        call qc25c(f_cb,a2,b2,c,area2,error2,krule,nev)
        neval = neval+nev
c
c           improve previous approximations to integral
c           and error and test for accuracy.
c
        area12 = area1+area2
        erro12 = error1+error2
        errsum = errsum+erro12-errmax
        area = area+area12-rlist(maxerr)
        if(abs(rlist(maxerr)-area12).lt.0.1e-04*abs(area12)
     *    .and.erro12.ge.0.99e+00*errmax.and.krule.eq.0)
     *    iroff1 = iroff1+1
        if(last.gt.10.and.erro12.gt.errmax.and.krule.eq.0)
     *    iroff2 = iroff2+1
        rlist(maxerr) = area1
        rlist(last) = area2
        errbnd = amax1(epsabs,epsrel*abs(area))
        if(errsum.le.errbnd) go to 15
c
c           test for roundoff error and eventually
c           set error flag.
c
        if(iroff1.ge.6.and.iroff2.gt.20) ier = 2
c
c           set error flag in the case that number of interval
c           bisections exceeds limit.
c
        if(last.eq.limit) ier = 1
c
c           set error flag in the case of bad integrand behaviour
c           at a point of the integration range.
c
        if(amax1(abs(a1),abs(b2)).le.(0.1e+01+0.1e+03*epmach)
     *    *(abs(a2)+0.1e+04*uflow)) ier = 3
c
c           append the newly-created intervals to the list.
c
   15   if(error2.gt.error1) go to 20
        alist(last) = a2
        blist(maxerr) = b1
        blist(last) = b2
        elist(maxerr) = error1
        elist(last) = error2
        go to 30
   20   alist(maxerr) = a2
        alist(last) = a1
        blist(last) = b1
        rlist(maxerr) = area2
        rlist(last) = area1
        elist(maxerr) = error2
        elist(last) = error1
c
c           call subroutine qpsrt to maintain the descending ordering
c           in the list of error estimates and select the
c           subinterval with nrmax-th largest error estimate (to be
c           bisected next).
c
   30    call qpsrt(limit,last,maxerr,errmax,elist,iord,nrmax)
c ***jump out of do-loop
        if(ier.ne.0.or.errsum.le.errbnd) go to 50
   40 continue
c
c           compute final result.
c           ---------------------
c
   50 result = 0.0e+00
      do 60 k=1,last
        result = result+rlist(k)
   60 continue
      abserr = errsum
   70 if (aa.eq.b) result=-result
  999 return
      end

*
*-----------------------------------------------------------------------
*

      subroutine qc25c(f_cb,a,b,c,result,abserr,krul,neval)
c***begin prologue  qc25c
c***date written   810101   (yymmdd)
c***revision date  830518   (yymmdd)
c***category no.  h2a2a2,j4
c***keywords  25-point clenshaw-curtis integration
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  to compute i = integral of f*w over (a,b) with
c            error estimate, where w(x) = 1/(x-c)
c***description
c
c        integration rules for the computation of cauchy
c        principal value integrals
c        standard fortran subroutine
c        real version
c
c        parameters
c           f      - real
c                    function subprogram defining the integrand function
c                    f(x). the actual name for f needs to be declared
c                    e x t e r n a l  in the driver program.
c
c           a      - real
c                    left end point of the integration interval
c
c           b      - real
c                    right end point of the integration interval, b.gt.a
c
c           c      - real
c                    parameter in the weight function
c
c           result - real
c                    approximation to the integral
c                    result is computed by using a generalized
c                    clenshaw-curtis method if c lies within ten percent
c                    of the integration interval. in the other case the
c                    15-point kronrod rule obtained by optimal addition
c                    of abscissae to the 7-point gauss rule, is applied.
c
c           abserr - real
c                    estimate of the modulus of the absolute error,
c                    which should equal or exceed abs(i-result)
c
c           krul   - integer
c                    key which is decreased by 1 if the 15-point
c                    gauss-kronrod scheme has been used
c
c           neval  - integer
c                    number of integrand evaluations
c
c***references  (none)
c***routines called  qcheb,qk15w,qwgtc
c***end prologue  qc25c
c
      real a,abserr,ak22,amom0,amom1,amom2,b,c,cc,
     *  centr,cheb12,cheb24,qwgtc,f,fval,hlgth,p2,p3,p4,
     *  resabs,resasc,result,res12,res24,u,x
      integer i,isym,k,kp,krul,neval
c
      dimension x(11),fval(25),cheb12(13),cheb24(25)
c
      external qwgtc
      real f_cb(2002)
c
c           the vector x contains the values cos(k*pi/24),
c           k = 1, ..., 11, to be used for the chebyshev series
c           expansion of f
c
      data x(1),x(2),x(3),x(4),x(5),x(6),x(7),x(8),x(9),x(10),
     *  x(11)/
     *     0.9914448613738104e+00,     0.9659258262890683e+00,
     *     0.9238795325112868e+00,     0.8660254037844386e+00,
     *     0.7933533402912352e+00,     0.7071067811865475e+00,
     *     0.6087614290087206e+00,     0.5000000000000000e+00,
     *     0.3826834323650898e+00,     0.2588190451025208e+00,
     *     0.1305261922200516e+00/
c
c           list of major variables
c           ----------------------
c           fval   - value of the function f at the points
c                    cos(k*pi/24),  k = 0, ..., 24
c           cheb12 - chebyshev series expansion coefficients,
c                    for the function f, of degree 12
c           cheb24 - chebyshev series expansion coefficients,
c                    for the function f, of degree 24
c           res12  - approximation to the integral corresponding
c                    to the use of cheb12
c           res24  - approximation to the integral corresponding
c                    to the use of cheb24
c           qwgtc - external function subprogram defining
c                    the weight function
c           hlgth  - half-length of the interval
c           centr  - mid point of the interval
c
c
c           check the position of c.
c
c***first executable statement  qc25c
      cc = (0.2e+01*c-b-a)/(b-a)
      if(abs(cc).lt.0.11e+01) go to 10
c
c           apply the 15-point gauss-kronrod scheme.
c
      krul = krul-1
      call qk15w(f_cb,c,p2,p3,p4,kp,a,b,result,abserr,
     *  resabs,resasc)
      neval = 15
      if (resasc.eq.abserr) krul = krul+1
      go to 50
c
c           use the generalized clenshaw-curtis method.
c
   10 hlgth = 0.5e+00*(b-a)
      centr = 0.5e+00*(b+a)
      neval = 25
      fval(1) = 0.5e+00*df_dv(hlgth+centr,f_cb)
      fval(13) = df_dv(centr,f_cb)
      fval(25) = 0.5e+00*df_dv(centr-hlgth,f_cb)
!dir$ concurrent
      do 20 i=2,12
        u = hlgth*x(i-1)
        isym = 26-i
!        fval(i) = f(u+centr,f_cb)
!        fval(isym) = f(centr-u,f_cb)
        fval(i) = df_dv(u+centr,f_cb)
        fval(isym) = df_dv(centr-u,f_cb)
   20 continue
c
c           compute the chebyshev series expansion.
c
      call qcheb(x,fval,cheb12,cheb24)
c
c           the modified chebyshev moments are computed
c           by forward recursion, using amom0 and amom1
c           as starting values.
c
      amom0 = alog(abs((0.1e+01-cc)/(0.1e+01+cc)))
      amom1 = 0.2e+01+cc*amom0
      res12 = cheb12(1)*amom0+cheb12(2)*amom1
      res24 = cheb24(1)*amom0+cheb24(2)*amom1
      do 30 k=3,13
        amom2 = 0.2e+01*cc*amom1-amom0
        ak22 = (k-2)*(k-2)
        if((k/2)*2.eq.k) amom2 = amom2-0.4e+01/(ak22-0.1e+01)
        res12 = res12+cheb12(k)*amom2
        res24 = res24+cheb24(k)*amom2
        amom0 = amom1
        amom1 = amom2
   30 continue
      do 40 k=14,25
        amom2 = 0.2e+01*cc*amom1-amom0
        ak22 = (k-2)*(k-2)
        if((k/2)*2.eq.k) amom2 = amom2-0.4e+01/
     *  (ak22-0.1e+01)
        res24 = res24+cheb24(k)*amom2
        amom0 = amom1
        amom1 = amom2
   40 continue
      result = res24
      abserr = abs(res24-res12)
   50 return
      end

*
*-----------------------------------------------------------------------
*

      subroutine qcheb(x,fval,cheb12,cheb24)
c***begin prologue  qcheb
c***refer to  qc25c,qc25f,qc25s
c***routines called  (none)
c***revision date  830518   (yymmdd)
c***keywords  chebyshev series expansion, fast fourier transform
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  this routine computes the chebyshev series expansion
c            of degrees 12 and 24 of a function using a
c            fast fourier transform method
c            f(x) = sum(k=1,..,13) (cheb12(k)*t(k-1,x)),
c            f(x) = sum(k=1,..,25) (cheb24(k)*t(k-1,x)),
c            where t(k,x) is the chebyshev polynomial of degree k.
c***description
c
c        chebyshev series expansion
c        standard fortran subroutine
c        real version
c
c        parameters
c          on entry
c           x      - real
c                    vector of dimension 11 containing the
c                    values cos(k*pi/24), k = 1, ..., 11
c
c           fval   - real
c                    vector of dimension 25 containing the
c                    function values at the points
c                    (b+a+(b-a)*cos(k*pi/24))/2, k = 0, ...,24,
c                    where (a,b) is the approximation interval.
c                    fval(1) and fval(25) are divided by two
c                    (these values are destroyed at output).
c
c          on return
c           cheb12 - real
c                    vector of dimension 13 containing the
c                    chebyshev coefficients for degree 12
c
c           cheb24 - real
c                    vector of dimension 25 containing the
c                    chebyshev coefficients for degree 24
c
c***end prologue  qcheb
c
      real alam,alam1,alam2,cheb12,cheb24,
     *  fval,part1,part2,part3,v,x
      integer i,j
c
      dimension cheb12(13),cheb24(25),fval(25),v(12),x(11)
c
c***first executable statement  qcheb
      do 10 i=1,12
        j = 26-i
        v(i) = fval(i)-fval(j)
        fval(i) = fval(i)+fval(j)
   10 continue
      alam1 = v(1)-v(9)
      alam2 = x(6)*(v(3)-v(7)-v(11))
      cheb12(4) = alam1+alam2
      cheb12(10) = alam1-alam2
      alam1 = v(2)-v(8)-v(10)
      alam2 = v(4)-v(6)-v(12)
      alam = x(3)*alam1+x(9)*alam2
      cheb24(4) = cheb12(4)+alam
      cheb24(22) = cheb12(4)-alam
      alam = x(9)*alam1-x(3)*alam2
      cheb24(10) = cheb12(10)+alam
      cheb24(16) = cheb12(10)-alam
      part1 = x(4)*v(5)
      part2 = x(8)*v(9)
      part3 = x(6)*v(7)
      alam1 = v(1)+part1+part2
      alam2 = x(2)*v(3)+part3+x(10)*v(11)
      cheb12(2) = alam1+alam2
      cheb12(12) = alam1-alam2
      alam = x(1)*v(2)+x(3)*v(4)+x(5)*v(6)+x(7)*v(8)
     *  +x(9)*v(10)+x(11)*v(12)
      cheb24(2) = cheb12(2)+alam
      cheb24(24) = cheb12(2)-alam
      alam = x(11)*v(2)-x(9)*v(4)+x(7)*v(6)-x(5)*v(8)
     *  +x(3)*v(10)-x(1)*v(12)
      cheb24(12) = cheb12(12)+alam
      cheb24(14) = cheb12(12)-alam
      alam1 = v(1)-part1+part2
      alam2 = x(10)*v(3)-part3+x(2)*v(11)
      cheb12(6) = alam1+alam2
      cheb12(8) = alam1-alam2
      alam = x(5)*v(2)-x(9)*v(4)-x(1)*v(6)
     *  -x(11)*v(8)+x(3)*v(10)+x(7)*v(12)
      cheb24(6) = cheb12(6)+alam
      cheb24(20) = cheb12(6)-alam
      alam = x(7)*v(2)-x(3)*v(4)-x(11)*v(6)+x(1)*v(8)
     *  -x(9)*v(10)-x(5)*v(12)
      cheb24(8) = cheb12(8)+alam
      cheb24(18) = cheb12(8)-alam
      do 20 i=1,6
        j = 14-i
        v(i) = fval(i)-fval(j)
        fval(i) = fval(i)+fval(j)
   20 continue
      alam1 = v(1)+x(8)*v(5)
      alam2 = x(4)*v(3)
      cheb12(3) = alam1+alam2
      cheb12(11) = alam1-alam2
      cheb12(7) = v(1)-v(5)
      alam = x(2)*v(2)+x(6)*v(4)+x(10)*v(6)
      cheb24(3) = cheb12(3)+alam
      cheb24(23) = cheb12(3)-alam
      alam = x(6)*(v(2)-v(4)-v(6))
      cheb24(7) = cheb12(7)+alam
      cheb24(19) = cheb12(7)-alam
      alam = x(10)*v(2)-x(6)*v(4)+x(2)*v(6)
      cheb24(11) = cheb12(11)+alam
      cheb24(15) = cheb12(11)-alam
      do 30 i=1,3
        j = 8-i
        v(i) = fval(i)-fval(j)
        fval(i) = fval(i)+fval(j)
   30 continue
      cheb12(5) = v(1)+x(8)*v(3)
      cheb12(9) = fval(1)-x(8)*fval(3)
      alam = x(4)*v(2)
      cheb24(5) = cheb12(5)+alam
      cheb24(21) = cheb12(5)-alam
      alam = x(8)*fval(2)-fval(4)
      cheb24(9) = cheb12(9)+alam
      cheb24(17) = cheb12(9)-alam
      cheb12(1) = fval(1)+fval(3)
      alam = fval(2)+fval(4)
      cheb24(1) = cheb12(1)+alam
      cheb24(25) = cheb12(1)-alam
      cheb12(13) = v(1)-v(3)
      cheb24(13) = cheb12(13)
      alam = 0.1e+01/0.6e+01
      do 40 i=2,12
        cheb12(i) = cheb12(i)*alam
   40 continue
      alam = 0.5e+00*alam
      cheb12(1) = cheb12(1)*alam
      cheb12(13) = cheb12(13)*alam
      do 50 i=2,24
        cheb24(i) = cheb24(i)*alam
   50 continue
      cheb24(1) = 0.5e+00*alam*cheb24(1)
      cheb24(25) = 0.5e+00*alam*cheb24(25)
      return
      end

*
*-----------------------------------------------------------------------
*

      subroutine qk15w(f_cb,p1,p2,p3,p4,kp,a,b,result,abserr,
     *   resabs,resasc)
c***begin prologue  qk15w
c***date written   810101   (yymmdd)
c***revision date  830518   (mmddyy)
c***category no.  h2a2a2
c***keywords  15-point gauss-kronrod rules
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  to compute i = integral of f*w over (a,b), with error
c                           estimate
c                       j = integral of abs(f*w) over (a,b)
c***description
c
c           integration rules
c           standard fortran subroutine
c           real version
c
c           parameters
c             on entry
c              f      - real
c                       function subprogram defining the integrand
c                       function f(x). the actual name for f needs to be
c                       declared e x t e r n a l in the driver program.
c
c              w      - real
c                       function subprogram defining the integrand
c                       weight function w(x). the actual name for w
c                       needs to be declared e x t e r n a l in the
c                       calling program.
c
c              p1, p2, p3, p4 - real
c                       parameters in the weight function
c
c              kp     - integer
c                       key for indicating the type of weight function
c
c              a      - real
c                       lower limit of integration
c
c              b      - real
c                       upper limit of integration
c
c            on return
c              result - real
c                       approximation to the integral i
c                       result is computed by applying the 15-point
c                       kronrod rule (resk) obtained by optimal addition
c                       of abscissae to the 7-point gauss rule (resg).
c
c              abserr - real
c                       estimate of the modulus of the absolute error,
c                       which should equal or exceed abs(i-result)
c
c              resabs - real
c                       approximation to the integral of abs(f)
c
c              resasc - real
c                       approximation to the integral of abs(f-i/(b-a))
c
c***references  (none)
c***routines called  r1mach
c***end prologue  qk15w
c
      real a,absc,absc1,absc2,abserr,b,centr,dhlgth,
     *  r1mach,epmach,f,fc,fsum,fval1,fval2,fv1,fv2,
     *  hlgth,p1,p2,p3,p4,resabs,resasc,resg,resk,reskh,result,uflow,
     *  w,wg,wgk,xgk
      integer j,jtw,jtwm1,kp
      external df_dv,qwgtc
      real f_cb(2002)
c
      dimension fv1(7),fv2(7),xgk(8),wgk(8),wg(4)
c
c           the abscissae and weights are given for the interval (-1,1).
c           because of symmetry only the positive abscissae and their
c           corresponding weights are given.
c
c           xgk    - abscissae of the 15-point gauss-kronrod rule
c                    xgk(2), xgk(4), ... abscissae of the 7-point
c                    gauss rule
c                    xgk(1), xgk(3), ... abscissae which are optimally
c                    added to the 7-point gauss rule
c
c           wgk    - weights of the 15-point gauss-kronrod rule
c
c           wg     - weights of the 7-point gauss rule
c
      data xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7),
     *  xgk(8)/
     *     0.9914553711208126e+00,     0.9491079123427585e+00,
     *     0.8648644233597691e+00,     0.7415311855993944e+00,
     *     0.5860872354676911e+00,     0.4058451513773972e+00,
     *     0.2077849550078985e+00,     0.0000000000000000e+00/
c
      data wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7),
     *  wgk(8)/
     *     0.2293532201052922e-01,     0.6309209262997855e-01,
     *     0.1047900103222502e+00,     0.1406532597155259e+00,
     *     0.1690047266392679e+00,     0.1903505780647854e+00,
     *     0.2044329400752989e+00,     0.2094821410847278e+00/
c
      data wg(1),wg(2),wg(3),wg(4)/
     *     0.1294849661688697e+00,    0.2797053914892767e+00,
     *     0.3818300505051889e+00,    0.4179591836734694e+00/
c
c
c           list of major variables
c           -----------------------
c
c           centr  - mid point of the interval
c           hlgth  - half-length of the interval
c           absc*  - abscissa
c           fval*  - function value
c           resg   - result of the 7-point gauss formula
c           resk   - result of the 15-point kronrod formula
c           reskh  - approximation to the mean value of f*w over (a,b),
c                    i.e. to i/(b-a)
c
c           machine dependent constants
c           ---------------------------
c
c           epmach is the largest relative spacing.
c           uflow is the smallest positive magnitude.
c
c***first executable statement  qk15w
c      epmach = r1mach(4)
c      uflow = r1mach(1)
      epmach = 1.0e-30
      uflow = 1.0e-30
c
      centr = 0.5e+00*(a+b)
      hlgth = 0.5e+00*(b-a)
      dhlgth = abs(hlgth)
c
c           compute the 15-point kronrod approximation to the
c           integral, and estimate the error.
c
      fc = df_dv(centr,f_cb)*qwgtc(centr,p1,p2,p3,p4,kp)
      resg = wg(4)*fc
      resk = wgk(8)*fc
      resabs = abs(resk)
!dir$ concurrent
      do 10 j=1,3
        jtw = j*2
        absc = hlgth*xgk(jtw)
        absc1 = centr-absc
        absc2 = centr+absc
        fval1 = df_dv(absc1,f_cb)*qwgtc(absc1,p1,p2,p3,p4,kp)
        fval2 = df_dv(absc2,f_cb)*qwgtc(absc2,p1,p2,p3,p4,kp)
        fv1(jtw) = fval1
        fv2(jtw) = fval2
        fsum = fval1+fval2
        resg = resg+wg(j)*fsum
        resk = resk+wgk(jtw)*fsum
        resabs = resabs+wgk(jtw)*(abs(fval1)+abs(fval2))
   10 continue
!dir$ concurrent
      do 15 j=1,4
        jtwm1 = j*2-1
        absc = hlgth*xgk(jtwm1)
        absc1 = centr-absc
        absc2 = centr+absc
        fval1 = df_dv(absc1,f_cb)*qwgtc(absc1,p1,p2,p3,p4,kp)
        fval2 = df_dv(absc2,f_cb)*qwgtc(absc2,p1,p2,p3,p4,kp)
        fv1(jtwm1) = fval1
        fv2(jtwm1) = fval2
        fsum = fval1+fval2
        resk = resk+wgk(jtwm1)*fsum
        resabs = resabs+wgk(jtwm1)*(abs(fval1)+abs(fval2))
   15 continue
      reskh = resk*0.5e+00
      resasc = wgk(8)*abs(fc-reskh)
      do 20 j=1,7
        resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh))
   20 continue
      result = resk*hlgth
      resabs = resabs*dhlgth
      resasc = resasc*dhlgth
      abserr = abs((resk-resg)*hlgth)
      if(resasc.ne.0.0e+00.and.abserr.ne.0.0e+00)
     *  abserr = resasc*amin1(0.1e+01,
     *  (0.2e+03*abserr/resasc)**1.5e+00)
      if(resabs.gt.uflow/(0.5e+02*epmach)) abserr = amax1((epmach*
     *  0.5e+02)*resabs,abserr)
      return
      end

*
*-----------------------------------------------------------------------
*

      subroutine qpsrt(limit,last,maxerr,ermax,elist,iord,nrmax)
c***begin prologue  qpsrt
c***refer to  qage,qagie,qagpe,qagse,qawce,qawse,qawoe
c***routines called  (none)
c***keywords  sequential sorting
c***description
c
c 1.        qpsrt
c           ordering routine
c              standard fortran subroutine
c              real version
c
c 2.        purpose
c              this routine maintains the descending ordering
c              in the list of the local error estimates resulting from
c              the interval subdivision process. at each call two error
c              estimates are inserted using the sequential search
c              method, top-down for the largest error estimate
c              and bottom-up for the smallest error estimate.
c
c 3.        calling sequence
c              call qpsrt(limit,last,maxerr,ermax,elist,iord,nrmax)
c
c           parameters (meaning at output)
c              limit  - integer
c                       maximum number of error estimates the list
c                       can contain
c
c              last   - integer
c                       number of error estimates currently
c                       in the list
c
c              maxerr - integer
c                       maxerr points to the nrmax-th largest error
c                       estimate currently in the list
c
c              ermax  - real
c                       nrmax-th largest error estimate
c                       ermax = elist(maxerr)
c
c              elist  - real
c                       vector of dimension last containing
c                       the error estimates
c
c              iord   - integer
c                       vector of dimension last, the first k
c                       elements of which contain pointers
c                       to the error estimates, such that
c                       elist(iord(1)),... , elist(iord(k))
c                       form a decreasing sequence, with
c                       k = last if last.le.(limit/2+2), and
c                       k = limit+1-last otherwise
c
c              nrmax  - integer
c                       maxerr = iord(nrmax)
c
c 4.        no subroutines or functions needed
c***end prologue  qpsrt
c
      real elist,ermax,errmax,errmin
      integer i,ibeg,ido,iord,isucc,j,jbnd,jupbn,k,last,limit,maxerr,
     *  nrmax
      dimension elist(last),iord(last)
c
c           check whether the list contains more than
c           two error estimates.
c
c***first executable statement  qpsrt
      if(last.gt.2) go to 10
      iord(1) = 1
      iord(2) = 2
      go to 90
c
c           this part of the routine is only executed
c           if, due to a difficult integrand, subdivision
c           increased the error estimate. in the normal case
c           the insert procedure should start after the
c           nrmax-th largest error estimate.
c
   10 errmax = elist(maxerr)
      if(nrmax.eq.1) go to 30
      ido = nrmax-1
      do 20 i = 1,ido
        isucc = iord(nrmax-1)
c ***jump out of do-loop
        if(errmax.le.elist(isucc)) go to 30
        iord(nrmax) = isucc
        nrmax = nrmax-1
   20    continue
c
c           compute the number of elements in the list to
c           be maintained in descending order. this number
c           depends on the number of subdivisions still
c           allowed.
c
   30 jupbn = last
      if(last.gt.(limit/2+2)) jupbn = limit+3-last
      errmin = elist(last)
c
c           insert errmax by traversing the list top-down,
c           starting comparison from the element elist(iord(nrmax+1)).
c
      jbnd = jupbn-1
      ibeg = nrmax+1
      if(ibeg.gt.jbnd) go to 50
      do 40 i=ibeg,jbnd
        isucc = iord(i)
c ***jump out of do-loop
        if(errmax.ge.elist(isucc)) go to 60
        iord(i-1) = isucc
   40 continue
   50 iord(jbnd) = maxerr
      iord(jupbn) = last
      go to 90
c
c           insert errmin by traversing the list bottom-up.
c
   60 iord(i-1) = maxerr
      k = jbnd
      do 70 j=i,jbnd
        isucc = iord(k)
c ***jump out of do-loop
        if(errmin.lt.elist(isucc)) go to 80
        iord(k+1) = isucc
        k = k-1
   70 continue
      iord(i) = last
      go to 90
   80 iord(k+1) = last
c
c           set maxerr and ermax.
c
   90 maxerr = iord(nrmax)
      ermax = elist(maxerr)
      return
      end

*
*-----------------------------------------------------------------------
*

      real function qwgtc(x,c,p2,p3,p4,kp)
c***begin prologue  qwgtc
c***refer to qk15w
c***routines called  (none)
c***revision date  810101   (yymmdd)
c***keywords  weight function, cauchy principal value
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  this function subprogram is used together with the
c            routine qawc and defines the weight function.
c***end prologue  qwgtc
c
      real c,p2,p3,p4,x
      integer kp
c***first executable statement
      qwgtc = 0.1e+01/(x-c)
      return
      end

*
*-----------------------------------------------------------------------
*


SUBROUTINE Force_2Linear(eNum)
   USE PrecTypes
   USE GlobalData
   IMPLICIT NONE

   ! -------------------------------------------------------------------------
   ! NAME:   Force_2Linear
   ! PARENT: F_Elast2Linear
   ! STATUS: Current
   ! OWNER:  Toshiro Matsumoto
   ! TEXT:   Calculate nodal force vector for a linear boundary element
   !         for two-dimensional elastostatic and thermo-elastostatic problems.
   ! REVISION DATE: 16-Jul-2009
   ! -------------------------------------------------------------------------

   INTEGER, INTENT(IN) :: eNum
   INTEGER :: i,j,k

   ! Variables used for integration of linear straight boundary elements
   REAL(dp) :: Lx, Ly, L
   REAL(dp) :: trac(2,2)
   INTEGER  :: n(2)

   ! Global node numbers defining this element
   n(1) = Sid(eNum,1)
   n(2) = Sid(eNum,2)

   ! Length of this straight boundary element
   Lx = x(n(2)) - x(n(1))
   Ly = y(n(2)) - y(n(1))
   L = sqrt(Lx*Lx + Ly*Ly)

   trac = 0.0_dp

   DO i=1,2 ! Counting the nodes
      DO j=1,2 ! Counting the direction
         IF(bcc(eNum,i,j) == 1)  trac(i,j) = bcv(eNum,i,j) * L * thickness(eNum)
      END DO
   END DO

   DO j=1,2 ! Counting the direction
      Flinear(1,1,j) = trac(1,j)/3.0_dp
      Flinear(1,2,j) = trac(2,j)/6.0_dp
      Flinear(2,1,j) = trac(1,j)/6.0_dp
      Flinear(2,2,j) = trac(2,j)/3.0_dp
   END DO

   RETURN
END SUBROUTINE Force_2Linear


      subroutine compute_error(blockno,mx,my,mbc,meqn,
     &      dx,dy,xlower,ylower,t,q,error)
     &      bind(c,name="compute_error")
      implicit none

      integer meqn,mbc,mx,my
      double precision xlower,ylower,dx,dy, t
      double precision error(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision xp,yp,zp, alpha,kappa
      double precision xc,yc
      integer*8 cont, get_context
      integer blockno
      logical fclaw2d_map_is_torus
      logical fclaw2d_map_is_sphere
      integer i,j

c     # Copied from 'metric_terms.i'

      double precision beta
      common /comtorus/ beta

      double precision pi
      common /compi/ pi

      cont = get_context()

      do i = 1,my
         do j = 1,mx
            xc = xlower + (i-0.5)*dx
            yc = ylower + (j-0.5)*dy

c           # Error in Jacobian, i.e. area(i,j)
            error(i,j,1) = 0  !! Not yet figured out

c           # Error in curvature
            if (fclaw2d_map_is_sphere(cont)) then
c              # --user:example=6 (pillowdisk); --user:example=7 (cubedsphere)
               error(i,j,2) = abs(q(i,j,2)-1.d0)
            elseif (fclaw2d_map_is_torus(cont)) then
c              # --user:example=8 (torus)
               kappa = (1 + 2*beta*cos(2*pi*yc))/
     &               (2*beta*(1 + beta*cos(2*pi*yc)))
               error(i,j,2) = abs(q(i,j,2) - kappa)
            else
c              # --user:example=0-5  (flat;  curvature = 0)
               error(i,j,2) = 0
            endif
         enddo
      enddo

      end


      SUBROUTINE MA01BZ( BASE, K, S, A, INCA, ALPHA, BETA, SCAL )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the general product of K complex scalars trying to
C     avoid over- and underflow.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     BASE    (input)  DOUBLE PRECISION
C             Machine base.
C
C     K       (input)  INTEGER
C             The number of scalars.  K >= 1.
C
C     S       (input)  INTEGER array, dimension (K)
C             The signature array. Each entry of S must be 1 or -1.
C
C     A       (input)  COMPLEX*16 array, dimension (K)
C             Vector of complex scalars.
C
C     INCA    (input)  INTEGER
C             Increment for the array A. INCA <> 0.
C
C     ALPHA   (output)  COMPLEX*16
C             ALPHA is a complex scalar with ABS(ALPHA) = 0, or
C             1.0 <= ABS(ALPHA) < BASE, such that
C
C                ALPHA / BETA * BASE**(SCAL)
C
C             is the general product of the scalars in the array A.
C
C     BETA    (output)  COMPLEX*16
C             BETA is either 0.0 or 1.0.
C             See also the description of ALPHA.
C
C     SCAL    (output)  INTEGER
C             Scaling factor exponent, see ALPHA.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, Dec. 2002.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Aug. 2009, SLICOT Library version of the routine ZLAPR1.
C
C     KEYWORDS
C
C     Computer arithmetic, overflow, underflow.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      COMPLEX*16        CONE, CZERO
      PARAMETER         ( CONE  = ( 1.0D+0, 0.0D+0 ),
     $                    CZERO = ( 0.0D+0, 0.0D+0 ) )
C     .. Scalar Arguments ..
      INTEGER           INCA, K, SCAL
      DOUBLE PRECISION  BASE
      COMPLEX*16        ALPHA, BETA
C     .. Array Arguments ..
      INTEGER           S(*)
      COMPLEX*16        A(*)
C     .. Local Scalars ..
      INTEGER           I, INDA
      COMPLEX*16        CBASE
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DCMPLX
C
C     .. Executable Statements ..
C
      CBASE = DCMPLX( BASE, ZERO )
      ALPHA = CONE
      BETA  = CONE
      SCAL = 0
      INDA = 1
C
      DO 40  I = 1, K
         IF ( S(I).EQ.1 ) THEN
            ALPHA = ALPHA * A(INDA)
         ELSE
            IF ( A(INDA).EQ.CZERO ) THEN
               BETA = CZERO
            ELSE
               ALPHA = ALPHA / A(INDA)
            END IF
         END IF
         IF ( ABS( ALPHA ).EQ.ZERO ) THEN
            ALPHA = CZERO
            SCAL  = 0
            IF ( ABS( BETA ).EQ.ZERO )
     $         RETURN
         ELSE
C           WHILE ( ABS( ALPHA ).LT.ONE )  DO
   10       CONTINUE
               IF ( ABS( ALPHA ).GE.ONE )
     $            GO TO 20
               ALPHA = ALPHA*CBASE
               SCAL  = SCAL - 1
            GO TO 10
C           END WHILE 10
C
C           WHILE ( ABS( ALPHA ).GE.BASE ) DO
   20       CONTINUE
               IF ( ABS( ALPHA ).LT.BASE )
     $            GO TO 30
               ALPHA = ALPHA / CBASE
               SCAL  = SCAL + 1
            GO TO 20
C           END WHILE 20
   30       CONTINUE
         END IF
         INDA = INDA + INCA
   40 CONTINUE
C
      RETURN
C *** Last line of MA01BZ ***
      END