c
c  This module contains interfacing subroutines for CQL
c
c--------------------------------------------------------------
 
 
      subroutine delp(dpwre, i, j, freqcy)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:52:01   6/14/01  
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
      use Vparam
      use Vcfdamp, ONLY: ifbilin, us, thets, coss, sinn, f, fxx, fyy, 
     1   fxxyy, ftemp, ibd, wk, sint, tempx, tempy, dus, dthets, 
     2   dudthets, usp, thetsp, bes0, bes1, dbes, ifirstb, nbes, cnstb, 
     3   besdel, bmax, nint, unorm
      use Vcgraphs, ONLY: seikon, spsi, sxu, szu, skp, skpar, spower, 
     1   sdpwri, sphi, stheta, spol, sdkpar, scepx, scepy, scepz, 
     2   sztpol, sbtot, sene, salphac, salphal, sjslofa, serrors, 
     3   spkpsi, sakpsi, sakth, swkve, jjslofa, sne, ste, sqr, spw, 
     4   sxh, sqte, sni, sti, sdeqs, spwer, spwmax, srtor, srplas, 
     5   sdenc, stec, sqc, sqa, sbaxis, scurr, sfreq, satm, sazi, 
     6   sconc, stic, sxpage, sypage, slenx, sleny, sdelx, sfirtx, 
     7   sdely, sfirty, symax, symin, skth, skphi, skpsi, sxx, jslofas, 
     8   nurefls, keiks, jpes, jpis, istarts, iprmt5, jhlfs, isimpl, 
     9   isimpl0, ngr, nps, nspie, kgraph, kprof, newgra, jksym, 
     .   lintyp, nxvarb, nyvarb, kwfr
      use Vcraylh
      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, rzero
      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 i, j
      real dpwre, freqcy
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 :: k, ier, lmhd, ir, kmax, ii
      real :: kpar, kperdom, pi, clight, clight2, x, zh, zbx01, zbx11, 
     1   bdb0, rootbdb0, dcapfdu, vpar, vpar2, fomce, deluprp, uprp, 
     2   uprp2, gammar2, gammar, upar, upar2, u2, u, arg, besj0, besj1, 
     3   uprp0, upar0, t0, ff, dfdx, dfdy, ct, st, dfdupar, delspol
      save kpar, kperdom, pi, clight, clight2, k, x, ier, lmhd, zh, 
     1   zbx01, zbx11, bdb0, rootbdb0, ir, dcapfdu, vpar, vpar2, fomce, 
     2   deluprp, kmax, uprp, uprp2, gammar2, gammar, upar, upar2, u2, u
     3   , arg, ii, besj0, besj1, uprp0, upar0, t0, ff, dfdx, dfdy, ct, 
     4   st, dfdupar, delspol
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
!      integer , EXTERNAL :: ifix
      real , EXTERNAL :: valspl
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c
c  Comfdamp
c
c
c----------------------------
c   common blocks of Cmgraphs
c
 
c    2   ,sqti(nprofm)
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       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
      data pi/3.141592654/
      data clight/2.9979E10/
      data clight2/8.9874E20/
c
c     Calculate damping within a ray element specified by
c           i = ray element
c           j = ray number
c
c     If ifirst.eq.1 set up the bessel functions:
c      (also cnstb = 2*pi**2*e**2/m_e)
      if (ifirstb == 1) then
         cnstb = 4.99915E9
         nbes = nbesa
         dbes = bmax/(nbes - 1)
         do k = 1, nbes
            x = (k - 1)*dbes
            call besj (x, 0, bes0(k), besdel, ier)
            call besj (x, 1, bes1(k), besdel, ier)
         end do
         ifirstb = 0
      endif
c
c     Need B_mag/B_o-mag.  (Ref. subroutine coords and p.20 of IPP 4/210)
      psi = spsi(i)
      theta = 0.0
