module mod_ECRad_abs_Fa
! All credit for these routines goes to Daniela Farina and Lorenzo Figini
! Based on Farina, Daniela. "Relativistic dispersion relation of electron cyclotron waves." Fusion science and technology 53.1 (2008): 130-138.
#ifdef OMP
  use omp_lib
#endif
  implicit none

  integer, parameter :: r8=selected_real_kind(15,300)
  real(r8), parameter :: pi=3.1415926535897932384626433832795_r8
  real(r8), parameter :: pi_sqrt=1.7724538509055160272981674833411_r8
  complex(r8), parameter :: ui=(0._r8,1._r8)
  integer, parameter :: ntv=501
  real(r8), parameter :: tmax=5.0_r8, dt=2.0_r8*tmax/(ntv-1)
  real(r8), save :: ttv(ntv),extdtv(ntv)

contains

  subroutine set_extv
    implicit none
    integer :: i
    do i = 1, ntv
      ttv(i) = -tmax+(i-1)*dt
      extdtv(i) = exp(-ttv(i)*ttv(i))*dt
    end do
  end subroutine set_extv

  function expei(x)
! derived from calcei for usee with int=3 only
! result ->  y = expei(x)
!
! computes the exponential integral exp(-x)*ei(x)  for real arguments x
! where
!
!          /  integral (from t=-infinity to t=x) (exp(t)/t),  x > 0,
! ei(x) = {
!          \ -integral (from t=-x to t=infinity) (exp(t)/t),  x < 0,
!
!  and where the first integral is a principal value integral.
!
    implicit none
    real(r8) :: expei
! arguments
    real(r8), intent(in) :: x
! local variables
    integer :: i, ip1, im1
    real(r8) :: frac, sump, sumq, t, w, xmx0, y, ysq
    real(r8), dimension(10) :: px, qx
    real(r8), parameter :: zero=0.0_r8,  p037=0.037_r8, half=0.5_r8,   &
        one=1.0_r8, two=2.0_r8, three=3.0_r8, four=4.0_r8,   six=6.0_r8,    &
        twelve=12.0_r8,         two4=24.0_r8, x01=381.5_r8,  x11=1024.0_r8, &
        x02=-5.1182968633365538008e-5_r8,     x0=0.37250741078136663466_r8
! machine-dependent constants
    real(r8), parameter :: xinf=1.79e+308_r8
! coefficients  for -1.0 <= x < 0.0
    real(r8), dimension(7), parameter ::                         &
       a=(/1.1669552669734461083368d2, 2.1500672908092918123209d3,    &
           1.5924175980637303639884d4, 8.9904972007457256553251d4,    &
           1.5026059476436982420737d5,-1.4815102102575750838086d5,    &
           5.0196785185439843791020d0/)
    real(r8), dimension(6), parameter ::                         &
       b=(/4.0205465640027706061433d1, 7.5043163907103936624165d2,    &
           8.1258035174768735759855d3, 5.2440529172056355429883d4,    &
           1.8434070063353677359298d5, 2.5666493484897117319268d5/)
! coefficients for -4.0 <= x < -1.0
    real(r8), dimension(9), parameter ::                         &
       c=(/3.828573121022477169108d-1, 1.107326627786831743809d+1,    &
           7.246689782858597021199d+1, 1.700632978311516129328d+2,    &
           1.698106763764238382705d+2, 7.633628843705946890896d+1,    &
           1.487967702840464066613d+1, 9.999989642347613068437d-1,    &
           1.737331760720576030932d-8/),                              &
       d=(/8.258160008564488034698d-2, 4.344836335509282083360d+0,    &
           4.662179610356861756812d+1, 1.775728186717289799677d+2,    &
           2.953136335677908517423d+2, 2.342573504717625153053d+2,    &
           9.021658450529372642314d+1, 1.587964570758947927903d+1,    &
           1.000000000000000000000d+0/)
! coefficients for x < -4.0
    real(r8), dimension(10), parameter ::                        &
       e=(/1.3276881505637444622987d+2,3.5846198743996904308695d+4,   &
           1.7283375773777593926828d+5,2.6181454937205639647381d+5,   &
           1.7503273087497081314708d+5,5.9346841538837119172356d+4,   &
           1.0816852399095915622498d+4,1.0611777263550331766871d03,   &
           5.2199632588522572481039d+1,9.9999999999999999087819d-1/), &
       f=(/3.9147856245556345627078d+4,2.5989762083608489777411d+5,   &
           5.5903756210022864003380d+5,5.4616842050691155735758d+5,   &
           2.7858134710520842139357d+5,7.9231787945279043698718d+4,   &
           1.2842808586627297365998d+4,1.1635769915320848035459d+3,   &
           5.4199632588522559414924d+1,1.0d0/)
! coefficients for rational approximation to ln(x/a), |1-x/a| < .1
    real(r8), dimension(4), parameter ::                         &
       plg=(/-2.4562334077563243311d+01,2.3642701335621505212d+02,    &
             -5.4989956895857911039d+02,3.5687548468071500413d+02/),  &
       qlg=(/-3.5553900764052419184d+01,1.9400230218539473193d+02,    &
             -3.3442903192607538956d+02,1.7843774234035750207d+02/)
! coefficients for  0.0 < x < 6.0,
! ratio of chebyshev polynomials
    real(r8), dimension(10), parameter ::                         &
       p=(/-1.2963702602474830028590d01,-1.2831220659262000678155d03,  &
           -1.4287072500197005777376d04,-1.4299841572091610380064d06,  &
           -3.1398660864247265862050d05,-3.5377809694431133484800d08,  &
            3.1984354235237738511048d08,-2.5301823984599019348858d10,  &
            1.2177698136199594677580d10,-2.0829040666802497120940d11/),&
       q=(/ 7.6886718750000000000000d01,-5.5648470543369082846819d03,  &
            1.9418469440759880361415d05,-4.2648434812177161405483d06,  &
            6.4698830956576428587653d07,-7.0108568774215954065376d08,  &
            5.4229617984472955011862d09,-2.8986272696554495342658d10,  &
            9.8900934262481749439886d10,-8.9673749185755048616855d10/)
! j-fraction coefficients for 6.0 <= x < 12.0
    real(r8), dimension(10), parameter ::                        &
       r=(/-2.645677793077147237806d00,-2.378372882815725244124d00,   &
           -2.421106956980653511550d01, 1.052976392459015155422d01,   &
            1.945603779539281810439d01,-3.015761863840593359165d01,   &
            1.120011024227297451523d01,-3.988850730390541057912d00,   &
            9.565134591978630774217d00, 9.981193787537396413219d-1/)
    real(r8), dimension(9), parameter ::                         &
       s=(/ 1.598517957704779356479d-4, 4.644185932583286942650d00,   &
            3.697412299772985940785d02,-8.791401054875438925029d00,   &
            7.608194509086645763123d02, 2.852397548119248700147d01,   &
            4.731097187816050252967d02,-2.369210235636181001661d02,   &
            1.249884822712447891440d00/)
! j-fraction coefficients for 12.0 <= x < 24.0
    real(r8), dimension(10), parameter ::                        &
       p1=(/-1.647721172463463140042d00,-1.860092121726437582253d01,  &
            -1.000641913989284829961d01,-2.105740799548040450394d01,  &
            -9.134835699998742552432d-1,-3.323612579343962284333d01,  &
             2.495487730402059440626d01, 2.652575818452799819855d01,  &
            -1.845086232391278674524d00, 9.999933106160568739091d-1/)
    real(r8), dimension(9), parameter ::                         &
       q1=(/ 9.792403599217290296840d01, 6.403800405352415551324d01,  &
             5.994932325667407355255d01, 2.538819315630708031713d02,  &
             4.429413178337928401161d01, 1.192832423968601006985d03,  &
             1.991004470817742470726d02,-1.093556195391091143924d01,  &
             1.001533852045342697818d00/)
! j-fraction coefficients for  x >= 24.0
    real(r8), dimension(10), parameter ::                        &
       p2=(/ 1.75338801265465972390d02,-2.23127670777632409550d02,    &
            -1.81949664929868906455d01,-2.79798528624305389340d01,    &
            -7.63147701620253630855d00,-1.52856623636929636839d01,    &
            -7.06810977895029358836d00,-5.00006640413131002475d00,    &
            -3.00000000320981265753d00, 1.00000000000000485503d00/)
    real(r8), dimension(9), parameter ::                         &
       q2=(/ 3.97845977167414720840d04, 3.97277109100414518365d00,    &
             1.37790390235747998793d02, 1.17179220502086455287d02,    &
             7.04831847180424675988d01,-1.20187763547154743238d01,    &
            -7.99243595776339741065d00,-2.99999894040324959612d00,    &
             1.99999999999048104167d00/)

    if (x == zero) then
      expei = -xinf
    else if (x < zero) then
!
! calculate ei for negative argument or for e1.
!
      y = abs(x)
      if (y <= one) then
        sump = a(7) * y + a(1)
        sumq = y + b(1)
        do i = 2, 6
          sump = sump * y + a(i)
          sumq = sumq * y + b(i)
        end do
        expei = (log(y) - sump / sumq ) * exp(y)
      else if (y <= four) then
        w = one / y
        sump = c(1)
        sumq = d(1)
        do i = 2, 9
          sump = sump * w + c(i)
          sumq = sumq * w + d(i)
        end do
        expei = - sump / sumq
      else
        w = one / y
        sump = e(1)
        sumq = f(1)
        do i = 2, 10
          sump = sump * w + e(i)
          sumq = sumq * w + f(i)
        end do
        expei = w * (w * sump / sumq - one)
      end if
    else if (x < six) then
!
! to improve conditioning, rational approximations are expressed
! in terms of chebyshev polynomials for 0 <= x < 6, and in
! continued fraction form for larger x.
!
      t = (x + x) / three - two
      px(1) = zero
      qx(1) = zero
      px(2) = p(1)
      qx(2) = q(1)
      do i = 2, 9
        ip1 = i+1
        im1 = i-1
        px(ip1) = t * px(i) - px(im1) + p(i)
        qx(ip1) = t * qx(i) - qx(im1) + q(i)
      end do
      sump = half * t * px(10) - px(9) + p(10)
      sumq = half * t * qx(10) - qx(9) + q(10)
      frac = sump / sumq
      xmx0 = (x - x01/x11) - x02
      if (abs(xmx0) >= p037) then
        expei = exp(-x) * ( log(x/x0) + xmx0 * frac )
      else
!
! special approximation to  ln(x/x0)  for x close to x0
!
        y = xmx0 / (x + x0)
        ysq = y*y
        sump = plg(1)
        sumq = ysq + qlg(1)
        do i = 2, 4
          sump = sump*ysq + plg(i)
          sumq = sumq*ysq + qlg(i)
        end do
        expei = exp(-x) * (sump / (sumq*(x+x0)) + frac) * xmx0
      end if
    else if (x < twelve) then
      frac = zero
      do i = 1, 9
        frac = s(i) / (r(i) + x + frac)
      end do
      expei = (r(10) + frac) / x
    else if (x <= two4) then
      frac = zero
      do i = 1, 9
        frac = q1(i) / (p1(i) + x + frac)
      end do
      expei = (p1(10) + frac) / x
    else
      y = one / x
      frac = zero
      do i = 1, 9
        frac = q2(i) / (p2(i) + x + frac)
      end do
      frac = p2(10) + frac
      expei = y + y * y * frac
    end if
  end function expei

  function fact(k)
! factorial function
    implicit none
    real(r8) :: fact
! arguments
    integer, intent(in) :: k
! local variables
    real(r8), dimension(0:15), parameter :: precomp = (/ &
        1._r8, 1._r8, 2._r8, 6._r8, 24._r8, 120._r8, 720._r8, 5040._r8, &
        40320._r8, 362880._r8, 3628800._r8, 39916800._r8, 479001600._r8, &
        6227020800._r8, 87178291200._r8, 1307674368000._r8 /)
    integer :: i

    if(k<0) then
      fact=0.0_r8
!    else
!      fact=1.0_r8
!      do i=2,k
!        fact=fact*i
!      end do
!    end if
    else if(k<16) then
      fact=precomp(k)
    else
      fact=precomp(15)
      do i=16,k
        fact=fact*i
      end do
    end if
  end function fact

  function gammln(x)
! Returns the value ln[Gamma(x)] for x > 0.
    implicit none
    real(r8) :: gammln
! arguments
    real(r8), intent(in) :: x
! parameters
    real(r8), parameter :: stp = 2.5066282746310005_r8
    real(r8), dimension(6), parameter :: cof = (/ 76.18009172947146_r8, &
        -86.50532032941677_r8, 24.01409824083091_r8, -1.231739572450155_r8,  &
        0.1208650973866179e-2_r8, -0.5395239384953e-5_r8 /)
! local variables
    integer :: j
    real(r8) :: ser, tmp, y

    y = x
    tmp = x + 5.5_r8
    tmp = (x + 0.5_r8)*log(tmp) - tmp
    ser = 1.000000000190015_r8
    do j = 1, 6
      y = y + 1._r8
      ser = ser + cof(j)/y
    end do
    gammln = tmp + log(stp*ser/x)
  end function gammln

  function ssbi(zz,n,l)
    implicit none
    real(r8), intent(in) :: zz
    integer, intent(in) :: n, l
    real(r8), dimension(l+2) :: ssbi
    integer :: k, m, mm
    real(r8) :: z2q, c0, c1, sbi
    real(r8), parameter :: eps = 1.e-10_r8

    z2q = 0.25_r8*zz**2
    do m = n, l+2
      c0 = 1.0_r8/exp(gammln(m + 1.5_r8))
!      c0 = 1.0_r8/gammah(m + 1.5_r8)
      sbi = c0
      do k = 1, 50
        c1 = c0*z2q/((m + k) + 0.5_r8)/k
        sbi = sbi + c1
        if(c1/sbi < eps) exit
        c0 = c1
      end do
      mm=m-n+1
      ssbi(mm)=sbi
    end do
  end function ssbi

!  function zetac(xi,yi)!,zr,zi,iflag)
!! PLASMA DISPERSION FUNCTION Z of complex argument
!! Z(z) = i sqrt(pi) w(z)
!! Function w(z) from:
!! algorithm 680, collected algorithms from acm.
!! this work published in transactions on mathematical software,
!! vol. 16, no. 1, pp. 47.
!!
!! given a complex number z = (xi,yi), this subroutine computes
!! the value of the faddeeva-function w(z) = exp(-z**2)*erfc(-i*z),
!! where erfc is the complex complementary error-function and i
!! means sqrt(-1).
!! the accuracy of the algorithm for z in the 1st and 2nd quadrant
!! is 14 significant digits; in the 3rd and 4th it is 13 significant
!! digits outside a circular region with radius 0.126 around a zero
!! of the function.
!! all real variables in the program are double precision.
!!
!!
!! the code contains a few compiler-dependent parameters :
!! rmaxreal = the maximum value of rmaxreal equals the root of
!!            rmax = the largest number which can still be
!!            implemented on the computer in double precision
!!            floating-point arithmetic
!! rmaxexp  = ln(rmax) - ln(2)
!! rmaxgoni = the largest possible argument of a double precision
!!            goniometric function (dcos, dsin, ...)
!! the reason why these parameters are needed as they are defined will
!! be explained in the code by means of comments
!!
!!
!! parameter list
!! xi     = real      part of z
!! yi     = imaginary part of z
!! u      = real      part of w(z)
!! v      = imaginary part of w(z)
!! iflag  = an error flag indicating whether overflow will
!!          occur or not; type integer;
!!          the values of this variable have the following
!!          meaning :
!!          iflag=0 : no error condition
!!          iflag=1 : overflow will occur, the routine
!!                    becomes inactive
!! xi, yi       are the input-parameters
!! u, v, iflag  are the output-parameters
!!
!! furthermore the parameter factor equals 2/sqrt(pi)
!!
!! the routine is not underflow-protected but any variable can be
!! put to 0 upon underflow;
!!
!! reference - gpm poppe, cmj wijers; more efficient computation of
!! the complex error-function, acm trans. math. software.
!!
!  implicit none
!  complex(r8) :: zetac
!! arguments
!  real(r8), intent(in)  :: xi, yi
!!  real(r8), intent(out) :: zr, zi
!!  integer      , intent(out) :: iflag
!! local variables
!  integer       :: n, j, i, kapn, nu, np1
!  real(r8) :: u, v, x, y, xabs, yabs, qrho, xabsq, xquad, yquad,   &
!                   xsum, ysum, xaux, u1, v1, daux, u2, v2, h, h2,       &
!                   qlambda, rx, ry, sx, sy, tx, ty, c, w1
!! parameters
!  real(r8), parameter :: factor = 1.12837916709551257388_r8, &
!                              rpi    = 2.0_r8/factor!,             &
!!                              rmaxreal = 0.5e+154_r8,             &
!!                              rmaxexp = 708.503061461606_r8,      &
!!                              rmaxgoni = 3.53711887601422e+15_r8
!
!!    iflag = 0
!    xabs = abs(xi)
!    yabs = abs(yi)
!    x    = xabs/6.3_r8
!    y    = yabs/4.4_r8
!!
!! the following if-statement protects
!! qrho = (x**2 + y**2) against overflow
!!
!!    if ((xabs>rmaxreal).or.(yabs>rmaxreal)) then
!!      iflag = 1
!!      return
!!    end if
!    qrho = x**2 + y**2
!    xabsq = xabs**2
!    xquad = xabsq - yabs**2
!    yquad = 2*xabs*yabs
!    if (qrho<0.085264_r8) then
!!
!! if (qrho<0.085264_r8) then the faddeeva-function is evaluated
!! using a power-series (abramowitz/stegun, equation (7.1.5), p.297)
!! n is the minimum number of terms needed to obtain the required
!! accuracy
!!
!      qrho  = (1-0.85_r8*y)*sqrt(qrho)
!      n     = nint(6 + 72*qrho)
!      j     = 2*n+1
!      xsum  = 1.0_r8/j
!      ysum  = 0.0_r8
!      do i=n, 1, -1
!        j    = j - 2
!        xaux = (xsum*xquad - ysum*yquad)/i
!        ysum = (xsum*yquad + ysum*xquad)/i
!        xsum = xaux + 1.0_r8/j
!      end do
!      u1   = -factor*(xsum*yabs + ysum*xabs) + 1.0_r8
!      v1   =  factor*(xsum*xabs - ysum*yabs)
!      daux =  exp(-xquad)
!      u2   =  daux*cos(yquad)
!      v2   = -daux*sin(yquad)
!      u    = u1*u2 - v1*v2
!      v    = u1*v2 + v1*u2
!    else
!!
!! if (qrho>1.0) then w(z) is evaluated using the laplace
!! continued fraction
!! nu is the minimum number of terms needed to obtain the required
!! accuracy
!!
!! if ((qrho>0.085264d0).and.(qrho<1.0)) then w(z) is evaluated
!! by a truncated taylor expansion, where the laplace continued fraction
!! is used to calculate the derivatives of w(z)
!! kapn is the minimum number of terms in the taylor expansion needed
!! to obtain the required accuracy
!! nu is the minimum number of terms of the continued fraction needed
!! to calculate the derivatives with the required accuracy
!!
!      if (qrho>1.0_r8) then
!        h    = 0.0_r8
!        kapn = 0
!        qrho = sqrt(qrho)
!        nu   = int(3 + (1442/(26*qrho+77)))
!      else
!        qrho = (1-y)*sqrt(1-qrho)
!        h    = 1.88_r8*qrho
!        h2   = 2*h
!        kapn = nint(7  + 34*qrho)
!        nu   = nint(16 + 26*qrho)
!      endif
!      if (h>0.0_r8) qlambda = h2**kapn
!      rx = 0.0_r8
!      ry = 0.0_r8
!      sx = 0.0_r8
!      sy = 0.0_r8
!      do n=nu, 0, -1
!        np1 = n + 1
!        tx  = yabs + h + np1*rx
!        ty  = xabs - np1*ry
!        c   = 0.5_r8/(tx**2 + ty**2)
!        rx  = c*tx
!        ry  = c*ty
!        if ((h>0.0_r8).and.(n<=kapn)) then
!          tx = qlambda + sx
!          sx = rx*tx - ry*sy
!          sy = ry*tx + rx*sy
!          qlambda = qlambda/h2
!        endif
!      end do
!      if (h==0.0_r8) then
!        u = factor*rx
!        v = factor*ry
!      else
!        u = factor*sx
!        v = factor*sy
!      end if
!      if (yabs==0.0_r8) u = exp(-xabs**2)
!    end if
!!
!! evaluation of w(z) in the other quadrants
!!
!    if (yi<0.0_r8) then
!      if (qrho<0.085264_r8) then
!        u2    = 2*u2
!        v2    = 2*v2
!      else
!        xquad =  -xquad
!!
!! the following if-statement protects 2*exp(-z**2)
!! against overflow
!!
!!        if ((yquad>rmaxgoni).or.(xquad>rmaxexp)) then
!!          iflag=1
!!          return
!!        end if
!        w1 =  2.0_r8*exp(xquad)
!        u2  =  w1*cos(yquad)
!        v2  = -w1*sin(yquad)
!      end if
!      u = u2 - u
!      v = v2 - v
!      if (xi>0.0_r8) v = -v
!    else
!      if (xi<0.0_r8) v = -v
!    end if
!!    zr = -v*rpi
!!    zi =  u*rpi
!    zetac = cmplx(-v*rpi,u*rpi,kind=r8)
!  end function zetac
!
!  subroutine fsup(yg,anpl,amu,cefp,cefm,lrm)
!    implicit none
!    real(r8), intent(in) :: yg,anpl,amu
!    integer, intent(in) :: lrm
!    complex(r8), intent(out) :: cefp(0:lrm,0:2),cefm(0:lrm,0:2)
!    real(r8), parameter :: soglia = 0.7_r8
!    integer :: l,is,isa,ir
!    real(r8) :: anpl2hm1,alpha,phi2,phim,psi,apsi
!    real(r8) :: xp,yp,xm,ym,x0,y0
!    complex(r8) :: czp,czm,cf12,cf32,cphi,cz0,cdz0,cf0,cf1,cf2
!
!    cefp=(0._r8,0._r8)
!    cefm=(0._r8,0._r8)
!    anpl2hm1=anpl**2/2.0_r8-1.0_r8
!    psi=sqrt(0.5_r8*amu)*anpl
!    apsi=abs(psi)
!    do is=-lrm,lrm
!      alpha=anpl2hm1+is*yg
!      phi2=amu*alpha
!      phim=sqrt(abs(phi2))
!      if (alpha>=0) then
!        xp=psi-phim
!        yp=0.0_r8
!        xm=-psi-phim
!        ym=0.0_r8
!        x0=-phim
!        y0=0.0_r8
!      else
!        xp=psi
!        yp=phim
!        xm=-psi
!        ym=phim
!        x0=0.0_r8
!        y0=phim
!      end if
!      czp=zetac(xp,yp)
!      czm=zetac(xm,ym)
!      if (alpha>0) then
!        cf12=-(czp+czm)/(2.0_r8*phim)
!      else if (alpha<0) then
!        cf12=-ui*(czp+czm)/(2.0_r8*phim)
!      else
!        cf12=(0.0_r8,0.0_r8)
!      end if
!      if(apsi>soglia) then
!        cf32=-(czp-czm)/(2.0_r8*psi)
!      else
!        cphi=phim
!        if(alpha<0) cphi=-ui*phim
!        cz0=zetac(x0,y0)
!        cdz0=2.0_r8*(1.0_r8-cphi*cz0)
!        cf32=cdz0
!      end if
!      cf0=cf12
!      cf1=cf32
!      if (is==0) then
!        cefp(0,0)=cf32
!        cefm(0,0)=cf32
!      end if
!      isa=abs(is)
!      do l=1,isa+2
!        if(apsi>soglia) then
!          cf2=(1.0_r8+phi2*cf0-(l-0.5_r8)*cf1)/psi**2
!        else
!          cf2=(1.0_r8+phi2*cf1)/(l+0.5_r8)
!        end if
!        ir=l-isa
!        if(ir>=0) then
!          cefp(isa,ir)=cefp(isa,ir)+cf2
!          if(is>0) then
!            cefm(isa,ir)=cefm(isa,ir)+cf2
!          else
!            cefm(isa,ir)=cefm(isa,ir)-cf2
!          end if
!        end if
!        cf0=cf1
!        cf1=cf2
!      end do
!    end do
!  end subroutine fsup
!
!  subroutine dieltens_maxw_wr(xg,yg,anpl,amu,e330,epsl,lrm)
!! weakly relativistic dielectric tensor computation
!! Krivenski and Orefice, JPP 30,125 (1983)
!    real(r8), intent(in) :: xg,yg,anpl,amu
!    integer, intent(in) :: lrm
!    complex(r8), intent(out) :: e330, epsl(3,3,lrm)
!    integer :: l,lm,is,k
!    real(r8) :: anpl2,fcl,asl,bsl
!    complex(r8) :: ca11,ca12,ca13,ca22,ca23,ca33
!    complex(r8) :: cq0p,cq0m,cq1p,cq1m,cq2p
!    complex(r8) :: cefp(0:lrm,0:2),cefm(0:lrm,0:2)
!
!    anpl2=anpl**2
!    call fsup(yg,anpl,amu,cefp,cefm,lrm)
!    do l=1,lrm
!      lm=l-1
!      fcl=0.5_r8**l*((1.0_r8/yg)**2/amu)**lm*fact(2*l)/fact(l)
!      ca11=(0._r8,0._r8)
!      ca12=(0._r8,0._r8)
!      ca13=(0._r8,0._r8)
!      ca22=(0._r8,0._r8)
!      ca23=(0._r8,0._r8)
!      ca33=(0._r8,0._r8)
!      do is=0,l
!        k=l-is
!        asl=real((-1)**k,kind=r8)/(fact(is+l)*fact(l-is))
!        bsl=asl*(is**2+real(2*k*lm*(l+is),kind=r8)/(2*l-1))
!        cq0p=amu*cefp(is,0)
!        cq0m=amu*cefm(is,0)
!        cq1p=amu*anpl*(cefp(is,0)-cefp(is,1))
!        cq1m=amu*anpl*(cefm(is,0)-cefm(is,1))
!        cq2p=cefp(is,1)+amu*anpl2*(cefp(is,2)+cefp(is,0)-2.0_r8*cefp(is,1))
!        ca11=ca11+is**2*asl*cq0p
!        ca12=ca12+is*l*asl*cq0m
!        ca22=ca22+bsl*cq0p
!        ca13=ca13+is*asl*cq1m/yg
!        ca23=ca23+l*asl*cq1p/yg
!        ca33=ca33+asl*cq2p/yg**2
!      end do
!      epsl(1,1,l) =  - xg*ca11*fcl
!      epsl(1,2,l) =  + ui*xg*ca12*fcl
!      epsl(2,2,l) =  - xg*ca22*fcl
!      epsl(1,3,l) =  - xg*ca13*fcl
!      epsl(2,3,l) =  - ui*xg*ca23*fcl
!      epsl(3,3,l) =  - xg*ca33*fcl
!    end do
!    cq2p=cefp(0,1)+amu*anpl2*(cefp(0,2)+cefp(0,0)-2.0_r8*cefp(0,1))
!    e330=1.0_r8-xg*amu*cq2p
!    epsl(1,1,1) = 1._r8 + epsl(1,1,1)
!    epsl(2,2,1) = 1._r8 + epsl(2,2,1)
!    do l=1,lrm
!      epsl(2,1,l) = - epsl(1,2,l)
!      epsl(3,1,l) =   epsl(1,3,l)
!      epsl(3,2,l) = - epsl(2,3,l)
!    end do
!  end subroutine dieltens_maxw_wr

  subroutine hermitian(yg,anpl,amu,rr,lrm,iwarm)
    implicit none
    real(r8), intent(in) :: yg,amu,anpl
    integer, intent(in) :: lrm,iwarm
    real(r8), intent(out) :: rr(-lrm:lrm,0:2,0:lrm)
    integer :: n,k,m,llm,i,n1,nn
    real(r8) :: t,x
    real(r8) :: cmxw,cr
    real(r8) :: upl,upl2,gx,exdx,gr,s,ffe,zm,fe0m
    real(r8) :: sy1,sy2,sy3,sy4,bth2,bth4,bth6,bth8,anpl2,anpl4
    real(r8) :: rxt,bth,amu2,amu4,amu6,amu8,zm2,zm3

    rr(:,:,:) = 0._r8
    cmxw = 1._r8 + 15._r8/(8._r8*amu) + 105._r8/(128._r8*amu**2)
    cr = -amu*amu/(pi_sqrt*cmxw)
    llm=min(3,lrm)
    bth2=2.0_r8/amu
    bth=sqrt(bth2)
    amu2=amu*amu
    amu4=amu2*amu2
    amu6=amu4*amu2
    amu8=amu4*amu4
    if(iwarm>2) then
      n1=-llm
    else
      n1=1
    end if
    do i = 1, ntv
      t = ttv(i)
      rxt = sqrt(1.0_r8 + t*t/(2.0_r8*amu))
      x = t*rxt
      upl2 = bth2*x**2
      upl = bth*x
      gx = 1.0_r8 + t*t/amu
      exdx = cr*extdtv(i)*gx/rxt
      do n = n1, llm
        nn = abs(n)
        gr = anpl*upl + n*yg
        zm = -amu*(gx-gr)
        s = amu*(gx+gr)
        zm2 = zm**2
        zm3 = zm2*zm
        fe0m = expei(zm)
        do m = nn, llm
          if(m==0) then
            rr(0,2,0) = rr(0,2,0) - exdx*fe0m*upl2
          else
            if (m==1) then
              ffe=(1._r8+s*(1._r8-zm*fe0m))/amu2
            else if (m==2) then
              ffe=(6._r8-2._r8*zm+4._r8*s+s*s*(1._r8+zm-zm2*fe0m))/amu4
            else if (m==3) then
              ffe=(18._r8*s*(s+4._r8-zm)+6._r8*(20._r8-8._r8*zm+zm2) &
                  +s**3*(2._r8+zm+zm2-zm3*fe0m))/amu6
            else
              ffe=(96._r8*s*(30._r8+s**2-10._r8*zm+zm**2) &
                  +24._r8*(210._r8-6._r8*s**2*(-5._r8+zm) &
                  -90._r8*zm+15._r8*zm**2-zm**3) &
                  +s**4*(6._r8+2._r8*zm+zm**2+zm**3-fe0m*zm**4))/amu8
            end if
            rr(n,0,m) = rr(n,0,m) + exdx*ffe
            rr(n,1,m) = rr(n,1,m) + exdx*ffe*upl
            rr(n,2,m) = rr(n,2,m) + exdx*ffe*upl2
          end if
        end do
      end do
    end do
    if(iwarm>2) return
    sy1 = 1._r8 + yg
    sy2 = 1._r8 + yg*2._r8
    sy3 = 1._r8 + yg*3._r8
    sy4 = 1._r8 + yg*4._r8
    anpl2=anpl**2
    anpl4=anpl2**2
    bth4=bth2*bth2
    bth6=bth4*bth2
    bth8=bth4*bth4
    rr(0,2,0) = -(1.0d0+bth2*(-1.25d0+1.5d0*anpl2) &
                +bth4*(1.71875d0-6.0d0*anpl2+3.75d0*anpl2*anpl2) &
                +bth6*3.0d0*(-65.0d0+456.0d0*anpl2-660.d0*anpl4 &
                + 280.0d0*anpl2*anpl4)/64.0d0 &
                + bth6*bth2*15.0d0*(252.853d3-2850.816d3*anpl2 &
                +6942.720d3*anpl4-6422.528d3*anpl4*anpl2 &
                +2064.384d3*anpl4*anpl4)/524.288d3)
    rr(0,1,1) = -anpl*bth2*(1.0d0+bth2*(-2.25d0+1.5d0*anpl2) &
                +bth4*9.375d-2*(6.1d1-9.6d1*anpl2+4.d1*anpl4 &
                +bth2*(-184.5d0+4.92d2*anpl2-4.5d2*anpl4 &
                +1.4d2*anpl2*anpl4)))
    rr(0,2,1) = -bth2*(1.0d0+bth2*(-0.5d0+1.5d0*anpl2) &
                +0.375d0*bth4*(3.d0-15.d0*anpl2+10.d0*anpl4) + &
                3.d0*bth6*(-61.d0+471.d0*anpl2-680*anpl4+280.d0*anpl2*anpl4)/64.d0)
    rr(-1,0,1) = -2.0d0/sy1*(1.0d0+bth2/sy1*(-1.25d0+0.5d0*anpl2/sy1) &
                 +bth4/sy1*(-0.46875d0+(2.1875d0+0.625d0*anpl2)/sy1 &
                 -2.625d0*anpl2/sy1**2+0.75d0*anpl4/sy1**3) + bth6/sy1* &
                 (0.234375d0+(1.640625d0+0.234375d0*anpl2)/sy1 + &
                 (-4.921875d0-4.921875d0*anpl2)/sy1**2 + &
                 2.25d0*anpl2*(5.25d0 + anpl2)/sy1**3 - 8.4375d0*anpl4/sy1**4 + &
                 1.875d0*anpl2*anpl4/sy1**5)+bth6*bth2/sy1*(0.019826889038*sy1 &
                 -0.06591796875d0+(-0.7177734375d0 - 0.1171875d0*anpl2)/sy1+ &
                 (-5.537109375d0 - 2.4609375d0*anpl2)/sy1**2 + &
                 (13.53515625d0 + 29.53125d0*anpl2 + 2.8125d0*anpl4)/sy1**3 + &
                 (-54.140625d0*anpl2 - 32.6953125d0*anpl4)/sy1**4 + &
                 (69.609375d0*anpl4 + 9.84375d0*anpl2*anpl4)/sy1**5 - &
                 36.09375d0*anpl2*anpl4/sy1**6 + 6.5625d0*anpl4**2/sy1**7))
    rr(-1,1,1) = -anpl*bth2/sy1**2*(1.0d0+bth2*(1.25d0-3.5d0/sy1+ &
                 1.5d0*anpl2/sy1**2)+bth4*9.375d-2*((5.0d0-7.d1/sy1+ &
                 (126.d0+48.d0*anpl2)/sy1**2-144.d0*anpl2/sy1**3+4.d1*anpl4/sy1**4)+ &
                 bth2*(-2.5d0-3.5d1/sy1+(3.15d2+6.d1*anpl2)/sy1**2+ &
                 (-4.62d2-5.58d2*anpl2)/sy1**3+(9.9d2*anpl2+2.1d2*anpl4)/sy1**4 &
                 -6.6d2*anpl4/sy1**5+1.4d2*anpl4*anpl2/sy1**6)))
    rr(-1,2,1) = -bth2/sy1*(1.0d0+bth2*(1.25d0-1.75d0/sy1+1.5d0*anpl2/sy1**2)+ &
                 bth4*3.d0/32.d0*(5.d0-35.d0/sy1+(42.d0+48.d0*anpl2)/sy1**2- &
                 108.d0*anpl2/sy1**3+40.0d0*anpl4/sy1**4 + &
                 0.5d0*bth2*(-5.d0-35.d0/sy1+(21.d1+12.d1*anpl2)/sy1**2- &
                 (231.d0+837.d0*anpl2)/sy1**3+12.d0*anpl2*(99.d0+35.d0*anpl2)/sy1**4 - &
                 1100.d0*anpl4/sy1**5 + 280.d0*anpl2*anpl4/sy1**6)))

    if(llm==1) return

    rr(0,0,2) = -4.0d0*bth2*(1.0d0+bth2*(-0.5d0+0.5d0*anpl2)+ &
                bth4*(1.125d0-1.875d0*anpl2+0.75d0*anpl4)+bth6* &
                3.0d0*(-61.d0+157.d0*anpl2-136.d0*anpl4+40.d0*anpl2*anpl4)/64.d0)
    rr(0,1,2) = -2.0d0*anpl*bth4*(1.0d0+bth2*(-1.5d0+1.5d0*anpl2)+ &
                bth4*(39.d0-69.d0*anpl2+30.0d0*anpl4)/8.0d0)
    rr(0,2,2) = -2.0d0*bth4*(1.0d0+bth2*(0.75d0+1.5d0*anpl2)+ bth4* &
                (13.d0-48.d0*anpl2 +40.0d0*anpl4)*3.0d0/32.0d0)
    rr(-1,0,2) = -4.0d0*bth2/sy1*(1.0d0+bth2* &
                 (1.25d0-1.75d0/sy1+0.5d0*anpl2/sy1**2)+bth4* &
                 (0.46875d0-3.28125d0/sy1+(3.9375d0+1.5d0*anpl2)/sy1**2 &
                 -3.375d0*anpl2/sy1**3+0.75d0*anpl4/sy1**4)+bth4*bth2*3.0d0/64.d0* &
                 (-5.0d0-35.0d0/sy1+(210.d0+40.d0*anpl2)/sy1**2-3.0d0*(77.d0+93.d0*anpl2)/sy1**3+ &
                 (396.0*anpl2+84.d0*anpl4)/sy1**4-220.d0*anpl4/sy1**5+40.d0*anpl4*anpl2/sy1**6))
    rr(-1,1,2) = -2.0d0*bth4*anpl/sy1**2*(1.0d0+bth2* &
                 (3.0d0-4.5d0/sy1+1.5d0*anpl2/sy1**2) + bth4* &
                 (20.d0-93.d0/sy1+(99.d0+42.d0*anpl2)/sy1**2- &
                 88.d0*anpl2/sy1**3+20.d0*anpl4/sy1**4)*3.0d0/16.0d0)
    rr(-1,2,2) = -2.0d0*bth4/sy1*(1.0d0+bth2* &
                 (3.0d0-2.25d0/sy1+1.5d0*anpl2/sy1**2)+ bth4* &
                 (40.d0*anpl4/sy1**4-132.0d0*anpl2/sy1**3+ &
                 (66.d0+84.d0*anpl2)/sy1**2-93.d0/sy1+40.0d0)*3.0d0/32.0d0)
    rr(-2,0,2) = -4.0d0*bth2/sy2*(1.0d0+bth2* &
                 (1.25d0-1.75d0/sy2+0.5d0*anpl2/sy2**2)+bth4* &
                 (0.46875d0-3.28125d0/sy2+(3.9375d0+1.5d0*anpl2)/sy2**2 &
                 -3.375d0*anpl2/sy2**3+0.75d0*anpl4/sy2**4)+bth4*bth2*3.0d0/64.d0* &
                 (-5.0d0-35.0d0/sy2+(210.d0+40.d0*anpl2)/sy2**2-3.0d0*(77.d0+93.d0*anpl2)/sy2**3+ &
                 (396.0*anpl2+84.d0*anpl4)/sy2**4-220.d0*anpl4/sy2**5+40.d0*anpl4*anpl2/sy2**6))
    rr(-2,1,2) = -2.0d0*bth4*anpl/sy2**2*(1.0d0+bth2* &
                 (3.0d0-4.5d0/sy2+1.5d0*anpl2/sy2**2) + bth4* &
                 (20.d0-93.d0/sy2+(99.d0+42.d0*anpl2)/sy2**2- &
                 88.d0*anpl2/sy2**3+20.d0*anpl4/sy2**4)*3.0d0/16.0d0)
    rr(-2,2,2) = -2.0d0*bth4/sy2*(1.0d0+bth2* &
                 (3.0d0-2.25d0/sy2+1.5d0*anpl2/sy2**2) + bth4* &
                 (40.d0*anpl4/sy2**4-132.0d0*anpl2/sy2**3+ &
                 (66.d0+84.d0*anpl2)/sy2**2-93.d0/sy2+40.0d0)*3.0d0/32.0d0)

    if(llm==2) return

    rr(0,0,3) = -12.0d0*bth4*(1.0d0+bth2*(0.75d0+0.5d0*anpl2)+bth4* &
                (1.21875d0-1.5d0*anpl2+0.75d0*anpl2*anpl2))
    rr(0,1,3) = -6.0d0*anpl*bth6*(1+bth2*(-0.25d0+1.5d0*anpl2))
    rr(0,2,3) = -6.0d0*bth6*(1.0d0+bth2*(2.5d0+1.5d0*anpl2))
    rr(-1,0,3) = -12.0d0*bth4/sy1* &
                 (1.0d0+bth2*(3.0d0-2.25d0/sy1+0.5d0*anpl2/sy1**2)+ &
                 bth4*(3.75d0-8.71875d0/sy1+(6.1875d0+2.625d0*anpl2) &
              /sy1**2-4.125d0*anpl2/sy1**3+0.75*anpl2*anpl2/sy1**4))
    rr(-1,1,3) = -6.0d0*anpl*bth6/sy1**2* &
                 (1.0d0+bth2*(5.25d0-5.5d0/sy1+1.5d0*anpl2/sy1**2))
    rr(-1,2,3) = -6.0d0*bth6/sy1* &
                 (1.0d0+bth2*(5.25d0-2.75d0/sy1+1.5d0*anpl2/sy1**2))
    rr(-2,0,3) = -12.0d0*bth4/sy2* &
                  (1.0d0+bth2*(3.0d0-2.25d0/sy2+0.5d0*anpl2/sy2**2)+ &
                  bth4*(3.75d0-8.71875d0/sy2+(6.1875d0+2.625d0*anpl2) &
              /sy2**2-4.125d0*anpl2/sy2**3+0.75*anpl2*anpl2/sy2**4))
    rr(-2,1,3) = -6.0d0*anpl*bth6/sy2**2* &
                  (1.0d0+bth2*(5.25d0-5.5d0/sy2+1.5d0*anpl2/sy2**2))
    rr(-2,2,3) = -6.0d0*bth6/sy2* &
                  (1.0d0+bth2*(5.25d0-2.75d0/sy2+1.5d0*anpl2/sy2**2))
    rr(-3,0,3) = -12.0d0*bth4/sy3* &
                  (1.0d0+bth2*(3.0d0-2.25d0/sy3+0.5d0*anpl2/sy3**2)+ &
                  bth4*(3.75d0-8.71875d0/sy3+(6.1875d0+2.625d0*anpl2) &
              /sy3**2-4.125d0*anpl2/sy3**3+0.75*anpl2*anpl2/sy3**4))
    rr(-3,1,3) = -6.0d0*anpl*bth6/sy3**2* &
                  (1.0d0+bth2*(5.25d0-5.5d0/sy3+1.5d0*anpl2/sy3**2))
    rr(-3,2,3) = -6.0d0*bth6/sy3* &
                  (1.0d0+bth2*(5.25d0-2.75d0/sy3+1.5d0*anpl2/sy3**2))

    if(llm==3) return

    rr(0,0,4) = -4.8d1*bth6*(1.0d0+bth2*(2.5d0+0.5d0*anpl2))
    rr(0,1,4) = -2.4d1*anpl*bth8
    rr(0,2,4) = -2.4d1*bth8
    rr(-1,0,4) = -4.8d1*bth6*(1.0d0+bth2*(5.25d0-2.75d0/sy1+0.5d0*anpl2/sy1**2))
    rr(-1,1,4) = -2.4d1*anpl*bth8/sy1**2
    rr(-1,2,4) = -2.4d1*bth8/sy1
    rr(-2,0,4) = -4.8d1*bth6*(1.0d0+bth2*(5.25d0-2.75d0/sy2+0.5d0*anpl2/sy2**2))
    rr(-2,1,4) = -2.4d1*anpl*bth8/sy2**2
    rr(-2,2,4) = -2.4d1*bth8/sy2
    rr(-3,0,4) = -4.8d1*bth6*(1.0d0+bth2*(5.25d0-2.75d0/sy3+0.5d0*anpl2/sy3**2))
    rr(-3,1,4) = -2.4d1*anpl*bth8/sy3**2
    rr(-3,2,4) = -2.4d1*bth8/sy3
    rr(-4,0,4) = -4.8d1*bth6*(1.0d0+bth2*(5.25d0-2.75d0/sy4+0.5d0*anpl2/sy4**2))
    rr(-4,1,4) = -2.4d1*anpl*bth8/sy4**2
    rr(-4,2,4) = -2.4d1*bth8/sy4
  end subroutine hermitian

  subroutine antihermitian(yg,anpl,amu,ri,lrm)
    implicit none
    real(r8), intent(in) :: yg,anpl,amu
    integer, intent(in) :: lrm
    real(r8), intent(out) :: ri(lrm,0:2,lrm)
    integer :: n, k, m, mm
    real(r8), dimension(lrm+2) :: fsbi
    real(r8) :: cmu,dnl,cmxw,ci,ygn,rdu2,rdu
    real(r8) :: du,ub,aa,up,um,gp,gm,xp,xm,eep,eem,ee,cm,cim
    real(r8) :: fi0p0,fi1p0,fi2p0,fi0m0,fi1m0,fi2m0
    real(r8) :: fi0p1,fi1p1,fi2p1,fi0m1,fi1m1,fi2m1,fi0m,fi1m,fi2m

    ri(:,:,:) = 0._r8
    dnl = 1.0_r8 - anpl**2
    cmu = anpl*amu
    cmxw = 1._r8 + 15._r8/(8._r8*amu) + 105._r8/(128._r8*amu**2)
    ci = sqrt(2._r8*pi*amu)*amu**2/cmxw
    do n=1,lrm
      ygn=n*yg
      rdu2=ygn**2-dnl
      if(rdu2>0.0_r8) then
        rdu=sqrt(rdu2)
        du=rdu/dnl
        ub=anpl*ygn/dnl
        aa=amu*anpl*du
        ! Change by S. Denk - it is possible to get values for gamma that are smaller than 1 - this line fixes that
        !if(ygn + anpl* (ub+du) < 1.d0 .or. (ygn + anpl* ub-du) < 1.d0) cycle! gamma < 1 possible for N_par large
        ! => resonance condition not full filled
        if (abs(aa)>5.0_r8) then !if (abs(aa)>1.0_r8) then
          up=ub+du
          um=ub-du
          gp=anpl*up+ygn
          gm=anpl*um+ygn
          xp=up+1.0_r8/cmu
          xm=um+1.0_r8/cmu
          eem=exp(-amu*(gm-1.0_r8))
          eep=exp(-amu*(gp-1.0_r8))
          fi0p0=-1.0_r8/cmu
          fi1p0=-xp/cmu
          fi2p0=-(1.0_r8/cmu**2+xp*xp)/cmu
          fi0m0=-1.0_r8/cmu
          fi1m0=-xm/cmu
          fi2m0=-(1.0_r8/cmu**2+xm*xm)/cmu
          do m=1,lrm
            fi0p1=-2.0_r8*m*(fi1p0-ub*fi0p0)/cmu
            fi0m1=-2.0_r8*m*(fi1m0-ub*fi0m0)/cmu
            fi1p1=-((1.0_r8+2*m)*fi2p0-2.0_r8*(m+1)*ub*fi1p0    &
                   +up*um*fi0p0)/cmu
            fi1m1=-((1.0_r8+2*m)*fi2m0-2.0_r8*(m+1)*ub*fi1m0    &
                   +up*um*fi0m0)/cmu
            fi2p1=(2.0_r8*(1+m)*fi1p1-2.0_r8*m*                 &
                 (ub*fi2p0-up*um*fi1p0))/cmu
            fi2m1=(2.0_r8*(1+m)*fi1m1-2.0_r8*m*                 &
                 (ub*fi2m0-up*um*fi1m0))/cmu
            if(m>=n) then
              ri(n,0,m)=0.5_r8*ci*dnl**m*(fi0p1*eep-fi0m1*eem)
              ri(n,1,m)=0.5_r8*ci*dnl**m*(fi1p1*eep-fi1m1*eem)
              ri(n,2,m)=0.5_r8*ci*dnl**m*(fi2p1*eep-fi2m1*eem)
            end if
            fi0p0=fi0p1
            fi1p0=fi1p1
            fi2p0=fi2p1
            fi0m0=fi0m1
            fi1m0=fi1m1
            fi2m0=fi2m1
          end do
        else
          ! Change by S. Denk - it is possible to get values for gamma that are smaller than 1 - this line fixes that
          !if((ygn- +anpl*ub) < 1.d0) cycle! gamma < 1 possible for N_par large
          ! => resonance condition not full filled
          ee=exp(-amu*(ygn-1.0_r8+anpl*ub))
          fsbi(1:lrm+2)=ssbi(aa,n,lrm)
          do m=n,lrm
            cm=pi_sqrt*fact(m)*du**(2*m+1)
            cim=0.5_r8*ci*dnl**m
            mm=m-n+1
            fi0m=cm*fsbi(mm)
            fi1m=-0.5_r8*aa*cm*fsbi(mm+1)
            fi2m=0.5_r8*cm*(fsbi(mm+1)+0.5_r8*aa*aa*fsbi(mm+2))
            ri(n,0,m)=cim*ee*fi0m
            ri(n,1,m)=cim*ee*(du*fi1m+ub*fi0m)
            ri(n,2,m)=cim*ee*(du*du*fi2m+2.0_r8*du*ub*fi1m+ub*ub*fi0m)
          end do
        end if
      end if
    end do
  end subroutine antihermitian

  subroutine dieltens_maxw_fr(xg,yg,anpl,amu,e330,epsl,lrm,iwarm)
