 
c
c  This module contains wave-physics routines
c
c------------------------------------------------
c
c
      subroutine fwibmc(iflg)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:03:04   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 iflg
C-----------------------------------------------
      iflg = 0
      return 
      end subroutine fwibmc
      subroutine absorb
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:03:04   6/14/01  
C...Switches: -p4 -yb
c
c ************ ************ ************ ************ ************
c
c  this module attributes the power absortbed along the ray
c     to the charged particle species
c  modified for fast ion, multi-species, collisional absorption
c
c   normal version
c
c ************ ************ ************ ************ ************
c
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vsizes
      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
      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, nminor, nsp1
      use Vchpcsd
!                , ONLY: irec, rec0, rec1, rec2, rec3, rec4, rec5, 
!     1   rec6, rec7, rec8, rec9, rec10, rec11, rec12, rec13, rec14, 
!     2   rec15, prmt, nraym
      use Vcraylh
      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
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 :: i, n, l, k
      real :: zgame, zgamce, zgami, zgamf
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
!      integer , EXTERNAL :: ifix, min0
      real , EXTERNAL :: valspl  !  , cabs
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 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
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   Comhpcsd
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
c ************ ************ ************ ************ ************
c
c $$$$  TK Mau   10/3/94
c     Calculate epsilon, B_max, and B_min locally.
!      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)
      boutbrd = binbrd*(1. - epsil)/(epsil + 1.)
c $$$$$$$$$$$$$$$$$$$$$
      if (prmt(5) /= 2.) then
c
         if (gamma == 0.) return 
c
         zpwabs = powold - pwx
c
      else
c
         gamma = 1.
         game = 0.
         gami(:nspec) = 0.
         gami(light) = 1.
c $$$$    TK Mau    4/6/94
         if (nalfa > 0) then
            do i = 1, nalfa
               gamal(i,:nharm0) = 0.
               gamal(light,:nharm0) = 1.
            end do
         endif
c $$$$$$
         zpwabs = powold
         pwx = 0.
c
      endif
      l = left
      if (hh > 0.5*dpsi) l = left + 1
      l = min(nprofs,l)
c
c  electrons
c
      zgame = zpwabs*game/gamma
      zgamce = zpwabs*gamce/gamma
      pwtote = pwtote + zgame + zgamce
      pde = zgame/volume(l)
      pdec = zgamce/volume(l)
      pwe(l) = pwe(l) + pde + pdec
c
c  $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c
      if (idmpsw /= 0) then
c
c  ions
c
         do i = 1, nspec
            zgami = zpwabs*gami(i)/gamma
            dpwri = dpwri + zgami
            pwtoti(i) = pwtoti(i) + zgami
            pdi(i) = zgami/volume(l)
            pwi(l,i) = pwi(l,i) + pdi(i)
         end do
c
c $$$$    TK Mau    4/6/94
c   energetic ions
c
         if (kalfa > 0) then
            do k = 1, nalfa
               do n = 1, nharm0
                  zgamf = zpwabs*gamal(k,n)/gamma
                  dpwrf = dpwrf + zgamf
                  pwtotf(k) = pwtotf(k) + zgamf
                  pdf(k,n) = zgamf/volume(l)
                  pwal(l,k) = pwal(l,k) + pdf(k,n)
               end do
            end do
         endif
      endif
c $$$$$$$$$$$$$
      powold = pwx
c
c  $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c   Modified by T.K. Mau on July 30, 1991.
c   Calculate current driven from electron absorbed power.
c     pwe : electron-absorbed power density (MW/m**3)
c     pwc : driven electron current density (A/m**2)
c
c     pwc1: driven minority current density (A/m**2)
c     pwc2: driven fast ion current density (A/m**2)
c     pwce, pwcm, and pwcf are incremental driven current densities
c
      if (idrive /= 0) then
         call cdcur (idcur)
c     if (abs(pwce).gt.1.e50) then
c       write(iout,1500) irec,nzeik,l,psi,theta,pwc(l),pwce
c1500    format(1x,'irec:',i5,2x,'nzeik:',i4,2x,'l-fluxsfce:',
c    1         i4/2x,'psi:',e14.6,'theta:',e14.6/
c    2         2x,'pwc(l):',e14.6,2x,'pwce:',e14.6)
c     endif
         pwc(l) = pwc(l) + pwce
         if (abs(pwc(l)) > largest) then         ! was 1.e50
c       write(iout,1501) irec,nzeik,l,pwc(l)
 1501       format(1x,'irec:',i5,3x,'nzeik:',i4,3x,'l-fluxsfce:',i4/2x,
     1         'pwc(l):',e14.6)
            stop 
         endif
         if (nminor /= 0) then
            pwc1(l,nsp1+1:nspec) = pwc1(l,nsp1+1:nspec) + pwcm(nsp1+1:
     1         nspec)
         endif
         if (kalfa /= 0) then
            pwc2(l,:nalfa) = pwc2(l,:nalfa) + pwcf(:nalfa)
c $$$$$$$$$$$$$$$$$$$$$$$$$$Added by TK Mau, 8/28/91.
         endif
         if (irec < nraym) then
            rec10(irec) = pde
            rec11(irec) = pwce
         endif
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
      endif
c
c  $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c
c
c  ions
c
c     do 525  i=1,nspec
c        zgami = zpwabs*gami(i)/gamma
c     dpwri = dpwri + zgami
c        pwtoti(i) = pwtoti(i) + zgami
c 525    pwi(l,i) = pwi(l,i) + zgami/volume(l)
c
c        powold = pwx
c
      return 
      end subroutine absorb
c
c
      subroutine alfadamp(imod)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:03:04   6/14/01  
C...Switches: -p4 -yb
c*****Calculates damping decrements due to energetic ion components
c***** All velocities are initially normalized to speed of light.
c      imod=1    : magnetized orbit model
c           2    : straight (unmagnetized) orbit model
c           else : no damping
c    Note: imod=1 is not working becuase of Bessel function table.
c $$$$   Added by TK Mau on 4/6/94
c $$$$   SCChiu  5/10/94   vectorized version
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vsizes
      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
      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, nfion
      use Vchpcsd
      use Vcraylh
      USE Vgrnout
      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 imod
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      integer, parameter :: nv = 127
      integer, parameter :: nl1 = 50
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer, dimension(nv) :: mx
      integer :: i, k, nu, nl, i1, j1, j2
      real, dimension(nions) :: egami
      real, dimension(nv) :: fung, fung1
      real, dimension(nl1) :: palf
      real, dimension(nfion) :: vth, wpa
      real, dimension(nv,nl1) :: besjf
      real, dimension(nv) :: vp, allam, th2, vtt, work
      real, dimension(nv,0:6) :: wk
      real :: clight, zpi, x1, y1, x2, dnot, egame, eb1, dnot1, eb2, 
     1   vcrit, valf0, vt1, vt3, vc3, alamda, wpa02, vpmax, acyc, vres, 
     2   vu, vl, dv, pktot, pnp, pnpar, const, xkl, xkt, xk11, xk22, 
     3   xk33, xk13
      complex :: cepxy, cepzy
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real , EXTERNAL :: simp  !  , cabs
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 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
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
c  New common added for FWCD
c  Storage related to FWCD:
c  Subroutines displh inital use Comnew1
 
 
c******      TKM   03/97, 09/99, 04/00, 06/00
c********************
 
c      parameter (nv=127,nl1=50)
      data clight/2.9979E10/
      data zpi/3.14159265/
c
      if (imod<1 .or. imod>2) return 
      cepxy = cepx/cepy
      x1 = real(cepxy)
      y1 = aimag(cepxy)
      cepzy = cepz/cepy
      x2 = real(cepzy)
      y2 = aimag(cepzy)
      dnot = 1./tempe
      dnot = dnot + sum(azi(:nspec)*azi(:nspec)*aconc(:nspec)/tempi(:
     1   nspec))
      egame = sqrt(2.9E27*tempe/(dense*dnot))
      do k = 1, nalfa
         if (densa(k) >= 1.E8) then
            vth(k) = 1.035E-3*sqrt(tempi(1)/atmf(k))
            wpa(k) = 2.10E2*azf(k)*sqrt(densa(k)/atmf(k))/freqcy
            wca(k) = 1.52E7*azf(k)*btot/(atmf(k)*freqcy)
            taua0(k) = 6.67E12*atmf(k)/azf(k)**2*tempe**1.5/(dense*alog(
     1         egame))
c **** Assume ave. ion energy is 1/4 of birth energy.
            eb1 = 0.25*ebkev(k)
            dnot1 = 0.
            where (eb1 >= 25.*(azi(:nspec)*azf(k))**2*atmf(k)) 
               egami(:nspec) = sqrt(5.34E30*eb1*atmf(k)/(dense*dnot))*
     1            atm(:nspec)/(atm(:nspec)+atmf(k))
            elsewhere
               egami(:nspec) = sqrt(2.09E29/(dense*dnot))*azi(:nspec)*
     1            eb1/((azi(:nspec)*azf(k))*(atm(:nspec)+atmf(k)))
            end where
            dnot1 = sum(azi(:nspec)**2*aconc(:nspec)*alog(egami(:nspec))
     1         /atm(:nspec))
            ecrit(k) = 14.8*tempe*atmf(k)*(dnot1/alog(egame))**0.667
            vcrit = 1.035E-3*sqrt(ecrit(k)/atmf(k))
            valf0 = 1.035E-3*sqrt(ebkev(k)/atmf(k))
c***** Normalize velocities to energetic ion birth speed
            vt1 = vth(k)/valf0
            vt3 = vt1**3
            vc3 = (vcrit/valf0)**3
            alamda = 0.3333333333*alog((1. + vc3)/(vt3 + vc3))
            if (irayio == 0) then
               wpa02 = wpa(k)**2/alamda
            else
               wpa02 = wpa(k)**2*taua0(k)
            endif
 
c***** Setting up velocity integral
            select case (imod) 
 
            case default
               vpmax = 1.0
               acyc = 1./wca(k)
               nu = acyc + incf
               nl = acyc - incf
               if (nl <= 0) nl = 1
               if (nu <= 0) nu = 1
               do i1 = nl, nu
                  vres = abs((1. - float(i1)*wca(k))/pkpar)/valf0
                  if (vpmax > vres) then
                     vu = sqrt(vpmax*vpmax - vres*vres)
                  else
                     vu = 0.
                  endif
                  if (vt1 > vres) then
                     vl = sqrt(vt1*vt1 - vres*vres)
                  else
                     vl = vt1
                  endif
                  if (vl < vu) then
                     dv = (vu - vl)/float(nv - 1)
                     do j1 = 1, nv
                        vp(j1) = vl + float(j1 - 1)*dv
                        allam(j1) = pkp*valf0*vp(j1)/wca(k)
                        vtt(j1) = sqrt(vp(j1)*vp(j1)+vres*vres)
                     end do
                     call besselj (i1 + 1, i1 - 1, nv, allam, besjf, 
     1                  0.01, nv, work, mx, wk)
                     th2(:nv) = x1*vp(:nv)*(besjf(:nv,1)+besjf(:nv,3))
     1                   + ((2.*vres)*besjf(:nv,2))*x2
                     work(:nv) = vp(:nv)*((y1 + 1.)*besjf(:nv,1)+(y1-1.)
     1                  *besjf(:nv,3)) + ((2.*vres)*besjf(:nv,2))*y2
                     th2(:nv) = th2(:nv)**2 + work(:nv)**2
                     work(:nv) = vtt(:nv)**3 + vc3
                     fung(:nv) = th2(:nv)*vp(:nv)*vtt(:nv)/work(:nv)/
     1                  work(:nv)
                     palf(i1) = simp(nv,dv,fung)
c-----Add delta function term at max velocity
c                              !+th2(nv)*vp(nv)**3/(3.*vtt(nv)*work(nv))
                     palf(i1) = palf(i1)
                  else
                     palf(i1) = 0.
                  endif
                  gamal(k,i1) = 12.*zpi*wpa02/(abs(pkpar)*valf0)*abs(
     1               cepy)**2*palf(i1)
               end do
               cycle 
 
            case (2) 
               vpmax = 1.0
               pktot = sqrt(pkp2 + pkpar2)
               pnp = pkp/pktot
               pnpar = pkpar/pktot
               const = 24.*zpi*wpa02/(pktot*valf0)
               vres = 1./(pktot*valf0)
               if (vpmax > vres) then
                  vu = sqrt(vpmax*vpmax - vres*vres)
               else
                  vu = 0.
               endif
               if (vt1 > vres) then
                  vl = sqrt(vt1*vt1 - vres*vres)
               else
                  vl = vt1
               endif
               if (vl <= vu) then
                  dv = (vu - vl)/float(nv - 1)
                  do j2 = 1, nv
                     vp(j2) = vl + float(j2 - 1)*dv
                     vtt(j2) = sqrt(vres*vres + vp(j2)*vp(j2))
                     work(j2) = vtt(j2)**3 + vc3
                     work(j2) = work(j2)*work(j2)
                     work(j2) = vtt(j2)/work(j2)
                     fung(j2) = vp(j2)*vres**2*work(j2)
                     fung1(j2) = vp(j2)**3*work(j2)
                  end do
                  xkl = const*simp(nv,dv,fung)
                  xkt = const*simp(nv,dv,fung1)
                  xk11 = xkl*pnp**2 + xkt*pnpar**2
                  xk22 = xkt
                  xk33 = xkl*pnpar**2 + xkt*pnp**2
                  xk13 = pnp*pnpar*(xkl - xkt)
                  gamal(k,1) = abs(cepx)**2*xk11 + abs(cepy)**2*xk22
     1                + abs(cepz)**2*xk33 + 2.*(real(cepx)*real(cepz)
     2                - aimag(cepx)*aimag(cepz))*xk13
               endif
            end select
         endif
      end do
      return 
      end subroutine alfadamp
c
      subroutine alpress
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:03:04   6/14/01  
C...Switches: -p4 -yb
 