!      lmhd = ifix(psi/dpsimhd) + 1
      lmhd = int(psi/dpsimhd) + 1
      zh = psi - psimhd(lmhd)
      zbx01 = valspl(zh,bx0,nprofn,lmhd,0)
      zbx11 = valspl(zh,bx1,nprofn,lmhd,0)
      ux = zbx01 + zbx11
      bdb0 = (ux/ukzero + rzero)/(sxu(i)+rzero)
      rootbdb0 = sqrt(bdb0)
c
c     Radial bin identifier
      do k = 1, nprof
         ir = k
         if (psi < ppsi(k)) exit 
      end do
c
c
      dpwre = 0.0
c  The following variable is added for diagnostic purposes, and
c  is the u_parallel derivative of the reduced distn function.
      dcapfdu = 0.0
      vpar = clight/skpar(i)
      vpar2 = vpar*vpar
      kpar = 2.*pi*freqcy/vpar
      fomce = 28.E9*sbtot(i)
      kperdom = freqcy*skp(i)/(clight*fomce)
      if (kperdom*us(imaxu) > bmax - dbes) stop 20
      deluprp = us(imaxu)/(nint - 1)
      kmax = us(imaxu)/deluprp
      if (kmax < 2) return 
      uprp = -0.5*deluprp
      do k = 1, kmax
         uprp = uprp + deluprp
         uprp2 = uprp*uprp
         gammar2 = (clight2 + uprp2)/(clight2 - vpar2)
         gammar = sqrt(gammar2)
         upar = gammar*vpar
         upar2 = upar*upar
         u2 = uprp2 + upar2
         u = sqrt(u2)
         if (u > unorm) exit 
         arg = kperdom*uprp
         ii = arg/dbes + 1
         besj0=bes0(ii)+(arg-(ii-1)*dbes)*(bes0(ii+1)-bes0(ii))/dbes
         besj1=bes1(ii)+(arg-(ii-1)*dbes)*(bes1(ii+1)-bes1(ii))/dbes
c
         uprp0 = uprp/rootbdb0
         upar0 = sign(1.0_dp,upar)*sqrt(u2 - uprp0*uprp0)
         t0 = atan2(uprp0,upar0)
         call distn(nuam,ntam,u,t0,ff,dfdx,dfdy,sene(i),pne,nprof,ir)
c
c     Transform derivatives to the local poloidal angle
         dfdy = upar/upar0/rootbdb0*dfdy
         ct = upar/u
         st = uprp/u
         dfdupar = ct*dfdx - st*dfdy/u
         dpwre = dpwre + uprp/gammar*(upar*besj0*real(scepz(i))-uprp*
     1      besj1*aimag(scepy(i)))**2*dfdupar
         dcapfdu = dcapfdu + uprp*dfdupar
      end do
c
      if (i/=1 .and. i/=isimpl(j)) then
         delspol = 0.5*(spol(i+1)-spol(i-1))*1.E2
      else if (i == 1) then
         delspol = 0.5*spol(2)*1.E2
      else if (i == isimpl(j)) then
         delspol = 0.5*(spol(i)-spol(i-1))*1.E2
      endif
 
c
      dpwre = -dpwre*cnstb*delspol*spower(i)/((sztpol(i)*clight/(8.*pi))
     1   *omega*(1.-vpar2/clight2))*deluprp*sign(1.0_dp,kpar)
      dcapfdu = 2.*pi*deluprp*dcapfdu
      if (2 > 1) then
         go to 25
      else
         go to 26
      endif
   25 continue
   26 continue
      return 
      end subroutine delp
c
c
c
      subroutine distn(nu,nt,u0,thet0,ff,dfdx,dfdy,denn,den,ird,ir)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:52:01   6/14/01  
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vcfdamp
      use Vcgraphs
      use Vcraylh
      use Viorlh
      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 nu, nt, ird, ir
      real u0, thet0, ff, dfdx, dfdy, denn
      real, dimension(ird) :: den
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 :: idm, im, ii, jj
      real :: ffm, dfdxm, dfdym, ddm, ddp, ddl ! was dd
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real , EXTERNAL :: terp2p
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     ird = length of density vector den
c     ir  = index of adjacent radial point exterior to the
c           location at which the distribution function is evaluated.
c           (1.le.ir.le.ird).
c
c
c Interpolate (using density) to get distribution functions
c  It is assumed that density is a
c  nonincreasing function of radius at the last two radial points.
c
      if (ifbilin == 0) then