! dielectric tensor elements using fully relativistic expressions
! Expansion to lrm-th order in Larmor radius
    implicit none
    real(r8), intent(in) :: xg,yg,anpl,amu
    integer, intent(in) :: lrm,iwarm
    complex(r8), intent(out) :: e330, epsl(3,3,lrm)
    integer :: i,j,l,lm,is,k
    complex(r8) :: ca11,ca12,ca22,ca13,ca23,ca33
    complex(r8) :: cq0p,cq0m,cq1p,cq1m,cq2p
    real(r8) :: rr(-lrm:lrm,0:2,0:lrm),ri(lrm,0:2,lrm)
    real(r8) :: fal,asl,bsl

    epsl(:,:,:) = (0._r8,0._r8)
    call hermitian(yg,anpl,amu,rr,lrm,iwarm)
    call antihermitian(yg,anpl,amu,ri,lrm)
    do l=1,lrm
      lm=l-1
      fal=-0.25_r8**l*fact(2*l)/(fact(l)**2*yg**(2*lm))
      ca11=(0._r8,0._r8)
      ca12=(0._r8,0._r8)
      ca13=(0._r8,0._r8)
      ca22=(0._r8,0._r8)
      ca23=(0._r8,0._r8)
      ca33=(0._r8,0._r8)
      do is=0,l
        k=l-is
        asl=real((-1)**k,kind=r8)/(fact(is+l)*fact(l-is))
        bsl=asl*(is*is+real(2*k*lm*(l+is),kind=r8)/(2*l-1))
        if(is>0) then
          cq0p=rr(is,0,l)+rr(-is,0,l)+ui*ri(is,0,l)
          cq0m=rr(is,0,l)-rr(-is,0,l)+ui*ri(is,0,l)
          cq1p=rr(is,1,l)+rr(-is,1,l)+ui*ri(is,1,l)
          cq1m=rr(is,1,l)-rr(-is,1,l)+ui*ri(is,1,l)
          cq2p=rr(is,2,l)+rr(-is,2,l)+ui*ri(is,2,l)
        else
          cq0p=rr(is,0,l)
          cq0m=rr(is,0,l)
          cq1p=rr(is,1,l)
          cq1m=rr(is,1,l)
          cq2p=rr(is,2,l)
        end if
        ca11=ca11+is**2*asl*cq0p
        ca12=ca12+is*l*asl*cq0m
        ca22=ca22+bsl*cq0p
        ca13=ca13+is*asl*cq1m/yg
        ca23=ca23+l*asl*cq1p/yg
        ca33=ca33+asl*cq2p/yg**2
      end do
      epsl(1,1,l) =  - xg*ca11*fal
      epsl(1,2,l) =  + ui*xg*ca12*fal
      epsl(2,2,l) =  - xg*ca22*fal
      epsl(1,3,l) =  - xg*ca13*fal
      epsl(2,3,l) =  - ui*xg*ca23*fal
      epsl(3,3,l) =  - xg*ca33*fal
    end do
    cq2p=rr(0,2,0)
    e330=1.0_r8+xg*cq2p
    epsl(1,1,1) = 1._r8 + epsl(1,1,1)
    epsl(2,2,1) = 1._r8 + epsl(2,2,1)
    do l=1,lrm
      epsl(2,1,l) = - epsl(1,2,l)
      epsl(3,1,l) =   epsl(1,3,l)
      epsl(3,2,l) = - epsl(2,3,l)
    end do
  end subroutine dieltens_maxw_fr

  subroutine warmdisp(xg,yg,anpl,amu,sox,iwarm,lrm,anprc,anpr,ex,ey,ez,ierr)
    implicit none
    real(r8), intent(in) :: xg,yg,anpl,amu,anprc
    integer, intent(in) :: sox,iwarm,lrm
    complex(r8), intent(out) :: anpr
    complex(r8), intent(out) :: ex,ey,ez
    integer, intent(out) :: ierr
    integer, parameter :: imx=100
    complex(r8) :: cc0,cc2,cc4,rr,anpr2a,anpra,anpr2,den
    complex(r8), dimension(3,3,lrm) :: epsl
    complex(r8), dimension(3,3) :: sepsl
    complex(r8) :: e330
    complex(r8) :: e11,e22,e12,e13,e23!,e33,e21,e31,e32
    complex(r8) :: a13,a31,a23,a32,a33
    real(r8) :: errnpr,s,anpl2,ex2,ey2,ez2,enx2
    integer :: i,j,k,ilrm

    ierr=0
    errnpr=1.0_r8
    anpr2a=anprc**2
    anpl2=anpl*anpl