c*****Subroutine to calculate the fast alpha particle pressure profile
c     given background thermal dueterium and tritium profiles.
c***** Set kalfa=1, nalfa=1, enkev(1)=3.59e3, azf(1)=1, and atmf(1)=4
c     in input curray_go file.
c     This routine also calculates fast ion density and average energy
c     profile.
c     This subroutine is called from PROFIN.
c
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vsizes
      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
      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
      use Vchpcsd
      use Vcraylh
      use Vceqdsk, ONLY: ntitle, dat, ipestg, nxeqd, nzeqd, xdimeqd, 
     1   zdimeqd, reqd, redeqd, zmideqd, xma, zma, psimag, psilim, 
     2   beqd, toteqd, psimx1, psimx2, xax1, xax2, zax1, zax2, psisep, 
     3   xsep, zsep, feqd, presseqd, ffpeqd, ppeqd, peqd, qeqd, xeqd, 
     4   zeqd, psiadj, dpolflx, psieqd, tpsieqd, tpsifeqd, iounit1, 
     5   inoperm1, nptsdm1, nptsd, torflux, tpsisav, ra, psifra, 
     6   dpsifra, fra, fra1, cspln, pds, wnoperm, xcontr, zcontr, 
     7   bpcontr, btcontr, dstarp, b_fld, jacob, pprime, vprime, 
     8   chipsi, ncontr, dang, bperr, arcl, thet, anglex, csplnx, 
     9   csplnz, pdsx, pdsz, nlim, rlim, zlim, nlimiter, rlimiter, 
     .   zlimiter, lrz, nprim, nimp, nion, nti, zi, zeffz, r, raeqd, 
     1   psifeqd, te, ti, ti1, ene, enp, bmod, rmd, btmd, bpmd, btpmd, 
     2   roa, nxa
      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
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 :: ij, jj, i, k, j
      real, dimension(nions) :: egami
      real, dimension(nprofm) :: xwork, ywork
      real, dimension(nxa) :: dumm
      real, dimension(nprofm,4) :: fbeam
      real :: sqt3, dlpsi, xpsi, f1, f2, dra, vbeam, eb1, dnot, egame, 
     1   dnot1, eb2, xc2, xc1, arg1, gxc1, arg2
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real , EXTERNAL :: simp, svfuse
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 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
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   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  Storage related to EQDSK:
c  Units used in the EQDSK are entirely MKSA.
c  Comeqdsk-->ceqdsk.i
 
c
c******     TKM   03/97
c********************
      data sqt3/0.57735/
c
c******     TKM   03/97
c      Calculate beam deposition profile F(rho), given analytic
c     form in F(psi)
      if (ibeam < 0) then
         dlpsi = 1./float(nxeqd - 1)
         do ij = 1, nxeqd
            xpsi = dlpsi*float(ij - 1)
            f1 = dbeam**2/((xpsi - abeam)**2 + dbeam**2)
            f2 = (1. - xpsi**2)**aneb
            if (f2 == 0.) f2 = 1.E-9
            dumm(ij) = f1*f2
         end do
         call intrpp ('zero', 'free', tpsieqd, dumm, nxeqd, ra, fbeam, 
     1      nprofs)
         dra = 1./float(nprofs - 1)
         xwork(:nprofs-1) = volume(:nprofs-1)*fbeam(:nprofs-1,1)/dra
         vbeam = simp(nprofs,dra,xwork)
      endif
c*********************
c
      eb1 = 0.25*ebkev(1)
c
c-----Looping over the plasma cross section
c
c  To avoid divergence, ignore the last two flux surfaces.
c
      do i = 1, nprof - 1
         dnot = 1./pte(i)
         dnot = dnot + sum(azi(:nspec)**2*conc(i,:nspec)/pti(i,:nspec))
         egame = sqrt(2.9E27*pte(i)/(pne(i)*dnot))
c-----Calculate slowing down time (s)
         tau0(i) = 1.998E13*atmf(1)/azf(1)**2*pte(i)**1.5/(pne(i)*alog(
     1      egame))
         dnot1 = 0.
         where (eb1 >= 25.*(azi(:nspec)*azf(1))**2*atmf(1)) 
            egami(:nspec) = sqrt(5.3E30*eb1*atmf(1)/(pne(i)*dnot))*atm(:
     1         nspec)/(atm(:nspec)+atmf(1))
         elsewhere
            egami(:nspec) = sqrt(2.09E29/(pne(i)*dnot))*azi(:nspec)*eb1/
     1         ((azi(:nspec)*azf(1))*(atm(:nspec)+atmf(1)))
         end where
         dnot1 = sum(azi(:nspec)**2*conc(i,:nspec)*alog(egami(:nspec))/
     1      atm(:nspec))
c-----Calculate alpha critical energy (keV)
         ecrita(i) = 14.8*pte(i)*atmf(1)*(dnot1/alog(egame))**0.667
         xc2 = ebkev(1)/ecrita(i)
         xc1 = sqrt(xc2)
         arg1 = (xc2 + 2.*xc1 + 1.)/(xc2 - xc1 + 1.)
         gxc1=0.5*xc2+alog(arg1)/6.-sqt3*atan(sqt3*(2.*xc1-1.))-0.3023
c-----Calculate alpha/beam particle source rate (m**-3/s) and fast alpha
c     pressure (pascals).
c********   TKM    03/97
         if (ibeam < 0) then
            sordt(i) = 6.241E21*bmpwr(1)*fbeam(i,1)/(vbeam*azf(1)*ebkev(
     1         1))
         else
            sordt(i) = 1.E6*pne(i)**2*conc(i,1)*conc(i,2)*svfuse(1.E3*
     1         pti(i,1),3)
         endif
c*************************************
         paf(i) = 1.068E-16*tau0(i)*ecrita(i)*sordt(i)*gxc1
c-----Calculate fast alpha density (cm**-3) and average energy (keV).
         arg2 = (1. + xc1*xc2)/(1. + (pte(i)/ecrita(i))**1.5)
c     tausd(i) = tau0(i)*alog(arg2)
         tausd(i) = tau0(i)
         denfa(i) = sordt(i)*tausd(i)
c**********   TKM    2/97
         if (denfa(i) == 0.) then
            eav(i) = eav(i-1)
         else
            eav(i) = paf(i)/(1.6022E-16*denfa(i))
         endif
c***************************
         denfa(i) = 1.E-6*denfa(i)
      end do
c-----------------------
c  assign a small value at the edge
c
      ecrita(nprof) = ecrita(nprof-1)*pte(nprof)/pte(nprof-1)
      tau0(nprof) = tau0(nprof-1)*pne(nprof-1)*pte(nprof-1)**1.5/pne(
     1   nprof)/pte(nprof-1)**1.5
      sordt(nprof) = 0.01*sordt(nprof-1)
      paf(nprof) = 0.01*paf(nprof-1)
      denfa(nprof) = denfa(nprof-1)*0.01
      eav(nprof) = 1.2*eav(nprof-1)
      tausd(nprof) = tau0(nprof)
      xwork(1) = 0.
      dra = 1./float(nprof - 1)
      xwork(2:nprof) = volume(2:nprof)/dra
      ywork(2:nprof) = paf(2:nprof)*xwork(2:nprof)
      betaf = 2.513E-6*simp(nprof,dra,ywork)/beqd**2/simp(nprof,dra,
     1   xwork)
c $$$$$     TKM   04/00
c   Add energetic alphas as a thermal ion species
c     nspec = nspec+1
c     atm(nspec) = 4.
c     azi(nspec) = 2.
c     do j = 1,nprof
c        pti(j,nspec) = denfa(j)
c        pni(j,nspec) = eav(j)
c     enddo
c $$$$$$$$$$$$
      return 
      end subroutine alpress
c
      subroutine chkpmc(lmcon, kdim, ixz, jmcind)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:03:04   6/14/01  
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vsizes
      use Viorlh
      use Vcmnew
      use Vchpcsd
      use Vcraylh
      use Vceqdsk
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer kdim, ixz, jmcind
      integer, dimension(kdim) :: lmcon
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: j
C-----------------------------------------------
c---------------
c  check if there is mode-conversion in previous five steps, if so
c  set jmcind=1 and lmcon(ixz)=0
c---------------
      jmcind = 0
      if (ixz > 5) then
         do j = 1, 5
            if (lmcon(ixz-j)==1 .or. lmcon(ixz-j)==(-1)) jmcind = 1
         end do
      else
         jmcind = 1
      endif
      if (jmcind == 1) lmcon(ixz) = 0
      return 
      end subroutine chkpmc
      subroutine deriv(x)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:03:04   6/14/01  
C...Switches: -p4 -yb
c
c ************ ************ ************ ************ ************
c
c  rhs of the ray tracing equations
c
c ************ ************ ************ ************ ************
c
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vsizes
      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
      use Vcmnew
      use Vchpcsd
!                , ONLY: irec, rec0, rec1, rec2, rec3, rec4, rec5, 
!     1   rec6, rec7, rec8, rec9, rec10, rec11, rec12, rec13, rec14, 
!     2   rec15
      use Vcraylh
      use Vceqdsk, ONLY: ntitle, dat, ipestg, nxeqd, nzeqd, xdimeqd, 
     1   zdimeqd, reqd, redeqd, zmideqd, xma, zma, psimag, psilim, 
     2   beqd, toteqd, psimx1, psimx2, xax1, xax2, zax1, zax2, psisep, 
     3   xsep, zsep, feqd, presseqd, ffpeqd, ppeqd, peqd, qeqd, xeqd, 
     4   zeqd, psiadj, dpolflx, psieqd, tpsieqd, tpsifeqd, iounit1, 
     5   inoperm1, nptsdm1, nptsd, torflux, tpsisav, ra, psifra, 
     6   dpsifra, fra, fra1, cspln, pds, wnoperm, xcontr, zcontr, 
     7   bpcontr, btcontr, dstarp, b_fld, jacob, pprime, vprime, 
     8   chipsi, ncontr, dang, bperr, arcl, thet, anglex, csplnx, 
     9   csplnz, pdsx, pdsz, nlim, rlim, zlim, nlimiter, rlimiter, 
     .   zlimiter, lrz, nprim, nimp, nion, nti, zi, zeffz, r, raeqd, 
     1   psifeqd, te, ti, ti1, ene, enp, bmod, rmd, btmd, bpmd, btpmd, 
     2   roa
      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-----------------------------------------------
      real x
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 :: i
      real :: zpi, zdivy
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 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
c
c
c   Comhpcsd
c
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  Storage related to EQDSK:
c  Units used in the EQDSK are entirely MKSA.
c  Comeqdsk-->ceqdsk.i
 
c
c ************ ************ ************ ************ ************
c
      data zpi/3.14159265359/
c
c ************ ************ ************ ************ ************
c
c  transfer
c
      psi = y(2)
      theta = y(4)
      phi = y(5)
c
      akpsi = y(1)
      akth = y(3)
c
c  metric elements
c
      call coords
c
c  profile factors
c
      call profix
c
c  components of the wavevector
c
      call wavect
c
c  dispersion relation and power transport
c
      call disper (1)
c
c  derivative of akpsi
c
      dy(1) = -(dhne*derdne + dhte*derte + dhom*dompsi + dkp2p*dhkp2 + 
     1   dkpzp*dhkz)
      dy(1) = dy(1) - sum((dhti(:nspec)*derti(:nspec)+dhni(:nspec)*
     1   derdni(:nspec)))
c
c  derivative of psi
c
      dy(2) = 2.*pkpsi*dhkp2*antau/aj
c
c  derivative of akth
c
      dy(3) = -(dhom*domth + dkp2t*dhkp2 + dkpzt*dhkz)
c
c  derivative of theta
c
      dy(4)=(2.*((-ag*pkpsi/aj)+acostq*pkheta)*dhkp2+asintq*dhkz)/antau
c
c  derivative of phi
c
      dy(5) = ((-2.*pkheta*asintq*dhkp2) + acostq*dhkz)/urhs
c
c  change to the phase as independent variable
c
      if (indvar <= 0) then
c
c  poloidal phase as independent variable
c
         zdivy = y(1)*dy(2) + y(3)*dy(4)
      else
c
c  toroidal (actually, total) phase as independent variable
c
         zdivy = y(1)*dy(2) + y(3)*dy(4) + anphi*dy(5)
c
      endif
      dy(:5) = dy(:5)/zdivy
c
c  logarithmic derivative of the power
c
c**bh  Changes in next two lines  (bh:Oct 12/89)
c        dy(6) = -2.*gamma/poyntn
      dy(6) = -gamma/poyntn
      if (indvar > 0) dy(6) = (y(1)*dy(2)+y(3)*dy(4))*dy(6)
c
      return 
c
      end subroutine deriv
c
      subroutine diel1h(psic, thetac, vp, clite, alphar, alphai, ck0)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:03:04   6/14/01  
C...Switches: -p4 -yb
c---------------------
c   For adj
c    given psic,thetac,vp,clite, calculate alphar,alphai,sxy,dxy
c
c   Note: vp and clite are wave v-phase and light-vel. normalized
c         to vte=sqrt(te/me)
c---------------------
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vsizes
      use Viorlh
      use Vcmnew
      use Vchpcsd
      use Vcraylh
      use Vceqdsk
      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-----------------------------------------------
      real psic, thetac, vp, clite, alphar, alphai, ck0
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 :: i
!      real, dimension(nions) :: cwork, cwwk, cwwk1, deli
      real, dimension(6) :: wrk
      real :: zpi, zdsqpi, zcalf, rt2, zhsi, c1, sxy, dxy, vte, pk2ms, 
     1   wrk5, wrk1, wrk2, wrk3, wrk4, wrk6, a4, a2, a0, a2k, discr, 
     2   disck2, pkpr2
      complex :: cwk
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
C      real , EXTERNAL :: sqrt
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 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
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  Storage related to EQDSK:
c  Units used in the EQDSK are entirely MKSA.
c  Comeqdsk-->ceqdsk.i
 
c********************************************
c  6/26/91,  Latest update: 06/02/00
c     Comnew
c  New common added for FWCD
c  Storage related to FWCD:
c  Subroutines displh inital use Comnew1
 
 
c******      TKM   03/97, 09/99, 04/00, 06/00
c********************
 
c
c
      data zpi/3.14159265359/
      data zdsqpi/1.772453851/
      data zcalf/3.198E-6/
      data rt2/1.414213562/
c
      psi = amax1(psic,1.E-4_dp)
      theta = thetac
      call coords
      call profix
      zhsi = btot/bzero
      wpe2 = wpe2c*dense
      wce2 = wce2c*zhsi*zhsi
      wce = sqrt(wce2)
      wpi2(:nspec) = wpi2c(:nspec)*densi(:nspec)
      wci(:nspec) = wci1c(:nspec)*zhsi
      wci2(:nspec) = wci2c(:nspec)*zhsi*zhsi
      cwork(:nspec) = 1. - wci2(:nspec)
      vti(:nspec) = 1.459E-3*sqrt(tempi(:nspec)/atm(:nspec))
      do i = 1, nspec
c       awork=abs(cwork(i))
c       if (awork.le.1.e-9) cwork(i)=1.e-9*cwork(i)/awork
c         if (awork.eq.0.) cwork(i)=1.e-9
         c1 = cwork(i)
         if (abs(c1) <= 1.E-20) then
            cwwk(i) = wpi2(i)*1.E20*sign(1.0_dp,c1)
         else
            cwwk(i) = wpi2(i)/(1. - wci2(i))
         endif
         cwwk1(i) = cwwk(i)/wci(i)
      end do
      sxy = 1. + wpe2/wce2
      dxy = 0.
      del0 = 0.
      sxy = sxy - sum(cwwk(:nspec))
      dxy = dxy + sum(cwwk1(:nspec))
      deli(:nspec) = -cwwk(:nspec)*vti(:nspec)**2/(1. - wci2(:nspec))
      del0 = del0 + sum(deli(:nspec))
      xe = vp/rt2
      zxmin = abs(xe)
      zxe2 = xe*xe