c
         idm = nuam
c
c
         ff = (denn/den(ir))*terp2p(u0,thet0,nu,us,nt,thets,f(1,1,ir),
     1      fxx(1,1,ir),fyy(1,1,ir),fxxyy(1,1,ir),idm,0,0,1)
         dfdx = (denn/den(ir))*terp2p(u0,thet0,nu,us,nt,thets,f(1,1,ir),
     1      fxx(1,1,ir),fyy(1,1,ir),fxxyy(1,1,ir),idm,1,0,0)
         dfdy = (denn/den(ir))*terp2p(u0,thet0,nu,us,nt,thets,f(1,1,ir),
     1      fxx(1,1,ir),fyy(1,1,ir),fxxyy(1,1,ir),idm,0,1,0)
c
         if (ir==1 .or. ir==ird .and. denn<=den(ird)) return 
         im = ir - 1
 
c  No further interpolation if at a radial interpolation pt,
c  or density profile is flat:
         if (denn==den(im) .or. denn==den(ir)) return 
 
         ffm = (denn/den(im))*terp2p(u0,thet0,nu,us,nt,thets,f(1,1,im),
     1      fxx(1,1,im),fyy(1,1,im),fxxyy(1,1,im),idm,0,0,0)
         dfdxm = (denn/den(im))*terp2p(u0,thet0,nu,us,nt,thets,f(1,1,im)
     1      ,fxx(1,1,im),fyy(1,1,im),fxxyy(1,1,im),idm,1,0,0)
         dfdym = (denn/den(im))*terp2p(u0,thet0,nu,us,nt,thets,f(1,1,im)
     1      ,fxx(1,1,im),fyy(1,1,im),fxxyy(1,1,im),idm,0,1,0)
c
      else
c
         ii = u0/dus + 1
         jj = thet0/dthets + 1
         if (ii >= nuam) ii = nuam - 1
         if (jj >= ntam) jj = ntam - 1
         ff = 0.0
         call fterp2 (u0, thet0, ii, jj, usp, thetsp, dudthets, fxx(1,1,
     1      ir), fyy(1,1,ir), nuam, ntam, dfdx, dfdy)
         dfdx = denn/den(ir)*dfdx
         dfdy = denn/den(ir)*dfdy
c
         if (ir==1 .or. ir==ird .and. denn<=den(ird)) return 
         im = ir - 1
 
c  No further interpolation if at a radial interpolation pt,
c  or density profile is flat:
         if (denn==den(im) .or. denn==den(ir)) return 
 
         ffm = 0.0
         call fterp2 (u0, thet0, ii, jj, usp, thetsp, dudthets, fxx(1,1,
     1      im), fyy(1,1,im), nuam, ntam, dfdxm, dfdym)
         dfdxm = denn/den(im)*dfdxm
         dfdym = denn/den(im)*dfdym
c
      endif
c
      ddm = denn - den(im)
      ddp = den(ir) - denn
      ddl = ddm + ddp
      ff = (ffm*ddp + ff*ddm)/dd
      dfdx = (dfdxm*ddp + dfdx*ddm)/ddl
      dfdy = (dfdym*ddp + dfdy*ddm)/ddl