!    if (iwarm==1) then
!      call dieltens_maxw_wr(xg,yg,anpl,amu,e330,epsl,lrm)
!    else
      call dieltens_maxw_fr(xg,yg,anpl,amu,e330,epsl,lrm,iwarm)
!    end if

    do i=1,imx
      do j=1,3
        do k=1,3
          sepsl(k,j)=cmplx(0.0_r8,0.0_r8,kind=r8)
          do ilrm=1,lrm
            sepsl(k,j)=sepsl(k,j)+epsl(k,j,ilrm)*anpr2a**(ilrm-1)
          end do
        end do
      end do
      anpra=sqrt(anpr2a)

      e11=sepsl(1,1)
      e22=sepsl(2,2)
      e12=sepsl(1,2)
      a33=sepsl(3,3)
      a13=sepsl(1,3)
      a23=sepsl(2,3)
      a31=a13
      a32=-a23
!     e33=e330+anpr2a*a33
      e13=anpra*a13
      e23=anpra*a23
!     e21=-e12
!     e31=e13
!     e32=-e23

!omaj - change: reduce the threshold (the first line is the original one)
!      if(i>2 .and. errnpr<1.0e-3_r8) exit
      if(i>2 .and. errnpr<1.0e-4_r8) exit
!omaj - end change

      cc4=(e11-anpl2)*(1.0_r8-a33)+(a13+anpl)*(a31+anpl)
      cc2=-e12*e12*(1.0_r8-a33) &
          -a32*e12*(a13+anpl)+a23*e12*(a31+anpl) &
          -(a23*a32+e330+(e22-anpl2)*(1.0_r8-a33))*(e11-anpl2) &
          -(a13+anpl)*(a31+anpl)*(e22-anpl2)
      cc0=e330*((e11-anpl2)*(e22-anpl2)+e12*e12)
      rr=cc2*cc2-4.0_r8*cc0*cc4
      if(yg>1.0_r8) then
        s=sox
        if(aimag(rr)<=0.0_r8) s=-s
      else
        s=-sox
        if(real(rr)<=0._r8 .and. aimag(rr)>=0._r8) s=-s
      end if
      anpr2=(-cc2+s*sqrt(rr))/(2.0_r8*cc4)
      errnpr=abs(1.0_r8-abs(anpr2)/abs(anpr2a))
      anpr2a=anpr2
    end do

    if(real(anpr2)<0.0_r8 .and. aimag(anpr2)<0.0_r8) then