c      call zfun(0,xe,cz,czp,zfn,zfc,xzz,nptzf,nptzfa,hzf,iout0)
      call zfun(xe, cz, czp)
      eps3r = 2.*wpe2*zxe2*(1. + xe*real(cz))
      eps3i = 2.*wpe2*zxe2*xe*aimag(cz)
      ceps3 = 2.*wpe2*zxe2*(1. + xe*cz)
      cwk = ceps3
      pkpar = clite/vp
      pkpar2 = pkpar*pkpar
      cwk = -clite*clite*wce*dxy/(sxy - pkpar2)/cwk
      cwk = cwk*(1. + del0)
      alphar = real(cwk)
      alphai = aimag(cwk)
      aeps32 = eps3r*eps3r + eps3i*eps3i
      vte = 0.0625*sqrt(tempe)
      delxp = 0.5*vte**2/wce
      del1 = pkpar*delxp
      delm = wpe2*vte**2*xe*cz/wce2
      pk2ms = pkpar2 - sxy
      wrk5 = real(delm)
      wrk1 = real((1. - wrk5)/ceps3)
      wrk2 = real(1./ceps3)
      wrk3 = 1. + del0
      wrk4 = pkpar2*wrk3*wrk3 - pk2ms
      wrk6 = dxy*dxy - pk2ms*pk2ms + pkpar2*wrk3*wrk3*pk2ms
      a4 = wrk4*wrk1
      a2 = pk2ms*(1. + del1*del1*eps3r - wrk5) - 2.*pkpar*del1*wrk3*dxy
     1    + wrk6*wrk2
      a0 = pk2ms**2 - dxy**2
      a2k = -a2/2./a4
      discr = a2**2 - 4.*a4*a0
      if (discr > 0.) then
         disck2 = sqrt(discr)/2./a4
         wrk(2) = a2k + disck2
         wrk(3) = a2k - disck2
         if (abs(wrk(2)) < abs(wrk(3))) then
            wrk(4) = wrk(2)
            wrk(2) = wrk(3)
            wrk(3) = wrk(4)
         endif
         pkpr2 = wrk(3)
      else
         pkpr2 = a2k
      endif
      pkpr2 = amax1(0.0_dp,pkpr2)
      ck0 = 1. + wrk4*pkpr2/pk2ms*wrk2
      return 
      end subroutine diel1h
c
      subroutine diel1l(psic, thetac, vp, clite, alphar, alphai, ck0)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:03:04   6/14/01  
C...Switches: -p4 -yb
c---------------------
c   For adj
c    given psic,thetac,vp,clite, calculate alphar,alphai,sxy,dxy
c
c   Note: vp and clite are wave v-phase and light-vel. normalized
c         to vte=sqrt(te/me)
c---------------------
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vsizes
      use Viorlh
      use Vcmnew
      use Vchpcsd
      use Vcraylh
      use Vceqdsk
      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-----------------------------------------------
      real psic, thetac, vp, clite, alphar, alphai, ck0
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 :: i
!      real, dimension(nions) :: cwork, cwwk, cwwk1
      real, dimension(6) :: wrk
      real :: zpi, zdsqpi, zcalf, rt2, zhsi, c1, sxy, dxy, vte, pk2ms, 
     1   wrk5, wrk1, wrk2, wrk3, wrk4, wrk6, a4, a2, a0, a2k, discr, 
     2   disck2, pkpr2
      complex :: cwk
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 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
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  Storage related to EQDSK:
c  Units used in the EQDSK are entirely MKSA.
c  Comeqdsk-->ceqdsk.i
 
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
 
      data zpi/3.14159265359/
      data zdsqpi/1.772453851/
      data zcalf/3.198E-6/
      data rt2/1.414213562/
c
      psi = amax1(psic,1.E-4_dp)
      theta = thetac
      call coords
      call profix
      zhsi = btot/bzero
      wpe2 = wpe2c*dense
      wce2 = wce2c*zhsi*zhsi
      wce = sqrt(wce2)
      wpi2(:nspec) = wpi2c(:nspec)*densi(:nspec)
      wci(:nspec) = wci1c(:nspec)*zhsi
      wci2(:nspec) = wci2c(:nspec)*zhsi*zhsi
      cwork(:nspec) = 1. - wci2(:nspec)
      do i = 1, nspec
c       awork=abs(cwork(i))
c       if (awork.le.1.e-9) cwork(i)=1.e-9*cwork(i)/awork
c         if (awork.eq.0.) cwork(i)=1.e-9
         c1 = cwork(i)
         if (abs(c1) <= 1.E-20) then
            cwwk(i) = wpi2(i)*1.E20*sign(1.0_dp,c1)
         else
            cwwk(i) = wpi2(i)/(1. - wci2(i))
         endif
         cwwk1(i) = cwwk(i)/wci(i)
      end do
      sxy = 1. + wpe2/wce2
      dxy = 0.
      del0 = 0.
      sxy = sxy - sum(cwwk(:nspec))
      dxy = dxy + sum(cwwk1(:nspec))
      xe = vp/rt2
      zxmin = abs(xe)
      zxe2 = xe*xe
c      call zfun(0,xe,cz,czp,zfn,zfc,xzz,nptzf,nptzfa,hzf,iout0)
      call zfun(xe, cz, czp)
      eps3r = 2.*wpe2*zxe2*(1. + xe*real(cz))
      eps3i = 2.*wpe2*zxe2*xe*aimag(cz)
      ceps3 = 2.*wpe2*zxe2*(1. + xe*cz)
      cwk = ceps3
      pkpar = clite/vp
      pkpar2 = pkpar*pkpar
      cwk = -clite*clite*wce*dxy/(sxy - pkpar2)/cwk
      cwk = cwk*(1. + del0)
      alphar = real(cwk)
      alphai = aimag(cwk)
      aeps32 = eps3r*eps3r + eps3i*eps3i
      vte = 0.0625*sqrt(tempe)
      delxp = 0.5*vte**2/wce
c     del1 = pkpar*delxp
      del1 = 0.
c     delm = wpe2*vte**2*xe*cz/wce2
      delm = 0.
      pk2ms = pkpar2 - sxy
      wrk5 = real(delm)
      wrk1 = real((1. - wrk5)/ceps3)
      wrk2 = real(1./ceps3)
      wrk3 = 1. + del0
      wrk4 = pkpar2*wrk3*wrk3 - pk2ms
      wrk6 = dxy*dxy - pk2ms*pk2ms + pkpar2*wrk3*wrk3*pk2ms
      a4 = wrk4*wrk1
      a2 = pk2ms*(1. + del1*del1*eps3r - wrk5) - 2.*pkpar*del1*wrk3*dxy
     1    + wrk6*wrk2
      a0 = pk2ms**2 - dxy**2
      a2k = -a2/2./a4
      discr = a2**2 - 4.*a4*a0
      if (discr > 0.) then
         disck2 = sqrt(discr)/2./a4
         wrk(2) = a2k + disck2
         wrk(3) = a2k - disck2
         if (abs(wrk(2)) < abs(wrk(3))) then
            wrk(4) = wrk(2)
            wrk(2) = wrk(3)
            wrk(3) = wrk(4)
         endif
         pkpr2 = wrk(3)
      else
         pkpr2 = a2k
      endif
      pkpr2 = amax1(0.0_dp,pkpr2)
      ck0 = 1. + wrk4*pkpr2/pk2ms*wrk2
      return 
      end subroutine diel1l
c
      subroutine disper(ientry)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:03:04   6/14/01  
C...Switches: -p4 -yb
c---------------------------------
c-------June 25,1991.
c---------------------------
c
c ************ ************ ************ ************ ************
c
c     dispersion relation, derivatives and absorption
c     for lower hybrid waves and fast waves
c  This is the standard version of disper
c  (option ichois=1 (forCLHW) is re-written)
c  Changes:  Multispecies; finite-beta for FW; electron damping;
c            collisional damping.
 
c
c ************ ************ ************ ************ ************
c---------------------------------TK'S changes
c---10/31/95   Latest major modification to include finite-beta terms
c               in fast wave dispersin relation, as discussed in M. Ono,
c               PPPL-3091 (1995).
c---06/02/00   Include fast ions (or alphas) as thermal species in
c               damping calculations (idmpsw=3, islofa=-1)
c---------------------------
c
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vsizes
      use Viorlh
      use Vcmnew
      use Vchpcsd
      use Vcraylh
      use Vceqdsk
      USE Vcfdamp, only: inf
      USE Vdissub
      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, dimension(4) :: kbd
      integer :: i, k, ij, j2, ncalc, nu, nl, i2, i3, i1, j1, n, idmpal
!      real, dimension(nions) :: zalfai, cwork, cwwk, cwwk2, cwwk1, deli
!     1   , da4ti, da2ti, da4ni, da2ni, da0ni
      real, dimension(100) :: besr, besi
      real, dimension(1001) :: funp
      real, dimension(100) :: zetai, zetat, wwork, zetaf
      real :: zpi, zdsqpi, zcalf, zhsi, adxyb, ddel0b, c1, zhs, zxpy2, 
     1   zalfae, zalfi, cwork2, pkp6, pkp4, cworkk, cworki, cwke4, cwke3
     2   , cwke1, cwke5, a4ne, a2ne, a0ne, zxh, zep, zes, zmod, thetz, 
     3   zemk, zkpol, xet, alme, epsyyi, epsyzr, almet, dumt, vthe, delu
     4   , ures, upx, alam, dfpar, th2, vthi, dii, zxi2, zexpxi, xif, 
     5   alconc, zxif2, zexpxf, rnue, coln, denomc, vte, pk2ms, wrk5, 
     6   wrk2, wrk3, wrk4, wrk6, aterm, bterm, cterm, dterm, dxez, 
     7   delmzr, ddel1z, wrk7, da4z, wrk8, da2z, da0z, ddel1b, delmbr, 
     8   da4b, da2b, da0b, dxete, delmter, da4te, da2te, ae32, epx2, 
     9   epz2, work2, xi0, yion, dumi, almit, xit0, apkp21, apkp22, epl0
     .   , epl1, eplus2, eminu2, exxic, exyrc, eyyic, eyzrc, ezzic, 
     1   pktot, xkt, xkl, pnp, pnpar, xk11, xk22, xk33, xk13, lwork,
     2   dfper, xf0, almf, yfion, dumf, acyc
      complex :: ddelmz, deps3z, ddelmb, ddelmte, deps3te, cepx0, cepy0
     1   , cepz0, cdd, css, csmnp2, xxtt, yytt, xytt, dd1, ss1, ssmnp21
      complex, dimension(nions) :: xxi1, yyi, xyr, xxti, yyti, xytr
      complex, dimension(nfion) :: xxif1, yyif, xyrf
      complex :: sy1, symnp21, wrk1, cfour, ctwo, czero, cdiscr, crtdcr
     1   , cpkp21, cpkp22, cwrk1, cpkp2c, cpkp1, ceps31, zwrk1, zwrk2, 
     2   zwrk3, zwrk4, zwrk6
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
C      integer , EXTERNAL :: min0
      real , EXTERNAL :: terp2, simp  !  , cabs
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 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
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 $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c   7/10 91
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
c     complex crot
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c  7/10/91   T.K. Mau
c  Complex and real array declaration for ICRF damping
c
c     complex gprm,cxet,czt,cztp,czetai,czi,czip,czetat,czti,
c    &        cztip,cth
c%%%%%%%%    10/31/95   TK Mau
c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
c-------------------SCC 12/10/96
c--------------------------------------------
c
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c
c ************ ************ ************ ************ ************
c
      data zpi/3.14159265359/
      data zdsqpi/1.772453851/
      data zcalf/3.198E-6/
c
c ************ ************ ************ ************ ************
c
c---------------------------------
c  7/2/91
c
c  bzero in teslas, freqcy in hertz, denc in 1/cm**3
c
c
      zhsi = btot/bzero
C******************************************** SCC 12/12/95
      wpe2 = wpe2c*dense
C***********************************************************
c---------
c  wpe2=fpe**2/f**2
c----------
C***************************************SCC  12/12/95
C     do 80 i=1,nspec
C80    conci(i)=aconc(i)*azi(i)
C**********************************************************
      apzz = 1. - wpe2
      wce2 = wce2c*zhsi*zhsi
      wce = sqrt(wce2)
      asxye = wpe2/wce2
      asxy = 1. + asxye
      asxy1 = asxy
      adxy1 = 0.
      adxy = 0.
      adxyb = 0.
      del0 = 0.
      ddel0b = 0.
C********************************************** SCC 12/12/95
      wpi2(:nspec) = densi(:nspec)*wpi2c(:nspec)
C****************************************************************
      wci(:nspec) = wci1c(:nspec)*zhsi
      wci2(:nspec) = wci2c(:nspec)*zhsi*zhsi
      vti(:nspec) = 1.459E-3*sqrt(tempi(:nspec)/atm(:nspec))
      if (nalfa > 0) then
         wpf2(:nalfa) = densa(:nalfa)*wpf2c(:nalfa)
         wcf(:nalfa) = wcf1c(:nalfa)*zhsi
         wcf2(:nalfa) = wcf2c(:nalfa)*zhsi*zhsi
      endif
      do i = 1, nspec
         c1 = 1. - wci2(i)
         if (abs(c1) <= 1.E-20) then
            cwwk(i) = wpi2(i)*1.E20*sign(1.0_dp,c1)
         else
            cwwk(i) = wpi2(i)/(1. - wci2(i))
         endif
      end do
      cwwk1(:nspec) = cwwk(:nspec)/wci(:nspec)
c----------------------------
c  nsp1=nspec-nminor
c----------------------------
      a4b = -asxye
      asxy1 = asxy1 - sum(cwwk(:nsp1))
      adxy1 = sum(cwwk1(:nsp1))
      a4b = a4b - sum(cwwk(:nsp1)*wci2(:nsp1)/(1.-wci2(:nsp1)))
      adxyb = sum(cwwk(:nsp1)/wci(:nsp1)*(3.*wci2(:nsp1)-1.)/(1.-wci2(:
     1   nsp1)))
      deli(:nsp1) = -cwwk(:nsp1)*vti(:nsp1)**2/(1. - wci2(:nsp1))
      del0 = sum(deli(:nsp1))
      ddel0b = -sum(4.*cwwk(:nsp1)*vti(:nsp1)**2*wci2(:nsp1)/(1.-wci2(:
     1   nsp1))**2)
      a4b = a4b*2.
      asxy = asxy1
      adxy = adxy1
      if (nminor > 0) then
c*******************************
c  july 9,1991
c--------------------------------
c**************************************
         asxy = asxy - sum(cwwk(nsp1+1:nminor+nsp1))