c
      return 
      end subroutine distn
 
      subroutine dodamp
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:52:01   6/14/01  
C...Switches: -p4 -yb
 
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vcfdamp
      use Vcgraphs, ONLY: seikon, spsi, sxu, szu, skp, skpar, spower, 
     1   sdpwri, sphi, stheta, spol, sdkpar, scepx, scepy, scepz, 
     2   sztpol, sbtot, sene, salphac, salphal, sjslofa, serrors, 
     3   spkpsi, sakpsi, sakth, swkve, jjslofa, sne, ste, sqr, spw, 
     4   sxh, sqte, sni, sti, sdeqs, spwer, spwmax, srtor, srplas, 
     5   sdenc, stec, sqc, sqa, sbaxis, scurr, sfreq, satm, sazi, 
     6   sconc, stic, sxpage, sypage, slenx, sleny, sdelx, sfirtx, 
     7   sdely, sfirty, symax, symin, skth, skphi, skpsi, sxx, jslofas, 
     8   nurefls, keiks, jpes, jpis, istarts, iprmt5, jhlfs, isimpl, 
     9   isimpl0, ngr, nps, nspie, kgraph, kprof, newgra, jksym, 
     .   lintyp, nxvarb, nyvarb, kwfr
      use Vcraylh
      use Viorlh
      use Vsizes
      use Viogrl, ONLY: calfa, px, sumpx, bk, refl, rtot, trans, 
     1   aksupw, ddk, nnk, joutrf, ireout, jumpw, jtest, ispec, ngra, 
     2   itrans, radius, freqcy
      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 :: j, i
      real :: dpwre
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 Cmgraphs
c
 
c    2   ,sqti(nprofm)
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   common blocks of Comiogrl
c---------------------------
c******************SCC  01/17/95
c        This is not working right now; we can't loop over rays
c          like that here. We need to output rays in rayop, then
c          do it ray by ray by reading in from rayop
c*********************************
c
c     Calculation of power in ray using numerical calc. of electron damping.
c
c     istarts() gives ray status:
c       -1,  ray damped completely
c        0,  ray failed to start, of stopped other than because of damping
c       +1,  integrate further along the ray
c
      do j = 1, indgr
         if (isimpl(j)>isimpl0(j) .and. istarts(j)/=0) then
            if (istarts(j) == (-1)) istarts(j) = 1
            do i = isimpl0(j), isimpl(j)
               if (istarts(j) == 1) then
                  call delp (dpwre, i, j, freqcy)
                  spower(i) = spower(i-1) - dpwre - sdpwri(i)
                  if (spower(i) <= 0.0) then
                     spower(i) = smallest        ! was 1.e-50
                     istarts(j) = -1
                  endif
               else
                  spower(i) = smallest           ! was 1.e-50
               endif
            end do
         endif
      end do
 
      return 
      end subroutine dodamp
c
c ************ ************ ************ ************ ************
c
c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c
      subroutine fnmax(kspec, npar, upar, nper, uper, umax, tnmax, dsf)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:52:01   6/14/01  
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vcfdamp
      use Vcgraphs
      use Vcraylh
      use Viorlh
      use Vsizes
      use Viogrl
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer kspec, npar, nper
      real umax, tnmax
      real, dimension(1) :: upar, uper
      real, dimension(1,1) :: dsf
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i, j
      real :: dpar, dper
C-----------------------------------------------
c $$$ Subroutine to calculate analytically non-Maxwellian distribution
c      for use in wave damping
c
c Input: kspec : <=0 : electrons     >0 : ions
c        npar  : number of grid points in v-parallel space
c        upar  : array of normalized v-parallel
c        nper  : number of grid points in v-perp space
c        uper  : array of normalized v-perp
c        umax  : maximum normalized u [=(upar**2+uper**2)**(1/2)]
c        tnmax : characteristic temperature (keV)
cOutput: dsf   : (npar,nper) array of distribution which integrates to
c                 unity in velocity space
c
      dpar = umax/float(npar - 1)
      dper = umax/float(nper - 1)
      do i = 1, npar
         upar(i) = dpar*float(i - 1)
         do j = 1, nper
            uper(j) = dper*float(j - 1)
            dsf(i,j) = 0.
         end do
      end do
      return 
      end subroutine fnmax
 
