c
      subroutine ckboot(nsp2, xmass, xchg, xt, xn, xtp, xnp, xeps, ftp, 
     1   rmajx, qloc, fmag, rnustare, xjboot)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:52:22   6/14/01  
C...Switches: -p4 -yb
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nsp2
      real xeps, ftp, rmajx, qloc, fmag, rnustare, xjboot
      real, dimension(10) :: xmass, xchg, xt, xn, xtp, xnp
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: j, k, l, ia, idgt, ifail
      integer, dimension(20) :: ipiv
      real, dimension(15) :: wf, zf
      real, dimension(10) :: xint1, xint2, xint3,
     1                  xk11, xk12, xk21, xk22,
     2                  xmu1, xmu2, xmu3, xvth, xnuz, xnux,
     3                  xpr, xprp, xtau, tforce, udotb
      real, dimension(10,10) :: xsum11, xsum12, xsum22
      real, dimension(20,20) :: fmat, tmat
      real, dimension(500) :: wkspce
      real, dimension(10,10) :: xsum21
      real :: chg, pi, xeps0, xclog, ftrap, sumf1, sumf2, sumf3, fint1, 
     1   fint2, fint3, facl, sum11, sum12, sum22, xab, sum
C-----------------------------------------------
c
c
c...This subroutine is to evaluate the bootstrap parallel current
c...density on a local flux surface.
c...It returns the quantity <j.B> in MKS units.
c...The bootstrap model is the full Hirshman-Sigmar model using the
c...viscosity expression continuously valid throughout collisonality
c...space.  This subroutine calls vnt which evaluates the function
c...in the velocity space integrals.
c...C. Kessel  PPPL  1994; modified by T.K. Mau for CURRAY.
c
c... List of input arguments:
c
c    *     nsp2          =         number of species including electrons
c                                  (electron is the last species)
c    *     xmass(j)      =         mass of specie j (kg)
c    *     xchg(j)       =         charge of specie j (Coulombs)
c          xt(j)         =         temperature of specie j (eV)
c          xn(j)         =         density of specie j (m-3)
c          xtp(j)        =         dT/dpsi of specie j
c          xnp(j)        =         dn/dpsi of specie j
c          xeps          =         local inverse aspect ratio
c    *     ftp           =         ratio of trapped to passing particles
c          rmajx         =         major radius of flux surface (m)
c          qloc          =         local safety factor
c          fmag          =         diamagnetism (T-m)
c
c... List of output arguments:
c
c          rnustare      =        electron collisionality
c          xjboot        =        bootstrap current density on flux surface
c                                 in the form of <j.B> (A-T/m**2)
c
c... List of useful defined quantities:
c
c          ftrap         =         trapped particle fraction
c          xpre(j)       =         presuure of species j
c          xprp(j)       =         dp/dpsi of species j
c          xtau(j)       =         collision time of specie j
c          xnux(j)       =         collisionality of specie j
c          xnuz(j)       =         plateau colisionality of specie j
c          xmu1
c          xmu2          =         viscosity coefficients
c          xmu3
c          xsum11
c          xsum12        =         friction coefficients
c          xsum21
c          xsum22
c          tforce(j)     =        thermodynamic force of specie j
c          udotb(j)      =        flows for specie j
c
c    * means that these variables are passed into this subroutine
c      through a common and are not directly available from the
c      subroutine call argument list or the local dimension statement
c      SO YOU MUST SUPPLY THESE QUANTITIES
c
c
c
      data wf/.218234885940, .342210177923, .263027577942, .126425818106
     1   , .0402068649210, .00856387780361, .00121243614721, 
     2   .000111674392344, .00000645992676202, .000000222631690710, 
     3   .00000000422743038498, .0000000000392189726704, 
     4   .000000000000145651526407, .000000000000000148302705111, 
     5   .0000000000000000000160059490621/
      data zf/.093307812017, .492691740302, 1.215595412071, 
     1   2.269949526204, 3.667622721751, 5.425336627414, 7.565916226613
     2   , 10.120228568019, 13.130282482176, 16.654407708330, 
     3   20.776478899449, 25.623894226729, 31.407519169754, 
     4   38.530683306486, 48.026085572686/
      data chg/1.6022E-19/
      data pi/3.14159265/
      data xeps0/8.854E-12/
      data xclog/17.0/
c
      ftrap = ftp/(1. + ftp)
c
c...determine the temperature, density and pressure for each specie
c...on the flux surface in proper units
c
      xchg(:nsp2) = chg*xchg(:nsp2)
      xt(:nsp2) = chg*xt(:nsp2)
      xpr(:nsp2) = xt(:nsp2)*xn(:nsp2)
      xtp(:nsp2) = chg*xtp(:nsp2)
      xprp(:nsp2) = xt(:nsp2)*xnp(:nsp2) + xtp(:nsp2)*xn(:nsp2)
c
c...calculate required parameters like inverse aspect ratio, thermal
c...velocity, collision time, and collisionality
c
      xvth(:nsp2) = sqrt(2.0*xt(:nsp2)/xmass(:nsp2))
      xtau(:nsp2) = (12.0*pi**1.5*xeps0**2*xmass(:nsp2)**2*xvth(:nsp2)**
     1   3)/(4.0*xn(:nsp2)*xchg(:nsp2)**4*xclog)
      xnux(:nsp2) = (rmajx*qloc)/((xtau(:nsp2)*xvth(:nsp2))*(xeps**1.5))
      xnuz(:nsp2) = 2.48*qloc*rmajx/((xtau(:nsp2)*xvth(:nsp2))*(xeps**
     1   1.5))
      rnustare = xnuz(nsp2)
c
c...determine the viscosity coefficients to be used in the matrix
c...multiplying the flow vector and the thermodynamic force vector,
c...using Gauss-Laguerre quadrature for the velocity space integrals
c
      do j = 1, nsp2
         sumf1 = 0.0
         sumf2 = 0.0
         sumf3 = 0.0
         do k = 1, 15
            call vnt (j, zf(k), xn, xt, xvth, xchg, xnuz, xnux, xeps, 
     1         nsp2, fint1, fint2, fint3)
            sumf1 = sumf1 + wf(k)*fint1
            sumf2 = sumf2 + wf(k)*fint2
            sumf3 = sumf3 + wf(k)*fint3
         end do
         xint1(j) = sumf1
         xint2(j) = sumf2
         xint3(j) = sumf3
         xk11(j) = (xn(j)*xmass(j)*ftrap*xint1(j))/(xtau(j)*(1.0-ftrap))
         xk12(j) = (xn(j)*xmass(j)*ftrap*xint2(j))/(xtau(j)*(1.0-ftrap))
         xk21(j) = xk12(j)
         xk22(j) = (xn(j)*xmass(j)*ftrap*xint3(j))/(xtau(j)*(1.0-ftrap))
         xmu1(j) = xk11(j)
         xmu2(j) = xk12(j) - 2.5*xk11(j)
         xmu3(j) = xk22(j) - 5.0*xk12(j) + 6.25*xk11(j)
      end do