c$$$$$$ T.K. Mau  8/9/91
c       Define dispersion coefficients for ray initialization
         adxy = adxy + sum(cwwk(nsp1+1:nminor+nsp1)/wci(nsp1+1:nminor+
     1      nsp1))
      endif
c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
      xe = 15.984/(abs(pkpar)*sqrt(tempe))
c-------------------
c tempe in kev
c---------------------
      zxmin = abs(xe)
c-----------------------------
c  6/25/91
      if (ichois == 1) then
c
C**********************************SCC  12/12/95
c
         xp = xpc*dense
         zp = amime*xp
         zhs = bzero/btot
         y2 = y2c*zhs*zhs
         zxpy2 = xp*y2
c
         zalfae = zcalf*zxpy2*y2*tempe/4.
         zalfi = 0.
         do i = 1, nspec
            c1 = 1. - 4.*wci2(i)
            if (abs(c1) <= 1.E-20) then
               cwwk2(i) = 1.E20*sign(1.0_dp,c1)
            else
               cwwk2(i) = 1./c1
            endif
            zalfai(i) = xxi(i)*cwwk(i)*cwwk2(i)*xp*aconc(i)/wpi2(i)*
     1         tempi(i)*zcalf
            zalfi = zalfi + zalfai(i)
         end do
 
c
c ----------------------------------------------------------------
c  dispersion function
c
         alfa = zalfae + zalfi
         atwo = (asxy + apzz)*(pkpar2 - asxy) + adxy**2
         cwork2 = (asxy - pkpar2)**2 - adxy**2
         azero = apzz*cwork2
         cwork(1) = asxy - pkpar2
         cwork(2) = apzz + cwork(1)
         cwork(3) = alfa*cwork(2)
         cwork(4) = apzz*cwork(1)
         cwork(5) = alfa*cwork(4)
         ha = asxy + cwork(3)
         hb = (-atwo) + cwork(5)
         hc = azero
         disph = (((-alfa*pkp2) + ha)*pkp2 - hb)*pkp2 + hc
c
c-------------------
c  derivatives  of dispersion relation
c-------------------
         pkp6 = pkp2*pkp2*pkp2
         pkp4 = pkp2*pkp2
         dhkp2 = (-3.*alfa*pkp4) + 2.*ha*pkp2 - hb
         cworkk = pkp6 - pkp4*cwork(2) + pkp2*cwork(4)
         dhte = -zalfae*cworkk
         atwoz = 2.*(apzz + asxy)*pkpar
         azeroz = -4.*pkpar*apzz*(asxy - pkpar2)
         dhkz=atwoz*pkp2+azeroz+2.*pkpar*alfa*pkp2*((-pkp2)+apzz)
         a2b = a4b*(pkpar2 - 2.*asxy - apzz) + 2.*adxy*adxyb
         a0b = 2.*apzz*((asxy - pkpar2)*a4b - adxy*adxyb)
         cworki = 0.
         dhti(:nspec) = -zalfai(:nspec)*cworkk
         cworki = cworki + sum(2.*wci2(:nspec)*zalfai(:nspec)*(5.-8.*
     1      wci2(:nspec))*cwwk(:nspec)*cwwk2(:nspec)/wpi2(:nspec))
         dhom = (a4b*pkp2 + a2b)*pkp2 + a0b + 4.*zalfae*cworkk + alfa*
     1      pkp2*a4b*(pkp2 - apzz) - cworki*cworkk
c
         cwke4 = asxye
         cwke3 = asxy - pkpar2
         cwke1 = asxy + apzz
         cwke5 = wpe2 - cwke4
         a4ne = cwke4
         a2ne = cwke5*cwke3 - cwke1*cwke4
         a0ne = (-wpe2*cwork2) + apzz*2.*cwke3*cwke4
         dhne = (a4ne*pkp2 + a2ne)*pkp2 + a0ne - cworkk*zalfae - alfa*
     1      pkp2*(cwke5*pkp2 - wpe2*cwke3 + cwke4*apzz)
         dhni(:nspec) = cwwk(:nspec)*(pkp2*((-pkp2) + cwke3 + cwke1 + 2.
     1      *adxy/wci(:nspec))-2.*apzz*(cwke3+adxy/wci(:nspec)))
         dhni(:nspec) = dhni(:nspec) - zalfai(:nspec)*cworkk - alfa*cwwk
     1      (:nspec)*pkp2*(pkp2 - apzz)
c
         if (ientry == 0) return 
c
         poyntn = 1.
c
         gamma = 0.
         game = 0.
         zxh = 15.984*sqrt(amime)/pkp
         gami(:nspec) = 0.
         xi(:nspec) = zxh*sqrt(atm(:nspec)/tempi(:nspec))
c
c ***bh***    if(zxmin.gt.8.)  return
c
c ----------------------------------------------------------------
c  polarizations
c
         zep = apzz - pkp2
         zes = asxy - pkpar2 - pkp2
         epx = zep*zes
         epy = -adxy*zep
         epz = -pkp*pkpar*zes
         zmod = sqrt(epx*epx + epy*epy + epz*epz)
         epx = epx/zmod
         epy = epy/zmod
         epz = epz/zmod
c
c ********************************************************************
c  polarizations with SC Chiu's corrections:
c ********************************************************************
         cei = cmplx(0.,1.)
         zxe2 = xe*xe
c-----------------
c         call zfun(0,xe,cz,czp,zfn,zfc,xzz,nptzf,nptzfa,hzf,iout0)
         call zfun(xe, cz, czp)
         eps3r = 2.*wpe2*zxe2*(1. + xe*real(cz))
         eps3i = 2.*wpe2*zxe2*xe*aimag(cz)
c-----------------------
         ceps3 = 2.*wpe2*zxe2*(1. + xe*cz)
         aeps32 = eps3r*eps3r + eps3i*eps3i
         dd = adxy
         ss = ha - alfa*pkp2
         ssmnp2 = ss - pkpar2
         gprm = (1. + xe*cz)/(1. + cz*(xe - pkpar*vdrfte/trate))*trate
         cepy = 1. - pkp2*ss*(eps3r - cei*eps3i)/(ssmnp2*aeps32)
         cepz = -cei*pkpar*pkp*(dd*(eps3r - cei*eps3i)/(aeps32*ssmnp2)
     1       + 0.5*gprm/(wce*pkpar2*zxe2))
         cepx = cei/ssmnp2*(dd*cepy + cei*pkpar*pkp*cepz)
         emod = sqrt(abs(cepx)**2 + abs(cepy)**2 + abs(cepz)**2)
c----------------SCC  5/24/95
         thetz = atan2(aimag(cepz),real(cepz))
c----------------------
         crot = cos(thetz) - cei*sin(thetz)
         cepx = cepx*crot/emod
         cepy = cepy*crot/emod
         cepz = cepz*crot/emod
c
 
c
c ----------------------------------------------------------------
c  projection of poynting vector
c
         zemk = epx*pkp + epz*pkpar
         ztx = pkp*(1. + alfa*epx*epx) - zemk*epx
         ztz = pkpar - zemk*epz
c
         ztpsi = pkpsi/pkp*ztx
         zttau = ztx*pkheta/pkp*acostq + ztz*asintq
c
         zkpol = sqrt(pkpsi*pkpsi + pktau*pktau)
c**bh         poyntn = abs((pkpsi*pkpsi+pkheta*pktau*acostq)*ztx/pkp +
c**bh     +               pktau*asintq*ztz)/zkpol
c-------------------------SCC  6/27/95
c        poyntn = abs((pkpsi*pkpsi+pkheta*pktau*acostq)*ztx/pkp +
c    +               pktau*asintq*ztz)
         poyntn = (pkpsi*pkpsi + pkheta*pktau*acostq)*ztx/pkp + pktau*
     1      asintq*ztz
         if (indvar==0 .and. jslofa==1) poyntn = -poyntn
c
c ----------------------------------------------------------------
c  absorption coefficients
c  This version uses corrected polarizations cepx,y,z for game
c   SCC 6/27/95
c
c
c     if(abs(xe).gt.10.)  goto 30
c  Omit electron absorption at this point in the code, if
c  (inf.ne.-1 .and. xe.gt.1.) for the LH wave.
c     if(inf.ne.-1 .and. abs(xe).gt.1. .and. jslofa.eq.1)  go to 30
c       jpe = jpe+1
c        zxe2 = xe*xe
c        zexpxe = 2.*zdsqpi*zxe2*abs(xe)*exp(-zxe2)
c        game = zp*zexpxe*epz*epz
c
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c  7/10/91  Revised by T.K. Mau
c  absorption coefficients
c
c  Electron Landau and TTMP Damping
c
         if (abs(xe)<=10 .or. concte/=0.) then
            xet = xe/sqrt(ttle)
            if (abs(xet) <= 10.) then
               if (inf > (-2)) then
                  jpe = jpe + 1
                  if (inf < 0) then
c
c $$$ Electron damping for anisotropic, bi-Maxwellian distribution.
c
                     alme = 1.951E-3*pkp2/wce2*tempe*trate
                     epsyyi = 2.*wpe2*xe*alme*aimag(cz)*(1. - pkpar*
     1                  vdrfte/trate)*trate
                     epsyzr = wpe2/wce*trate*pkp/pkpar*aimag(cz)*(xe - 
     1                  pkpar*vdrfte/trate)
                     if (concte /= 0.) then
                        almet = alme*ttle*tratte/trate
c     cxet = cmplx(xet,0.)
c                        call zfun (0, xet, czt, cztp, zfn, zfc, xzz, 
c     1                     nptzf, nptzfa, hzf, iout0)
                        call zfun(xet, czt, cztp)
                        dumt = wpe2*concte*aimag(czt)
                        epsyyi = (1. - concte)*epsyyi + 2.*dumt*tratte*
     1                     almet*(1. - pkpar*vdrfte/tratte)
                        epsyzr = (1. - concte)*epsyzr + dumt/wce*tratte*
     1                     pkp/pkpar*(xet - pkpar*vdrfte/tratte)
                        eps3i = (1. - concte)*eps3i + 2.*dumt*xet**3
                     endif
                     game = epsyyi*abs(cepy)**2 + 2.*epsyzr*(real(cepy)
     1                  *aimag(cepz) - aimag(cepy)*real(cepz)) + eps3i*
     2                  abs(cepz)**2
c $$$$$  Crude inclusion of quasilinear flattening of distribution
c        After Bonoli, PFC/RR-84-5 (1984), Eq. (31)
c     game = game/(1.+1.414*xet**3)
c
                  else
c
c $$$ Electron damping for non-Maxwellian distribution
c
                     kbd = 4
                     call fnmax(0,npar,upar,nper,uper,tnmaxe,dsfe)
                     call coeff2 (npar, upar, nper, uper, dsfe, fpar2, 
     1                  fper2, fpp2, npar, kbd, wwork)
                     vthe = 0.06346*sqrt(tnmaxe)
                     delu = (uper(nper)-uper(1))/float(intg - 1)
                     ures = 1./(abs(pkpar)*vthe)
                     do j2 = 1, intg
                        upx = delu*float(j2 - 1)
                        alam = pkp*upx/wce
                        call beslci (alam, 0., 2, 0, besr, besi, ncalc)
                        cth=(-cei*cepy*upx*besr(2))+ures*cepz*besr(1)
                        dfpar = terp2(ures,upx,npar,upar,nper,uper,dsfe,
     1                     fpar2,fper2,fpp2,npar,1,0)
                        th2 = abs(cth)**2
                        funp(j2) = th2*pkpar*upx*vthi*dfpar
                     end do
                     game = -4.*sqrt(zpi)*wpe2/abs(pkpar)*simp(intg,delu
     1                  ,funp)
                  endif
               endif
            endif
         endif
         gamma = game
 
c     dii is the imag contribution to the dispersion relation due
c     to ion damping (Bonoli, IEEE Trans. of Pl. Sc., p. 95(1984)).
 
         dii = 0.0
         gamit = 0.
c
         do i = 1, nspec
            if (abs(xi(i)) <= 10.) then
               jpi = jpi + 1
               zxi2 = xi(i)*xi(i)
               zexpxi = 2.*zdsqpi*zxi2*abs(xi(i))*exp((-zxi2))
               dii = dii + zdsqpi*pkp2*azi(i)*azi(i)*aconc(i)/atm(i)*xp*
     1            (2.9979E10/9.79E5)**2/(1000.*tempi(i)/atm(i))*abs(xi(i
     2            ))*exp((-zxi2))
               gami(i) = xp*atpi(i)*aconc(i)*zexpxi*epx*epx
               gamit = gamit + gami(i)
            endif
            gamma = gamma + gami(i)
         end do
c
c $$$$$$$       TKM    04/00
c  Calculate alpha damping using straight orbit approximation
c
         if (atm(1)==2. .and. atm(2)==3.) then
            if (ioread == 0) then
               gamal(1,1) = 0.
               nharm0 = min(1,nharm0)
               xif = zxh*sqrt(atmf(1)/temsa(1))
               alconc = densa(1)/dense
               zxif2 = xif*xif
               if (abs(xif) <= 10.) then
                  zexpxf = 2.*zdsqpi*zxif2*abs(xif)*exp((-zxif2))
                  gamal(1,1) = xp*azf(1)*azf(1)/atmf(1)*alconc*zexpxf*
     1               epx*epx
                  gamat = gamal(1,1)
               endif
               gamma = gamma + gamat
            endif
         endif
c $$$$$$$$$$$$$$$$$$$$$$
c     Collisional damping:
c     1.47e-9 = (4/3)*sqrt(2*pi)*16*q**4/(sqrt(me)*(1.6e-9 erg/keV)**1.5)
C***********************************SCC  12/13/95
         rnue = 1.47E-9*dense*zeff/tempe**1.5
C*****************************************************
         alphac = abs(rnue/omega*(zxpy2*pkp2 + zp*pkpar2)*pkp2/(dhkp2*
     1      pkp*2.9979E10/omega))
         alphal = abs(dii/(dhkp2*pkp*2.9979E10/omega))
 
c
c ************ ************ ************ ************ ************
c
         return 
      endif
      rnue = 1.47E-9*dense*zeff/tempe**1.5
      coln = fcoll*rnue/omega
      denomc = 1. + coln*coln
      cei = cmplx(0.,1.)
      zxe2 = xe*xe
c      call zfun(0,xe,cz,czp,zfn,zfc,xzz,nptzf,nptzfa,hzf,iout0)
      call zfun(xe, cz, czp)
      eps3r = 2.*wpe2*zxe2*(1. + xe*real(cz))
      eps3i = 2.*wpe2*zxe2*xe*aimag(cz)
      ceps3 = 2.*wpe2*zxe2*(1. + xe*cz)
      aeps32 = eps3r*eps3r + eps3i*eps3i
      vte = 0.0625*sqrt(tempe)
      delxp = 0.5*vte**2/wce
      del1 = pkpar*delxp
      delm = asxye*vte**2*xe*cz