c
      subroutine fokker(inf, enorm, den, tem, rdf, ir0, inname, rtail, 
     1   r1t, r2t, ttail, rhot, r1h, r2h, thotpar, thotper, hotexp, 
     2   hotmnpar, hotmxpar, hotmnper, hotmxper, rbeam, r1b, r2b, tbeam
     3   , ebeam, thbeam)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:52:01   6/14/01  
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vcfdamp, ONLY: ifbilin, us, thets, coss, sinn, f, fxx, fyy, 
     1   fxxyy, ftemp, ibd, wk, sint, tempx, tempy, dus, dthets, 
     2   dudthets, usp, thetsp, bes0, bes1, dbes, ifirstb, nbes, cnstb, 
     3   besdel, bmax, nint, irmax, nuam, ntam, imaxu, jmax
      use Vcgraphs
!      use Vcraylh
      use Viorlh
      use Vsizes
      use Viogrl
      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 inf, ir0
      real enorm, rtail, r1t, r2t, ttail, rhot, r1h, r2h, thotpar, 
     1   thotper, hotexp, hotmnpar, hotmxpar, hotmnper, hotmxper, rbeam
     2   , r1b, r2b, tbeam, ebeam, thbeam
      character inname*10
      real, dimension(irmax) :: den, tem, rdf
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, j, ir, itail, ihot, ibeam, ilen, nu, nt, l, ll, iy, 
     1   jx, lrz, idm, irr
      real, dimension(irmax) :: dnorm
      real, dimension(5) :: dumm
      real :: pi, clight, clight2, unorm, rmu, dnormt, rmutail, gamma, 
     1   fmax, ftail, du, vvol, dnormh, rmuhpar, rmuhper, upar2, uper2, 
     2   fact, gampar, gamper, epar, eper, dnormb, rmubeam, gammab, 
     3   ubovc, uparb, uperb, upar, uper, umax, renormf, renormv

      save dnorm, dumm, pi, clight, clight2, unorm, i, j, ir, rmu, itail
     1   , dnormt, rmutail, ihot, ibeam, gamma, fmax, ftail, du, vvol, 
     2   dnormh, rmuhpar, rmuhper, upar2, uper2, fact, gampar, gamper, 
     3   epar, eper, dnormb, rmubeam, gammab, ubovc, uparb, uperb, upar
     4   , uper, ilen, nu, nt, l, ll, iy, jx, lrz, umax, renormf, 
     5   renormv, idm, irr
C-----------------------------------------------
c     optimize level a
c
c    There are two modes given by inf:
c    inf=0, Electron dirstributions are calculated from analytic functions,
c           according io input values of
c             den(1:ir0)  density (/cc)
c             tem(1:ir0)  temperature (keV)
c             rdf(1:ir0)  normalized raii (0. to 1.)
c             the tail distribution specs.
c           Output is the distribution function, spline coeffs., and
c           arrays in Comfdamp_3
c    inf=1, Distributions read in from file inname.
c           Output is the distribution function, spline coeffs. and arrays in
c           Comfdamp_3, plot enorm, den, tem, rdf, ir0,
c           plus ion density specs. (ion specs later).
 
c
c    Output distributions are in cgs.
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  Comiorlh_1
c
c     character*1 line(132)
c
c
      pi = 3.141592654
      clight = 2.9979E10
      clight2 = clight*clight
c
      if (inf /= 1) then
c
c set up distribution functions
c
         unorm = clight*sqrt((1. + enorm/511.)**2 - 1.)
         do i = 1, imaxu
            us(i) = float(i - 1)*unorm/float(imaxu - 1)
         end do
         do j = 1, jmax
            thets(j) = pi*(j - 1.0)/(jmax - 1.0)
            coss(j) = cos(thets(j))
            sinn(j) = sin(thets(j))
         end do