c
c...calculate the friction coefficients in the matrix that multiplies
c...the flow vector
c
      do j = 1, nsp2
         facl = xn(j)*xmass(j)/xtau(j)
         do k = 1, nsp2
            sum11 = 0.0
            sum12 = 0.0
            sum22 = 0.0
            if (k == j) then
               do l = 1, nsp2
                  xab = xvth(l)/xvth(j)
                  sum11 = sum11 + ((xn(l)*xchg(l)**2)/(xn(j)*xchg(j)**2)
     1               )*(-(1.0 + xmass(j)/xmass(l))/(1.0+xab**2)**1.5)
                  sum12 = sum12 + ((xn(l)*xchg(l)**2)/(xn(j)*xchg(j)**2)
     1               )*(-1.5*(1.0 + xmass(j)/xmass(l))/(1.0+xab**2)**2.5
     2               )
                  sum22 = sum22 + ((xn(l)*xchg(l)**2)/(xn(j)*xchg(j)**2)
     1               )*(-(3.25 + 4.0*xab**2 + 7.5*xab**4)/(1.0 + xab**2)
     2               **2.5)
               end do
            endif
            xab = xvth(k)/xvth(j)
            xsum11(j,k) = sum11 + ((xn(k)*xchg(k)**2)/(xn(j)*xchg(j)**2)
     1         )*((1.0 + xmass(j)/xmass(k))/(1.0+xab**2)**1.5)
            xsum12(j,k) = sum12 + ((xn(k)*xchg(k)**2)/(xn(j)*xchg(j)**2)
     1         )*(1.5*(xt(j)/xt(k))*(1.0/xab)*(1.0+xmass(k)/xmass(j))/(
     2         1.0+(1.0/xab)**2)**2.5)
            xsum21(j,k) = sum12 + ((xn(k)*xchg(k)**2)/(xn(j)*xchg(j)**2)
     1         )*(1.5*(1.0 + xmass(j)/xmass(k))/(1.0+xab**2)**2.5)
            xsum22(j,k) = sum22 + ((xn(k)*xchg(k)**2)/(xn(j)*xchg(j)**2)
     1         )*(6.75*(xt(j)/xt(k))*xab**2/(1.0+xab**2)**2.5)
            xsum11(j,k) = facl*xsum11(j,k)
            xsum12(j,k) = facl*xsum12(j,k)
            xsum21(j,k) = facl*xsum21(j,k)
            xsum22(j,k) = facl*xsum22(j,k)
         end do
      end do
c
c...load matrices according to quadrants
c
c...upper left quadrants
c
      do j = 1, nsp2
         do k = 1, nsp2
            fmat(j,k) = xsum11(j,k)
            tmat(j,k) = 0.0
            if (k == j) then
               fmat(j,k) = fmat(j,k) - xmu1(j)
               tmat(j,k) = -xmu1(j)
            endif
         end do
      end do
c
c...upper right quadrants
c
      do j = 1, nsp2
         do k = 1, nsp2
            fmat(j,k+nsp2) = -xsum12(j,k)
            tmat(j,k+nsp2) = 0.0
            if (k == j) then
               fmat(j,k+nsp2) = fmat(j,k+nsp2) - xmu2(j)
               tmat(j,k+nsp2) = -xmu2(j)
            endif
         end do
      end do
c
c...lower left quadrants
c
      do j = 1, nsp2
         do k = 1, nsp2
            fmat(j+nsp2,k) = -xsum21(j,k)
            tmat(j+nsp2,k) = 0.0
            if (k == j) then
               fmat(j+nsp2,k) = fmat(j+nsp2,k) - xmu2(j)
               tmat(j+nsp2,k) = -xmu2(j)
            endif
         end do
      end do
c
c...lower right quadrants
c
      do j = 1, nsp2
         do k = 1, nsp2
            fmat(j+nsp2,k+nsp2) = xsum22(j,k)
            tmat(j+nsp2,k+nsp2) = 0.0
            if (k == j) then
               fmat(j+nsp2,k+nsp2) = fmat(j+nsp2,k+nsp2) - xmu3(j)
               tmat(j+nsp2,k+nsp2) = -xmu3(j)
            endif
         end do
      end do
c
c...invert matrix multiplying the flow vector onto the matrix multiplying
c...the thermodynamic force vector using NAG library routine
c
c $$$$  TKM    8/98
      ia = 20
      idgt = 0
c     ib=20
c     ic=20
c     iaa=20
c     ibb=20
c     ifail=0
c     call f04aee(fmat,ia,tmat,ib,2*nsp2,2*nsp2,smat,ic,
c    +wkspce,aa,iaa,bb,ibb,ifail)
!      call leqt2f(fmat, 2*nsp2, 2*nsp2, ia, tmat, idgt, wkspce, ifail)
      call dgesv(2*nsp2, 2*nsp2, fmat, 20, ipiv, tmat, 20, ifail)
c $$$$$$$$$$$$$$$$$$
c
c...calculate thermodynamic forces
c
      tforce(:nsp2) = -((xt(:nsp2)*fmag)/xchg(:nsp2))*(xprp(:nsp2)/xpr(:
     1   nsp2))
      tforce(1+nsp2:nsp2*2) = -((xt(:nsp2)*fmag)/xchg(:nsp2))*(xtp(:nsp2
     1   )/xt(:nsp2))
c
c...calculate resulting flows
c
      do j = 1, nsp2
         sum = 0.0
         do k = 1, 2*nsp2
c $$$$      TKM    8/98
c     sum=sum+smat(j,k)*tforce(k)
            sum = sum + tmat(j,k)*tforce(k)
c $$$$$$$$$$$$$$$$$
         end do
         udotb(j) = sum
      end do
c
c...calculate bootstrap current density on the flux surface
c
      sum = 0.0
      sum = dot_product(xchg(:nsp2)*xn(:nsp2),udotb(:nsp2))
c
      xchg(:nsp2) = xchg(:nsp2)/chg
      xt(:nsp2) = xt(:nsp2)/chg
      xtp(:nsp2) = xtp(:nsp2)/chg
      xjboot = sum
c
      return 
      end subroutine ckboot
c
c
c
c     ==================== vnt ============================
c
      subroutine vnt(nspx, arg, xn, xt, xvth, xchg, xnuz, xnux, xeps, 
     1   nsp2, fint1, fint2, fint3)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:52:22   6/14/01  
C...Switches: -p4 -yb
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nspx, nsp2
      real arg, xeps, fint1, fint2, fint3
      real, dimension(10) :: xn, xt, xvth, xchg, xnuz, xnux
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: j, ifail
      real :: sqpi, xnud, xnus, xnup, xnue, xnut, zab, sarg, zarg, xfac
     1   , xerf, xdenom1, xdenom2
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real , EXTERNAL :: derf
C-----------------------------------------------
c
c
      data sqpi/1.77245385/
c
      xnud = 0.0
      xnus = 0.0
      xnup = 0.0
      xnue = 0.0
      xnut = 0.0
      fint1 = 0.0
      fint2 = 0.0
      fint3 = 0.0
      do j = 1, nsp2
         ifail = 0
         zab = xvth(nspx)/xvth(j)
         sarg = sqrt(arg)
         zarg = sqrt(arg)*zab
         xfac = (3.0*sqpi*xn(j)*xchg(j)**2)/(4.0*xn(nspx)*xchg(nspx)**2)
c     xerf=s15aee(zarg,ifail)
c $$$$     TKM   8/98
         xerf = derf(zarg)
c $$$$$$$$$$$
c
         xnud = xnud + xfac*(xerf/sarg**3 - xerf/(2.0*sarg**3*zarg**2)
     1       + (2.0/sqpi)*zarg*exp((-zarg**2))/(2.0*sarg**3*zarg**2))
c
         xnus = xnus + xfac*(2.0*(xt(nspx)/xt(j)+zab**2)*(xerf/(2.0*sarg
     1      *zarg**2)-(2.0/sqpi)*zarg*exp((-zarg**2))/(2.0*sarg*zarg**2)
     2      ))
c
         xnup = xnup + xfac*(2.0*(xerf/(2.0*sarg**3*zarg**2) - (2.0/sqpi
     1      )*zarg*exp((-zarg**2))/(2.0*sarg**3*zarg**2)))
c
      end do
c
      xnue = 2.0*xnus - 2.0*xnud - xnup
c
      xnut = 3.0*xnud + xnue
c
      xdenom1 = 1.0 + xnuz(nspx)*xnud/sarg
      xdenom2 = 1.0 + 1.96*xnux(nspx)*xnut*xeps**1.5/sarg
c     xdenom1=1.0
c     xdenom2=1.0
c
      fint1 = (8.0/(3.0*sqpi))*xnud*sarg**4/(xdenom1*xdenom2)/(2.0*sarg)
      fint2 = (8.0/(3.0*sqpi))*xnud*sarg**6/(xdenom1*xdenom2)/(2.0*sarg)
      fint3 = (8.0/(3.0*sqpi))*xnud*sarg**8/(xdenom1*xdenom2)/(2.0*sarg)