!      print*,'  X, Y nperp2=',xg,yg,anpr2,'   nperp2 < 0'
      anpr2=0.0_r8
      ierr=99
    end if
    if(i>imx) then
!      print*,'    i>imx ',yg,errnpr,i
      ierr=100
    end if

    anpr=sqrt(anpr2)

    ex=(0.0_r8,0.0_r8)
    ey=(0.0_r8,0.0_r8)
    ez=(0.0_r8,0.0_r8)
    if (abs(anpl)>1.0e-6_r8) then
      den=e12*e23-(e13+anpr*anpl)*(e22-anpr2-anpl2)
      ey=-(e12*(e13+anpr*anpl)+(e11-anpl2)*e23)/den
      ez=(e12*e12+(e22-anpr2-anpl2)*(e11-anpl2))/den
      ez2=abs(ez)**2
      ey2=abs(ey)**2
      enx2=1.0_r8/(1.0_r8+ey2+ez2)
      ex=cmplx(sqrt(enx2),0.0_r8,kind=r8)
      ez2=ez2*enx2
      ey2=ey2*enx2
      ez=ez*ex
      ey=ey*ex
    else
      if(sox<0) then
        ez=(1.0_r8,0.0_r8)
        ez2=abs(ez)**2
      else
        ex2=1.0_r8/(1.0_r8+abs(-e11/e12)**2)
        ex=sqrt(ex2)
        ey=-ex*e11/e12
        ey2=abs(ey)**2
        ez2=0.0_r8
      end if
    end if
  end subroutine warmdisp

  subroutine colddisp(xg,yg,npl,sox,nprf)