c        atwo=(asxy1+apzz)*(pkpar2-asxy1)+adxy1**2
c        cwork2=(asxy1-pkpar2)**2-adxy1**2
c        azero=apzz*cwork2
c        disph=(asxy1*pkp2+atwo)*pkp2+azero
      pk2ms = pkpar2 - asxy1
      wrk5 = real(delm)
      wrk1 = real((1. - wrk5)/ceps3)
      wrk2 = real(1./ceps3)
      wrk3 = 1. + del0
      wrk4 = pkpar2*wrk3*wrk3 - pk2ms
      wrk6 = adxy1*adxy1 - pk2ms*pk2ms + pkpar2*wrk3*wrk3*pk2ms
      afour = wrk4*wrk1
      atwo = pk2ms*(1. + del1*del1*eps3r - wrk5) - 2.*pkpar*del1*wrk3*
     1   adxy1 + wrk6*wrk2
      azero = pk2ms**2 - adxy1**2
      disph = (afour*pkp2 + atwo)*pkp2 + azero
c     ha = asxy1
      ha = afour
      hb = -atwo
      hc = azero
c---- TKM     9/98
c   Check accuracy of wave dispersion relation
      aterm = abs(afour*pkp2*pkp2)
      bterm = abs(atwo*pkp2)
      cterm = abs(azero)
      dterm = amax1(aterm,bterm,cterm)
      if (dterm <= 1.E-30) then
         dsperr = 0.
      else
         dsperr = disph/dterm
      endif
c-------------------
c  derivatives
c-------------------
c ----- w.r.t. pkp2
c        dhkp2=2.*asxy1*pkp2+atwo
      dhkp2 = 2.*afour*pkp2 + atwo
c        dhte=0.
c        do i=1,nspec
c          dhti(i)=0.
c        enddo
c        atwoz=2.*(apzz+asxy1)*pkpar
c        azeroz=-4.*pkpar*apzz*(asxy1-pkpar2)
c        dhkz=atwoz*pkp2+azeroz
c ----- w.r.t. pkpar
      dxez = -xe/pkpar
      ddelmz = asxye*vte**2*(cz + xe*czp)*dxez
      delmzr = real(ddelmz)
      ddel1z = delxp
      deps3z = 2.*wpe2*xe*(2. + 3.*xe*cz + xe*xe*czp)*dxez
      wrk7 = real(delmzr/ceps3 + (1. - wrk5)*deps3z/ceps3/ceps3)
      da4z = 2.*pkpar*(wrk3**2 - 1.)*wrk1 - wrk4*wrk7
      wrk8 = real(deps3z/ceps3/ceps3)
      da2z = 2.*pkpar*(1. - wrk5 + del1*del1*eps3r) + pk2ms*((-delmzr)
     1    + 2.*del1*delxp*eps3r + del1*del1*real(deps3z)) - 4.*del1*wrk3
     2   *adxy1 - 2.*pkpar*(2.*pk2ms - wrk3*wrk3*(pk2ms + pkpar2))*wrk2
     3    - wrk6*wrk8
      da0z = 4.*pkpar*pk2ms
      dhkz = (da4z*pkp2 + da2z)*pkp2 + da0z
c ----- w.r.t. B : B*d/dB
c     a2b = a4b*(pkpar2-2.*asxy1-apzz)+2.*adxy1*adxyb
c     a0b = 2.*apzz*((asxy1-pkpar2)*a4b-adxy1*adxyb)
c        dhom=(a4b*pkp2+a2b)*pkp2+a0b
c
      ddel1b = -del1
      ddelmb = -2.*delm
      delmbr = real(ddelmb)
      wrk7 = real(delmbr/ceps3)
      wrk8 = real((-ddelmb) + 2.*del1*ddel1b*eps3r)
      da4b = (a4b + 2.*pkpar2*wrk3*ddel0b)*wrk1 - wrk4*wrk7
      da2b = (-a4b*(1. - wrk5 + del1*del1*eps3r)) + pk2ms*wrk8 - 2.*
     1   pkpar*ddel1b*wrk3*adxy1 - 2.*del1*pkpar*ddel0b*adxy1 - 2.*pkpar
     2   *del1*wrk3*adxyb + (2.*adxyb*adxy1 + 2.*pk2ms*a4b - pkpar2*wrk3
     3   *wrk3*a4b + 2.*pkpar2*wrk3*pk2ms*ddel0b)*wrk2
      da0b = -2.*(pk2ms*a4b + adxyb*adxy1)
      dhom = (da4b*pkp2 + da2b)*pkp2 + da0b
c$$$$$   TK Mau    02/00
c  Modified to cold electron approximation - for NSTX runs
c ----- w.r.t. Ti  :  Ti*d/dTi
      dhti(:nspec) = 0.
c     go to 501
      da4ti(:nspec) = (pkpar2*wrk3)*(2.*deli(:nspec))*wrk1
      da2ti(:nspec) = (2.*deli(:nspec))*((pkpar2*wrk3)*pk2ms - del1*
     1   pkpar*adxy1)*wrk2
      dhti(:nspec) = (da4ti(:nspec)*pkp2+da2ti(:nspec))*pkp2
c ----- w.r.t. Te  :  Te*d/dTe
      dhte = 0.
      dxete = -0.5*xe
      ddelmte = ddelmz*dxete/dxez + delm
      delmter = real(ddelmte)
      deps3te = deps3z*dxete/dxez
      wrk7 = real(delmter/ceps3 + (1. - wrk5)*deps3te/ceps3/ceps3)
      da4te = -wrk7*wrk4
      wrk8 = real((-ddelmte) + 2.*del1*del1*ceps3 + del1*del1*deps3te)
      da2te = pk2ms*wrk8 - 2.*pkpar*del1*adxy1*wrk3 - wrk6*real(deps3te/
     1   ceps3/ceps3)
      dhte = (da4te*pkp2 + da2te)*pkp2
c501  dhte = 0.
c$$$$$    02/00
c ----- w.r.t. density  :  n*d/dn
c        cwke3=asxy1-pkpar2
c        cwke1=asxy1+apzz
c        cwke5=wpe2-asxye
      a4ne = asxye*wrk1 - wrk2*wrk4
      a2ne = pk2ms*(del1*del1*eps3r - wrk5) - asxye*(1. - wrk5 + del1*
     1   del1*eps3r) + (2.*pk2ms - pkpar2*wrk3*wrk3)*asxye*wrk2 - wrk2*
     2   wrk6
      a0ne = -2.*asxye*pk2ms
      dhne = (a4ne*pkp2 + a2ne)*pkp2 + a0ne
      da4ni(:nsp1) = ((-cwwk(:nsp1))+(((2.*pkpar2)*wrk3)*deli(:nsp1)))*
     1   wrk1
      da2ni(:nsp1) = cwwk(:nsp1)*(1. - wrk5 + del1*del1*eps3r) - 2.*
     1   pkpar*del1*(wrk3*cwwk(:nsp1)/wci(:nsp1)+deli(:nsp1)*adxy1) + ((
     2   2.*cwwk(:nsp1))*adxy1/wci(:nsp1)-(2.*cwwk(:nsp1))*pk2ms+(((2.*
     3   pkpar2)*wrk3)*deli(:nsp1))*pk2ms-pkpar2*wrk3*wrk3*deli(:nsp1))*
     4   wrk2
      da0ni(:nsp1) = 2.*(cwwk(:nsp1)*pk2ms-cwwk(:nsp1)*adxy1/wci(:nsp1))
      dhni(:nsp1) = (da4ni(:nsp1)*pkp2+da2ni(:nsp1))*pkp2 + da0ni(:nsp1)
      dhni(nsp1+1:nspec) = 0.
c
      if (ientry == 0) return 
c
      poyntn = 1.
c
      gamma = 0.
      game = 0.
c
c ********************************************************************
c  polarizations with SC Chiu's corrections:
c ********************************************************************
      dd = adxy
      ss = asxy
      cdd = dd + cei*2.*wpe2*coln/wce/wce2
      css = ss + cei*wpe2*coln/wce2
      coln = coln/denomc
      delm = delm + asxye*vte**2*cei*coln*0.5
      eps3i = eps3i + wpe2*coln
      ae32 = eps3r*eps3r + eps3i*eps3i
      ssmnp2 = ss - pkpar2
      csmnp2 = css - pkpar2
      cepy0=1.-pkp2*(ssmnp2+pkpar2*wrk3*wrk3)*eps3r/(ssmnp2*aeps32)
      cepz0 = -cei*pkpar*pkp*(dd*eps3r*wrk3/(aeps32*ssmnp2) + 0.5*gprm/(
     1   wce*pkpar2*zxe2))
      cepx0 = cei/ssmnp2*(dd*cepy0 + cei*pkpar*pkp*wrk3*cepz0)
      emod = sqrt(abs(cepx0)**2 + abs(cepy0)**2 + abs(cepz0)**2)
      thetz = atan2(aimag(cepz0),real(cepz0))
      crot = cos(thetz) - cei*sin(thetz)
      cepx0 = cepx0*crot/emod
      cepy0 = cepy0*crot/emod
      cepz0 = cepz0*crot/emod
 
c
c-------------------SCC   6/27/95
c  for Poynting flux, we need to use cold dispersion for polarization
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c  7/10/91   Revised by T.K. Mau
c  projection of poynting vector
c
      zemk = epx*pkp + epz*pkpar
      epx2 = abs(cepx0)**2
      epz2 = abs(cepz0)**2
      work2 = real(cepx0)*real(cepz0) + aimag(cepx0)*aimag(cepz0)
      ztx = pkp*(1. - epx2) - pkpar*work2
      ztz = pkpar*(1. - epz2) - pkp*work2
c
      ztpsi = pkpsi/pkp*ztx
      zttau = ztx*pkheta/pkp*acostq + ztz*asintq
 
      poyntn = abs((pkpsi*pkpsi + pkheta*pktau*acostq)*ztx/pkp + pktau*
     1   asintq*ztz)
c
c       zep=apzz-pkp2
c       zes=asxy1-pkpar2-pkp2
c       epx=zep*zes
c       epy=-adxy1*zep
c       epz=-pkp*pkpar*zes
c       zmod=sqrt(epx*epx+epy*epy+epz*epz)
c       epx=epx/zmod
c       epy=epy/zmod
c       epz=epz/zmod
c
c       zemk = epx*pkp + epz*pkpar
c       ztx=pkp-zemk*epx
c       ztz=pkpar-zemk*epz
c
c        ztpsi = pkpsi/pkp*ztx
c        zttau = ztx*pkheta/pkp*acostq +ztz*asintq
c
c        zkpol = sqrt(pkpsi*pkpsi+pktau*pktau)
c        poyntn = (pkpsi*pkpsi+pkheta*pktau*acostq)*ztx/pkp +
c    +               pktau*asintq*ztz
c
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c
c$$$$ Evaluate complex Kij terms due to thermal ions, and modified
c     Nper to include correction terms in field polarization factors
c
c     if(idmpsw.ge.0) then
      if (idmpsw>=0 .and. idmpsw/=2) then
         xxtt = 0.
         yytt = 0.
         xytt = 0.
c $$$$    TK Mau   6/98
         gamip(:nspec) = 0.
         gamir(:nspec) = 0.
c $$$$
         do k = 1, nspec
            xi0 = 684.91*sqrt(atm(k)/tempi(k))/abs(pkpar)
            almi = 1.0626E-6*pkp2/wci2(k)*tempi(k)*trati(k)/atm(k)
            yion = 1./wci(k)
            nu = yion + inc
            nl = yion - inc
            if (nl <= 0) nl = 1
            if (nu <= 0) nu = 1
            call ibesin (nu + 2, besr, almi)
            xxi1(k) = 0.
            yyi(k) = 0.
            xyr(k) = 0.
            do i2 = nl, nu
               zetai(i2) = xi0*(1. - i2*wci(k))
c               call zfun (0, zetai(i2), czi, czip, zfn, zfc, xzz, nptzf
c     1            , nptzfa, hzf, iout0)
               call zfun( zetai(i2), czi, czip)
               besi(i2) = (1. + i2/almi)*besr(i2+1) - besr(i2)
               dumi = wpi2(k)*xi0*trati(k)*(1. - i2*wci(k)+(i2*wci(k)-
     1            pkpar*vdrfti(k))/trati(k))
               if (almi <= 1.) dumi = exp((-almi))*dumi
               xxi1(k) = xxi1(k) + i2*i2*besr(i2+1)*czi*dumi/almi
               yyi(k) = yyi(k) + 2.*besi(i2)*czi*almi*dumi
               xyr(k) = xyr(k) + i2*besi(i2)*czi*dumi
               if (i2 == 1) then
                  c1 = 1. - wci(k)
                  if (abs(c1) <= 1.E-10) then
                     wwork(k) = 2.*cwwk(k)
                  else
                     wwork(k) = wpi2(k)/c1
                  endif
                  xxi1(k) = xxi1(k) + 0.5*wwork(k)
                  xyr(k) = xyr(k) - 0.5*wwork(k)
               endif
c $$$$    TK Mau    6/98
               gamip(k) = gamip(k) + 0.5*zdsqpi*dumi*exp((-zetai(i2)**2)
     1            )*(i2*besr(i2)+almi*(besr(i2+1)-besr(i2)))
c $$$$
            end do
            yyi(k) = xxi1(k) + yyi(k)
            if (concti(k) /= 0.) then
               almit = almi*ttli(k)*tratti(k)/trati(k)
               call ibesin (nu + 2, besr, almit)
               xxti(k) = 0.
               yyti(k) = 0.
               xytr(k) = 0.
               xit0 = xi0/sqrt(ttli(k))
               do i3 = nl, nu
                  zetat(i3) = xit0*(1. - i3*wci(k))
c                  call zfun (0, zetat(i3), czti, cztip, zfn, zfc, xzz, 
c     1               nptzf, nptzfa, hzf, iout0)
                  call zfun(zetat(i3), czti, cztip)
                  besi(i3) = (1. + i3/almit)*besr(i3+1) - besr(i3)
                  dumt = wpi2(k)*xit0*tratti(k)*(1. - i3*wci(k)+(i3*wci(
     1               k)-pkpar*vdrfti(k))/tratti(k))
                  if (almit <= 1.) dumt = exp((-almit))*dumt
                  xxti(k) = xxti(k) + i3*i3*besr(i3+1)*czti*dumt/almi
                  yyti(k) = yyti(k) + 2.*dumt*almi*besi(i3)*czti
                  xytr(k) = xytr(k) + i3*besi(i3)*czti*dumt
                  if (i3 == 1) then
                     c1 = 1. - wci(k)
                     if (abs(c1) <= 1.E-10) then
                        wwork(k) = 2.*cwwk(k)
                     else
                        wwork(k) = wpi2(k)/c1
                     endif
                     xxti(k) = xxti(k) + 0.5*wwork(k)
                     xytr(k) = xytr(k) - 0.5*wwork(k)
                  endif
               end do
               yyti(k) = xxti(k) + yyti(k)
               xxi1(k) = (1. - concti(k))*xxi1(k) + concti(k)*xxti(k)
               yyi(k) = (1. - concti(k))*yyi(k) + concti(k)*yyti(k)
               xyr(k) = (1. - concti(k))*xyr(k) + concti(k)*xytr(k)
            endif
            xxtt = xxtt + xxi1(k)
            yytt = yytt + yyi(k)
            xytt = xytt + xyr(k)
         end do
         ss1 = css + xxtt
         sy1 = css + yytt
         dd1 = cdd + xytt
         ssmnp21 = css - pkpar2 + xxtt
         symnp21 = css - pkpar2 + yytt