c
      return 
      end subroutine vnt
c
c
      subroutine cadj1(iadj, nthp0, npsi0, psimx, psimn, nmax, umax, 
     1   imax, lmax, psis, eden, etem, zefi, jop, nwp, wpmx, wpmn, dwp, 
     2   wp, nthp1, thetp, iout4, iout5, nimx, ua, ug, th0a, th0g, fm, 
     3   chi, chixi, dchixi, dchiw, xi, gamr, delb, bfld, wr2, wr, wk, 
     4   chir, dchir, wk1, wk2, wk3, wk4, wk5, wk6, wtab, dchiwr, dchixr
     5   , mwr, iswr, lam1a)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:52:22   6/14/01  
C...Switches: -p4 -yb
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer iadj, nthp0, npsi0, nmax, imax, lmax, nwp, nthp1, iout4, 
     1   iout5, nimx
      real psimx, psimn, umax, wpmx, wpmn, dwp
      integer, dimension(nimx) :: mwr, iswr
      real, dimension(npsi0) :: psis, eden, etem, zefi
      real, dimension(nwp,nthp1,npsi0) :: jop
      real, dimension(nwp) :: wp
      real, dimension(nthp1) :: thetp
      real, dimension(0:nmax - 1) :: ua
      real, dimension(0:nmax) :: ug
      real, dimension(0:imax - 1) :: th0a
      real, dimension(0:imax) :: th0g
      real, dimension(0:nmax - 1) :: fm
      real, dimension(0:imax - 1,0:nmax - 1) :: chi
      real, dimension(0:imax,0:nmax - 1) :: chixi, dchixi, dchiw
      real, dimension(0:imax) :: xi
      real, dimension(nimx) :: gamr
      real, dimension(nthp1) :: delb, bfld
      real, dimension(nimx) :: wr2, wr, wk, chir, dchir, wk1, wk2, wk3, 
     1   wk4, wk5, wk6
      real, dimension(nimx,5) :: wtab
      real, dimension(nimx) :: dchiwr, dchixr
      real, dimension(0:imax - 1) :: lam1a
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: tmax, imax1, nmax1, i, np, jnmax, jimax, jkmax, jlmax, 
     1   n, nnp, nnnp, j, k, iv, it, iu, k1, ia, iiia, jj, jjjja, i1, 
     2   imax2, iw
      real :: one, half, pi, dthp1, u12, t, c2, ze, epsa, umax1, th0max
     1   , du, dth0, rho, dbmx, bmin, bmax, dt, alpha, cond, abserr, 
     2   relerr, hu, hth, clite, x1, deta, sintg, cth0a, xit, bee, rtb, 
     3   deltb, wp2, gamp2, vp2, gamp, vp, alphr, alphi, ck0, alp1, alp2
     4   , rgamp2, wpt2, wpt, sum, pj
C-----------------------------------------------
c---------------------------
c   calculate a j/p table with independent variables wp
c     (wp=gammap*vp, resonant electron momentum/m), psi(flux-surface),
c     thetap(poloidal-angle), lamda(T/mc**2, only at lamda=0 and lamda=0.1
c     and linear interpolate)
c   nthp0=No. of poloidal theta points for line integrals;
c   npsi0=No. of psi-grid points;
c   psimx,psimn=max. and min. psi;
c   nmax=No. of points in u-grid; umax=max. u; imax=No. points in pitch-ang.
c   lmax=No. of Lengendre harmonics; nwp=No. point in wave-phase wp;
c   wpmx=maximum wp;
c    nthp1=No. of poloidal theta points for j/p calculations;
c
c  Output:
c   wp(1:nwp)=wave-phase momentum/me;
c   jop(nwp,nthp1,npsi0)=j/p
c   thetp(nthp1) = grid points of poloidal angles
c   npsi0 values of density (eden),temperature (etem),zeffective(zefi),
c              psi-values(psis).
c
c----------------------------
 
c
c
      imax1 = imax + 1
      nmax1 = nmax + 1
      one = 1.0E0
      half = 0.5E0
      pi = 4*atan(1.0E0)
      dthp1 = 2.*pi/(nthp1 - 1)
      do i = 1, nthp1
         thetp(i) = (i - 1)*dthp1
      end do
c     dwp=(wpmx-wpmn)/(nwp-1)
c     do i=1,nwp
c       wp(i)=wpmn+(i-1.e0)*dwp
c     enddo
      u12 = umax**2
 
C
C   Start looping over psi-grid
C
      do np = 1, npsi0
         read (iout5, 3000) psis(np), eden(np), etem(np)
         read (iout5, 3010) jnmax, jimax, jkmax, jlmax
         read (iout5, 3020) t, c2, ze, zefi(np), epsa
         read(iout5,3020)umax1,th0max,du,dth0,rho,dbmx,bmin,bmax
c----------------
c  dbmx is deltb at bmax; gives bmax/bmin
c-------------------------
         read (iout5, 3040) dt, tmax, alpha
         read (iout5, 3020) cond, abserr, relerr
         read (iout5, 3030) ua
         read (iout5, 3030) ug
         read (iout5, 3030) th0a
         read (iout5, 3030) th0g
         read (iout5, 3030) lam1a
         read (iout5, 3030) fm
         read (iout5, 3030) chi
c--------------------
c   map chi from th0a-grid to xi-grid ( get chixi)
c
 
c       hth=th0a(1)-th0a(0)
c       hu=ua(1)-ua(0)
         hu = du
         hth = dth0
c---------------------
c   Hardwire dwp and wpmn; so input of dwp,wpmx,wpmn are obsolete;
c     only nwp is needed. jop on axis is simplified.
c-----------------------
         dwp = hu
         wpmn = ua(0)
         do i = 1, nwp
            wp(i) = wpmn + (i - 1.E0)*dwp
         end do
         nnp = np/5
         nnp = nnp*5
         if (nnp /= np) then
         else
            nnnp = nnp
         endif
         clite = sqrt(c2)
         xi(:imax) = cos(th0g(:imax))
         xi(imax) = amax1(0.0_dp,xi(imax))
c-------------------
c  map chi from th0a-grid to th0g-grid
c-------------------
         chixi(imax,:nmax-1) = 0.
         wtab(:nmax,:4) = transpose(chi(:3,:nmax-1))
         do iv = 0, 1
            x1 = th0a(0)
            call intrv (wk, th0g(iv), wtab, hth, x1, nmax, nimx)
            chixi(iv,:nmax-1) = wk(:nmax)
         end do
         wtab(:nmax,:4) = transpose(chi(imax-4:imax-1,:nmax-1))
         do iv = imax - 1, imax
            x1 = th0a(imax-4)
            call intrv (wk, th0g(iv), wtab, hth, x1, nmax, nimx)
            chixi(iv,:nmax-1) = wk(:nmax)
         end do
         do iv = 2, imax - 2
            x1 = th0a(iv-2)
            wtab(:nmax,:4) = transpose(chi(iv-2:1+iv,:nmax-1))
            call intrv (wk, th0g(iv), wtab, hth, x1, nmax, nimx)
            chixi(iv,:nmax-1) = wk(:nmax)
         end do
c---------------
c   find dchixi=dchixi/dxi
c---------------
         deta = xi(1) - xi(0)
         dchixi(0,:nmax-1) = (chixi(1,:nmax-1)-chixi(0,:nmax-1))/deta
         wtab(:nmax,:) = transpose(chixi(:4,:nmax-1))
         call der4v (2, hth, wtab, wk, nmax, nimx)
         dchixi(1,:nmax-1) = wk(:nmax)
         wtab(:nmax,:) = transpose(chixi(imax-4:imax,:nmax-1))
         do it = 4, 5
            call der4v (it, hth, wtab, wk, nmax, nimx)
            dchixi(imax-5+it,:nmax-1) = wk(:nmax)
         end do
         do it = 2, imax - 2
            wtab(:nmax,:) = transpose(chixi(it-2:2+it,:nmax-1))
            call der4v (3, hth, wtab, wk, nmax, nimx)
            dchixi(it,:nmax-1) = wk(:nmax)
         end do
         do it = 1, imax
            sintg = sin(th0g(it))
            dchixi(it,:nmax-1) = -dchixi(it,:nmax-1)/sintg
         end do