!
! solution cold dispersion relation
!
    implicit none
!
    real(r8), intent(in) :: xg           ! X=omegap^2/omega^2
    real(r8), intent(in) :: yg           ! Y=omegac/omega
    real(r8), intent(in) :: npl          ! N parallel to B
    integer, intent(in) :: sox           ! sox=-1 ==> O mode, sox=1 ==> X mode
    real(r8), intent(out) :: nprf        ! N perpendicular to B (cold)
!
    real(r8) :: yg2,npl2,nprf2,n_f2,dnl,del
!
    npl2=npl**2
    dnl=1.0_r8-npl2
    yg2=yg**2
    del=sqrt(dnl**2+4.0_r8*npl2*(1.0_r8-xg)/yg2)
    n_f2=1.0_r8-xg-xg*yg2*(1.0_r8+npl2+sox*del)/(1.0_r8-xg-yg2)/2.0_r8
!
    nprf2=n_f2-npl2
    nprf=sqrt(nprf2)
!
  end subroutine colddisp

  function larmornumber(yg,npl,mu) result(nharm)
!
! computation of local harmonic number
!
    implicit none
!
    integer :: nharm                    ! n=number of the armonic
    real(r8), parameter :: expcr=15._r8 ! maximum value for mu*(gamma-1) above
                                        ! which the distribution function is
                                        ! considered to be 0
!    real(r8), parameter :: eps=1.d-8    ! small number to have a correct rounding
!                                        ! when ygnc/yg is an integer
    real(r8), intent(in) :: yg          ! Y=omegac/omega
    real(r8), intent(in) :: npl         ! parallel N
    real(r8), intent(in) :: mu          ! me*c^2/Te
    real(r8) :: ygn                     ! n*Y
    real(r8) :: gg                      ! gamma=sqrt(1+u^2)
    real(r8) :: dnl,rdu2
    real(r8) :: argexp
    integer :: lrm,larm, imax
!
    dnl=1.0_r8-npl**2
!
    imax = 1
    nharm=int(1.0_r8/yg)
    if(nharm*yg < 1.0_r8) nharm=nharm+1
!    ygnc=sqrt(dnl)             ! critical value of Y*n to have resonance
!    nharm=int(ygnc/yg-eps)+1 ! first resonant harmonic
!    nharm=int(1.0_r8/yg-eps)+1 ! first harmonic with u1,u2 of opposite sign
!
    do
      ygn=nharm*yg
      rdu2=ygn**2-dnl
      gg=(ygn-sqrt(npl**2*rdu2))/dnl
      argexp=mu*(gg-1.0_r8)
      if(argexp.gt.expcr) exit
      nharm=nharm+1
      imax = imax + 1
      if(imax > 100) then
        nharm = int(yg)
        exit
      end if
    enddo
!    if((yg*(nharm-1))**2 >= dnl) nharm=nharm-1
!
  end function larmornumber
! Interface written by Omar Maj
  subroutine warmdamp(op, oc, Nr, theta, te, m, imod, N_perp_cmplx, pol_vec)

    ! ---------------------------------------------------------------------
    ! Wrapper for D. Farina' warmdisp routine.
    ! ---------------------------------------------------------------------

    use constants, only: mass_e, c0, e0
    ! ... implicit none statement ...
    implicit none

    ! ... paramenters ...
    integer, parameter :: imax = 3 ! max harmonics number
    integer, parameter :: fast = 3
    integer, parameter :: r8 = selected_real_kind(15,300)

    ! ... input variables ...
    integer, intent(in)  ::   &
         imod, &                   ! = -1 for O-mode, = 1 for X-mode
         m
    real(r8), intent(in) ::   &
         op,                  & ! = omega_p^2 / omega^2
         oc,                  & ! = omega_c^2 / omega^2
         theta,               & ! angle between N and the magnetic field
         te                     ! electron temperature in keV
    real(r8), intent(in) ::  Nr! modulus of the refractive index N

    ! ... output variables ...
    complex(r8), intent(out) ::  &
        N_perp_cmplx                 ! complex refractive index
                                     ! N_perp_cmplx obtained from the disp. rel.
    complex(r8), intent(out), dimension(:), optional :: pol_vec
    ! ... local variables ...
    integer  ::               &
         err,                 & ! error flag
         nharm,               & ! hamrnic number
         lrm                    ! effective harmonic number
    real(r8) ::               &
         sqoc,                & ! = omega_c / omega
         mu,                  & ! = 511.e0_r8/te
         Nll, Npr               ! parallel and perpendicular N
    complex(r8) ::            &
         ex, ey, ez             ! polarization unit vector

! ... f2py directives ...
!f2py integer intent(in) :: imod
!f2py real*8 intent(in) :: op, oc, Nr, theta, te
!f2py real*8 intent(out) :: imNprw

    ! =====================================================================
    ! Executable statements

    ! ... initialize common variables of the module ecdisp ...
    !call set_extv

    ! ... definition of parameters ...
    sqoc = sqrt(oc)
    Nll  = Nr * cos(theta)
    Npr  = sqrt(Nr**2 - Nll**2)
    mu   = mass_e * c0**2/(te * e0)

    ! ... find the harmonic number ...
    nharm = larmornumber(sqoc, Nll, mu)
    !if(nharm == 1) then
    !   imNprw = 0.
    !   return
    !end if

    lrm = min(imax, nharm)

    ! ... estimate the warm-plasma dispersion function ...
    call warmdisp(op, sqoc, Nll, mu, imod, fast, lrm, Npr,                &
         N_perp_cmplx, ex, ey, ez, err)

    ! ... extract imaginary part of the refractive index ...
    if(present(pol_vec)) then
      pol_vec(1) = ex
      pol_vec(2) = ey
      pol_vec(3) = ez
    end if
    ! ... do not allow negative values, put 0 instead ...
    if (aimag(N_perp_cmplx) < 0.) then
       N_perp_cmplx = cmplx(0., 0.)
       if(present(pol_vec)) pol_vec(:) = cmplx(0.d0, 0.d0)
    end if

    return
  end subroutine warmdamp

end module mod_ECRad_abs_Fa


      subroutine dgeco(a,lda,n,ipvt,rcond,z)
      integer lda,n,ipvt(*)
      double precision a(lda,*),z(*)
      double precision rcond
c
c     dgeco factors a double precision matrix by gaussian elimination
c     and estimates the condition of the matrix.
c
c     if  rcond  is not needed, dgefa is slightly faster.
c     to solve  a*x = b , follow dgeco by dgesl.
c     to compute  inverse(a)*c , follow dgeco by dgesl.
c     to compute  determinant(a) , follow dgeco by dgedi.
c     to compute  inverse(a) , follow dgeco by dgedi.
c
c     on entry
c
c        a       double precision(lda, n)
c                the matrix to be factored.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        rcond   double precision
c                an estimate of the reciprocal condition of  a .
c                for the system  a*x = b , relative perturbations
c                in  a  and  b  of size  epsilon  may cause
c                relative perturbations in  x  of size  epsilon/rcond .
c                if  rcond  is so small that the logical expression
c                           1.0 + rcond .eq. 1.0
c                is true, then  a  may be singular to working
c                precision.  in particular,  rcond  is zero  if
c                exact singularity is detected or the estimate
c                underflows.
c
c        z       double precision(n)
c                a work vector whose contents are usually unimportant.
c                if  a  is close to a singular matrix, then  z  is
c                an approximate null vector in the sense that
c                norm(a*z) = rcond*norm(a)*norm(z) .
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     linpack dgefa
c     blas daxpy,ddot,dscal,dasum
c     fortran dabs,dmax1,dsign
c
c     internal variables
c
      double precision ddot,ek,t,wk,wkm
      double precision anorm,s,dasum,sm,ynorm
      integer info,j,k,kb,kp1,l
c
c
c     compute 1-norm of a

c
      anorm = 0.0d0
      do 10 j = 1, n

           anorm = dmax1(anorm,dasum(n,a(1,j),1))

   10 continue

c
c     factor
c
      call dgefa(a,lda,n,ipvt,info)