c------------------------------
c
c  calculate modified kperp for damping and polarization
c    SCC   10/8/96
c
c-------------------------------------
         ceps31 = ceps3 + cei*wpe2*coln
         zwrk1 = (1. - delm)/ceps31
         zwrk2 = 1./ceps31
         zwrk3 = 1. + del0
         zwrk4 = pkpar2*zwrk3*zwrk3 + ssmnp21
         zwrk6 = dd1*dd1 - ssmnp21*symnp21 - pkpar2*zwrk3*zwrk3*symnp21
         cfour = zwrk4*zwrk1
         ctwo = (-ssmnp21*(del1*del1*ceps31 + 1. - delm)) - 2.*pkpar*
     1      del1*zwrk3*dd1 + zwrk6*zwrk2
         czero = ssmnp21*symnp21 - dd1**2
         cdiscr = ctwo*ctwo - 4.*cfour*czero
         crtdcr = csqrt(cdiscr)
         cpkp21 = ((-ctwo) + crtdcr)/2./cfour
         cpkp22 = ((-ctwo) - crtdcr)/2./cfour
         apkp21 = abs(cpkp21)
         apkp22 = abs(cpkp22)
         if (apkp21 > apkp22) then
            cwrk1 = cpkp21
            cpkp21 = cpkp22
            cpkp22 = cwrk1
         endif
c$$$$$$$$$$   TKM    11/98
c    Fix jslofa to islofa, i.e., no mode conversion is allowed.
c    Temporary fix due to 'bug' in mode conversion scheme
c    Needs to be fixed.
         if (islofa == (-1)) jslofa = islofa
c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
         if (jslofa == (-1)) then
            cpkp2c = cpkp21
         else
            cpkp2c = cpkp22
         endif
         cpkp1 = csqrt(cpkp2c)
      else
         cpkp2c = pkp2
         cpkp1 = pkp
      endif
c--------------------------------------
      gprm = (1. + xe*cz)/(1. + cz*(xe - pkpar*vdrfte/trate))*trate
      cepy = 1. - cpkp2c*(ssmnp21 + pkpar2*wrk3*wrk3)*(eps3r - cei*eps3i
     1   )/(ssmnp21*ae32)
      cepz = -cei*pkpar*cpkp1*(dd1*(eps3r - cei*eps3i)*wrk3/(ae32*
     1   ssmnp21) + 0.5*gprm/(wce*pkpar2*zxe2))
c    1     /(ae32*ssmnp21))
      cepx = cei/ssmnp21*(dd1*cepy + cei*pkpar*cpkp1*wrk3*cepz)
      emod = sqrt(abs(cepx)**2 + abs(cepy)**2 + abs(cepz)**2)
      thetz = atan2(aimag(cepz),real(cepz))
      crot = cos(thetz) - cei*sin(thetz)
      cepx = cepx*crot/emod
      cepy = cepy*crot/emod
      cepz = cepz*crot/emod
c-----------------------------------------
c ****   TKM   8/98
c Calculate left- and right-hand circularly polarized components
c   and their ratio
      epl0 = abs(cepx)**2 + abs(cepy)**2
      epl1 = 2.*(aimag(cepx)*real(cepy) - real(cepx)*aimag(cepy))
      eplus2 = epl0 + epl1
      eminu2 = epl0 - epl1
      eprat = eplus2/eminu2
c ************
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c  7/10/91  Revised by T.K. Mau
c  absorption coefficients
c
c  Electron Landau and TTMP Damping
c
      gamce = 0.
      if (abs(xe)<=10 .or. concte/=0.) then
         xet = xe/sqrt(ttle)
         if (abs(xet) <= 10.) then
            if (inf > (-2)) then
               jpe = jpe + 1
               if (inf < 0) then
c
c $$$ Electron damping for anisotropic, bi-Maxwellian distribution.
c
                  alme = 1.951E-3*pkp2/wce2*tempe*trate
                  epsyyi = 2.*wpe2*xe*alme*aimag(cz)*(1. - pkpar*vdrfte/
     1               trate)*trate
                  epsyzr = wpe2/wce*trate*pkp/pkpar*aimag(cz)*(xe - 
     1               pkpar*vdrfte/trate)
                  if (concte /= 0.) then
                     almet = alme*ttle*tratte/trate
c     cxet = cmplx(xet,0.)
c                    call zfun (0, xet, czt, cztp, zfn, zfc, xzz, nptzf
c    1                  , nptzfa, hzf, iout0)
                     call zfun(xet, czt, cztp)
                     dumt = wpe2*concte*aimag(czt)
                     epsyyi = (1. - concte)*epsyyi + 2.*dumt*tratte*
     1                  almet*(1. - pkpar*vdrfte/tratte)
                     epsyzr = (1. - concte)*epsyzr + dumt/wce*tratte*pkp
     1                  /pkpar*(xet - pkpar*vdrfte/tratte)
                     eps3i = (1. - concte)*eps3i + 2.*dumt*xet**3
                  endif
                  game = epsyyi*abs(cepy)**2 + 2.*epsyzr*(real(cepy)*
     1               aimag(cepz) - aimag(cepy)*real(cepz)) + eps3i*abs(
     2               cepz)**2
c----------------
c  pkp2 and pkp used here; probably not very consistent. But error
c   should be small
c---------------
c-------------------
c  collisional damping
c-------------------
                  exxic = aimag(css)
                  exyrc = aimag(cdd)
                  eyyic = wpe2*alme*coln + exxic
                  eyzrc = 0.5*wpe2*pkp/wce/pkpar*coln/xe/xe
                  ezzic = wpe2*coln
                  gamce = exxic*abs(cepx)**2 + eyyic*abs(cepy)**2 + 
     1               ezzic*abs(cepz)**2 + 2.*eyzrc*(real(cepy)*aimag(
     2               cepz) - aimag(cepy)*real(cepz)) + 2.*exyrc*(real(
     3               cepx)*aimag(cepy) - aimag(cepx)*real(cepy))
               else
c
c $$$ Electron damping for non-Maxwellian distribution
c
                  kbd = 4
                  call fnmax (0, npar, upar, nper, uper, tnmaxe, dsfe)
                  call coeff2 (npar, upar, nper, uper, dsfe, fpar2, 
     1               fper2, fpp2, npar, kbd, wwork)
                  vthe = 0.06346*sqrt(tnmaxe)
                  delu = (uper(nper)-uper(1))/float(intg - 1)
                  ures = 1./(abs(pkpar)*vthe)
                  do j2 = 1, intg
                     upx = delu*float(j2 - 1)
                     alam = pkp*upx/wce
                     call beslci (alam, 0., 2, 0, besr, besi, ncalc)
                     cth = (-cei*cepy*upx*besr(2)) + ures*cepz*besr(1)
                     dfpar = terp2(ures,upx,npar,upar,nper,uper,dsfe,
     1                  fpar2,fper2,fpp2,npar,1,0)
                     th2 = abs(cth)**2
                     funp(j2) = th2*pkpar*upx*vthi*dfpar
                  end do
                  game = -4.*sqrt(zpi)*wpe2/abs(pkpar)*simp(intg,delu,
     1               funp)
               endif
            endif
         endif
      endif
      gamma = game + gamce
c
c$$$$  Harmonic ion cyclotron damping
c
      gamit = 0.
      gami(:nspec) = 0.
      if (idmpsw /= 0) then
         do k = 1, nspec
            jpi = jpi + 1
            if (infi(k) <= 0) then
               if (idmpsw /= 2) then
                  gami(k) = aimag(xxi1(k))*abs(cepx)**2 + 2.*aimag(xyr(
     1               k))*(real(cepx)*aimag(cepy) - aimag(cepx)*real(cepy
     2               )) + aimag(yyi(k))*abs(cepy)**2
c $$$$     TK Mau    8/98
                  gamip(k) = gamip(k)*eplus2
                  gamir(k) = 0.5*eminu2*(0.5*(aimag(xxi1(k))+aimag(yyi(k
     1               )))+aimag(xyr(k))) - 0.5*(aimag(yyi(k))-aimag(xxi1(
     2               k)))*(abs(cepx)**2 - abs(cepy)**2)
c $$$$
c $$$$    TK Mau    7/95
               else
                  pktot = sqrt(pkp2 + pkpar2)
                  xi0 = 684.91*sqrt(atm(k)/tempi(k))/pktot
                  if (xi0 >= 10.) then
                     xkt = 0.
                  else
                     xkt = 2.*zdsqpi*wpi2(k)*xi0*exp((-xi0**2))
                  endif
                  xkl = xi0**2*xkt
                  pnp = pkp/pktot
                  pnpar = pkpar/pktot
                  xk11 = xkl*pnp**2 + xkt*pnpar**2
                  xk22 = xkt
                  xk33 = xkl*pnpar**2 + xkt*pnp**2
                  xk13 = pnp*pnpar*(xkl - xkt)
                  gami(k) = abs(cepx)**2*xk11 + abs(cepy)**2*xk22 + 
     1               abs(cepz)**2*xk33 + 2.*(real(cepx)*real(cepz) - 
     2               aimag(cepx)*aimag(cepz))*xk13
               endif
c $$$$$$$$$$$$$$$$$$$$$
            else
c $$$ Harmonic ion cyclotron damping for a given non-Maxwellian distribution
c     function, which is in a 2D array with respect to uperp and upar,
c     normalized to a characteristic thermal speed with a given temperature.
c
               kbd = 4
               call fnmax (1, npar, upar, nper, uper, tnmaxi, dsfi)
               call coeff2 (npar, upar, nper, uper, dsfi, fpar2, fper2, 
     1            fpp2, npar, kbd, lwork)
               vthi = 1.0327E-3*sqrt(tnmaxi/atm(k))
               delu = (uper(nper)-uper(1))/float(intg - 1)
               acyc = 1./wci(k)
               nu = acyc + inc
               nl = acyc - inc
               if (nl <= 0) nl = 1
               if (nu <= 0) nu = 1
               do i1 = nl, nu
                  ures = (1. - float(i1)*wci(k))/(abs(pkpar)*vthi)
                  do j1 = 1, intg
                     upx = delu*float(j1 - 1)
                     alam = pkp*upx/wci(k)
                     call beslci(alam,0.,i1+1,0,besr,besi,ncalc)
                     cth = cepx*upx*(besr(i1)+besr(i1+2)) + cei*cepx*upx
     1                  *(besr(i1)-besr(i1+2)) + 2.*ures*cepz*besr(i1+1)
                     dfper = terp2(ures,upx,npar,upar,nper,uper,dsfi,
     1                  fpar2,fper2,fpp2,npar,0,1)
                     dfpar = terp2(ures,upx,npar,upar,nper,uper,dsfi,
     1                  fpar2,fper2,fpp2,npar,1,0)
                     th2 = abs(cth)**2
                     funp(j1) = th2*(float(i1)*wci(k)*dfper+pkpar*upx*
     1                  vthi*dfpar)
                  end do
                  gami(k) = gami(k) - sqrt(zpi)*wpi2(k)/pkpar*simp(intg,
     1               delu,funp)
               end do
            endif
            gamma = gamma + gami(k)
            gamit = gamit + gami(k)
         end do
c  $$$$$$
c  $$$$  TK Mau    7/95, 01/00
         if (kalfa > 0) then
            gamal(:nalfa,:nharm0) = 0.
c********    TKM   06/97
c     if(kalfa.ne.0.and.idmpsw.gt.1) then
            if (idmpsw == 2) then
               idmpal = 2
               if (psi < ppsi(nprof-2)) call alfadamp (idmpal)
            else
               if (idmpsw == 1) then
                  call alfadamp (1)              ! To be corrected.
               else
                  nharm0 = 1
                  do k = 1, nalfa
                     xf0 = 684.91*sqrt(atmf(k)/temsa(k))/abs(pkpar)
                     almf = 1.0626E-6*pkp2/wcf2(k)*temsa(k)/atmf(k)
                     yfion = 1./wcf(k)
                     nu = yfion + inc
                     nl = yfion - inc
                     if (nl <= 0) nl = 1
                     if (nu <= 0) nu = 1
                     call ibesin (nu + 2, besr, almf)
                     xxif1(k) = 0.
                     yyif(k) = 0.
                     xyrf(k) = 0.
                     do i2 = nl, nu
                        zetaf(i2) = xf0*(1. - i2*wcf(k))
c                        call zfun (0, zetaf(i2), czi, czip, zfn, zfc, 
c     1                     xzz, nptzf, nptzfa, hzf, iout0)
                        call zfun(zetaf(i2), czi, czip)
                        besi(i2) = (1. + i2/almf)*besr(i2+1) - besr(i2)
                        dumf = wpf2(k)*xf0
                        if (almf <= 1.) dumf = exp((-almf))*dumf
                        xxif1(k) = xxif1(k) + i2*i2*besr(i2+1)*czi*dumf/
     1                     almf
                        yyif(k) = yyif(k) + 2.*besi(i2)*czi*almf*dumf
                        xyrf(k) = xyrf(k) + i2*besi(i2)*czi*dumf
                        if (i2 == 1) then
                           c1 = 1. - wcf(k)
                           if (abs(c1) <= 1.E-10) then
                              wwork(k) = 2.*cwwk(k)
                           else
                              wwork(k) = wpi2(k)/c1
                           endif
                           xxif1(k) = xxif1(k) + 0.5*wwork(k)
                           xyrf(k) = xyrf(k) - 0.5*wwork(k)
                        endif
                     end do
                     yyif(k) = xxif1(k) + yyif(k)
                     gamal(k,1) = aimag(xxif1(k))*abs(cepx)**2 + 2.*
     1                  aimag(xyrf(k))*(real(cepx)*aimag(cepy) - aimag(
     2                  cepx)*real(cepy)) + aimag(yyif(k))*abs(cepy)**2
                  end do
               endif
            endif
            gamat = 0.
            do k = 1, nalfa
               gamma = gamma + sum(gamal(k,:nharm0))
               gamat = gamat + sum(gamal(k,:nharm0))
            end do
         endif
      endif
c  $$$$$$
 