c----------------------
c  find dchiw=dchixi/dw
c----------------------
         dchiw(imax,:nmax-1) = 0.
         wtab(:imax,:) = chixi(:imax-1,:4)
         do iu = 1, 2
            call der4v (iu, hu, wtab, wk, imax, nimx)
            dchiw(:imax-1,iu-1) = wk(:imax)
         end do
         wtab(:imax,:) = chixi(:imax-1,nmax-5:nmax-1)
         do iu = 4, 5
            call der4v (iu, hu, wtab, wk, imax, nimx)
            dchiw(:imax-1,nmax-6+iu) = wk(:imax)
         end do
         do k = 2, nmax - 3
            wtab(:imax,:) = chixi(:imax-1,k-2:2+k)
            call der4v (3, hu, wtab, wk, imax, nimx)
            dchiw(:imax-1,k) = wk(:imax)
         end do
c  -----------------------
c   ignore eps effect when epsa.lt.2.e-3 and assume chi is
c     proportional to P(1)
c  --------------------------
c  wk6 is dchi/dxi, wk5 is dchi/dw/xi
c---------------------------------
         if (epsa < 2.E-3) then
            cth0a = cos(th0a(0))
            wk6(:nmax) = chi(0,:nmax-1)/cth0a
            wk(:5) = wk6(:5)
            do iv = 1, 2
               call deriv4 (iv, hu, wk, wk5(iv))
            end do
            wk(:5) = wk6(nmax-4:nmax)
            do iv = 4, 5
               call deriv4 (iv, hu, wk, wk5(nmax+iv-5))
            end do
            do iv = 3, nmax - 2
               wk(:5) = wk6(iv-2:2+iv)
               call deriv4 (3, hu, wk, wk5(iv))
            end do
         endif
 
c**************************************
 
 
         do i = 1, nthp1
            call bfield (psis(np), thetp(i), bfld(i))
         end do
         xit = xi(imax)
         do i = 1, nthp1
            bee = bfld(i)/bmin
            bee = amax1(one,bee)
            rtb = sqrt(bee)
            ia = i/10
            ia = ia*10
            if (ia /= i) then
            else
               iiia = ia
            endif
            deltb = bee - one
            delb(i) = deltb
            do j = 1, nwp
               jj = j/10
               jj = jj*10
               if (jj /= j) then
               else
                  jjjja = jj
               endif
               wp2 = wp(j)*wp(j)
               gamp2 = one + wp2/c2
               vp2 = wp2/gamp2
c           fac1=one-bee*gamp2*bmin/bmax
c           fac2=wp2/u12-fac1
c           wpt2=cvmgp(u12,wp2/fac1,fac2)
               gamp = sqrt(gamp2)
               vp = sqrt(vp2)
               select case (iadj) 
               case (0) 
                  call diel1l (psis(np), thetp(i), vp, clite, alphr, 
     1               alphi, ck0)
c------low beta
c
               case (1) 
                  call diel1h (psis(np), thetp(i), vp, clite, alphr, 
     1               alphi, ck0)
c---------high beta
c
               case (2) 
                  alphr = 1.E9
                  alphi = 0.
                  ck0 = 1.
c-----Landau limit
c
               case (3) 
                  alphr = 0.
                  alphi = 0.
                  ck0 = 1.
c------Alfven limit
c
               end select
               alp1 = alphr - 1
               alp2 = alp1*alp1 + alphi*alphi
               rgamp2 = one/gamp2
               wpt2=vp2/amax1(rgamp2-bee*(one-xi(imax)**2),1.E-3*vp2)
               wpt = sqrt(wpt2)
               if (epsa >= 2.E-3) then
c           if (abs(wpt-umax).lt.1.e-10) wpt=umax
                  wr2(:imax1) = vp2/amax1(rgamp2 - bee*(one - xi(:imax1-
     1               1)**2),1.E-3*vp2)
                  gamr(:imax1) = sqrt(one + wr2(:imax1)/c2)
                  wr(:imax1) = sqrt(wr2(:imax1))
                  mwr(:imax1) = (wr(:imax1)+0.5*hu)/hu
                  iswr(:imax1) = isign(1,nmax - mwr(:imax1))
c--------------------------
c  wr(1:imax1) are resonant momentum at th0g(0:imax)
c   wr(1:imax2) are less than umax
c--------------------------
                  imax2 = 0
                  do i1 = 1, imax1
                     imax2 = imax2 + iswr(i1)
                  end do
                  imax2 = (imax1 + imax2)/2
                  iswr(:imax2) = max0(0,mwr(:imax2)-2)
                  iswr(:imax2) = min0(iswr(:imax2),nmax-4)
                  wk(:imax2) = ua(iswr(:imax2))
                  do k = 1, 4
                     do i1 = 1, imax2
                        wtab(i1,k) = dchiw(i1,iswr(i1)+k-1)
                     end do
                  end do
                  call intrv1 (dchiwr, wr, wtab, hu, wk, imax2, nimx, 
     1               wk1, wk2, wk3, wk4)
                  do k = 1, 4
                     do i1 = 1, imax2
                        wtab(i1,k) = dchixi(i1,iswr(i1)+k-1)
                     end do
                  end do
                  call intrv1 (dchixr, wr, wtab, hu, wk, imax2, nimx, 
     1               wk1, wk2, wk3, wk4)
                  wk6(imax2+1:imax1) = 0.
                  wr(imax2+1:imax1) = wpmx
                  wk(:imax2) = one - gamr(:imax2)**2*vp2/wr2(:imax2)
                  wk1(:imax2) = dchiwr(:imax2) + dchixr(:imax2)*wk(:
     1               imax2)/(bee*wr(:imax2)*xi(:imax2-1))
c             wk1(k)=wk1(k)*exp(-c2*(gamr(k)-gamp))/gamr(k)
c             wk6(k)=wk1(k)*((half*wr2(k)*wk(k)+alp1)**2
c    1            +alphi**2)
                  wk1(:imax2) = wk1(:imax2)*exp((-c2*(gamr(:imax2)-gamp)
     1               ))
                  wk6(:imax2) = wk1(:imax2)*((ck0*half*wr2(:imax2)*wk(:
     1               imax2)+gamr(:imax2)*alp1)**2+(gamr(:imax2)*alphi)**
     2               2)
                  sum = 0.
                  do k = 1, imax
                     sum = sum + half*(wr(k+1)-wr(k))*(wk6(k)+wk6(k+1))
                  end do
               else
                  wr(:nmax) = ua(:nmax-1)
                  wr2(:nmax) = wr(:nmax)*wr(:nmax)
                  wk2(:nmax) = one + wr2(:nmax)/c2
                  gamr(:nmax) = sqrt(wk2(:nmax))
                  wk(:nmax) = one - wk2(:nmax)*vp2/wr2(:nmax)
                  wk1(:nmax) = vp*wk5(:nmax)/wr(:nmax) + wk(:nmax)*wk6(:
     1               nmax)/wk2(:nmax)/vp
                  wk1(:nmax) = wk1(:nmax)*exp((-c2*(gamr(:nmax)-gamp)))*
     1               gamr(:nmax)
                  wk3(:nmax) = wk1(:nmax)*((ck0*half*wr2(:nmax)*wk(:nmax
     1               )+gamr(:nmax)*alp1)**2+(gamr(:nmax)*alphi)**2)
c-------------------------
c  This part is simplified by hardwiring dwp and wpmn
c
c           iw=(wp(j)-wr(1))/hu
c           iw=iw+2
                  iw = j
                  sum = 0.
                  do k = iw, nmax - 1
                     sum = sum + half*hu*(wk3(k)+wk3(k+1))
                  end do