c
c     rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) .
c     estimate = norm(z)/norm(y) where  a*z = y  and  trans(a)*y = e .
c     trans(a)  is the transpose of a .  the components of  e  are
c     chosen to cause maximum local growth in the elements of w  where
c     trans(u)*w = e .  the vectors are frequently rescaled to avoid
c     overflow.
c
c     solve trans(u)*w = e
c
      ek = 1.0d0
      do 20 j = 1, n
         z(j) = 0.0d0
   20 continue
      do 100 k = 1, n
         if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k))
         if (dabs(ek-z(k)) .le. dabs(a(k,k))) go to 30
            s = dabs(a(k,k))/dabs(ek-z(k))
            call dscal(n,s,z,1)
            ek = s*ek
   30    continue

         wk = ek - z(k)
         wkm = -ek - z(k)
         s = dabs(wk)
         sm = dabs(wkm)
         if (a(k,k) .eq. 0.0d0) go to 40
            wk = wk/a(k,k)
            wkm = wkm/a(k,k)
         go to 50
   40    continue
            wk = 1.0d0
            wkm = 1.0d0
   50    continue
         kp1 = k + 1
         if (kp1 .gt. n) go to 90
            do 60 j = kp1, n
               sm = sm + dabs(z(j)+wkm*a(k,j))
               z(j) = z(j) + wk*a(k,j)
               s = s + dabs(z(j))
   60       continue
            if (s .ge. sm) go to 80
               t = wkm - wk
               wk = wkm
               do 70 j = kp1, n
                  z(j) = z(j) + t*a(k,j)
   70          continue
   80       continue
   90    continue
         z(k) = wk
  100 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
c
c     solve trans(l)*y = w
c
      do 120 kb = 1, n
         k = n + 1 - kb
         if (k .lt. n) z(k) = z(k) + ddot(n-k,a(k+1,k),1,z(k+1),1)
         if (dabs(z(k)) .le. 1.0d0) go to 110
            s = 1.0d0/dabs(z(k))
            call dscal(n,s,z,1)
  110    continue
         l = ipvt(k)
         t = z(l)
         z(l) = z(k)
         z(k) = t
  120 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
c
      ynorm = 1.0d0
c
c     solve l*v = y
c
      do 140 k = 1, n
         l = ipvt(k)
         t = z(l)
         z(l) = z(k)
         z(k) = t
         if (k .lt. n) call daxpy(n-k,t,a(k+1,k),1,z(k+1),1)
         if (dabs(z(k)) .le. 1.0d0) go to 130
            s = 1.0d0/dabs(z(k))
            call dscal(n,s,z,1)
            ynorm = s*ynorm
  130    continue
  140 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
      ynorm = s*ynorm
c
c     solve  u*z = v
c
      do 160 kb = 1, n
         k = n + 1 - kb
         if (dabs(z(k)) .le. dabs(a(k,k))) go to 150
            s = dabs(a(k,k))/dabs(z(k))
            call dscal(n,s,z,1)
            ynorm = s*ynorm
  150    continue
         if (a(k,k) .ne. 0.0d0) z(k) = z(k)/a(k,k)
         if (a(k,k) .eq. 0.0d0) z(k) = 1.0d0
         t = -z(k)
         call daxpy(k-1,t,a(1,k),1,z(1),1)
  160 continue
c     make znorm = 1.0
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
      ynorm = s*ynorm
c
      if (anorm .ne. 0.0d0) rcond = ynorm/anorm
      if (anorm .eq. 0.0d0) rcond = 0.0d0
      return
      end
      subroutine dgefa(a,lda,n,ipvt,info)
      integer lda,n,ipvt(*),info
      double precision a(lda,*)
c
c     dgefa factors a double precision matrix by gaussian elimination.
c
c     dgefa is usually called by dgeco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c     (time for dgeco) = (1 + 9/n)*(time for dgefa) .
c
c     on entry
c
c        a       double precision(lda, n)
c                the matrix to be factored.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that dgesl or dgedi will divide by zero
c                     if called.  use  rcond  in dgeco for a reliable
c                     indication of singularity.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal,idamax
c
c     internal variables
c
      double precision t
      integer idamax,j,k,kp1,l,nm1
c
c
c     gaussian elimination with partial pivoting
c
      info = 0
      nm1 = n - 1
      if (nm1 .lt. 1) go to 70
      do 60 k = 1, nm1
         kp1 = k + 1
c
c        find l = pivot index
c
         l = idamax(n-k+1,a(k,k),1) + k - 1
         ipvt(k) = l
c
c        zero pivot implies this column already triangularized
c
         if (a(l,k) .eq. 0.0d0) go to 40
c
c           interchange if necessary
c
            if (l .eq. k) go to 10
               t = a(l,k)
               a(l,k) = a(k,k)
               a(k,k) = t
   10       continue
c
c           compute multipliers
c
            t = -1.0d0/a(k,k)
            call dscal(n-k,t,a(k+1,k),1)
c
c           row elimination with column indexing
c
            do 30 j = kp1, n
               t = a(l,j)
               if (l .eq. k) go to 20
                  a(l,j) = a(k,j)
                  a(k,j) = t
   20          continue
               call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1)
   30       continue
         go to 50
   40    continue
            info = k
   50    continue
   60 continue
   70 continue
      ipvt(n) = n
      if (a(n,n) .eq. 0.0d0) info = n
      return
      end
      subroutine dgesl(a,lda,n,ipvt,b,job)
      integer lda,n,ipvt(*),job
      double precision a(lda,*),b(*)
c
c     dgesl solves the double precision system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by dgeco or dgefa.
c
c     on entry
c
c        a       double precision(lda, n)
c                the output from dgeco or dgefa.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c        ipvt    integer(n)
c                the pivot vector from dgeco or dgefa.
c
c        b       double precision(n)
c                the right hand side vector.
c
c        job     integer
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b  where
c                            trans(a)  is the transpose.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if dgeco has set rcond .gt. 0.0
c        or dgefa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call dgeco(a,lda,n,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call dgesl(a,lda,n,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,ddot
c
c     internal variables
c
      double precision ddot,t
      integer k,kb,l,nm1
c
      nm1 = n - 1
      if (job .ne. 0) go to 50
c
c        job = 0 , solve  a * x = b
c        first solve  l*y = b
c
         if (nm1 .lt. 1) go to 30
         do 20 k = 1, nm1
            l = ipvt(k)
            t = b(l)
            if (l .eq. k) go to 10
               b(l) = b(k)
               b(k) = t
   10       continue
            call daxpy(n-k,t,a(k+1,k),1,b(k+1),1)
   20    continue
   30    continue
c
c        now solve  u*x = y
c
         do 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/a(k,k)
            t = -b(k)
            call daxpy(k-1,t,a(1,k),1,b(1),1)
   40    continue
      go to 100
   50 continue
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         do 60 k = 1, n
            t = ddot(k-1,a(1,k),1,b(1),1)
            b(k) = (b(k) - t)/a(k,k)
   60    continue
c
c        now solve trans(l)*x = y
c
         if (nm1 .lt. 1) go to 90
         do 80 kb = 1, nm1
            k = n - kb
            b(k) = b(k) + ddot(n-k,a(k+1,k),1,b(k+1),1)
            l = ipvt(k)
            if (l .eq. k) go to 70
               t = b(l)
               b(l) = b(k)
               b(k) = t
   70       continue
   80    continue
   90    continue
  100 continue
      return
      end
      subroutine dgbco(abd,lda,n,ml,mu,ipvt,rcond,z)
      integer lda,n,ml,mu,ipvt(*)
      double precision abd(lda,*),z(*)
      double precision rcond
c
c     dgbco factors a double precision band matrix by gaussian
c     elimination and estimates the condition of the matrix.
c
c     if  rcond  is not needed, dgbfa is slightly faster.
c     to solve  a*x = b , follow dgbco by dgbsl.
c     to compute  inverse(a)*c , follow dgbco by dgbsl.
c     to compute  determinant(a) , follow dgbco by dgbdi.
c
c     on entry
c
c        abd     double precision(lda, n)
c                contains the matrix in band storage.  the columns
c                of the matrix are stored in the columns of  abd  and
c                the diagonals of the matrix are stored in rows
c                ml+1 through 2*ml+mu+1 of  abd .
c                see the comments below for details.
c
c        lda     integer
c                the leading dimension of the array  abd .
c                lda must be .ge. 2*ml + mu + 1 .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c                0 .le. ml .lt. n .
c
c        mu      integer
c                number of diagonals above the main diagonal.
c                0 .le. mu .lt. n .
c                more efficient if  ml .le. mu .
c
c     on return
c
c        abd     an upper triangular matrix in band storage and
c                the multipliers which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        rcond   double precision
c                an estimate of the reciprocal condition of  a .
c                for the system  a*x = b , relative perturbations
c                in  a  and  b  of size  epsilon  may cause
c                relative perturbations in  x  of size  epsilon/rcond .
c                if  rcond  is so small that the logical expression
c                           1.0 + rcond .eq. 1.0
c                is true, then  a  may be singular to working
c                precision.  in particular,  rcond  is zero  if
c                exact singularity is detected or the estimate
c                underflows.
c
c        z       double precision(n)
c                a work vector whose contents are usually unimportant.
c                if  a  is close to a singular matrix, then  z  is
c                an approximate null vector in the sense that
c                norm(a*z) = rcond*norm(a)*norm(z) .
c
c     band storage
c
c           if  a  is a band matrix, the following program segment
c           will set up the input.
c
c                   ml = (band width below the diagonal)
c                   mu = (band width above the diagonal)
c                   m = ml + mu + 1
c                   do 20 j = 1, n
c                      i1 = max0(1, j-mu)
c                      i2 = min0(n, j+ml)
c                      do 10 i = i1, i2
c                         k = i - j + m
c                         abd(k,j) = a(i,j)
c                10    continue
c                20 continue
c
c           this uses rows  ml+1  through  2*ml+mu+1  of  abd .
c           in addition, the first  ml  rows in  abd  are used for
c           elements generated during the triangularization.
c           the total number of rows needed in  abd  is  2*ml+mu+1 .
c           the  ml+mu by ml+mu  upper left triangle and the
c           ml by ml  lower right triangle are not referenced.
c
c     example..  if the original matrix is
c
c           11 12 13  0  0  0
c           21 22 23 24  0  0
c            0 32 33 34 35  0
c            0  0 43 44 45 46
c            0  0  0 54 55 56
c            0  0  0  0 65 66
c
c      then  n = 6, ml = 1, mu = 2, lda .ge. 5  and abd should contain
c
c            *  *  *  +  +  +  , * = not used
c            *  * 13 24 35 46  , + = used for pivoting
c            * 12 23 34 45 56
c           11 22 33 44 55 66
c           21 32 43 54 65  *
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     linpack dgbfa
c     blas daxpy,ddot,dscal,dasum
c     fortran dabs,dmax1,max0,min0,dsign
c
c     internal variables
c
      double precision ddot,ek,t,wk,wkm
      double precision anorm,s,dasum,sm,ynorm
      integer is,info,j,ju,k,kb,kp1,l,la,lm,lz,m,mm
c
c
c     compute 1-norm of a
c
      anorm = 0.0d0
      l = ml + 1
      is = l + mu
      do 10 j = 1, n
         anorm = dmax1(anorm,dasum(l,abd(is,j),1))
         if (is .gt. ml + 1) is = is - 1
         if (j .le. mu) l = l + 1
         if (j .ge. n - ml) l = l - 1
   10 continue
c
c     factor
c
      call dgbfa(abd,lda,n,ml,mu,ipvt,info)
c
c     rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) .
c     estimate = norm(z)/norm(y) where  a*z = y  and  trans(a)*y = e .
c     trans(a)  is the transpose of a .  the components of  e  are
c     chosen to cause maximum local growth in the elements of w  where
c     trans(u)*w = e .  the vectors are frequently rescaled to avoid
c     overflow.
c
c     solve trans(u)*w = e
c
      ek = 1.0d0
      do 20 j = 1, n
         z(j) = 0.0d0
   20 continue
      m = ml + mu + 1
      ju = 0
      do 100 k = 1, n
         if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k))
         if (dabs(ek-z(k)) .le. dabs(abd(m,k))) go to 30
            s = dabs(abd(m,k))/dabs(ek-z(k))
            call dscal(n,s,z,1)
            ek = s*ek
   30    continue
         wk = ek - z(k)
         wkm = -ek - z(k)
         s = dabs(wk)
         sm = dabs(wkm)
         if (abd(m,k) .eq. 0.0d0) go to 40
            wk = wk/abd(m,k)
            wkm = wkm/abd(m,k)
         go to 50
   40    continue
            wk = 1.0d0
            wkm = 1.0d0
   50    continue
         kp1 = k + 1
         ju = min0(max0(ju,mu+ipvt(k)),n)
         mm = m
         if (kp1 .gt. ju) go to 90
            do 60 j = kp1, ju
               mm = mm - 1
               sm = sm + dabs(z(j)+wkm*abd(mm,j))
               z(j) = z(j) + wk*abd(mm,j)
               s = s + dabs(z(j))
   60       continue
            if (s .ge. sm) go to 80
               t = wkm - wk
               wk = wkm
               mm = m
               do 70 j = kp1, ju
                  mm = mm - 1
                  z(j) = z(j) + t*abd(mm,j)
   70          continue
   80       continue
   90    continue
         z(k) = wk
  100 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