c
c
c
         do ir = 1, ir0
            dnorm(ir) = 0.0
            rmu = 511./tem(ir)
            if (rdf(ir)>=r1t .and. rdf(ir)<=r2t .and. rtail/=0.) then
               itail = 1
               dnormt = 0.0
               rmutail = 511./ttail
            else
               itail = 0
               dnormt = 1.0
            endif
            if (rdf(ir)>=r1h .and. rdf(ir)<=r2h .and. rhot/=0.0) then
               ihot = 1
            else
               ihot = 0
            endif
            if (rdf(ir)>=r1b .and. rdf(ir)<=r2b .and. rbeam/=0.0) then
               ibeam = 1
            else
               ibeam = 0
            endif
            do i = 1, imaxu
               gamma = sqrt(1.0 + us(i)*us(i)/clight2)
               fmax = exp((-rmu*(gamma - 1.0)))
               if (itail /= 0) ftail = exp((-rmutail*(gamma - 1.)))
               du = 0.0
               if (i == 1) du = (0.5*(us(2)+us(1)))**3/3.
               if (i>1 .and. i<imaxu) du = 0.5*(us(i+1)-us(i-1))
               vvol = 4.0*pi*us(i)*us(i)*du
               dnorm(ir) = dnorm(ir) + vvol*fmax
               f(i,:jmax,ir) = fmax
               if (itail /= 0) then
                  dnormt = dnormt + vvol*ftail
                  ftemp(i,:jmax) = ftail
               endif
            end do
c
            f(:imaxu,:jmax,ir) = den(ir)*((1. - (itail*rtail) - ihot*
     1         rhot - ibeam*rbeam)*f(:imaxu,:jmax,ir)/dnorm(ir)+(itail*
     2         rtail)*ftemp(:imaxu,:jmax)/dnormt)
            j = jmax + 1
c
c     Add in hot component
            if (ihot == 1) then
               dnormh = 0.0
               rmuhpar = 511./thotpar
               rmuhper = 511./thotper
               do i = 1, imaxu
                  du = 0.0
                  if (i == 1) du = (0.5*(us(2)+us(1)))**3/3.
                  if (i>1 .and. i<imaxu) du = 0.5*(us(i+1)-us(i-1))
                  do j = 1, jmax
                     upar2 = 0.5*(coss(j)*us(i))**2/clight2
                     uper2 = 0.5*(sinn(j)*us(i))**2/clight2
                     if (hotexp == 0.) then
                        fact = 1.0
                     else
                        fact = uper2**(hotexp/2.)
                     endif
                     ftemp(i,j) = fact*exp((-rmuhpar*upar2) - rmuhper*
     1                  uper2)
                     gampar = sqrt(1. + 2.*upar2)
                     gamper = sqrt(1. + 2.*uper2)
                     epar = (gampar - 1.)*511.
                     eper = (gamper - 1.)*511.
                     if(epar<hotmnpar.or.epar>hotmxpar)ftemp(i,j)=0.0
                     if(eper<hotmnper.or.eper>hotmxper)ftemp(i,j)=0.0
                  end do
                  dnormh = dnormh + sum(2.*pi*us(i)**2*du*0.5*(ftemp(i,:
     1               jmax-1)+ftemp(i,2:jmax))*sin(0.5*(thets(:jmax-1)+
     2               thets(2:jmax)))*(thets(2:jmax)-thets(:jmax-1)))
               end do
               f(:imaxu,:jmax,ir) = f(:imaxu,:jmax,ir) + rhot*den(ir)*
     1            ftemp(:imaxu,:jmax)/dnormh
               j = jmax + 1
            endif
c
c
c     Add in beam component
            if (ibeam == 1) then
               dnormb = 0.0
               rmubeam = 511./tbeam
               gammab = ebeam/511. + 1.
               ubovc = sqrt(gammab**2 - 1.)
               uparb = ubovc*cos(thbeam*pi/180.)
               uperb = ubovc*sin(thbeam*pi/180.)
               do i = 1, imaxu
                  du = 0.0
                  if (i == 1) du = (0.5*(us(2)+us(1)))**3/3.
                  if (i>1 .and. i<imaxu) du = 0.5*(us(i+1)-us(i-1))
                  do j = 1, jmax
                     upar = coss(j)*us(i)/clight
                     uper = sinn(j)*us(i)/clight
                     ftemp(i,j) = exp((-0.5*rmubeam*((upar - uparb)**2
     1                   + (uper - uperb)**2)))
                  end do
                  dnormb = dnormb + sum(2.0*pi*us(i)**2*du*0.5*(ftemp(i,
     1               :jmax-1)+ftemp(i,2:jmax))*sin(0.5*(thets(:jmax-1)+
     2               thets(2:jmax)))*(thets(2:jmax)-thets(:jmax-1)))
               end do
               f(:imaxu,:jmax,ir) = f(:imaxu,:jmax,ir) + rbeam*den(ir)*
     1            ftemp(:imaxu,:jmax)/dnormb
               j = jmax + 1
            endif