c           iw=iw-2
c           x1=wr(iw)
c           do k=1,4
c             wtab(1,k)=wk6(iw+k-1)
c           enddo
c           call intrv(wk4,wp(j),wtab,hu,x1,1,nimx)
c           gwk6=wk4(1)
c           do k=1,4
c             wtab(1,k)=wk5(iw+k-1)
c           enddo
c           call intrv(wk4,wp(j),wtab,hu,x1,1,nimx)
c           gwk5=wk4(1)
c           gwk=one-gamp2*vp2/wp2
c           gwk1=vp*gwk5/wp(j)+gwk*gwk6/gamp2/vp
c           gwk3=gwk1*((half*wp2*gwk-alp1)**2+alphi**2)
c           sum=sum+half*(wr(iw+2)-wp(j))*(wk3(iw+2)+gwk3)
 
               endif
 
c*****************************************************
               jop(j,i,np) = sum
c           cwk=c2*gamp
c           if (cwk.lt.19.) then
c             pj=0.25*(6.+cwk*(6.+cwk*(3.+cwk)))/cwk/cwk/gamp2
c    1           -(half*c2-alp1)*(cwk+one)/cwk/gamp
c    2          +((half*c2-alp1)**2+alphi**2)*(E1(cwk)*exp(cwk))
c             pj=pj*c2
c           else
c             pj=2./gamp2/gamp+alp1*(one+one/gamp)/gamp+alp2/gamp
c    1           -(2.*alp1/gamp+alp2)/c2/gamp2
c    2           +(6./gamp2+6.*alp1/gamp+2.*alp2)/c2/c2/gamp2/gamp
c           endif
               pj = alp2*gamp2 + 2.*alp1*ck0 + 2.*ck0*ck0/gamp2 + (2.*
     1            alp2*gamp + 6.*ck0*alp1/gamp + 6.*ck0*ck0/gamp/gamp2)/
     2            c2 + (2.*alp2 + 6.*ck0*alp1/gamp2 + 6.*ck0*ck0/gamp2/
     3            gamp2)/c2/c2
               jop(j,i,np) = jop(j,i,np)/pj
            end do
         end do
      end do
 
c---------------------------
 3000 format(4(2x,e20.12))
 3010 format(1x,4i8)
 3020 format(4(1x,e20.12))
 3030 format(5(1x,e20.12))
 3040 format(1x,e20.12,2x,i8,2x,e20.12)
 
      return 
      end subroutine cadj1
c
c  $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c   Added by T.K. Mau on July 30, 1991.
c   To calculate local driven current density by RF waves.
c
      subroutine cdcur(ientry)
      use Vdynamic
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:52:22   6/14/01  
C...Switches: -p4 -yb
c
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vcraylh
      use Vcmnew, ONLY: wpi1c, wpi2c, wci1c, wci2c, wpi2, wci2, wci, 
     1   conci, aziomi, rtzom, ay2, ay1, trate, tratte, ttle, concte, 
     2   trati, tratti, ttli, concti, vdrfte, vdrfti, infi, gprm, cxet, 
     3   czt, cztp, czetai, czi, czip, czetat, czti, cztip, cth, npar, 
     4   nper, upar, uper, umax, dsfe, dsfi, fper2, fpar2, fpp2, intg, 
     5   inc, incf, tnmaxe, tnmaxi, idrive, binb, boutb, boutbrd, 
     6   binbrd, epsl, binbd, epsil, dlob, wte, eta0, eta, rprof, 
     7   amprof, cprof, xjop, vloop, kboot, mboot, btbsp, ftbsps, pde, 
     8   pdec, pdi, pdf, pwce, pwcm, pwcf, pwc, pwc1, pwc2, pwct, 
     9   pwct1, pwct2, pwc0, pwcray, pwc1ray, pwc2ray, pweray, pwiray, 
     .   pwfray, currf, currfe, currf1, currf2, curay, curay1, curay2, 
     1   fpwray, fpowe, fpowf, fpowi, pwte0, pwti0, effcd, effcdt, 
     2   ptot, ftpowe, ftpowi, ftpowf, ftpi, ftpf, ftedge, pwedge, 
     3   wfrac, pwxwl, frpowi, frpowf, frpow, pwit, pwft, ptedge, 
     4   ptot0, fpowt, tpowi, tpowf, wfrac0, ebkev, bmpwr, azf, atmf, 
     5   densa, kalfa, nalfa, nharm0, pnfi, pnf, zetab, tnf, ecrit, 
     6   taua0, wca, gamal, gamat, ibeam, abeam, dbeam, aneb, enbeam, 
     7   wbeam, temsa, ptfi, ttf, wpf2c, wpf2, wcf2c, wcf1c, wcf2, wcf, 
     8   cxc, czc, cy, denfa, eav, tausd, tau0, paf, sordt, ecrita, 
     9   betaf, wce, adxy
      use Viorlh, ONLY: nprofn, psimhd, dpsimhd, rmaj, rrho, triang, 
     1   elong, nmhd, denc, tempec, atm, azi, conc, tempic, nspec, 
     2   mainsp, pavtne, pavtte, pavtti, pavpp, beta, betap, ali3, 
     3   ppsi, pjavg, pne, pte, nprofs, nprof, iedge, ipropt, pni, pti, 
     4   psinm, tani, nspect, omega, anzin, anzsup, anzinf, anplin, 
     5   anpsup, anpinf, pwcpl, pwtra, specfac, power, powers, thgril, 
     6   delthe, phase, rgrill, nnkpar, nnkpol, poldk, nthin, maxref, 
     7   igrill, islofa, irayio, ioread, nraypic, deykpr, psistep, 
     8   pkexpnt, nequip, iprint, indvar, iploxy, igraph, iplopr, jwfr, 
     9   pwe, pwe0, pwi, pwii0, pwev, pwiv, wkarea, pwal, ffast, tite, 
     .   alpene1, alpte1, frcte, frcne, frcti, gamte1, gamti1, alpti1, 
     1   gamene1, presfr, iout, btsign
      use Vdynamic
      USE Vblkcof
      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer ientry
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: lthet, jwp, ithp, lpsi, n1, n2, l, ll, i, ii, j1, j
      real, dimension(3) :: awrk, awrk1, awrk2, cs2
      real, dimension(18) :: cs
      real, dimension(7,3) :: dc
      real, dimension(4) :: anm
      real :: rt2, twopi, pi, one, two, cov2, arg1, algame, alpr, alpi, 
     1   alp0, akcd, c0cd, amcd, ccd, acd, alt2s, alt2, alt1, ytt, arg, 
     2   fact, awt, aci, aci2, gloop, eloop, floop, vph, rgamp2, gamp2, 
     3   gamp, wph, thetac, wwk
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
!      integer , EXTERNAL :: ifix
      real , EXTERNAL :: valspl
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c---------------------------
c   common block for Comraylh
c-------------------------
c
c
c$$$$$$$$     TKM    11/98
c*********    TKM   2/97, 6/99, 9/99
c*********    TKM   2/97
c*******   TK Mau   8/98
c*************************
c  SCC  3/7/95
 
c********************************************
c  6/26/91,  Latest update: 06/02/00
c     Comnew
cNew common added for FWCD
c  Storage related to FWCD:
cSubroutines displh inital use Comnew1
 
 
c******      TKM   03/97, 09/99, 04/00, 06/00
c********************
 
c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   #option for n-T profile calculation: 1 if
c                        # calculated from prontp; else =0.
 
 
c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
      data rt2/1.414213562/
      data twopi/6.283185308/
      data pi/3.14159265/
      data one/1.E0/
      data two/2.E0/
      data cs2/0.92, 0.08, 0./
      data cs/1.5, -20., 0., 0., 1.225, -3.5, 1.5, -4., 0.45, 8., 0.63, 
     1   2., -0.39, -2.1, -0.50, 1.0, 0.8, 0.0/
      data dc/3.70, -5.7, 7.5, 4.5, 25.0, 43.0, -2.0, 0., 0., 0., 0., 0.
     1   , 0., 0., 300., -300., 0., 0., 0., 0., 0./
      data anm/0.8475, 0.1125, -0.04, 0./