c
c     solve trans(l)*y = w
c
      do 120 kb = 1, n
         k = n + 1 - kb
         lm = min0(ml,n-k)
         if (k .lt. n) z(k) = z(k) + ddot(lm,abd(m+1,k),1,z(k+1),1)
         if (dabs(z(k)) .le. 1.0d0) go to 110
            s = 1.0d0/dabs(z(k))
            call dscal(n,s,z,1)
  110    continue
         l = ipvt(k)
         t = z(l)
         z(l) = z(k)
         z(k) = t
  120 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
c
      ynorm = 1.0d0
c
c     solve l*v = y
c
      do 140 k = 1, n
         l = ipvt(k)
         t = z(l)
         z(l) = z(k)
         z(k) = t
         lm = min0(ml,n-k)
         if (k .lt. n) call daxpy(lm,t,abd(m+1,k),1,z(k+1),1)
         if (dabs(z(k)) .le. 1.0d0) go to 130
            s = 1.0d0/dabs(z(k))
            call dscal(n,s,z,1)
            ynorm = s*ynorm
  130    continue
  140 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
      ynorm = s*ynorm
c
c     solve  u*z = w
c
      do 160 kb = 1, n
         k = n + 1 - kb
         if (dabs(z(k)) .le. dabs(abd(m,k))) go to 150
            s = dabs(abd(m,k))/dabs(z(k))
            call dscal(n,s,z,1)
            ynorm = s*ynorm
  150    continue
         if (abd(m,k) .ne. 0.0d0) z(k) = z(k)/abd(m,k)
         if (abd(m,k) .eq. 0.0d0) z(k) = 1.0d0
         lm = min0(k,m) - 1
         la = m - lm
         lz = k - lm
         t = -z(k)
         call daxpy(lm,t,abd(la,k),1,z(lz),1)
  160 continue
c     make znorm = 1.0
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
      ynorm = s*ynorm
c
      if (anorm .ne. 0.0d0) rcond = ynorm/anorm
      if (anorm .eq. 0.0d0) rcond = 0.0d0
      return
      end
      subroutine dgbfa(abd,lda,n,ml,mu,ipvt,info)
      integer lda,n,ml,mu,ipvt(*),info
      double precision abd(lda,*)
c
c     dgbfa factors a double precision band matrix by elimination.
c
c     dgbfa is usually called by dgbco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c
c     on entry
c
c        abd     double precision(lda, n)
c                contains the matrix in band storage.  the columns
c                of the matrix are stored in the columns of  abd  and
c                the diagonals of the matrix are stored in rows
c                ml+1 through 2*ml+mu+1 of  abd .
c                see the comments below for details.
c
c        lda     integer
c                the leading dimension of the array  abd .
c                lda must be .ge. 2*ml + mu + 1 .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c                0 .le. ml .lt. n .
c
c        mu      integer
c                number of diagonals above the main diagonal.
c                0 .le. mu .lt. n .
c                more efficient if  ml .le. mu .
c     on return
c
c        abd     an upper triangular matrix in band storage and
c                the multipliers which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that dgbsl will divide by zero if
c                     called.  use  rcond  in dgbco for a reliable
c                     indication of singularity.
c
c     band storage
c
c           if  a  is a band matrix, the following program segment
c           will set up the input.
c
c                   ml = (band width below the diagonal)
c                   mu = (band width above the diagonal)
c                   m = ml + mu + 1
c                   do 20 j = 1, n
c                      i1 = max0(1, j-mu)
c                      i2 = min0(n, j+ml)
c                      do 10 i = i1, i2
c                         k = i - j + m
c                         abd(k,j) = a(i,j)
c                10    continue
c                20 continue
c
c           this uses rows  ml+1  through  2*ml+mu+1  of  abd .
c           in addition, the first  ml  rows in  abd  are used for
c           elements generated during the triangularization.
c           the total number of rows needed in  abd  is  2*ml+mu+1 .
c           the  ml+mu by ml+mu  upper left triangle and the
c           ml by ml  lower right triangle are not referenced.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal,idamax
c     fortran max0,min0
c
c     internal variables
c
      double precision t
      integer i,idamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1
c
c
      m = ml + mu + 1
      info = 0
c
c     zero initial fill-in columns
c
      j0 = mu + 2
      j1 = min0(n,m) - 1
      if (j1 .lt. j0) go to 30
      do 20 jz = j0, j1
         i0 = m + 1 - jz
         do 10 i = i0, ml
            abd(i,jz) = 0.0d0
   10    continue
   20 continue
   30 continue
      jz = j1
      ju = 0
c
c     gaussian elimination with partial pivoting
c
      nm1 = n - 1
      if (nm1 .lt. 1) go to 130
      do 120 k = 1, nm1
         kp1 = k + 1
c
c        zero next fill-in column
c
         jz = jz + 1
         if (jz .gt. n) go to 50
         if (ml .lt. 1) go to 50
            do 40 i = 1, ml
               abd(i,jz) = 0.0d0
   40       continue
   50    continue
c
c        find l = pivot index
c
         lm = min0(ml,n-k)
         l = idamax(lm+1,abd(m,k),1) + m - 1
         ipvt(k) = l + k - m
c
c        zero pivot implies this column already triangularized
c
         if (abd(l,k) .eq. 0.0d0) go to 100
c
c           interchange if necessary
c
            if (l .eq. m) go to 60
               t = abd(l,k)
               abd(l,k) = abd(m,k)
               abd(m,k) = t
   60       continue
c
c           compute multipliers
c
            t = -1.0d0/abd(m,k)
            call dscal(lm,t,abd(m+1,k),1)
c
c           row elimination with column indexing
c
            ju = min0(max0(ju,mu+ipvt(k)),n)
            mm = m
            if (ju .lt. kp1) go to 90
            do 80 j = kp1, ju
               l = l - 1
               mm = mm - 1
               t = abd(l,j)
               if (l .eq. mm) go to 70
                  abd(l,j) = abd(mm,j)
                  abd(mm,j) = t
   70          continue
               call daxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1)
   80       continue
   90       continue
         go to 110
  100    continue
            info = k
  110    continue
  120 continue
  130 continue
      ipvt(n) = n
      if (abd(m,n) .eq. 0.0d0) info = n
      return
      end
      subroutine dgbsl(abd,lda,n,ml,mu,ipvt,b,job)
      integer lda,n,ml,mu,ipvt(*),job
      double precision abd(lda,*),b(*)