c     Collisional damping:
c
c $$$$$$$$$$$$$$$$$$$$$$$
c   7/16/91   T.K. Mau
c
c     1.47e-9 = (4/3)*sqrt(2*pi)*16*q**4/(sqrt(me)*(1.6e-9 erg/keV)**1.5)
C******************************************* SCC  12/13/95
c  70 rnue = 1.47e-9*dense*zeff/tempe**1.5
C************************************************************
c     rnue2=rnue*rnue
c     eps3ci=wpe2*rnue/(1.+rnue2)
c     gamce = eps3ci*abs(cepz)**2
c     xxci = 0.
c     xyci = 0.
c     do 61 kc = 1,nspec
c     denom = (1.-rnue2-wci2(kc))**2+4.*rnue2
c     xxci = xxci+wpi2(kc)*rnue*(1.+rnue2+wci2(kc))/denom
c     xyci = xyci -2.*wpi2(kc)*wci(kc)*rnue/denom
c  61 continue
c     gamci = xxci*(abs(cepx)**2+abs(cepy)**2)-2.*xyci*
c    &        (real(cepy)*aimag(cepx)-real(cepx)*aimag(cepy))
c
c $$$$$$$$$$$$$$$$$$$$$
 
      return 
      end subroutine disper
      subroutine grill
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:03:04   6/14/01  
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vsizes
      use Viorlh
      use Vcmnew
      use Vchpcsd
      use Vcraylh
      use Vceqdsk
      implicit none
C-----------------------------------------------
c
c  dummy routine for the case in which the raylh code
c     is used alone.
c
c  to use it in conjunction with the grill code, include here instead
c     all the segments of the grill code except the main
c
      return 
      end subroutine grill
 
      subroutine scatperp
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:03:04   6/14/01  
C...Switches: -p4 -yb
c
c  Scatters perp wavenumber by an angel given by a normal random
c  number generator with standard deviation sqrt(2.*scatd)
c
c ************ ************ ************ ************ ************
c
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vsizes
      use Viorlh
      use Vcmnew
      use Vchpcsd
      use Vcraylh
      use Vceqdsk
      use Viogrl
      use Vcgraphs
      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
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-----------------------------------------------
      real :: pkpsi1, pkheta1, pktau1, pkphi1, akpsi1, akth1, anphi1
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
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 blocks of Comiogrl
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
c
c
c   Comhpcsd
c
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----------------------------
c   common blocks of Cmgraphs
c
 
c    2   ,sqti(nprofm)
c
      real anum
      call random_number(anum)
      alpha1 = atan2(pkheta,pkpsi)
      alpha2 = alpha1 + sqrt(2.*scatd)*anum
c   Recalculate physical wavenumber components
      pkpsi1 = pkp*cos(alpha2)
      pkheta1 = pkp*sin(alpha2)
      pktau1 = pkpar*asintq + pkheta1*acostq
      pkphi1 = pkpar*acostq - pkheta1*asintq
c   Recalculate covariant wavevector components:
      akpsi1 = (aj*pkpsi1 + ag*pktau1)/antau
      akth1 = antau*pktau1
      anphi1 = urhs*pkphi1
c
c     Skip reset of wave-vector according to conditions:
      if (pkpsi*pkpsi1>0. .or. psi<=1.) then
         if (akpsi*akpsi1>0. .or. psi<=1.) then
            pkpsi = pkpsi1
            pkheta = pkheta1
            pktau = pktau1
            pkphi = pkphi1
            akpsi = akpsi1
            akth = akth1
            anphi = anphi1
         endif
      endif
      return 
      end subroutine scatperp
      subroutine scovte(q)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:03:04   6/14/01  
C...Switches: -p4 -yb
c ************ ************ ************ ************ ************
c  n parallel versus radius giving omega/(kpar*vthe) = q
c  with the electron temperature profiles of raylh & raylh0
c ************ ************ ************ ************ ************
c
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vsizes
      use Viorlh
      use Vcmnew
      use Vchpcsd
      use Vcraylh
      use Vceqdsk
      use Viogrl
      use Vcgraphs
      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-----------------------------------------------
      real q
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 :: n
      real :: c, covte
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 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
c
c----------------------------
c   common blocks of Cmgraphs
c
 
c    2   ,sqti(nprofm)
c
c ************ ************ ************ ************ ************
c
      data c/15.985/
c
      sqte(:nprof) = c/sqrt(pte(:nprof))/q
c
      return 
      end subroutine scovte
      subroutine subkmc(pkp21, pkp22, pkp23, ind2, kslofa, jchois, kmcon
     1   , pkp20, iermc, disck2, a2k, nslofa, imode)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:03:04   6/14/01  
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vsizes
      use Viorlh
      use Vcmnew
      use Vchpcsd
      use Vcraylh
      use Vceqdsk
      use Viogrl
      use Vcgraphs
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer ind2, kslofa, jchois, kmcon, iermc, nslofa, imode
      real pkp21, pkp22, pkp23, pkp20, disck2, a2k
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      real, dimension(3) :: wrk
      real :: dk2tst
C-----------------------------------------------
c
c  check if close to mode conversion, if so, kmcon=1
c  check if close to evanescence, if so, kmcon=-1
c  otherwise, kmcon=0
c---------------------------
c------------------
      iermc = 0
      dk2tst = amin1(abs(disck2),abs(disck2/a2k))
      if (pkp20<0.1 .or. pkp2<0.1) then
         kmcon = -1
         return 
      endif
      if (abs(disck2)<0.1 .and. abs(a2k)<0.1) then
         kmcon = -1
         return 
      endif
      select case (jchois) 
      case default
         if (iermc == 0) then
            if (dk2tst<=5.E-2 .or. abs((pkp22-pkp23)/pkp22)<=5.E-2) then
               kmcon = 1
               ind2 = 0
               if (kslofa == 1) then
                  pkp20 = pkp23
                  imode = 3
               else
                  pkp20 = pkp22
                  imode = 2
               endif
               nslofa = -kslofa
            else
               kmcon = 0
            endif
         endif
         return 
c-------------
      case (1) 
         wrk(1) = pkp21
         wrk(2) = pkp22
         wrk(3) = pkp23
         if (iermc == 0) then
            if (dk2tst<=5.E-2 .or. abs((pkp22-pkp23)/pkp22)<=5.E-2
     1          .and. imode/=1) then
               kmcon = 1
               if (kslofa == (-1)) then
                  pkp20 = wrk(2)
                  nslofa = -kslofa
                  imode = 2
               else if (kslofa == 2) then
                  pkp20 = wrk(3)
                  nslofa = 1
                  imode = 3
               else if (ind2 == 0) then
                  pkp20 = wrk(3)
                  nslofa = -1
                  imode = 3
               else if (ind2 == 1) then
                  pkp20 = wrk(2)
                  nslofa = 2
                  imode = 2
               endif
            else
               kmcon = 0
            endif
         endif
         return 
      end select
      end subroutine subkmc
 
      function svfuse (tiloc, irate)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:03:04   6/14/01  
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vsizes
      use Viorlh
      use Vcmnew
      use Vchpcsd
      use Vcraylh
      use Vceqdsk
      use Viogrl
      use Vcgraphs
      USE Verrsvf
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real svfuse
      integer irate
      real tiloc
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: ipt, ix
      real, dimension(96,6) :: sv
      real, dimension(96) :: sv1, sv2, sv3, sv4, sv5, sv6
      real :: t, dtx, tx, tl, svl
C-----------------------------------------------
c***********************************************************************
c*****w.a.houlberg ornl 2/79.                                          *
c*****tabulated data provided by j.r.mcnally,jr.                       *
c***********************************************************************
c*****svfuse is <sigma*vel> averaged over two maxwellian distributions *
c*****with temperature ti. units are in cm**3/sec for svfuse.          *
c*****irate=index denoting reaction                                    *
c*****  = 1   d+d => 3he(  817kev) +n( 2450kev)                  ref 1 *
c*****  = 2   d+d =>   t( 1008kev) +p( 3024kev)                  ref 1 *
c*****  = 3   d+t =>   a( 3517kev) +n(14069kev)                  ref 1 *
c*****  = 4   t+t =>   a( 1259kev) +n( 5034kev) +n( 5034kev)     ref 1 *
c*****  = 5 3he+t =>   d( 9546kev) +a( 4773kev)              41% ref 2 *
c*****            =>   p( 5374kev) +a( 1344kev) +n( 5374kev) 55% ref 2 *
c*****            =>   p(10077kev) +a(  403kev) +n( 1612kev)  4% ref 2 *
c*****  = 6 3he+d =>   p(14681kev) +a( 3670kev)                  ref 1 *
c*****the energies for the products are inversely proportional to the  *
c*****mass of each product.                                            *
c*****the branching ratio for reaction 5 is energy sensitive.          *
c*****ref 1: ucrl-70552 (1967)                                         *
c*****ref 2: bnwl-1685  (1975) p. 75                                   *
c*****       sov phys jetp 12 (1961) p. 163                            *
c*****ti=maxwellian temperature in ev.                                 *
c*****cross-sections tabulated in steps of .2 kev for   1.<t< 10. kev  *
c*****                                     2. kev for  10.<t<100. kev  *
c*****                                    20. kev for 100.<t<200. kev  *
c***********************************************************************
      equivalence(sv(1,1),sv1(1)),(sv(1,2),sv2(1)),(sv(1,3),sv3(1))
      equivalence(sv(1,4),sv4(1)),(sv(1,5),sv5(1)),(sv(1,6),sv6(1))
      data sv1/9.65E-23, 2.61E-22, 5.75E-22, 1.10E-21, 1.90E-21, 
     1   3.04E-21, 4.58E-21, 6.57E-21, 9.06E-21, 1.21E-20, 1.57E-20, 
     2   2.00E-20, 2.49E-20, 3.04E-20, 3.67E-20, 4.37E-20, 5.14E-20, 
     3   5.98E-20, 6.90E-20, 7.90E-20, 8.97E-20, 1.01E-19, 1.13E-19, 
     4   1.26E-19, 1.40E-19, 1.55E-19, 1.70E-19, 1.86E-19, 2.03E-19, 
     5   2.21E-19, 2.39E-19, 2.58E-19, 2.78E-19, 2.99E-19, 3.20E-19, 
     6   3.42E-19, 3.64E-19, 3.88E-19, 4.12E-19, 4.37E-19, 4.62E-19, 
     7   4.88E-19, 5.15E-19, 5.42E-19, 5.70E-19, 5.99E-19, 9.18E-19, 
     8   1.29E-18, 1.71E-18, 2.16E-18, 2.65E-18, 3.17E-18, 3.71E-18, 
     9   4.27E-18, 4.85E-18, 5.44E-18, 6.04E-18, 6.66E-18, 7.28E-18, 
     .   7.90E-18, 8.54E-18, 9.18E-18, 9.82E-18, 1.05E-17, 1.11E-17, 
     1   1.18E-17, 1.24E-17, 1.30E-17, 1.37E-17, 1.43E-17, 1.50E-17, 
     2   1.56E-17, 1.63E-17, 1.69E-17, 1.76E-17, 1.82E-17, 1.88E-17, 
     3   1.95E-17, 2.01E-17, 2.07E-17, 2.13E-17, 2.20E-17, 2.26E-17, 
     4   2.32E-17, 2.38E-17, 2.44E-17, 2.50E-17, 2.56E-17, 2.62E-17, 
     5   2.68E-17, 2.74E-17, 3.32E-17, 3.86E-17, 4.37E-17, 4.86E-17, 
     6   5.32E-17/
      data sv2/9.66E-23, 2.61E-22, 5.76E-22, 1.10E-21, 1.91E-21, 
     1   3.05E-21, 4.59E-21, 6.58E-21, 9.07E-21, 1.21E-20, 1.57E-20, 
     2   1.99E-20, 2.48E-20, 3.04E-20, 3.66E-20, 4.35E-20, 5.11E-20, 
     3   5.95E-20, 6.86E-20, 7.84E-20, 8.90E-20, 1.00E-19, 1.12E-19, 
     4   1.25E-19, 1.39E-19, 1.53E-19, 1.68E-19, 1.83E-19, 2.00E-19, 
     5   2.17E-19, 2.35E-19, 2.53E-19, 2.72E-19, 2.92E-19, 3.12E-19, 
     6   3.33E-19, 3.55E-19, 3.77E-19, 4.00E-19, 4.23E-19, 4.48E-19, 
     7   4.72E-19, 4.97E-19, 5.23E-19, 5.49E-19, 5.76E-19, 8.72E-19, 
     8   1.21E-18, 1.58E-18, 1.99E-18, 2.41E-18, 2.85E-18, 3.31E-18, 
     9   3.79E-18, 4.27E-18, 4.76E-18, 5.25E-18, 5.75E-18, 6.26E-18, 
     .   6.77E-18, 7.28E-18, 7.79E-18, 8.30E-18, 8.81E-18, 9.32E-18, 
     1   9.84E-18, 1.03E-17, 1.09E-17, 1.14E-17, 1.19E-17, 1.24E-17, 
     2   1.29E-17, 1.34E-17, 1.39E-17, 1.44E-17, 1.49E-17, 1.54E-17, 
     3   1.59E-17, 1.64E-17, 1.69E-17, 1.73E-17, 1.78E-17, 1.83E-17, 
     4   1.88E-17, 1.93E-17, 1.97E-17, 2.02E-17, 2.07E-17, 2.12E-17, 
     5   2.16E-17, 2.21E-17, 2.66E-17, 3.09E-17, 3.51E-17, 3.90E-17, 
     6   4.29E-17/
      data sv3/6.27E-21, 1.86E-20, 4.44E-20, 9.11E-20, 1.67E-19, 
     1   2.83E-19, 4.47E-19, 6.72E-19, 9.67E-19, 1.34E-18, 1.81E-18, 
     2   2.38E-18, 3.06E-18, 3.86E-18, 4.79E-18, 5.86E-18, 7.07E-18, 
     3   8.43E-18, 9.95E-18, 1.16E-17, 1.35E-17, 1.55E-17, 1.77E-17, 
     4   2.00E-17, 2.26E-17, 2.53E-17, 2.81E-17, 3.12E-17, 3.44E-17, 
     5   3.78E-17, 4.14E-17, 4.52E-17, 4.91E-17, 5.31E-17, 5.74E-17, 
     6   6.17E-17, 6.63E-17, 7.09E-17, 7.57E-17, 8.07E-17, 8.57E-17, 
     7   9.09E-17, 9.62E-17, 1.02E-16, 1.07E-16, 1.13E-16, 1.74E-16, 
     8   2.39E-16, 3.06E-16, 3.70E-16, 4.31E-16, 4.88E-16, 5.39E-16, 
     9   5.86E-16, 6.28E-16, 6.65E-16, 6.98E-16, 7.27E-16, 7.52E-16, 
     .   7.74E-16, 7.93E-16, 8.09E-16, 8.23E-16, 8.35E-16, 8.45E-16, 
     1   8.54E-16, 8.61E-16, 8.66E-16, 8.70E-16, 8.74E-16, 8.76E-16, 
     2   8.77E-16, 8.78E-16, 8.78E-16, 8.77E-16, 8.76E-16, 8.74E-16, 
     3   8.72E-16, 8.70E-16, 8.67E-16, 8.64E-16, 8.61E-16, 8.57E-16, 
     4   8.54E-16, 8.50E-16, 8.46E-16, 8.42E-16, 8.37E-16, 8.33E-16, 
     5   8.29E-16, 8.24E-16, 7.77E-16, 7.31E-16, 6.89E-16, 6.50E-16, 
     6   6.16E-16/
      data sv4/3.28E-23, 1.02E-22, 2.52E-22, 5.29E-22, 9.84E-22, 
     1   1.68E-21, 2.66E-21, 4.00E-21, 5.75E-21, 7.96E-21, 1.07E-20, 
     2   1.40E-20, 1.79E-20, 2.24E-20, 2.76E-20, 3.35E-20, 4.01E-20, 
     3   4.75E-20, 5.56E-20, 6.45E-20, 7.42E-20, 8.47E-20, 9.60E-20, 
     4   1.08E-19, 1.21E-19, 1.35E-19, 1.49E-19, 1.64E-19, 1.80E-19, 
     5   1.97E-19, 2.14E-19, 2.32E-19, 2.51E-19, 2.71E-19, 2.91E-19, 
     6   3.12E-19, 3.34E-19, 3.56E-19, 3.79E-19, 4.03E-19, 4.27E-19, 
     7   4.52E-19, 4.77E-19, 5.03E-19, 5.30E-19, 5.57E-19, 8.54E-19, 
     8   1.19E-18, 1.56E-18, 1.96E-18, 2.37E-18, 2.80E-18, 3.24E-18, 
     9   3.68E-18, 4.13E-18, 4.59E-18, 5.04E-18, 5.50E-18, 5.96E-18, 
     .   6.41E-18, 6.87E-18, 7.33E-18, 7.78E-18, 8.23E-18, 8.68E-18, 
     1   9.12E-18, 9.57E-18, 1.00E-17, 1.04E-17, 1.09E-17, 1.13E-17, 
     2   1.17E-17, 1.22E-17, 1.26E-17, 1.30E-17, 1.34E-17, 1.39E-17, 
     3   1.43E-17, 1.47E-17, 1.51E-17, 1.55E-17, 1.59E-17, 1.63E-17, 
     4   1.67E-17, 1.71E-17, 1.75E-17, 1.79E-17, 1.83E-17, 1.87E-17, 
     5   1.91E-17, 1.95E-17, 2.32E-17, 2.66E-17, 2.97E-17, 3.25E-17, 
     6   3.48E-17/
      data sv5/0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 
     1   0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 
     2   0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 
     3   0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 
     4   0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 
     5   0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 
     6   0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 
     7   0.00E-00, 0.00E-00, 0.00E-00, 0.00E-00, 1.16E-20, 6.17E-20, 
     8   1.12E-19, 1.62E-19, 2.12E-19, 2.62E-19, 4.37E-19, 6.11E-19, 
     9   7.85E-19, 9.60E-19, 1.13E-18, 1.47E-18, 1.80E-18, 2.14E-18, 
     .   2.47E-18, 2.81E-18, 3.30E-18, 3.80E-18, 4.29E-18, 4.79E-18, 
     1   5.29E-18, 5.93E-18, 6.58E-18, 7.22E-18, 7.87E-18, 8.52E-18, 
     2   9.29E-18, 1.01E-17, 1.09E-17, 1.16E-17, 1.24E-17, 1.33E-17, 
     3   1.42E-17, 1.51E-17, 1.60E-17, 1.69E-17, 1.78E-17, 1.88E-17, 
     4   1.98E-17, 2.08E-17, 2.18E-17, 2.29E-17, 2.39E-17, 2.50E-17, 
     5   2.61E-17, 2.71E-17, 4.01E-17, 5.30E-17, 6.59E-17, 7.88E-17, 
     6   9.18E-17/
      data sv6/3.10E-26, 1.80E-25, 7.28E-25, 2.31E-24, 6.11E-24, 
     1   1.41E-23, 2.94E-23, 5.63E-23, 1.01E-22, 1.70E-22, 2.73E-22, 
     2   4.22E-22, 6.29E-22, 9.09E-22, 1.28E-21, 1.75E-21, 2.36E-21, 
     3   3.11E-21, 4.03E-21, 5.14E-21, 6.46E-21, 8.03E-21, 9.87E-21, 
     4   1.20E-20, 1.45E-20, 1.73E-20, 2.05E-20, 2.41E-20, 2.81E-20, 
     5   3.26E-20, 3.76E-20, 4.32E-20, 4.93E-20, 5.61E-20, 6.35E-20, 
     6   7.15E-20, 8.03E-20, 8.98E-20, 1.00E-19, 1.11E-19, 1.23E-19, 
     7   1.36E-19, 1.50E-19, 1.65E-19, 1.81E-19, 1.97E-19, 4.33E-19, 
     8   8.17E-19, 1.39E-18, 2.19E-18, 3.26E-18, 4.61E-18, 6.28E-18, 
     9   8.27E-18, 1.06E-17, 1.32E-17, 1.62E-17, 1.95E-17, 2.30E-17, 
     .   2.68E-17, 3.09E-17, 3.52E-17, 3.96E-17, 4.42E-17, 4.89E-17, 
     1   5.37E-17, 5.87E-17, 6.36E-17, 6.87E-17, 7.37E-17, 7.88E-17, 
     2   8.38E-17, 8.88E-17, 9.38E-17, 9.87E-17, 1.04E-16, 1.08E-16, 
     3   1.13E-16, 1.18E-16, 1.22E-16, 1.27E-16, 1.31E-16, 1.36E-16, 
     4   1.40E-16, 1.44E-16, 1.48E-16, 1.52E-16, 1.56E-16, 1.60E-16, 
     5   1.63E-16, 1.67E-16, 1.97E-16, 2.19E-16, 2.34E-16, 2.45E-16, 
     6   2.52E-16/
      svfuse = 0.
      t = tiloc/1000.
      if (t>=1. .or. irate/=3) then
         if (t < 1.) return 
         if (t > 200.) ierrsv = 1
         t = amin1(200.0_dp,t)
         dtx = .2
         ipt = -4
         if (t >= 10.) then
            dtx = 2.
            ipt = 41
            if (t >= 100.) then
               dtx = 20.
               ipt = 86
            endif
         endif