c
      cov2 = 511.925/tempe
      arg1 = 1.E-3/tempe*sqrt(dense)
      algame = 24. - alog(arg1)
      go to (100,200,300) ientry
c---------------------
c  ientry = 1   Ehst-Karney model
c  ientry = 2   Chiu et. al. model
c  ientry = 3   direct adj integration
c----------------------
  100 continue
      pwce = 0.
      alpr = -cov2*wce*adxy*eps3r/(aeps32*ssmnp2)
      alpi = eps3i/eps3r*alpr
      alpr = alpr*(1. + del0)
      alpi = alpi*(1. + del0)
      alp0 = 1. + alpr*alpr + alpi*alpi
c $$$$$$$$$$$$$
      if (islofa == (-1)) then
         alp0 = 1.
         alpr = 0.
         alpi = 0.
         akcd = 11.91/(0.678 + zeff)
         c0cd = 4.13/zeff**0.707
         amcd = 1.38 + 1.10/alp0
         ccd = 0.389 - 0.2903/alp0
         acd = 12.3/alp0
      else
         akcd = 3./zeff
         c0cd = 3.83/zeff**0.707
         amcd = 1.38
         ccd = 0.389
         acd = 0.
      endif
c
!      left = ifix(psi/dpsi) + 1
      left = int(psi/dpsi) + 1
      hh = psi - tpsi(left)
      if (left > nprof) then
         left = nprof
         hh = 0.0
      endif
      epsil = valspl(hh,epsl,nprofn,left,0)
      binbrd = valspl(hh,binbd,nprofn,left,0)
      alt2s = 1. - btot/binbrd
      alt2 = abs(alt2s)
      alt1 = sqrt(alt2)
      wte = 1.414*xe
      ytt = (1. - alt2)*wte**2/alt2
      rprof=1.-(epsil**0.77*sqrt(12.25+wte**2))/(3.5*epsil**0.77+wte)
      arg = (ccd*ytt)**amcd
      cprof = 1. - exp((-arg))
      amprof = 1. + acd*(alt1/wte)**3
c
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c  Added by T.K. Mau on Oct. 9, 1991.
c
c  modcd  = 0 : Use Ehst's model for j/p w/o trapped effect
c    otherwise : Use Chiu's model for j/p w/o trapped effect
c
c--------------------------------------
c $$$$$  added by TK Mau on 11/21/91
      if (modcd == 0) then
         eta0 = akcd/abs(wte) + c0cd + 4.*wte**2/(5. + zeff)
      else
c-----------------SCC 3/13/92
c $$$$$$  added by TK Mau on 11/21/91
c $$$$$$$$$$$$$
         fact = exp((-zxe2))
c     eta0 = fact*2.1213/(zeff+0.6667*alp0)*(1.+3.*(1.+alpr)/alp0)/wte
c    &   +(1.-fact)*(4.*wte*wte/(5.+zeff)+6.*(6.+zeff)/(5.+zeff)/(3.+zeff)
c    &       +6.*(2.*alpr+2.-alpi*alpi)/(alp0*(5.+zeff))+
c    &       60./((2.+zeff)*(1.+zeff)*wte))
c-----------------SCC 3/12/92
         awt = abs(wte)
         aci = 4.*awt**2/(5. + zeff) + 6.*(6. + zeff)/((5. + zeff)*(3.
     1       + zeff)) + 6.*(2.*alpr + 2. - alpi**2)/((5. + zeff)*alp0)
     2       + 42./(awt*(2. + zeff)*(1. + zeff))
         aci2 = 3.759942*(1. - 2.*alpr/alp0)/zeff + (16.8465/(0.32922 + 
     1      zeff))*(alpr - 1.)/alp0 + (110.85/(0.62879 + zeff))/(4.*alp0
     2      ) + awt**2*((11.5 - 1.5/alp0) + (7.5 + 4.5/alp0)*zeff)/((2.
     3       + zeff)*(1. + zeff)) - awt**4*8.*alpr/(4. + zeff)/alp0 + 
     4      awt**2*55.*alpi**2/(45. + zeff)/alp0
         aci2 = aci2/awt
         eta0 = fact*aci2 + (1. - fact)*aci
      endif
      gloop = 2./(zeff + 5.)*(1. + 2./(zeff + 3.))*wte**4 + 4./(zeff + 
     1   5.)*wte**2*(2. + 4.*(alpr + 1.)/alp0 + (2.*zeff + 9. + 24./(3.*
     2   zeff + 7.))/(zeff + 3.))
      eloop = 1.5915E-3*vloop/urhs*ukzero
      floop = 1. - 3.828E15*tempe/(dense*algame)*eloop*gloop/eta0
c    eloop : loop electric field in v/cm
      eta = cprof*amprof*eta0*rprof*floop
c $$$$$$$$$$$$$$$$$$$$$$$$
      xjop = 3.81E15/algame*tempe/dense*eta
c
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c     pwce = -sign(1.0_dp,pkpar)*abs(btor/btot)*btsign*pde*xjop
      pwce = -sign(1.0_dp,pkpar)*abs(btor/btot)*pde*xjop
      pwce = pwce*btsign
c-------------------
      return 
  300 continue
      pwce = 0.
      vph = rt2*xe
      rgamp2 = 1. - 1./pkpar2
      if (rgamp2 <= 0.) then
         xjop = 0.
      else
         gamp2 = 1./rgamp2
         gamp = sqrt(gamp2)
         wph = gamp*vph
         if (wph >= wpmx) go to 100
         if (wph <= wpmn) go to 100
         if (psi > psimx) go to 100
         if (psi < psimn) go to 100
         lthet = theta/twopi
         thetac = theta - lthet*twopi
         if (thetac < 0.) thetac = twopi + thetac
         jwp = (wph - wpmn)/dwp + 1
         ithp = (thetac - thetp(1))/dthp1 + 1
         lpsi = (psi - psis(1))/dpsis + 1
         if (jwp >= nwp1) jwp = nwp2
         if (ithp >= nthp11) ithp = nthp12
         if (lpsi >= npsi01) lpsi = npsi02
c       mthwp=nthp1*nwp
         n1 = (lpsi - 1)*mthwp
         n2 = (ithp - 1)*nwp
         do l = 1, 3
            ll = n1 + (l - 1)*mthwp
            do i = 1, 3
               ii = n2 + (i - 1)*nwp
               j1 = ll + ii + jwp
               do j = 1, 3
                  awrk(j) = sjop(j1+j-1)
               end do
               call inter3 (wwk, wph, awrk, wp(jwp), dwp)
               awrk1(i) = wwk
            end do
            call inter3 (wwk, thetac, awrk1, thetp(ithp), dthp1)
            awrk2(l) = wwk
         end do
         call inter3 (wwk, psi, awrk2, psis(lpsi), dpsis)
         eta = wwk
      endif
      xjop = 3.81E15/algame*tempe/dense*eta
      pwce = -sign(1.0_dp,pkpar)*abs(btor/btot)*pde*xjop
      pwce = pwce*btsign
c     if (abs(pwce).gt.1.e50) then
c       write(iout,1550) irec,nzeik,pwce
c1550    format(/5x,'irec:',i5,2x,'nzeik:',i4,2x,'pwce:',e14.6/)
c     endif
      return 
c
c
  200 continue