c
c     dgbsl solves the double precision band system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by dgbco or dgbfa.
c
c     on entry
c
c        abd     double precision(lda, n)
c                the output from dgbco or dgbfa.
c
c        lda     integer
c                the leading dimension of the array  abd .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c
c        mu      integer
c                number of diagonals above the main diagonal.
c
c        ipvt    integer(n)
c                the pivot vector from dgbco or dgbfa.
c
c        b       double precision(n)
c                the right hand side vector.
c
c        job     integer
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b , where
c                            trans(a)  is the transpose.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if dgbco has set rcond .gt. 0.0
c        or dgbfa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call dgbco(abd,lda,n,ml,mu,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call dgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,ddot
c     fortran min0
c
c     internal variables
c
      double precision ddot,t
      integer k,kb,l,la,lb,lm,m,nm1
c
      m = mu + ml + 1
      nm1 = n - 1
      if (job .ne. 0) go to 50
c
c        job = 0 , solve  a * x = b
c        first solve l*y = b
c
         if (ml .eq. 0) go to 30
         if (nm1 .lt. 1) go to 30
            do 20 k = 1, nm1
               lm = min0(ml,n-k)
               l = ipvt(k)
               t = b(l)
               if (l .eq. k) go to 10
                  b(l) = b(k)
                  b(k) = t
   10          continue
               call daxpy(lm,t,abd(m+1,k),1,b(k+1),1)
   20       continue
   30    continue
c
c        now solve  u*x = y
c
         do 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/abd(m,k)
            lm = min0(k,m) - 1
            la = m - lm
            lb = k - lm
            t = -b(k)
            call daxpy(lm,t,abd(la,k),1,b(lb),1)
   40    continue
      go to 100
   50 continue
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         do 60 k = 1, n
            lm = min0(k,m) - 1
            la = m - lm
            lb = k - lm
            t = ddot(lm,abd(la,k),1,b(lb),1)
            b(k) = (b(k) - t)/abd(m,k)
   60    continue
c
c        now solve trans(l)*x = y
c
         if (ml .eq. 0) go to 90
         if (nm1 .lt. 1) go to 90
            do 80 kb = 1, nm1
               k = n - kb
               lm = min0(ml,n-k)
               b(k) = b(k) + ddot(lm,abd(m+1,k),1,b(k+1),1)
               l = ipvt(k)
               if (l .eq. k) go to 70
                  t = b(l)
                  b(l) = b(k)
                  b(k) = t
   70          continue
   80       continue
   90    continue
  100 continue
      return
      end
      subroutine dtrdi(t,ldt,n,det,job,info)
      integer ldt,n,job,info
      double precision t(ldt,*),det(2)
c
c     dtrdi computes the determinant and inverse of a double precision
c     triangular matrix.
c
c     on entry
c
c        t       double precision(ldt,n)
c                t contains the triangular matrix. the zero
c                elements of the matrix are not referenced, and
c                the corresponding elements of the array can be
c                used to store other information.
c
c        ldt     integer
c                ldt is the leading dimension of the array t.
c
c        n       integer
c                n is the order of the system.
c
c        job     integer
c                = 010       no det, inverse of lower triangular.
c                = 011       no det, inverse of upper triangular.
c                = 100       det, no inverse.
c                = 110       det, inverse of lower triangular.
c                = 111       det, inverse of upper triangular.
c
c     on return
c
c        t       inverse of original matrix if requested.
c                otherwise unchanged.
c
c        det     double precision(2)
c                determinant of original matrix if requested.
c                otherwise not referenced.
c                determinant = det(1) * 10.0**det(2)
c                with  1.0 .le. dabs(det(1)) .lt. 10.0
c                or  det(1) .eq. 0.0 .
c
c        info    integer
c                info contains zero if the system is nonsingular
c                and the inverse is requested.
c                otherwise info contains the index of
c                a zero diagonal element of t.
c
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal
c     fortran dabs,mod
c
c     internal variables
c
      double precision temp
      double precision ten
      integer i,j,k,kb,km1,kp1
c
c     begin block permitting ...exits to 180
c
c        compute determinant
c
         if (job/100 .eq. 0) go to 70
            det(1) = 1.0d0
            det(2) = 0.0d0
            ten = 10.0d0
            do 50 i = 1, n
               det(1) = t(i,i)*det(1)
c           ...exit
               if (det(1) .eq. 0.0d0) go to 60
   10          if (dabs(det(1)) .ge. 1.0d0) go to 20
                  det(1) = ten*det(1)
                  det(2) = det(2) - 1.0d0
               go to 10
   20          continue
   30          if (dabs(det(1)) .lt. ten) go to 40
                  det(1) = det(1)/ten
                  det(2) = det(2) + 1.0d0
               go to 30
   40          continue
   50       continue
   60       continue
   70    continue
c
c        compute inverse of upper triangular
c
         if (mod(job/10,10) .eq. 0) go to 170
            if (mod(job,10) .eq. 0) go to 120
c              begin block permitting ...exits to 110
                  do 100 k = 1, n
                     info = k
c              ......exit
                     if (t(k,k) .eq. 0.0d0) go to 110
                     t(k,k) = 1.0d0/t(k,k)
                     temp = -t(k,k)
                     call dscal(k-1,temp,t(1,k),1)
                     kp1 = k + 1
                     if (n .lt. kp1) go to 90
                     do 80 j = kp1, n
                        temp = t(k,j)
                        t(k,j) = 0.0d0
                        call daxpy(k,temp,t(1,k),1,t(1,j),1)
   80                continue
   90                continue
  100             continue
                  info = 0
  110          continue
            go to 160
  120       continue
c
c              compute inverse of lower triangular
c
               do 150 kb = 1, n
                  k = n + 1 - kb
                  info = k
c     ............exit
                  if (t(k,k) .eq. 0.0d0) go to 180
                  t(k,k) = 1.0d0/t(k,k)
                  temp = -t(k,k)
                  if (k .ne. n) call dscal(n-k,temp,t(k+1,k),1)
                  km1 = k - 1
                  if (km1 .lt. 1) go to 140
                  do 130 j = 1, km1
                     temp = t(k,j)
                     t(k,j) = 0.0d0
                     call daxpy(n-k+1,temp,t(k,k),1,t(k,j),1)
  130             continue
  140             continue
  150          continue
               info = 0
  160       continue
  170    continue
  180 continue
      return
      end
      subroutine dchdc(a,lda,p,work,jpvt,job,info)
      integer lda,p,jpvt(*),job,info
      double precision a(lda,*),work(*)
c
c     dchdc computes the cholesky decomposition of a positive definite
c     matrix.  a pivoting option allows the user to estimate the
c     condition of a positive definite matrix or determine the rank
c     of a positive semidefinite matrix.
c
c     on entry
c
c         a      double precision(lda,p).
c                a contains the matrix whose decomposition is to
c                be computed.  onlt the upper half of a need be stored.
c                the lower part of the array a is not referenced.
c
c         lda    integer.
c                lda is the leading dimension of the array a.
c
c         p      integer.
c                p is the order of the matrix.
c
c         work   double precision.
c                work is a work array.
c
c         jpvt   integer(p).
c                jpvt contains integers that control the selection
c                of the pivot elements, if pivoting has been requested.
c                each diagonal element a(k,k)
c                is placed in one of three classes according to the
c                value of jpvt(k).
c
c                   if jpvt(k) .gt. 0, then x(k) is an initial
c                                      element.
c
c                   if jpvt(k) .eq. 0, then x(k) is a free element.
c
c                   if jpvt(k) .lt. 0, then x(k) is a final element.
c
c                before the decomposition is computed, initial elements
c                are moved by symmetric row and column interchanges to
c                the beginning of the array a and final
c                elements to the end.  both initial and final elements
c                are frozen in place during the computation and only
c                free elements are moved.  at the k-th stage of the
c                reduction, if a(k,k) is occupied by a free element
c                it is interchanged with the largest free element
c                a(l,l) with l .ge. k.  jpvt is not referenced if
c                job .eq. 0.
c
c        job     integer.
c                job is an integer that initiates column pivoting.
c                if job .eq. 0, no pivoting is done.
c                if job .ne. 0, pivoting is done.
c
c     on return
c
c         a      a contains in its upper half the cholesky factor
c                of the matrix a as it has been permuted by pivoting.
c
c         jpvt   jpvt(j) contains the index of the diagonal element
c                of a that was moved into the j-th position,
c                provided pivoting was requested.
c
c         info   contains the index of the last positive diagonal
c                element of the cholesky factor.
c
c     for positive definite matrices info = p is the normal return.
c     for pivoting with positive semidefinite matrices info will
c     in general be less than p.  however, info may be greater than
c     the rank of a, since rounding error can cause an otherwise zero
c     element to be positive. indefinite systems will always cause
c     info to be less than p.
c
c     linpack. this version dated 03/19/79 .
c     j.j. dongarra and g.w. stewart, argonne national laboratory and
c     university of maryland.
c
c
c     blas daxpy,dswap
c     fortran dsqrt
c
c     internal variables
c
      integer pu,pl,plp1,i,j,jp,jt,k,kb,km1,kp1,l,maxl
      double precision temp
      double precision maxdia
      logical swapk,negk
c
      pl = 1
      pu = 0
      info = p
      if (job .eq. 0) go to 160
c
c        pivoting has been requested. rearrange the
c        the elements according to jpvt.
c
         do 70 k = 1, p
            swapk = jpvt(k) .gt. 0
            negk = jpvt(k) .lt. 0
            jpvt(k) = k
            if (negk) jpvt(k) = -jpvt(k)
            if (.not.swapk) go to 60
               if (k .eq. pl) go to 50
                  call dswap(pl-1,a(1,k),1,a(1,pl),1)
                  temp = a(k,k)
                  a(k,k) = a(pl,pl)
                  a(pl,pl) = temp
                  plp1 = pl + 1
                  if (p .lt. plp1) go to 40
                  do 30 j = plp1, p
                     if (j .ge. k) go to 10
                        temp = a(pl,j)
                        a(pl,j) = a(j,k)
                        a(j,k) = temp
                     go to 20
   10                continue
                     if (j .eq. k) go to 20
                        temp = a(k,j)
                        a(k,j) = a(pl,j)
                        a(pl,j) = temp
   20                continue
   30             continue
   40             continue
                  jpvt(k) = jpvt(pl)
                  jpvt(pl) = k
   50          continue
               pl = pl + 1
   60       continue
   70    continue
         pu = p
         if (p .lt. pl) go to 150
         do 140 kb = pl, p
            k = p - kb + pl
            if (jpvt(k) .ge. 0) go to 130
               jpvt(k) = -jpvt(k)
               if (pu .eq. k) go to 120
                  call dswap(k-1,a(1,k),1,a(1,pu),1)
                  temp = a(k,k)
                  a(k,k) = a(pu,pu)
                  a(pu,pu) = temp
                  kp1 = k + 1
                  if (p .lt. kp1) go to 110
                  do 100 j = kp1, p
                     if (j .ge. pu) go to 80
                        temp = a(k,j)
                        a(k,j) = a(j,pu)
                        a(j,pu) = temp
                     go to 90
   80                continue
                     if (j .eq. pu) go to 90
                        temp = a(k,j)
                        a(k,j) = a(pu,j)
                        a(pu,j) = temp
   90                continue
  100             continue
  110             continue
                  jt = jpvt(k)
                  jpvt(k) = jpvt(pu)
                  jpvt(pu) = jt
  120          continue
               pu = pu - 1
  130       continue
  140    continue
  150    continue
  160 continue
      do 270 k = 1, p
c
c        reduction loop.
c
         maxdia = a(k,k)
         kp1 = k + 1
         maxl = k
c
c        determine the pivot element.
c
         if (k .lt. pl .or. k .ge. pu) go to 190
            do 180 l = kp1, pu
               if (a(l,l) .le. maxdia) go to 170
                  maxdia = a(l,l)
                  maxl = l
  170          continue
  180       continue
  190    continue
c
c        quit if the pivot element is not positive.
c
         if (maxdia .gt. 0.0d0) go to 200
            info = k - 1
c     ......exit
            go to 280
  200    continue
         if (k .eq. maxl) go to 210
c
c           start the pivoting and update jpvt.
c
            km1 = k - 1
            call dswap(km1,a(1,k),1,a(1,maxl),1)
            a(maxl,maxl) = a(k,k)
            a(k,k) = maxdia
            jp = jpvt(maxl)
            jpvt(maxl) = jpvt(k)
            jpvt(k) = jp
  210    continue
c
c        reduction step. pivoting is contained across the rows.
c
         work(k) = dsqrt(a(k,k))
         a(k,k) = work(k)
         if (p .lt. kp1) go to 260
         do 250 j = kp1, p
            if (k .eq. maxl) go to 240
               if (j .ge. maxl) go to 220
                  temp = a(k,j)
                  a(k,j) = a(j,maxl)
                  a(j,maxl) = temp
               go to 230
  220          continue
               if (j .eq. maxl) go to 230
                  temp = a(k,j)
                  a(k,j) = a(maxl,j)
                  a(maxl,j) = temp
  230          continue
  240       continue
            a(k,j) = a(k,j)/work(k)
            work(j) = a(k,j)
            temp = -a(k,j)
            call daxpy(j-k,temp,work(kp1),1,a(kp1,j),1)
  250    continue
  260    continue
  270 continue
  280 continue
      return
      end
      double precision function dasum(n,dx,incx)
c
c     takes the sum of the absolute values.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dtemp
      integer i,incx,m,mp1,n,nincx

c
      dasum = 0.0d0
      dtemp = 0.0d0
      if(n.le.0)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dtemp = dtemp + dabs(dx(i))
   10 continue
      dasum = dtemp
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,6)

      if( m .eq. 0 ) go to 40
      do 30 i = 1,m

        dtemp = dtemp + dabs(dx(i))
   30 continue
      if( n .lt. 6 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,6
        dtemp = dtemp + dabs(dx(i)) + dabs(dx(i + 1)) + dabs(dx(i + 2))
     *  + dabs(dx(i + 3)) + dabs(dx(i + 4)) + dabs(dx(i + 5))
   50 continue
   60 dasum = dtemp
      return
      end
      subroutine daxpy(n,da,dx,incx,dy,incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dy(*),da
      integer i,incx,incy,ixiy,m,mp1,n
c
      if(n.le.0)return
      if (da .eq. 0.0d0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dy(iy) + da*dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dy(i) + da*dx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        dy(i) = dy(i) + da*dx(i)
        dy(i + 1) = dy(i + 1) + da*dx(i + 1)
        dy(i + 2) = dy(i + 2) + da*dx(i + 2)
        dy(i + 3) = dy(i + 3) + da*dx(i + 3)
   50 continue
      return
      end
      double precision function ddot(n,dx,incx,dy,incy)
c
c     forms the dot product of two vectors.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dy(*),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      ddot = 0.0d0
      dtemp = 0.0d0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dtemp + dx(ix)*dy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      ddot = dtemp
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dtemp + dx(i)*dy(i)
   30 continue
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) +
     *   dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
   50 continue
   60 ddot = dtemp
      return
      end
      subroutine  dscal(n,da,dx,incx)
c
c     scales a vector by a constant.
c     uses unrolled loops for increment equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision da,dx(*)
      integer i,incx,m,mp1,n,nincx
c
      if(n.le.0)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dx(i) = da*dx(i)
   10 continue
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dx(i) = da*dx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dx(i) = da*dx(i)
        dx(i + 1) = da*dx(i + 1)
        dx(i + 2) = da*dx(i + 2)
        dx(i + 3) = da*dx(i + 3)
        dx(i + 4) = da*dx(i + 4)
   50 continue
      return
      end
      subroutine  dswap (n,dx,incx,dy,incy)
c
c     interchanges two vectors.
c     uses unrolled loops for increments equal one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dy(*),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c       code for unequal increments or equal increments not equal
c         to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dx(ix)
        dx(ix) = dy(iy)
        dy(iy) = dtemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c       code for both increments equal to 1
c
c
c       clean-up loop
c
   20 m = mod(n,3)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
   30 continue
      if( n .lt. 3 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,3
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
        dtemp = dx(i + 1)
        dx(i + 1) = dy(i + 1)
        dy(i + 1) = dtemp
        dtemp = dx(i + 2)
        dx(i + 2) = dy(i + 2)
        dy(i + 2) = dtemp
   50 continue
      return
      end
      integer function idamax(n,dx,incx)
c
c     finds the index of element having max. absolute value.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dmax
      integer i,incx,ix,n
c
      idamax = 0
      if( n .lt. 1 ) return
      idamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      dmax = dabs(dx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(dabs(dx(ix)).le.dmax) go to 5
         idamax = i
         dmax = dabs(dx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 dmax = dabs(dx(1))
      do 30 i = 2,n
         if(dabs(dx(i)).le.dmax) go to 30
         idamax = i
         dmax = dabs(dx(i))
   30 continue
      return
      end


!##############################################
!##########Compile Instructions###############
!"chmod +x config.sh"
!"./config.sh"
!
!###########Execution######################
!"./cpflow_1D.exe"
!
!##############################################

program cpflow1D

use module_parameters
use module_grid
use module_solver

IMPLICIT NONE

!next 4 lines for individual module_grid
!REAL(8)	            ::ALPHA
!REAL(8)             ::H
!REAL(8),ALLOCATABLE ::YHAD(:),YPAD(:)
!INTEGER		    ::N,I

INTEGER		    	::I,K
	REAL(8)	            ::UMAX,UAVG,UTAU1,UTAU2
	REAL(8),ALLOCATABLE ::YHAD(:),YPAD(:),A(:),B(:)
	REAL(8),ALLOCATABLE ::U(:),U1(:),DYN_VIS_TUR(:),MIX_LEN(:),LEN_ZERO(:),TKIN_VISN(:),TKIN_VISS(:),LD(:),MD(:),UD(:),D(:)
	REAL(8)	::A1,A2,ERROR
CHARACTER(len=100)::excommand

	ALLOCATE(YPAD(N),YHAD(N),U(N),U1(N),DYN_VIS_TUR(N),MIX_LEN(N),LEN_ZERO(N),A(N),B(N))

	ALLOCATE(TKIN_VISN(N),TKIN_VISS(N),LD(N),MD(N),UD(N),D(N))
	U=0.0d0
	!TKIN_VIS is the turbulent kinematic viscosity
	!YPAD is the y coordinates of the mesh
	!YHAD(n) is the distance between YPAD(n) & YPAD(n-1)
	!UMAX= MAX VEL IN THE FLOW
	!UAVG= AVG VEL IN THE FLOW

	CALL sGrid_Generator(H,N,ALPHA,YPAD,YHAD)		!Stretched grid generator

	!DO I=1,N
	 !  WRITE(*,11)I,YPAD(I),YHAD(I)
	!ENDDO
	!DEALLOCATE(YPAD,YHAD)

	!11 FORMAT(I3,2x,2(F16.8,2x))

	CALL SOLVE_CP(U,ERROR,U1,VW,H,N,LD,MD,UD,D,YPAD,YHAD,ALPHA,DPDX,DYN_VIS,KIN_VIS,RHO,CONV_CRIT,OUTPUTFILE)

	DEALLOCATE(YPAD,YHAD,U,U1,DYN_VIS_TUR,MIX_LEN,LEN_ZERO,A,B)

	DEALLOCATE(TKIN_VISN,TKIN_VISS,LD,MD,UD,D)

	CLOSE(77)

print *, "copying generated simulation data to the directory Simulated_Data "
excommand="cp "//OUTPUTFILE//" ../Simulated_Data/"//OUTPUTFILE
print *, trim(excommand)
call system(trim(excommand))
print *, "copied successfully "

excommand="python plot_case.py --file "//OUTPUTFILE
if (PLOT=='Y') then
        print *, "Creating Plots"
        print *, trim(excommand)
        call system(trim(excommand))
else
        print *, "Auto Plotting Disabled"

end if

!next 10 lines for individual module_grid
!ALLOCATE(YPAD(N),YHAD(N))
!CALL sGrid_Generator(H,N,ALPHA,YPAD,YHAD)
!
!DO I=1,N
!   WRITE(*,11)I,YPAD(I),YHAD(I)
!ENDDO
!
!DEALLOCATE(YPAD,YHAD)
!
!11 FORMAT(I3,2x,2(F10.4,2x))

end program