!         ix = ifix(t/dtx) + ipt
         ix = int(t/dtx) + ipt
         tx = dtx*(ix - ipt)
         svfuse=sv(ix,irate)+(sv(ix+1,irate)-sv(ix,irate))*(t-tx)/dtx
         return 
      endif
      tl = alog10(tiloc)
      svl = (((-1.110333*tl) + 12.26350)*tl - 49.01817)*tl + 86.86500
      if (svl < 37.) svfuse = 10.**(-svl)
c     this fit is good to svl=50. but dec machines can't handle 1.e-50
      return 
      end function svfuse
 
 
      subroutine wavect
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:03:04   6/14/01  
C...Switches: -p4 -yb
c
c   ****************************************************************
c   *                                                              *
c   *      this modulus evaluates the phisical components          *
c   *           of the wavevector in the psi, theta, phi           *
c   *           frame and in the local stix frame.                 *
c   *                                                              *
c   ****************************************************************
c
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vsizes
      use Viorlh
      use Vcmnew
      use Vchpcsd
      use Vcraylh
      use Vceqdsk
      use Viogrl
      use Vcgraphs
      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
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-----------------------------------------------
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 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
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   ****************************************************************
c
      pkpsi = (antau*akpsi - ag*akth/antau)/aj
      pktau = akth/antau
      pkphi = anphi/urhs
      pk = sqrt(pkpsi*pkpsi + pktau*pktau + pkphi*pkphi)
c
c  stix components
c
      pkheta = pktau*acostq - pkphi*asintq
      pkpar = pktau*asintq + pkphi*acostq
      pkpar2 = pkpar*pkpar
      pkp2 = pkpsi*pkpsi + pkheta*pkheta
      pkp = sqrt(pkp2)
c
c  cartesian components
c
      pkx = (akpsi*dzth - akth*dzpsi)/aj
      pkz = ((-akpsi*dxth) + akth*dxpsi)/aj
c
c  derivatives
c
      dkpsip = (dntaup - djp)*pkpsi + (2.*ag*dntaup - dgp)*pktau/aj
      dkpsit = (dntaut - djt)*pkpsi + (2.*ag*dntaut - dgt)*pktau/aj
      dkhep=(-dntaup*acostq*pktau)+pkphi*dxpsi*asintq/urhs-dqpsi*pkpar
      dkhet=(-dntaut*acostq*pktau)+pkphi*dxth*asintq/urhs-dqth*pkpar
      dkp2p = 2.*(pkpsi*dkpsip + pkheta*dkhep)
      dkp2t = 2.*(pkpsi*dkpsit + pkheta*dkhet)
      dkpzp = (-dntaup*asintq*pktau) - pkphi*dxpsi*acostq/urhs + dqpsi*
     1   pkheta
      dkpzt = (-dntaut*asintq*pktau) - pkphi*dxth*acostq/urhs + dqth*
     1   pkheta
c
      return 
c
      end subroutine wavect
c
      subroutine wloss
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:03:04   6/14/01  
C...Switches: -p4 -yb
c
c  routine to calculate ray power degradation due to each wall specular
c   reflection
c  icoll=1   wfrac = wfrac0 specified in curray_go
c       =2   wfrac calculated from SOL collisional damping
c  Input for icoll=2
c    If psi.ge.0.95 edge damping is added to total damping,
c     otherwise, no extra damping is added.
c       fcoll=multiplication factor for collision frequency.
c         fdened=density of SOL as a fraction of that at separatrix
c         fzefed=z-effective of SOL as a fraction of that at separ.
c       fteed=electron temp. of SOL as a fraction of that at separ.
c       ftied=ion temp.      """"""""""""""""""""""""""""""""""""
c       the B-field of the reflection point is assumed
c       wsol=thickness of scrape-off-layer at the outboard equatorial
c             plane in meters.
c
c
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vsizes
      use Viorlh
      use Vcmnew
      use Vchpcsd
      use Vcraylh
      use Vceqdsk
      use Viogrl
      use Vcgraphs
      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
C...  /chpcsd/
!      common /chpcsd/ prmt(6), y(10), dy(10), dy6o, serror, psilast, yin
!     1   (10), dyin(10), hlast, ndim, jhlf, ind, mcnt, h, klim, irecmx
!      integer   ndim, jhlf, ind, mcnt, klim, irecmx
!      real   prmt, y, dy, dy6o, serror, psilast, yin, dyin, hlast, h
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 :: i
      real :: dspsi, dstau, dsphi, dseta, dsp, cosvg, dened, teed, zefed
     1   , zhsied, rnue, c1, coln, denomc, asmnp2, pkp2ed, pkped, betaed
     2   , vte, anpkpi, pki
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 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
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********************
 
!      common /chpcsd/ prmt(6),y(10),dy(10),dy6o,hlast,ndim,
!     1                jhlf,ind,serror,psilast,yin(10),dyin(10),
!     2                mcnt, h, klim,irecmx
c
      select case (icoll) 
      case default
         wfrac = wfrac0
         return 
      case (2) 
         dspsi = aj*dy(2)/antau
         dstau = antau*dy(4) + ag*dy(2)/antau
         dsphi = urhs*dy(5)
         dseta = dstau*acostq - dsphi*asintq
         dsp = sqrt(dspsi**2 + dseta**2)
         cosvg = abs(dspsi/dsp)
         dened = fdened*tne(nprof,1)
         teed = fteed*tte(nprof,1)
         zefed = fzefed*tzeff(nprof,1)
         zhsied = btot/bzero
         wpe2 = wpe2c*dened
         apzz = 1. - wpe2
         wce2 = wce2c*zhsied**2
         wce = sqrt(wce2)
         asxye = wpe2/wce2
         asxy = 1. + asxye
         adxy = 0.
         denied(:nspec) = fdened*tni(nprof,1,:nspec)
         tied(:nspec) = ftied*tti(nprof,1,:nspec)
         wpi2(:nspec) = denied(:nspec)*wpi2c(:nspec)
         wci(:nspec) = wci1c(:nspec)*zhsied
         wci2(:nspec) = wci(:nspec)*wci(:nspec)
         vti(:nspec) = 1.459E-3*sqrt(tied(:nspec)/atm(:nspec))
         if (psi >= 0.95) then
            rnue = 1.47E-9*dened*zefed/teed**1.5
         else
            rnue = 0.
         endif
         do i = 1, nspec
            c1 = 1. - wci2(i)
            if (abs(c1) <= 1.E-20) then
               cwwk(i) = wpi2(i)*1.E20*sign(1.0_dp,c1)
            else
               cwwk(i) = wpi2(i)/(1. - wci2(i))
            endif
         end do
         cwwk1(:nspec) = cwwk(:nspec)/wci(:nspec)
         asxy = asxy - sum(cwwk(:nspec))
         adxy = adxy + sum(cwwk1(:nspec))
         xe = 15.984/(abs(pkpar)*sqrt(teed))
c-------------------
c teed in kev
c---------------------
         zxmin = abs(xe)
         coln = fcoll*rnue/omega
         denomc = 1. + coln*coln
         coln = coln/denomc
         asmnp2 = asxy - pkpar2
         pkp2ed = (asmnp2**2 - adxy**2)/asmnp2
         if (pkp2ed > 0.) then
            pkped = sqrt(pkp2ed)
            betaed = 4.03E-16*dened*teed/btot**2
            cei = cmplx(0.,1.)
            zxe2 = xe*xe
c           call zfun(0,xe,cz,czp,zfn,zfc,xzz,nptzf,nptzfa,hzf,iout0)
            call zfun(xe, cz, czp)
            eps3r = 2.*wpe2*zxe2*(1. + xe*real(cz))
            eps3i = 2.*wpe2*zxe2*xe*aimag(cz)
            aeps32 = eps3r*eps3r + eps3i*eps3i
            vte = 0.0625*sqrt(tempe)
            anpkpi = 0.5*betaed*(coln*(1. + (adxy*511.925/teed*wce)**2/
     1         aeps32/asmnp2**2*0.5/zxe2/denomc))
            anpkpi = anpkpi + fcoll*rnue/omega*asxye*(2./pkp2ed - 1./
     1         asmnp2)
            anpkpi = anpkpi*pkped
            pki = anpkpi*ukzero
            wfrac = exp((-2.0_dp*pki*wsol))
            return 
         endif
         wfrac = 1.E0
         return 
      end select
      end subroutine wloss