c $$$$$$$$$$$$$
      write (iout, 1560)
 1560 format(2x,'****This option is not working yet.***'//)
      stop 
c-------------------
c
      end subroutine cdcur
c
      subroutine curadj(nthp0, npsi0, psimx, psimn, nmax, umax, imax, 
     1   lmax, psis, eden, etem, zefi, jop, nwp, wpmx, wpmn, dwp, wp, 
     2   nthp1, thetp, iout4, iout5, iadj, wk5, wk6, npoint)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:52:22   6/14/01  
C...Switches: -p4 -yb
c---------------------------
c   calculate a j/p table with independent variables wp
c     (wp=gammap*vp, resonant electron momentum/m), psi(flux-surface),
c     thetap(poloidal-angle), lamda(T/mc**2, only at lamda=0 and lamda=0.1
c     and linear interpolate)
c   nthp0=No. of poloidal theta points for line integrals;
c   npsi0=No. of psi-grid points;
c   psimx,psimn=max. and min. psi;
c   nmax=No. of points in u-grid; umax=max. u; imax=No. points in pitch-ang.
c   lmax=No. of Lengendre harmonics; nwp=No. point in wave-phase wp;
c   wpmx=maximum wp;
c    nthp1=No. of poloidal theta points for j/p calculations;
c   iadj=0 : low beta j/p; iadj=1 : high beta j/p;
c
c  Output:
c   wp(1:nwp)=wave-phase momentum/me;
c   jop(nwp,nthp1,npsi0)=j/p
c   thetp(nthp1) = grid points of poloidal angles
c   npsi0 values of density (eden),temperature (etem),zeffective(zefi),
c              psi-values(psis).
c
c----------------------------
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
!      use Vcraylh
!      use Vcmnew
!      use Viorlh
       implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nthp0, npsi0, nmax, imax, lmax, nwp, nthp1, iout4, iout5, 
     1   iadj, npoint
      real psimx, psimn, umax, wpmx, wpmn, dwp
      real, dimension(npsi0) :: psis, eden, etem, zefi
      real, dimension(nwp,nthp1,npsi0) :: jop
      real, dimension(nwp) :: wp
      real, dimension(nthp1) :: thetp
      real, dimension(npoint) :: wk5, wk6
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: uaptr, ugptr, thaptr, thgptr, fmptr, chiptr, chxptr, 
     1   dchxpt, dchwpt, xiptr, gamrpt, dbptr, bfdptr, wr2ptr, wrptr, 
     2   wkptr, chirpt, dchirp, wk1ptr, wk2ptr, wk3ptr, wk4ptr, wk5ptr, 
     3   wk6ptr, wtabpt, mwrptr, iswrpt, dchwrp, dchxrp, lam1p
      integer, allocatable, dimension(:) :: intdum
      integer :: jthp0, jpsi0, jdthp, jdpsi, j1, ier, nimx, ii, lam1pt, 
     1   iercj, ierci, i, ndum, ndumi
      real, allocatable, dimension(:) :: dum
      real :: psimax, psimin, dpsimx, dpsimn, dpsim, stat
C-----------------------------------------------
c
c   Common block for Comdynray
c
 
      read (iout5, 2000) jthp0, jpsi0
      read (iout5, 2010) psimax, psimin
      jdthp = nthp0 - jthp0
      jdpsi = npsi0 - jpsi0
      dpsimx = psimx - psimax
      dpsimn = psimn - psimin
      j1 = iabs(jdthp) + iabs(jdpsi)
      dpsim = abs(dpsimx) + abs(dpsimn)
      if (j1/=0 .or. dpsim>1.E-13) then
         ier = 99
         write (iout4, 4000) ier
         write (iout4, 4010)
 4010    format(1x,'psi-thetap grids disagree.')
 4000    format(1x,'error in curadj, ier=',i8)
         stop 
      endif
c------------------------------------------------------
c  allocate memory
c------------------------------------------------------
      nimx = max0(nmax + 3,imax + 3)
      ii = 1
      uaptr = ii
      ii = ii + nmax
      ugptr = ii
      ii = ii + nmax + 1
      thaptr = ii
      ii = ii + imax
      thgptr = ii
      ii = ii + imax + 1
      lam1pt = ii
      ii = ii + imax
      fmptr = ii
      ii = ii + nmax
      chiptr = ii
      ii = ii + imax*nmax
      chxptr = ii
      ii = ii + (imax + 1)*nmax
      dchxpt = ii
      ii = ii + (imax + 1)*nmax
      dchwpt = ii
      ii = ii + (imax + 1)*nmax
      xiptr = ii
      ii = ii + imax + 1
      gamrpt = ii
      ii = ii + nimx
      dbptr = ii
      ii = ii + nthp1
      bfdptr = ii
      ii = ii + nthp1
      wr2ptr = ii
      ii = ii + nimx
      wrptr = ii
      ii = ii + nimx
      wkptr = ii
      ii = ii + nimx
      chirpt = ii
      ii = ii + nimx
      dchirp = ii
      ii = ii + nimx
      wk1ptr = ii
      ii = ii + nimx
      wk2ptr = ii
      ii = ii + nimx
      wk3ptr = ii
      ii = ii + nimx
      wk4ptr = ii
      ii = ii + nimx
      wk5ptr = ii
      ii = ii + nimx
      wk6ptr = ii
      ii = ii + nimx
      wtabpt = ii
      ii = ii + 5*nimx
      dchwrp = ii
      ii = ii + nimx
      dchxrp = ii
      ndum = ii + nimx - 1
c      call hpalloc(dumptr,ndum,iercj,1)
      if (.not.allocated(dum)) then
         ALLOCATE(dum(ndum),stat=iercj)
         if (iercj /= 0) then
            print *, 'dum could not be allocated in curadj'
            return 
         endif
      endif
      ii = 1
      mwrptr = ii
      ii = ii + nimx
      iswrpt = ii
      ndumi = ii + nimx - 1
c      call hpalloc(intdumpr,ndumi,ierci,1)
      if (.not.allocated(intdum)) then
         ALLOCATE(intdum(ndumi),stat=ierci)
         if (ierci /= 0) then
            print *, 'intdum could not be allocated in curadj'
            return 
         endif
      endif
c
      call cadj1 (iadj, nthp0, npsi0, psimx, psimn, nmax, umax, imax, 
     1   lmax, psis, eden, etem, zefi, jop, nwp, wpmx, wpmn, dwp, wp, 
     2   nthp1, thetp, iout4, iout5, nimx, dum(uaptr), dum(ugptr), dum(
     3   thaptr), dum(thgptr), dum(fmptr), dum(chiptr), dum(chxptr), dum
     4   (dchxpt), dum(dchwpt), dum(xiptr), dum(gamrpt), dum(dbptr), dum
     5   (bfdptr), dum(wr2ptr), dum(wrptr), dum(wkptr), dum(chirpt), dum
     6   (dchirp), dum(wk1ptr), dum(wk2ptr), dum(wk3ptr), dum(wk4ptr), 
     7   dum(wk5ptr), dum(wk6ptr), dum(wtabpt), dum(dchwrp), dum(dchxrp)
     8   , intdum(mwrptr), intdum(iswrpt), dum(lam1pt))
      wk5(:nwp) = dum(wk5ptr:nwp-1+wk5ptr)
      wk6(:nwp) = dum(wk6ptr:nwp-1+wk6ptr)
 
c      call hpdeallc(dumptr,iercj,0)
c      call hpdeallc(intdumpr,ierci,0)
      DEALLOCATE(dum, intdum)
 2000 format(1x,2i8)
 2010 format(4(2x,e20.12))
      return 
      end subroutine curadj
      subroutine subcof(akz, bkz, az, bz)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:52:22   6/14/01  
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
      use Vparam
      use Vcraylh
      use Vcmnew
      use Viorlh
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real, dimension(6,3) :: akz, bkz
      real, dimension(6,3,3) :: az, bz
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i, j, k, i1, j1, ier, l
      integer, dimension(20) :: ipiv
      real, dimension(6,6) :: g
      real, dimension(6,3,3) :: a, b
      real, dimension(6,6,3) :: c
      real, dimension(54) :: work
      real, dimension(6) :: wk
      real, dimension(3,3) :: ga, gb
      real, dimension(3) :: wka
      real :: c1, c2, c3, c4, d1, d2, d3, d4, z
C-----------------------------------------------
c------------------
c   Expansion of integrals I_i, SI_i as series of sqrt(eps) and 1/lamda
c    and 1/(Z+c)
c------------------------
c-------------------------
c  a(i,j,k) i=1,6, j=1,3 (I_j(Z_k)), k=1,3, Z_1=1,Z_2=2,Z_3=4
c  b(i,j,k) i=1,6, j=1,3 (SI_j(Z_k)), """""""
c   i=1,2,3 (eps=0.,.1,.2, lamda=infinity); i=4,5,6 (eps=0.,.1,.2, lamda=20.4)
c--------------------------
      g = 0.
      c = 0.
      a = 0.
      b = 0.
      c1 = sqrt(1.E-1)
      c2 = sqrt(2.E-1)
      c3 = .1
      c4 = .2
      d1 = c1/20.4
      d2 = c2/20.4
      d3 = c3/20.4
      d4 = c4/20.4
      g(:,1) = 1.E0
      g(4:6,4) = 1.E0/20.4
      do i = 2, 3
         i1 = i + 3
         g(i,2) = sqrt(1.E-1*(i - 1.E0))
         g(i1,2) = sqrt(1.E-1*(i - 1.E0))
         g(i,3) = 1.E-1*(i - 1.E0)
         g(i1,3) = 1.E-1*(i - 1.E0)
         g(i1,5) = g(i1,2)/20.4
         g(i1,6) = g(i1,3)/20.4
      end do
      c(1,1,1) = 0.5914
      c(2,1,1) = 0.3609
      c(3,1,1) = 0.2839
      c(4,1,1) = 0.4362
      c(5,1,1) = 0.2556
      c(6,1,1) = 0.1978
      c(1,2,1) = 1.0900
      c(2,2,1) = 0.7456
      c(3,2,1) = 0.6150
      c(4,2,1) = 0.8005
      c(5,2,1) = 0.5284
      c(6,2,1) = 0.4300
      c(1,3,1) = 1.3490
      c(2,3,1) = 0.8501
      c(3,3,1) = 0.6782
      c(4,3,1) = 1.2114
      c(5,3,1) = 0.7437
      c(6,3,1) = 0.5880
      c(1,4,1) = 3.7619
      c(2,4,1) = 1.9924
      c(3,4,1) = 1.4785
      c(4,4,1) = 4.1202
      c(5,4,1) = 2.1646
      c(6,4,1) = 1.6040
      c(1,5,1) = 12.644
      c(2,5,1) = 7.4390
      c(3,5,1) = 5.7523
      c(4,5,1) = 13.7668
      c(5,5,1) = 7.9627
      c(6,5,1) = 6.1369
      c(1,6,1) = 67.921
      c(2,6,1) = 42.731
      c(3,6,1) = 34.0572
      c(4,6,1) = 70.6398
      c(5,6,1) = 43.3395
      c(6,6,1) = 34.2480
      c(1,1,2) = 0.3484
      c(2,1,2) = 0.2302
      c(3,1,2) = 0.1847
      c(4,1,2) = 0.2474
      c(5,1,2) = 0.1585
      c(6,1,2) = 0.1256
      c(1,2,2) = 0.7268
      c(2,2,2) = 0.5215
      c(3,2,2) = 0.4332
      c(4,2,2) = 0.5174
      c(5,2,2) = 0.3622
      c(6,2,2) = 0.2979
      c(1,3,2) = 0.8230
      c(2,3,2) = 0.5574
      c(3,3,2) = 0.4522
      c(4,3,2) = 0.7234
      c(5,3,2) = 0.4815
      c(6,3,2) = 0.3880
      c(1,4,2) = 1.8805
      c(2,4,2) = 1.1195
      c(3,4,2) = 0.8611
      c(4,4,2) = 2.0586
      c(5,4,2) = 1.2200
      c(6,4,2) = 0.9376
      c(1,5,2) = 7.1483
      c(2,5,2) = 4.5932
      c(3,5,2) = 3.6432
      c(4,5,2) = 7.6954
      c(5,5,2) = 4.8914
      c(6,5,2) = 3.8663
      c(1,6,2) = 41.373
      c(2,6,2) = 27.972
      c(3,6,2) = 22.6690
      c(4,6,2) = 42.1644
      c(5,6,2) = 28.0322
      c(6,6,2) = 22.5795
      c(1,1,3) = 0.1995
      c(2,1,3) = 0.1364
      c(3,1,3) = 0.1105
      c(4,1,3) = 0.1369
      c(5,1,3) = 0.0916
      c(6,1,3) = 0.0735
      c(1,2,3) = 0.4609
      c(2,2,3) = 0.3338
      c(3,2,3) = 0.2767
      c(4,2,3) = 0.3197
      c(5,2,3) = 0.2278
      c(6,2,3) = 0.1875
      c(1,3,3) = 0.4861
      c(2,3,3) = 0.3387
      c(3,3,3) = 0.2763
      c(4,3,3) = 0.4198
      c(5,3,3) = 0.2892
      c(6,3,3) = 0.2349
      c(1,4,3) = 0.9401
      c(2,4,3) = 0.5989
      c(3,4,3) = 0.4714
      c(4,4,3) = 1.0288
      c(5,4,3) = 0.6538
      c(6,4,3) = 0.5144
      c(1,5,3) = 3.9507
      c(2,5,3) = 2.6496
      c(3,5,3) = 2.1279
      c(4,5,3) = 4.2146
      c(5,5,3) = 2.8079
      c(6,5,3) = 2.2500
      c(1,6,3) = 24.385
      c(2,6,3) = 16.960
      c(3,6,3) = 13.8260
      c(4,6,3) = 24.4418
      c(5,6,3) = 16.8149
      c(6,6,3) = 13.6510
c--------------------
c  Determine a(i,j,k), b(i,j,k)
c  I(j,k)=a(1,j,k)+sqrt(eps)*a(2,j,k) +eps*a(3,j,k)
c         +(a(4,j,k)+sqrt(eps)*a(5,j,k) +eps*a(6,j,k))/lamda
c  SI(j,k)= (a  ----> b)
c----------------------------
      do j = 1, 3
         j1 = j + 3
         do k = 1, 3
            wk = c(:,j,k)
!            call leqt2f(g, 1, 6, 6, wk, 8, work, ier)
             call dgesv(6, 1, g, 6, ipiv, wk, 6, ier)
            a(:,j,k) = wk
            wk = c(:,j1,k)
!            call leqt2f (g, 1, 6, 6, wk, 8, work, ier)
             call dgesv(6, 1, g, 6, ipiv, wk, 6, ier)
            b(:,j,k) = wk
         end do
      end do
      akz = 0.
      bkz = 0.
      akz(1,1) = 0.5E0
      akz(4,1) = 1.E0
      akz(5,1) = 0.5E0
      akz(6,1) = 0.5E0
      akz(1,2) = 1.E0
      akz(2,2) = 0.5E0
      akz(3,2) = 0.5E0
      akz(4,2) = 0.50E0
      akz(5,2) = 0.00E0
      akz(6,2) = 0.50E0
      akz(1,3) = 0.5E0
      akz(4,3) = 0.50E0
      akz(5,3) = 0.50E0
      akz(6,3) = 0.50E0
      bkz(4,1) = 0.5E0
      bkz(1,2) = 0.5E0
      bkz(4,2) = 1.E0
      bkz(5,2) = 0.5E0
      bkz(6,2) = 0.5E0
      bkz(1,3) = 0.5E0
      bkz(4,3) = 0.50E0
      bkz(5,3) = 0.00E0
      bkz(6,3) = 0.0E0
      do i = 1, 6
         do j = 1, 3
            wka = a(i,j,:)
            do k = 1, 3
               z = 2.**(k - 1)
               do l = 1, 3
                  ga(k,l) = 1./(z + akz(i,j))**l
                  gb(k,l) = 1./(z + bkz(i,j))**l
               end do
            end do
!            call leqt2f(ga, 1, 3, 3, wka, 8, work, ier)
             call dgesv(3, 1, ga, 3, ipiv, wka, 3, ier)
            az(i,j,:) = wka
            wka = b(i,j,:)
!            call leqt2f(gb, 1, 3, 3, wka, 8, work, ier)
             call dgesv(3, 1, gb, 3, ipiv, wka, 3, ier)
            bz(i,j,:) = wka
         end do
      end do
      bz(1,1,2) = 0.
      bz(1,1,3) = 0.
 
      return 
      end subroutine subcof