c
         end do
c
c
      else
c     Here we read ir0 distn fctns from inname
c
         ilen = 0
c**bh iout1=fopen("feulh4","read")
c     Skip past c3d namelist data.
c  400 call rdline(10,line,clen)
c      if(line(1).eq. "*" .and. line(2) .eq. "*" .and.
c     1  line(3) .eq. "_" .and. line(4) .eq. "e" .and.
c     1  line(5) .eq. "_" .and. line(6) .eq. "z" .and.
c     1  line(7) .eq. "d" .and. line(8) .eq. "a" .and.
c     1  line(9) .eq. "t" .and. line(10).eq. "a") go to 500
c      if(clen .lt. 0)  go to 500
c      go to 400
c  500 continue
         nu = imaxu
         nt = jmax
  100    format(5e16.8)
  101    format(5i16)
         do l = 1, ir0
            read (iout1, 101) ll, iy, jx, lrz
            if (iy/=nt .or. jx/=nu .or. ir0/=lrz) stop 10
            read (iout1, 100) (thets(j),j=1,nt)
            read (iout1, 100) (us(i),i=1,nu)
            read (iout1, 100) dumm
            rdf(l) = dumm(1)
            unorm = dumm(2)
            den(l) = dumm(5)
            read (iout1, 100) dumm
            tem(l) = dumm(1)
            if (l == 1) then
c     umax = unorm (from cql3d)  /sqrt(2. * Te0 / me)
               umax = dumm(3)
               renormf = 1./unorm**3
               renormv = unorm
            endif
            read (iout1, 100) ((fxx(j,i,l),i=1,nt),j=1,nu)
            i = 1
            if (nu > 0) then
               j = 1
               if (nt > 0) then
                  f(:nu,:nt,l) = fxx(:nu,:nt,l)*renormf
                  j = nt + 1
               endif
               i = nu + 1
            endif
         end do
         us(:nu) = renormv*us(:nu)
c**bh call fclose(iout1)
      endif
c
c  Set up to do interpolation of dist functn:
c
      if (ifbilin == 0) then
c
c
c now set up the splines used to interpolate for the distn
c function in the calculation of emissivity and absorptivity
c
         idm = nuam
         ibd(1) = 4
         ibd(2) = 4
         ibd(3) = 2
         ibd(4) = 2
         do irr = 1, ir0
            fyy(:imaxu,1,irr) = 0.0
            fyy(:imaxu,ntam,irr) = 0.0
            i = imaxu + 1
            call coeff2 (nuam, us, ntam, thets, f(1,1,irr), fxx(1,1,irr)
     1         , fyy(1,1,irr), fxxyy(1,1,irr), idm, ibd, wk)
         end do
c
      else
c
c
c  Set up for bilinear interpolation:
c
c  Loop over radial mesh
         do irr = 1, ir0
            call fterp1 (f(1,1,irr), fxx(1,1,irr), fyy(1,1,irr), nuam, 
     1         ntam, us, thets, tempx, tempy)
         end do
c
         dus = (us(nuam)-us(1))/(nuam - 1)
         dthets = (thets(ntam)-thets(1))/(ntam - 1)
         dudthets = dus*dthets
         do i = 1, nuam
            usp(i) = (i - 1)*dus
         end do
         do j = 1, ntam
            thetsp(j) = (j - 1)*dthets
         end do
c
      endif
c
      return 
      end subroutine fokker
