c $$$$$  Added by TK Mau on 11/20/91
      subroutine anread
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:56:19   6/14/01
C...Switches: -p4 -yb
c
c     This routine, called from BR_GO when IGRILL=-2, reads in calculated
c     antenna n_par power spectra.
c     Number of spectra = isimm
c     Number of n_par components = nnkpar(i), i=1,isimm; specified in BR_GO
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      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   epserr, epser1, epspfw, epspsw, epsray, rzero, rplasm,
     2   bzero, btsign, tcurr, fbsc, rshift, dtrian, qsaf0, qsafa,
     3   gamene1, presfr, iout1, polasp
      use Viogrl, ONLY: calfa, px, sumpx, bk, refl, rtot, trans,
     1   aksupw, ddk, nnk, joutrf, ireout, jumpw, jtest, ispec, ngra,
     2   itrans, radius, freqcy, isimm, heigth
      use kind_spec

      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
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 blocks of Comiogrl
c---------------------------
c
      read (iout1, 1003) isimm, islofa, freqcy, heigth
      do j = 1, isimm
         read (iout1, 1001) nnkpar(j)
         read (iout1, 1002) (anzin(j,i),i=1,nnkpar(j))
         read (iout1, 1002) (pwcpl(j,i),i=1,nnkpar(j))
      end do
 1002 format(5e16.9)
 1001 format(i4)
 1003 format(2i4,2e16.9)
      return
      end subroutine anread
      subroutine outrun(ientry)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:56:19   6/14/01
C...Switches: -p4 -yb
c
c ************ ************ ************ ************ ************
c
c  output of the run parameters
c   Normal output
c
c ************ ************ ************ ************ ************
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      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, bzero, rplasm, tcurr, denlav, fbsc,
     2   aiseed, fdia, powrq, iout, iout1, iout2, nharm
      use Viogrl, ONLY: calfa, px, sumpx, bk, refl, rtot, trans,
     1   aksupw, ddk, nnk, joutrf, ireout, jumpw, jtest, ispec, ngra,
     2   itrans, radius, freqcy, isimm, heigth
      use Vcraylh
      use Vcmnew, ONLY: wpi1c, wpi2c, wci1c, wci2c, wpi2, wci2, wci,
     1   conci, aziomi, rtzom, ay2, ay1, trate, tratte, ttle, concte,
     2   trati, tratti, ttli, concti, vdrfte, vdrfti, infi, gprm, cxet,
     3   czt, cztp, czetai, czi, czip, czetat, czti, cztip, cth, npar,
     4   nper, upar, uper, umax, dsfe, dsfi, fper2, fpar2, fpp2, intg,
     5   inc, incf, tnmaxe, tnmaxi, idrive, binb, boutb, boutbrd,
     6   binbrd, epsl, binbd, epsil, dlob, wte, eta0, eta, rprof,
     7   amprof, cprof, xjop, vloop, kboot, mboot, btbsp, ftbsps, pde,
     8   pdec, pdi, pdf, pwce, pwcm, pwcf, pwc, pwc1, pwc2, pwct,
     9   pwct1, pwct2, pwc0, pwcray, pwc1ray, pwc2ray, pweray, pwiray,
     .   pwfray, currf, currfe, currf1, currf2, curay, curay1, curay2,
     1   fpwray, fpowe, fpowf, fpowi, pwte0, pwti0, effcd, effcdt,
     2   ptot, ftpowe, ftpowi, ftpowf, ftpi, ftpf, ftedge, pwedge,
     3   wfrac, pwxwl, frpowi, frpowf, frpow, pwit, pwft, ptedge,
     4   ptot0, fpowt, tpowi, tpowf, wfrac0, ebkev, bmpwr, azf, atmf,
     5   densa, kalfa, nalfa, nharm0, pnfi, pnf, zetab, tnf, ecrit,
     6   taua0, wca, gamal, gamat, ibeam, abeam, dbeam, aneb, enbeam,
     7   wbeam, temsa, ptfi, ttf, wpf2c, wpf2, wcf2c, wcf1c, wcf2, wcf,
     8   cxc, czc, cy, denfa, eav, tausd, tau0, paf, sordt, ecrita,
     9   betaf
      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 Vchpcsd, ONLY: irec, rec0, rec1, rec2, rec3, rec4, rec5,
     1   rec6, rec7, rec8, rec9, rec10, rec11, rec12, rec13, rec14,
     2   rec15
      use kind_spec

      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 :: j, l, i, k, n, iy, ip, is, nuk, jprt, ir
      real(kind=dp) :: zpi, zconc, zfremh, wlengt, zpwin, zpwyes,
     1    zpwab, zpwnab
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   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  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 $$$$$ Added by TK Mau on 11/19/91
c----------------------------
c   common blocks of Cmgraphs
c

c    2   ,sqti(nprofm)
c
c   Comhpcsd
c
c $$$$$$$$$$$$$$$$$$$$$$$$
c ************ ************ ************ ************ ************
c
      data zpi/3.14159265359/
c
c ************ ************ ************ ************ ************
c
c     go to (100,200), ientry
c $$$$$  Altered by TK Mau on 11/19/91
      select case (ientry)
c
c ************ ************ ************ ************ ************
c
      case default
         write (iout, 1500)
         write (iout, 1510) rzero, raxmag, rplasm, xmin, xmax, bzero,
     1      baxis, tcurr, pqr(nprof,1), pqr(1,1)
c      write(iout,1520)  denc,tempec
c$$$$$     TKM   2/00
         write (iout, 1520) denc, denlav, tempec, pavtne, pavtte, pavtti
     1      , pavpp, betap, beta, betaf, ali3, zeff
c$$$$$$$$$$$$
         do j = 1, nspec
            zconc = azi(j)*tconc(1,1,j)
            tempic(j) = tti(1,1,j)
            write (iout, 1530) j, atm(j), azi(j), zconc, tempic(j)
         end do
         zfremh = 1.E-9*freqcy
         wlengt = 2.*zpi/ukzero
         write (iout, 1540) zfremh, wlengt
         if (islofa <= 0) then
            write (iout, 1610)
 1610       format('0',24x,"fast wave coupled")
         else
            write (iout, 1620)
 1620       format('0',24x,"slow wave coupled")
c ************ ************ ************ ************ ************
c 140 if(iprint.le.1)  return
c $$$$$$  Altered by TK Mau on 11/19/91
         endif
         write (iout, 1550)
         do l = 1, nprof
            write (iout, 1560) tpsi(l), tqr(l,1), pqr(l,1), pne(l), pte(
     1         l), pti(l,1)
         end do
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c
c ************ ************ ************ ************ ************
c
 1500    format('0',"========plasmas parameters=======,"//)
 1510    format('0',9x,"major radius =",f8.3," m",/10x,
     1      "radius of the magnetic axis =",f8.3," m",/10x,
     2      "minor radius =",f8.3," m",/10x,"inner plasma edge at x =",
     3      f8.3," m",/10x,"outer plasma edge at x =",f8.3," m",/10x,
     4      "toroidal magnetic field on the centre =",f7.2," tesla",/10x
     5      ,"toroidal magnetic field on the axis =",f7.2," tesla",/10x,
     6      "toroidal current =",1pe12.3," MA"/,10x,
     7      "safety factor at the edge =",0pf6.2/10x,
     8      "safety factor at centre =",f6.2/)
 1520    format('0',4x,"central density =",1pe13.3," cm-3",/,5x,
     1      "line-ave. density =",1pe13.3," cm-3",/,5x,
     2      "central electron temperature =",0pf8.3," kev",/,5x,
     3      "density peaking factor =",f8.3,/,5x,
     4      "volume temperature peaking factor =",f8.3,/,5x,
     5      "density-weighted temp. peaking factor =",f8.3,/,5x,
     6      "pressure peaking factor =",f8.3,/,5x,"poloidal beta =",f8.4
     7      ,/,5x,"total beta =",f8.4,/,5x,"fast ion beta =",f8.4,/,5x,
     8      "plasma internal inductance =",f8.3,/,5x,
     9      "Effective charge =",f8.3)
 1530    format(' ',24x,"species ",i2,5x,"a =",f5.1,5x,"z =",f5.1,5x,
     1      "z*n(j)/n(e) =",f9.3,5x,"ti(0) =",f10.3," kev")
 1540    format('0',24x,"applied frequency =",f12.3," ghz",/25x,
     1      "wavelength =",f12.3," m")
c $$$$$$$  Altered by TK Mau on 11/19/91
 1550    format('0',2/,20x,"density and temperature profiles",2/,4x,
     1      "psi",9x,"bp/bt",9x,"q",11x,"ne",11x,"Te",11x,"Ti",/)
 1560    format(6(1x,e12.5))
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c ****   1570 format(1h ,5x,"psi =",e15.4,2x,"ni  =",e15.4,2x,"ti  =",
c ****       +   e15.4,2x,"ni  =",e15.4,2x,"ti  =",e15.4)
c ****   1580 format(1h ,5x,"psi =",e15.4,2x,"ni  =",e15.4,2x,"ti  =",
c ****       +   e15.4)
c ****   1590 format(1h0)
c
c ************ ************ ************ ************ ************
c
         return
c
c ************ ************ ************ ************ ************
c
      case (2)
c
c ************ ************ ************ ************ ************
c
c   print-out of the power deposition profiles
c
c ************ ************ ************ ************ ************
c
         zpwin = 0.
         zpwabs = pwtote
         zpwabs = zpwabs + sum(pwtoti(:nspec))
         zpwabs = zpwabs + sum(pwtotf(:nalfa))
c--------------Deleted 7/29/95  SCC
c     if((zpwabs/power).lt.1.e-6)   return
c
c  Peak electron and ion species densities and temperatures:
c
         write (iout, 2511) nspec, pne(1), (pni(1,k),k=1,nspec), pte(1)
     1      , (pti(1,k),k=1,nspec)
 2511    format("nspec=",i5,/,"den(0)=",4(2x,e16.4),/,"tem(0)=",4(2x,
     1      e16.4))
c
c  psi power deposition profiles
c
         write (iout, 2510)
         do n = 1, nprof
            write (iout, 2520) tpsi(n), pwe(n), (pwi(n,i),i=1,nspec), (
     1         pwal(n,j),j=1,nalfa)
         end do
c
c $$$$$$ Added by T.K. Mau on 10/17/91.
c
c     Output for ray tracing after RAYLH is modified.
c
         write (iout, 2521)
         do iy = 1, indgr
            write (iout, 2522) iy, fpwray(iy), fpowe(iy), frpowi(iy),
     1         frpowf(iy), curay(iy), effcd(iy)
         end do
         write (iout, 2523)
         do ip = 1, nprof
            write (iout, 2524) tpsi(ip), pwe(ip), pwit(ip), pwft(ip),
     1         pwct(ip)                          !,ajtrt(ip)
         end do
         write (iout, 2525) fpowt, ptot0, ftpowe, ftpi, ftpf, ftedge,
     1      currfe, currf1, currf2, currf, effcdt
c ---- Added by TK Mau on 10/28/91.
         write (iout, 2526) tcurr, fbsc, fdia, aiseed, powrq
c ----    TKM   09/99
         write (iout, 2529)
 2529    format("Total toroidal seed current at radial grids (MA)")
         write (iout, 2528) (aisdt(i),i=1,nprof)
c     write(iout,2527)
c2527 format("Bootstrap current, <J.B>_bs (A*T*m-2)")
c     write(iout,2528) (ajbsb(i),i=1,nprof)
 2528    format(5(e12.6,2x))
c
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c
c  spectral distribution
c
         write (iout, 2530)
         zpwyes = 0.
         do is = 1, isimm
            write (iout, 2500)
            nuk = nnkpar(is)
            do n = 1, nuk
               zpwyes = zpwyes + pwcpl(is,n)
               zpwab = pwcpl(is,n) - pwtra(is,n)
               if (zpwab<0. .and. abs(zpwab)<1.E-9) zpwab = 0.
               write (iout, 2540) anzin(is,n), pwcpl(is,n), zpwab, pwtra
     1            (is,n)
            end do
         end do
         zpwnab = zpwyes - zpwabs
c
c  global balance
c
         write (iout, 2550) power, zpwyes, zpwnab, zpwabs
         write (iout, 2560) pwtote
         write (iout, 2570) (i,pwtoti(i),i=1,nspec)
         write (iout, 2571) (k,pwtotf(k),k=1,nalfa)
c
c ************ ************ ************ ************ ************
c
 2510    format('0',20x,"power deposition profiles",2/,3x,"rho",6x,
     1      "electrons",8x,"ions",6x,"fast ions",/)
 2520    format(' ',f8.4,5(2x,e10.3))
c$$$$$$$$$$$$$$$$$$$$$$$$
c $$$$$$$$$$  Added by T.K. Mau on 10/17/91.
c
 2521    format('0',15x,"SUMMARY OF RAY TRACING RESULTS",2/,3x,"ray",5x,
     1      "P_ab/P_0",5x,"P_e/P_0",5x,"P_i/P_0",5x,"P_f/P_0",5x,
     2      "I_e(MA)",3x,"I/P(A/W)",/)
 2522    format(3x,i3,6(2x,e10.3))
 2523    format(//,'0',20x,"OVERALL RESULTS",2/,'0',30x,
     1      "Power Deposition & Current Profiles",2/,2x,"rho",2x,
     2      "P_e (W/cm**3)",2x,"P_i (W/cm**3)",2x,"P_f (W/cm**3)",2x,
     3      "j_rf (A/cm**2)",2x,"j_tar (A/cm**2)",/)
c2524 format(1x,f5.3,5(2x,e10.3))
 2524    format(1x,f5.3,4(2x,e10.3))
 2525    format(//,2x,"Fraction of power absorbed =",e10.3,/,2x,
     1      "Total incident power (MW) =",e10.3,/,2x,
     2      "Fraction of power to electrons =",e10.3,/,2x,
     3      "Fraction of power to ions      =",e10.3,/,2x,
     4      "Fraction of power to fast ions =",e10.3,/,2x,
     5      "Fraction of power to edge      =",e10.3,/,2x,
     6      "Driven electron current (MA)   =",e10.3,/,2x,
     7      "Driven minority current (MA)   =",e10.3,/,2x,
     8      "Driven fast ion current (MA)   =",e10.3,/,2x,
     9      "Total driven RF current (MA)   =",e10.3,/,2x,
     .      "Total current-drive efficiency (A/W) =",e10.3)
c ---- Added by TK Mau on 10/28/91.
 2526    format(//,2x,"Total plasma current (MA)    =",e13.3,/,2x,
     1      "Bootstrap current fraction   =",e13.3,/,2x,
     2      "Diamagnetic current fraction =",e13.3,/,2x,
     3      "Seed currents (MA)",/,2x,5(e10.4,2x),/,2x,5(e10.4,2x),/,2x,
     4      "Current drive power (MW)     =",e13.3)
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
 2530    format('0',2/,40x,"spectre of the non-absorbed power",/)
 2500    format('0')
 2540    format(' ',5x,"n par =",1pe13.3,5x,"coup. power  =",e13.3,5x,
     1      "absorbed =",e13.3,5x,"non absorbed =",e13.3,5x,"mw")
 2550    format('0',/40x,"total power balance",/,21x,
     1      "launched power          =",1pe13.3," MW",/21x,
     2      "within n par. range     =",e13.3," MW",/21x,
     3      "non-absorbed            =",e13.3," MW",/21x,
     4      "absorbed by the plasma   ",e13.3," MW")
 2560    format(' ',20x,"total power to the electrons =",e14.4," MW.")
 2570    format(' ',20x,"            to species",i6," =",e14.4," MW.")
 2571    format(' ',20x,"       to fast species",i6," =",e14.4," MW")
c
c ************ ************ ************ ************ ************
c
         return
c $$$$$ Added by TK Mau on 11/19/91
c
      case (3)
         jprt = iabs(iprint)
         write (iout, 2580) indgr, jprt
c     do 240 ir = 1,isimpl(indgr),jprt
         do ir = 1, irec, jprt
            write (iout, 2581) rec13(ir), rec4(ir), rec5(ir), rec14(ir)
     1         , rec12(ir), rec7(ir), rec8(ir)
c     write(iout,2581) sene(ir),skpar(ir),skp(ir),swkve(ir),sbtot(ir),
c    &                 salphac(ir),salphal(ir)
         end do
 2580    format("*** Condensed info on ray ",i3," every ",i3,
     1      " time-steps",2/,3x,"dene",6x,"N_par",6x,"Nper2",6x," Te ",
     2      6x,"w/wci",6x,"game",6x,"gami",/)
 2581    format(2(1x,f9.5),1x,e12.4,2(1x,f9.5),2(1x,e10.3))
         return
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c**************SCC  5/3/95
c
      case (4)
         write (iout, 2590)
 2590    format(//
     1      'The following sums up contribution of all FW sources:'//)
         write (iout, 2510)
         do n = 1, nprof
            write (iout, 2520) tpsi(n), pwe(n), (pwi(n,i),i=1,nspec)
         end do
         write (iout, 2523)
         do ip = 1, nprof
            write (iout, 2524) tpsi(ip), pwe(ip), pwit(ip), pwc(ip)
         end do
         write(iout,2525)fpowt,ptot0,ftpowe,ftpi,ftedge,currf,effcdt
         write (iout, 2526) tcurr, fbsc
         return
      end select
      end subroutine outrun
c
      subroutine rayinout(inout)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:56:19   6/14/01
C...Switches: -p4 -yb
c
c ************ ************ ************ ************ ************
c
c Inputs or outputs ray data using file rayop.
c   inout = 1, input data
c           2, output data.
c  from R.Harvey for interface with CQL
c
c ************ ************ ************ ************ ************
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      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, iout2, nharm, tcurr, fbsc
      use Viogrl, ONLY: calfa, px, sumpx, bk, refl, rtot, trans,
     1   aksupw, ddk, nnk, joutrf, ireout, jumpw, jtest, ispec, ngra,
     2   itrans, radius, freqcy, heigth
      use Vcraylh
      use Vcmnew, ONLY: wpi1c, wpi2c, wci1c, wci2c, wpi2, wci2, wci,
     1   conci, aziomi, rtzom, ay2, ay1, trate, tratte, ttle, concte,
     2   trati, tratti, ttli, concti, vdrfte, vdrfti, infi, gprm, cxet,
     3   czt, cztp, czetai, czi, czip, czetat, czti, cztip, cth, npar,
     4   nper, upar, uper, umax, dsfe, dsfi, fper2, fpar2, fpp2, intg,
     5   inc, incf, tnmaxe, tnmaxi, idrive, binb, boutb, boutbrd,
     6   binbrd, epsl, binbd, epsil, dlob, wte, eta0, eta, rprof,
     7   amprof, cprof, xjop, vloop, kboot, mboot, btbsp, ftbsps, pde,
     8   pdec, pdi, pdf, pwce, pwcm, pwcf, pwc, pwc1, pwc2, pwct,
     9   pwct1, pwct2, pwc0, pwcray, pwc1ray, pwc2ray, pweray, pwiray,
     .   pwfray, currf, currfe, currf1, currf2, curay, curay1, curay2,
     1   fpwray, fpowe, fpowf, fpowi, pwte0, pwti0, effcd, effcdt,
     2   ptot, ftpowe, ftpowi, ftpowf, ftpi, ftpf, ftedge, pwedge,
     3   wfrac, pwxwl, frpowi, frpowf, frpow, pwit, pwft, ptedge,
     4   ptot0, fpowt, tpowi, tpowf, wfrac0, ebkev, bmpwr, azf, atmf,
     5   densa, kalfa, nalfa, nharm0, pnfi, pnf, zetab, tnf, ecrit,
     6   taua0, wca, gamal, gamat, ibeam, abeam, dbeam, aneb, enbeam,
     7   wbeam, temsa, ptfi, ttf, wpf2c, wpf2, wcf2c, wcf1c, wcf2, wcf,
     8   cxc, czc, cy, denfa, eav, tausd, tau0, paf, sordt, ecrita,
     9   betaf, nminor
      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 Vchpcsd, ONLY: irec, rec0, rec1, rec2, rec3, rec4, rec5,
     1   rec6, rec7, rec8, rec9, rec10, rec11, rec12, rec13, rec14,
     2   rec15
      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
      use kind_spec

      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 inout
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, k, m, m1
      real(kind=dp), dimension(npdim) :: scratch
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c  Storage related to EQDSK:
c  Units used in the EQDSK are entirely MKSA.
c  Comeqdsk-->ceqdsk.i

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
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
      select case (inout)
c
c Open rayop using Basis sub.  This will destroy an existing rayop file.
c**bh iout2=fopen("rayop","write")
c
c     Write header lines
c
c
c
c     Write out ray data:
c
c $$$$$$$$$  Added by T.K. Mau on 10/10/91.
      case default
 1001    format(2i5,1pe16.9,i5)
c $$$$$$$$$$$$$$$$$$$$$
 1002    format(5(1pe16.9))
 1003    format(9i6)
c
c $$$$$$$$$$  Modified by T.K. Mau, 10/10/91.
         if (irayio /= 0) then
            write (iout2, 1001) indgr, nharm, freqcy
         else
            write (iout2, 1001) indgr, nharm, freqcy, nprof
c       write(iout2,1003)  nminor,kalfa,nalfa
            write (iout2, 1001) nminor, kalfa, raxmag, nalfa
            write (iout2, 1003) kboot, ncontr(nprof)
         endif
         return
c $$$$$$$$$$$$$$
c
      case (2)
c
         j = indgr
         write (iout2, 1003) isimpl(j), jslofas(j), nurefls(j), keiks(j)
     1      , jpes(j), jpis(j), istarts(j), iprmt5(j), jhlfs(j)
         write (iout2, 1002) sxx(j), skpsi(j), skth(j), skphi(j)
         scratch(:isimpl(j)) = 1.E2*spol(:isimpl(j))
         write (iout2, 1002) (scratch(i),i=1,isimpl(j))
         write (iout2, 1002) (seikon(i),i=1,isimpl(j))
         write (iout2, 1002) (spsi(i),i=1,isimpl(j))
         scratch(:isimpl(j)) = 1.E2*(raxmag + sxu(:isimpl(j)))
         write (iout2, 1002) (scratch(i),i=1,isimpl(j))
         scratch(:isimpl(j)) = 2.*3.141592654*sphi(:isimpl(j))
         write (iout2, 1002) (scratch(i),i=1,isimpl(j))
         scratch(:isimpl(j)) = 1.E2*szu(:isimpl(j))
         write (iout2, 1002) (scratch(i),i=1,isimpl(j))
         write (iout2, 1002) (skpar(i),i=1,isimpl(j))
         write (iout2, 1002) (skp(i),i=1,isimpl(j))
         scratch(:isimpl(j)) = 1.E13*spower(:isimpl(j))
         write (iout2, 1002) (scratch(i),i=1,isimpl(j))
         scratch(:isimpl(j)) = 1.E13*sdpwri(:isimpl(j))
         write (iout2, 1002) (scratch(i),i=1,isimpl(j))
c     do 1051 i = 1,isimpl(j)
c1051 scratch(i) = 1.e13*sdpwrf(i,j)
c     write(iout2,1002)  (scratch(i),i=1,isimpl(j))
         write (iout2, 1002) (sdkpar(i),i=1,isimpl(j))
         write (iout2, 1002) (scepx(i),i=1,isimpl(j))
         write (iout2, 1002) (scepy(i),i=1,isimpl(j))
         write (iout2, 1002) (scepz(i),i=1,isimpl(j))
         write (iout2, 1002) (sztpol(i),i=1,isimpl(j))
         scratch(:isimpl(j)) = 1.E4*sbtot(:isimpl(j))
         write (iout2, 1002) (scratch(i),i=1,isimpl(j))
c $$$$  TK Mau   10/3/94
c     do 107  i=1,isimpl(j)
c107  scratch(i)=1.e4*sbout(i,j)
c     write(iout2,1002)  (scratch(i),i=1,isimpl(j))
c     write(iout2,1002)  (srpsi(i,j),i=1,isimpl(j))
         if (irayio == 0) write (iout2, 1002) (swkve(i),i=1,isimpl(j))
         write (iout2, 1002) (sene(i),i=1,isimpl(j))
         write (iout2, 1002) (salphac(i),i=1,isimpl(j))
         write (iout2, 1002) (salphal(i),i=1,isimpl(j))
c     write(iout2,1002)  (spoyntn(i,j),i=1,isimpl(j))
         if (irayio == 0) then
c $$$$$$$  Added by T.K. Mau on 10/10/91.
            write (iout2, 1002) (pweray(i,indgr),i=1,nprof)
            write (iout2, 1002) (pwcray(i,indgr),i=1,nprof)
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$
         endif
         return
c
c
      case (3)
         if (irayio == 0) then
c $$$$$$$$$ Added by T.K. Mau on 10/10/91.
            write (iout2, 1002) (ppsi(i),i=1,nprof)
            write (iout2, 1002) (psinm(i),i=1,nprof)
            write (iout2, 1002) (volume(i),i=1,nprof)
            write (iout2, 1002) (pwe(i),i=1,nprof)
            write (iout2, 1003) nspec
c******************SCC  4/13,95
            do k = 1, nspec
               write (iout2, 1002) (pwi(i,k),i=1,nprof)
               write (iout2, 1002) (pwiv(i,k),i=1,nprof)
            end do
            if (kalfa > 0) then
               do k = 1, nalfa
                  write (iout2, 1002) (pwal(i,k),i=1,nprof)
               end do
            endif
            write (iout2, 1002) (pwev(i),i=1,nprof)
c*****************************
            write (iout2, 1002) (pwit(i),i=1,nprof)
            write (iout2, 1002) (pwft(i),i=1,nprof)
            write (iout2, 1002) (pwc(i),i=1,nprof)
            write (iout2, 1002) (pwct(i),i=1,nprof)
            if (nminor > 0) write (iout2, 1002) (pwct1(i),i=1,nprof)
            if (kalfa > 0) write (iout2, 1002) (pwct2(i),i=1,nprof)
c ----- Added by TK Mau on 10/25/91
            if (kboot /= 0) then
c     write(iout2,1002) (pni(i,1),i=1,nprof)
c     write(iout2,1002) (pni(i,nspec),i=1,nprof)
c     write(iout2,1002) (pti(i,1),i=1,nprof)
c     write(iout2,1002) (pti(i,nspec),i=1,nprof)
c     write(iout2,1002) (tani(i),i=1,nprof)
               write (iout2, 1002) (ajtb(i),i=1,nprof)
               write (iout2, 1002) (ajbsb(i),i=1,nprof)
               write (iout2, 1002) (ajbst(i),i=1,nprof)
               write (iout2, 1002) (ajtrb(i),i=1,nprof)
               write (iout2, 1002) (ftrp(i),i=1,nprof)
               write (iout2, 1002) (ajtar(i),i=1,nprof)
               write (iout2, 1002) (ajdit(i),i=1,nprof)
               write (iout2, 1002) (ajtor(i),i=1,nprof)
            endif
            write (iout2, 1002) (pne(i),i=1,nprof)
            write (iout2, 1002) (pte(i),i=1,nprof)
c*****************SCC  5/3/95
            write (iout2, 1002) fpowt, ptot0, ftpowe, ftpi, ftedge,
     1         currf, effcdt, tcurr, fbsc
c $$$$$$$$$$$$$$$$$$$$$$
c $$$$$    TK Mau   12/6/94
            write (iout2, 1002) (rmd(i),i=1,2*nprof - 1)
            write (iout2, 1002) (btmd(i),i=1,2*nprof - 1)
            write (iout2, 1002) (bpmd(i),i=1,2*nprof - 1)
c     endif
c $$$$    TK Mau    7/95
c     if(irayio.eq.0.and.kalfa.gt.0) then
            if (kalfa > 0) then
               write (iout2, 1002) (paf(i),i=1,nprof)
               write (iout2, 1002) (ppra(i,1),i=1,nprof)
               write (iout2, 1002) (denfa(i),i=1,nprof)
               write (iout2, 1002) (eav(i),i=1,nprof)
               write (iout2, 1002) (ecrita(i),i=1,nprof)
            endif
c
c $$$$$$    TK Mau   10/27/98
c Read information about plasma shape
            write (iout2, 1002) (xcontr(i,nprof),i=1,ncontr(nprof))
            write (iout2, 1002) (zcontr(i,nprof),i=1,ncontr(nprof))
            write (iout2, 1002) xeqd(1), xeqd(nxeqd), zeqd(1), zeqd(
     1         nzeqd)
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c $$$$$$    TK Mau   1/3/00
c  Mod(B) in (R,Z) space for cyclotron resonance surface plot
            write (iout2, 1003) nxeqd, nzeqd
            write (iout2, 1002) ((bmod(i,j),i=1,nxeqd),j=1,nzeqd)
            do m = 1, 5
               m1 = int((nprof - 1)*float(m - 1)/float(m)) + 1
               if (m1 == 1) m1 = m1 + 1
               write (iout2, 1003) ncontr(m1)
               write (iout2, 1002) (xcontr(i,m1),i=1,ncontr(m1))
               write (iout2, 1002) (zcontr(i,m1),i=1,ncontr(m1))
            end do
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c
         endif
c
         return
c
c
c     Read data from file rayop
      case (4)
c**bh iout2=fopen("rayop","read")
c
c     Skip over header
c**bh read(iout2,1000)
c     Read and restore data
c $$$$$$$$  Modified by T.K. Mau on 10/10/91.
         if (irayio /= 0) then
            read (iout2, 1001) indgr, nharm, freqcy
         else
            read (iout2, 1001) indgr, nharm, freqcy, nprof
            read (iout2, 1003) nminor, kalfa, nalfa
c       read(iout2,1001)  nminor,kalfa,raxmag,nalfa
         endif
         return
c $$$$$$$$$$$$$$$$$$$$$
      case (5)
c
         j = nrayno
         read (iout2, 1003) isimpl(j), jslofas(j), nurefls(j), keiks(j)
     1      , jpes(j), jpis(j), istarts(j), iprmt5(j), jhlfs(j)
         read (iout2, 1002) sxx(j), skpsi(j), skth(j), skphi(j)
         read (iout2, 1002) (scratch(i),i=1,isimpl(j))
         spol(:isimpl(j)) = 1.E-2*scratch(:isimpl(j))
         read (iout2, 1002) (seikon(i),i=1,isimpl(j))
         read (iout2, 1002) (spsi(i),i=1,isimpl(j))
         read (iout2, 1002) (scratch(i),i=1,isimpl(j))
         sxu(:isimpl(j)) = 1.E-2*scratch(:isimpl(j)) - raxmag
         read (iout2, 1002) (scratch(i),i=1,isimpl(j))
         sphi(:isimpl(j)) = scratch(:isimpl(j))/(2.*3.141592654)
         read (iout2, 1002) (scratch(i),i=1,isimpl(j))
         szu(:isimpl(j)) = 1.E-2*scratch(:isimpl(j))
         read (iout2, 1002) (skpar(i),i=1,isimpl(j))
         read (iout2, 1002) (skp(i),i=1,isimpl(j))
         read (iout2, 1002) (scratch(i),i=1,isimpl(j))
         spower(:isimpl(j)) = 1.E-13*scratch(:isimpl(j))
         read (iout2, 1002) (scratch(i),i=1,isimpl(j))
         sdpwri(:isimpl(j)) = 1.E-13*scratch(:isimpl(j))
c     read(iout2,1002)  (scratch(i),i=1,isimpl(j))
c     do 2051  i=1,isimpl(j)
c2051 sdpwrf(i,j) = 1.e-13*scratch(i)
         read (iout2, 1002) (sdkpar(i),i=1,isimpl(j))
         read (iout2, 1002) (scepx(i),i=1,isimpl(j))
         read (iout2, 1002) (scepy(i),i=1,isimpl(j))
         read (iout2, 1002) (scepz(i),i=1,isimpl(j))
         read (iout2, 1002) (sztpol(i),i=1,isimpl(j))
         read (iout2, 1002) (scratch(i),i=1,isimpl(j))
         sbtot(:isimpl(j)) = 1.E-4*scratch(:isimpl(j))
c     read(iout2,1002)  (scratch(i),i=1,isimpl(j))
c $$$$  TK Mau   10/3/94
c     do 207  i=1,isimpl(j)
c207  sbout(i,j)=1.e-4*scratch(i)
c     read(iout2,1002) (srpsi(i,j),i=1,isimpl(j))
         read (iout2, 1002) (swkve(i),i=1,isimpl(j))
         read (iout2, 1002) (sene(i),i=1,isimpl(j))
         read (iout2, 1002) (salphac(i),i=1,isimpl(j))
         read (iout2, 1002) (salphal(i),i=1,isimpl(j))
c     read(iout2,1002)  (spoyntn(i,j),i=1,isimpl(j))
         if (irayio == 0) then
c $$$$$$$$$$  Added by T.K. Mau on 10/10/91.
            read (iout2, 1002) (pweray(i,j),i=1,nprof)
            read (iout2, 1002) (pwcray(i,j),i=1,nprof)
c $$$$$$$$$$$$$$$$$$$$$
         endif
         return
c**bh call fclose(iout2)
c
      case (6)
         if (irayio == 0) then
c $$$$$$$$$$ Added by T.K. Mau on 10/10/91.
            read (iout2, 1002) (ppsi(i),i=1,nprof)
            read (iout2, 1002) (psinm(i),i=1,nprof)
            read (iout2, 1002) (volume(i),i=1,nprof)
            read (iout2, 1002) (pwe(i),i=1,nprof)
            read (iout2, 1003) nspec
c******************SCC  4/13,95
            do k = 1, nspec
               read (iout2, 1002) (pwi(i,k),i=1,nprof)
               read (iout2, 1002) (pwiv(i,k),i=1,nprof)
            end do
            if (kalfa > 0) then
               do k = 1, nalfa
                  read (iout2, 1002) (pwal(i,k),i=1,nprof)
               end do
            endif
            read (iout2, 1002) (pwev(i),i=1,nprof)
c*****************************
            read (iout2, 1002) (pwit(i),i=1,nprof)
            read (iout2, 1002) (pwft(i),i=1,nprof)
            read (iout2, 1002) (pwc(i),i=1,nprof)
            read (iout2, 1002) (pwct(i),i=1,nprof)
            if (nminor > 0) read (iout2, 1002) (pwct1(i),i=1,nprof)
            if (kalfa > 0) read (iout2, 1002) (pwct2(i),i=1,nprof)
c ----- Added by TK Mau on 10/25/91
            if (kboot /= 0) then
               read (iout2, 1002) (ajtb(i),i=1,nprof)
               read (iout2, 1002) (ajbsb(i),i=1,nprof)
               read (iout2, 1002) (ajbst(i),i=1,nprof)
               read (iout2, 1002) (ajtrb(i),i=1,nprof)
               read (iout2, 1002) (ftrp(i),i=1,nprof)
               read (iout2, 1002) (ajtar(i),i=1,nprof)
               read (iout2, 1002) (ajdit(i),i=1,nprof)
               read (iout2, 1002) (ajtor(i),i=1,nprof)
            endif
            read (iout2, 1002) (pne(i),i=1,nprof)
            read (iout2, 1002) (pte(i),i=1,nprof)
c******************SCC  5/3/95
            read (iout2, 1002) fpowt, ptot0, ftpowe, ftpi, ftedge, currf
     1         , effcdt, tcurr, fbsc
            read (iout2, 1002) (rmd(i),i=1,2*nprof - 1)
            read (iout2, 1002) (btmd(i),i=1,2*nprof - 1)
            read (iout2, 1002) (bpmd(i),i=1,2*nprof - 1)
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
         endif
c $$$$    TK Mau    7/95
         if (irayio==0 .and. kalfa>0) then
            read (iout2, 1002) (paf(i),i=1,nprof)
            read (iout2, 1002) (ppra(i,1),i=1,nprof)
            read (iout2, 1002) (denfa(i),i=1,nprof)
            read (iout2, 1002) (eav(i),i=1,nprof)
            read (iout2, 1002) (ecrita(i),i=1,nprof)
         endif
c
         return
      end select
      end subroutine rayinout
      subroutine rtinout(inout)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:56:19   6/14/01
C...Switches: -p4 -yb
c
c ************ ************ ************ ************ ************
c
c Inputs or outputs data for coupling to ONETWO transport code.
c (But may be useful for stand alone operation).
c   inout = 1, input data
c           2, output data.
c         3,  read spectrum from spectrm.dat
c
c ************ ************ ************ ************ ************
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      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, iout1, iout2, nharm, tcurr, fbsc, rzero,
     2   rplasm,  bzero, qsaf0, qsafa, polasp
      use Viogrl, ONLY: calfa, px, sumpx, bk, refl, rtot, trans,
     1   aksupw, ddk, nnk, joutrf, ireout, jumpw, jtest, ispec, ngra,
     2   itrans, radius, freqcy, isimm, heigth
      use Vcraylh
      use Vcmnew, ONLY: wpi1c, wpi2c, wci1c, wci2c, wpi2, wci2, wci,
     1   conci, aziomi, rtzom, ay2, ay1, trate, tratte, ttle, concte,
     2   trati, tratti, ttli, concti, vdrfte, vdrfti, infi, gprm, cxet,
     3   czt, cztp, czetai, czi, czip, czetat, czti, cztip, cth, npar,
     4   nper, upar, uper, umax, dsfe, dsfi, fper2, fpar2, fpp2, intg,
     5   inc, incf, tnmaxe, tnmaxi, idrive, binb, boutb, boutbrd,
     6   binbrd, epsl, binbd, epsil, dlob, wte, eta0, eta, rprof,
     7   amprof, cprof, xjop, vloop, kboot, mboot, btbsp, ftbsps, pde,
     8   pdec, pdi, pdf, pwce, pwcm, pwcf, pwc, pwc1, pwc2, pwct,
     9   pwct1, pwct2, pwc0, pwcray, pwc1ray, pwc2ray, pweray, pwiray,
     .   pwfray, currf, currfe, currf1, currf2, curay, curay1, curay2,
     1   fpwray, fpowe, fpowf, fpowi, pwte0, pwti0, effcd, effcdt,
     2   ptot, ftpowe, ftpowi, ftpowf, ftpi, ftpf, ftedge, pwedge,
     3   wfrac, pwxwl, frpowi, frpowf, frpow, pwit, pwft, ptedge,
     4   ptot0, fpowt, tpowi, tpowf, wfrac0, ebkev, bmpwr, azf, atmf,
     5   densa, kalfa, nalfa, nharm0, pnfi, pnf, zetab, tnf, ecrit,
     6   taua0, wca, gamal, gamat, ibeam, abeam, dbeam, aneb, enbeam,
     7   wbeam, temsa, ptfi, ttf, wpf2c, wpf2, wcf2c, wcf1c, wcf2, wcf,
     8   cxc, czc, cy, denfa, eav, tausd, tau0, paf, sordt, ecrita,
     9   betaf
      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, nraypts
      use Vchpcsd, ONLY: irec, rec0, rec1, rec2, rec3, rec4, rec5,
     1   rec6, rec7, rec8, rec9, rec10, rec11, rec12, rec13, rec14,
     2   rec15
      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, codeid, ieqdsk, lrza
      use kind_spec

      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 inout
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 :: nrt, j, i, k, n, l
      real(kind=dp) :: kappa, dra, zdecay
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
c  Storage related to EQDSK:
c  Units used in the EQDSK are entirely MKSA.
c  Comeqdsk-->ceqdsk.i

c
c $$$$$$$$$  Added b y T.K. Mau on 10/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
c
      select case (inout)


c  Read wave input data pertaining to ray initial conditions,
c  and plasma equilibria (relevant for analytic equilibria):
      case default
         read (iout1, 1000) freqcy, nraypts, nrt, codeid
         read (iout1, 1001) (powers(j),j=1,nrt)
         read (iout1, 1003) (nnkpar(j),j=1,nrt)
         read (iout1, 1001) (anzinf(j),j=1,nrt)
         read (iout1, 1001) (anzsup(j),j=1,nrt)
         read (iout1, 1003) (nnkpol(j),j=1,nrt)
         read (iout1, 1001) (anpinf(j),j=1,nrt)
         read (iout1, 1001) (anpsup(j),j=1,nrt)
         read (iout1, 1002) nthin, maxref, islofa, heigth, thgril(1),
     1      tcurr, bzero
         read (iout1, 1001) rzero, rplasm, kappa, qsaf0, qsafa
c ********  Added by SCC on 11/1/91
         read (iout1, 1003) nprofs, itrans
         nprof = nprofs
         read (iout1, 1001) (radius(j),j=1,nprofs)
c **************************
 1000    format(1pe16.9,2i5,a8)
 1001    format(5(1pe16.9))
 1002    format(3i5,4(1pe16.9))
 1003    format(10i5)

         if (nrt > nspectm) nrt = isimm

c  Change units for some variables
         bzero = bzero/1.E4
         rzero = rzero/1.E2
         rplasm = rplasm/1.E2
         polasp(1) = kappa
         polasp(2) = kappa
c-----   TKM   05/00
         igrill = -1
         if (nnkpol(1) > 0) igrill = -3
c-------------
c
c  Use Brambilla analytic equibrium if codeid='onedee', else use
c  extended eqdsk.
         if (codeid == '  onedee') then
            ieqdsk = 0
         else
            ieqdsk = 4
         endif


c*************************************************************************
c     Continue reading if ieqdsk.eq.0, i.e., the eqdsk extension
c    has been written onto raytracing input file.
c*************************************************************************


         if (ieqdsk == 0) then
            read (iout1, 8210) nlim, nlimiter
c    if (nlim.ne.0) then
            read (iout1, 8200) (rlim(i),zlim(i),i=1,nlim)
            read (iout1, 8200) (rlimiter(i),zlimiter(i),i=1,nlimiter)
c     endif
c..................................................................
c     The following output is not part of the "official" eqdsk.
c..................................................................

            nti = 1
            read (iout1, 8210) lrz, nprim, nimp, nti
            if (lrz > lrza) stop 60
            nion = nprim + nimp
            read (iout1, 8200) (atm(k),k=1,nion)
            do k = 1, nion
               read (iout1, 8200) (zi(j,k),j=1,lrz)
            end do
            read (iout1, 8200) (zeffz(j),j=1,lrz)
            read (iout1, 8200) (r(j),j=1,lrz)
            read (iout1, 8200) (psifeqd(j),j=1,lrz)
            read (iout1, 8200) (te(j),j=1,lrz)
            do k = 1, nti
               read (iout1, 8200) (ti(j,k),j=1,lrz)
            end do
            read (iout1, 8200) (ene(j),j=1,lrz)
            do k = 1, nion
               read (iout1, 8200) (enp(j,k),j=1,lrz)
            end do

 8210       format(5i5)
 8200       format(5e16.9)


c     Put these variables into the ray tracing code format:
            nspec = nion
C
C*************************************  SCC   12/12/95
            azi(:nion) = zi(1,:nion)

            raeqd(:lrz) = r(:lrz)/r(lrz)
            ene(:lrz) = 1.E-6*ene(:lrz)
            enp(:lrz,:nion) = 1.E-6*enp(:lrz,:nion)

C
C
c--------SCC 8/18/94
            dra = 1./(nprofs - 1.)
            do j = 1, nprofs
               ra(j) = (j - 1.)*dra
            end do
c-----------------------

c     Initialize ne, te, ti profiles from plasma center to edge.

C
            call intrpp ('zero', 'free', raeqd, ene, lrz, ra, pne,
     1         nprofs)
            call intrpp ('zero', 'free', raeqd, te, lrz, ra, pte, nprofs
     1         )
c-------------------SCC  4/23/96
            call intrpp ('zero', 'free', raeqd, zeffz(1), lrz, ra, tzeff
     1         (1,1), nprofs)
c---------------------------
            do k = 1, nion
               call intrpp ('zero', 'free', raeqd, ti(1,k), lrz, ra, pti
     1            (1,k), nprofs)
               call intrpp ('zero', 'free', raeqd, enp(1,k), lrz, ra,
     1            pni(1,k), nprofs)
            end do
            do k = 1, nion
               conc(:nprofs,k) = pni(:nprofs,k)/pne(:nprofs)
            end do

c     Extend beyond plasma surface if iedge=1:
            if (iedge == 1) then
               do j = nprofs + 1, nprof
                  zdecay = exp((-float(j - nprofs)/2.))
                  pne(j) = pne(nprofs)*zdecay
                  pte(j) = pte(nprofs)*zdecay
                  pni(j,:nion) = pni(j,:nion)*zdecay
                  pti(j,:nion) = pti(j,:nion)*zdecay
                  conc(j,:nion) = pni(j,:nion)/pne(j)
               end do
            endif
C*****************************************************
C
C


         endif
         return



c   Non-circular case.
c   Write heating and current drive data produced by ray tracing code.

      case (2)
         write (iout1, 3000) nprofs, nspec
c ******  Altered by SCC on 11/1/91
c****  changed back to original by SCC  2/19/92
c------------------------- SCC  change to ra  2/20/92
c     write(iout1,3010) (ppsi(j),j=1,nprofs)
         write (iout1, 3010) (ra(j),j=1,nprofs)
         write (iout1, 3010) (pwe(j),j=1,nprofs)
         do n = 1, nspec
            write (iout1, 3010) (pwi(j,n),j=1,nprofs)
         end do
c *******************************************
         pwc(:nprofs) = -pwc(:nprofs)
         write (iout1, 3010) (pwc(j),j=1,nprofs)
 3000    format(2i5)
 3010    format(5(1pe19.6))

         return
c
c
      case (3)
         read (iout1, 2001) nspect
 2001    format(1x,i5)
         read (iout1, 2002) (nnkpar(j),j=1,nspect)
 2002    format(2x,4(1x,i4))
         do k = 1, nspect
            read (iout1, 2003) (anzin(k,l),l=1,nnkpar(k))
         end do
         do k = 1, nspect
            read (iout1, 2003) (pwcpl(k,l),l=1,nnkpar(k))
         end do
 2003    format(5(1x,e14.5))

         return
      end select
      end subroutine rtinout

c
      subroutine outgra(ientry)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:56:19   6/14/01
C...Switches: -p4 -yb
c
c ************ ************ ************ ************ ************
c
c interface for the output of graphs
c
c ************ ************ ************ ************ ************
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
!      use Vparam
      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, tcurr, rzero, rplasm
      use Viogrl, ONLY: calfa, px, sumpx, bk, refl, rtot, trans,
     1   aksupw, ddk, nnk, joutrf, ireout, jumpw, jtest, ispec, ngra,
     2   itrans, radius, freqcy
      use Vcraylh
      use Vcmnew, ONLY: wpi1c, wpi2c, wci1c, wci2c, wpi2, wci2, wci,
     1   conci, aziomi, rtzom, ay2, ay1, trate, tratte, ttle, concte,
     2   trati, tratti, ttli, concti, vdrfte, vdrfti, infi, gprm, cxet,
     3   czt, cztp, czetai, czi, czip, czetat, czti, cztip, cth, npar,
     4   nper, upar, uper, umax, dsfe, dsfi, fper2, fpar2, fpp2, intg,
     5   inc, incf, tnmaxe, tnmaxi, idrive, binb, boutb, boutbrd,
     6   binbrd, epsl, binbd, epsil, dlob, wte, eta0, eta, rprof,
     7   amprof, cprof, xjop, vloop, kboot, mboot, btbsp, ftbsps, pde,
     8   pdec, pdi, pdf, pwce, pwcm, pwcf, pwc, pwc1, pwc2, pwct,
     9   pwct1, pwct2, pwc0, pwcray, pwc1ray, pwc2ray, pweray, pwiray,
     .   pwfray, currf, currfe, currf1, currf2, curay, curay1, curay2,
     1   fpwray, fpowe, fpowf, fpowi, pwte0, pwti0, effcd, effcdt,
     2   ptot, ftpowe, ftpowi, ftpowf, ftpi, ftpf, ftedge, pwedge,
     3   wfrac, pwxwl, frpowi, frpowf, frpow, pwit, pwft, ptedge,
     4   ptot0, fpowt, tpowi, tpowf, wfrac0, ebkev, bmpwr, azf, atmf,
     5   densa, kalfa, nalfa, nharm0, pnfi, pnf, zetab, tnf, ecrit,
     6   taua0, wca, gamal, gamat, ibeam, abeam, dbeam, aneb, enbeam,
     7   wbeam, temsa, ptfi, ttf, wpf2c, wpf2, wcf2c, wcf1c, wcf2, wcf,
     8   cxc, czc, cy, denfa, eav, tausd, tau0, paf, sordt, ecrita,
     9   betaf
      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, ngdim, initlh
      use Vchpcsd, ONLY: irec, rec0, rec1, rec2, rec3, rec4, rec5,
     1   rec6, rec7, rec8, rec9, rec10, rec11, rec12, rec13, rec14,
     2   rec15, prmt, jhlf, y, serror
      use Vceqdsk
      use kind_spec

      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-----------------------------------------------
      integer, parameter :: ngd16 = 1
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: nmsp, k, j, i, l, n
      real(kind=dp) :: zpi, ztwpi
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
!      integer , EXTERNAL :: min0
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 $$$$$    TKM   03/00
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     parameter (ngd16 = 16*ngdim)
c********SCC  01/17/95    graphics to be done differently
c ************ ************ ************ ************ ************
c
      data zpi/3.14159265359/
      data ztwpi/6.28318530718/
c
c $$$$$      TKM    03/00
      data nmsp/2/
c $$$$$$$$$$$
c ********** ********** ********** ********** ********** **********
c
      select case (ientry)
c
c ********** ********** ********** ********** ********** **********
c
      case default
c
c ************ ************ ************ ************
c maximal dimension of the plot storage
c ************ ************ ************ ************
c
         nequip = min(npdim,nequip)
         nps = nequip
         if (igraph > 1) then
            ngr = min(ngdim,nthin)
         else
            ngr = min(ngdim,nnztot)
         endif
c ************ ************ ************ ************
c initialization of the plot storage
c ************ ************ ************ ************
         sdeqs = deykpr/(2.*zpi)
         if (initlh /= 1) then
            isimpl0(:ngdim) = 2
            isimpl(:ngdim) = 0
            seikon(:npdim) = 0.0
         endif
c
         kgraph = igraph
         kprof = nprof
         kwfr = jwfr
c  Initializing of power to ions between calls to outgra
         dpwri = 0.0
c
c ************ ************ ************ ************
c   storage for graphical output of the profiles
c ************ ************ ************ ************
c
         srtor = rzero
         srplas = rplasm
         sbaxis = baxis
         scurr = 1.E-6*tcurr
         sfreq = 1.E-9*freqcy
         spwer = power
         sdenc = denc*1.E-14
         stec = tempec
         satm(:nspec) = atm(:nspec)
         sazi(:nspec) = azi(:nspec)
         stic(:nspec) = pti(1,:nspec)
         sconc(:nspec) = conc(1,:nspec)
         sqc = pqr(1,1)
         sqa = pqr(nprof,1)
         if (iplopr == 0) return
         do l = 1, nprof
            sxh(l) = ppsi(l)
            sne(l) = pne(l)/denc
            ste(l) = pte(l)/tempec
            sti(l,:nspec) = pti(l,:nspec)/stic(:nspec)
            sni(l,:nspec) = pni(l,:nspec)/denc
            sqr(l) = pqr(l,1)/sqa
         end do
         return
c
c ************ ************ ************ ************ ************
c
      case (2)
c
c ************ ************ ************ ************
c   storage for graphical output of the results
c ************ ************ ************ ************
         isimpl(indgr) = isxz
c  plot tables complete
         if (isxz >= nps) prmt(5) = 1.
         seikon(isxz) = eikon
         spsi(isxz) = psi
         sxu(isxz) = xu
         szu(isxz) = zu
         skp(isxz) = pkp
         skpar(isxz) = pkpar
c*****     TKM    2/97
         swkve(isxz) = xe
c******************************
c---------------SCC  7/9/95
         spkpsi(isxz) = pkpsi
         sakpsi(isxz) = y(1)
         sakth(isxz) = y(3)
c---------------------------
c
         stheta(isxz) = y(4)
         sphi(isxz) = y(5)/ztwpi
         spower(isxz) = pwx

c***********************************************************
c  Added for coupling to cql3d
c***********************************************************
         jslofas(indgr) = jslofa
         nurefls(indgr) = nurefl
         keiks(indgr) = keik
         jpes(indgr) = jpe
         jpis(indgr) = jpi
         istarts(indgr) = istart
         iprmt5(indgr) = prmt(5)
         jhlfs(indgr) = jhlf
         skpsi(indgr) = y(1)
         skth(indgr) = y(3)
         skphi(indgr) = anphi
         sxx(indgr) = xx
         sbtot(isxz) = btot
         sene(isxz) = dense
c $$$$$     TKM    03/00
         salphac(isxz) = game
         salphal(isxz) = gami(nmsp)
c     salphac(isxz)=alphac
c     salphal(isxz)=alphal
c $$$$$$$$$$$$$$$
         sdpwri(isxz) = dpwri
c  Resetting dpwri to zero, hence accumulating power deposition to the
c    ions in the subsequent ray element:
         dpwri = 0.0
         if (isxz == 1) then
            spol(isxz) = 0.0
         else
            spol(isxz) = sqrt((sxu(isxz-1)-xu)**2+(szu(isxz-1)-zu)**2)
     1          + spol(isxz-1)
         endif
         if (nnkpar(isign) == 0) then
            sdkpar(isxz) = 0.0
         else
            sdkpar(isxz) = (anzsup(isign)-anzinf(isign))/nnkpar(isign)/(
     1         acostq - pkheta/pkpar*asintq)*(sxu(1)+rzero)/(xu + rzero)
            sdkpar(isxz) = abs(sdkpar(isxz))
         endif
         scepx(isxz) = cepx
         scepy(isxz) = cepy
         scepz(isxz) = cepz
c $$$$$      TKM    03/00
c  To display kperp*rhoi for resonant species for NSTX runs
         sztpol(isxz) = 0.707*pkp*vti(nmsp)/wci(nmsp)
c     sztpol(isxz) = sqrt(ztpsi*ztpsi + zttau*zttau)
c $$$$$$$$$$$$$$
         sjslofa(isxz) = jslofa
         serrors(isxz) = serror
c***********************************************************************

         return
c
c ************ ************ ************ ************ ************
c
      case (3)
c
c ************ ************ ************ ************
c   storage for graphical output of the power
c           deposition profiles
c ************ ************ ************ ************
c
         nspie = nspec + 1
         spwmax = 0.
         do n = 1, nprof
            sxh(n) = ppsi(n)
            spw(n,nspie) = pwe(n)
            spwmax = max(spwmax,pwe(n))
            spw(n,:nspec) = pwi(n,:nspec)
            spwmax = max(spwmax,maxval(spw(n,:nspec)))
         end do
c
c ************ ************ ************ ************

         return

c output of graphs
c ************ ************ ************ ************
c
c            call gtitle
c      if(iplopr.eq.0)  go to 50
c            call grprof
c   50 continue
c            call gcross
c      if(kgraph.eq.-999) go to 9990
c      do 60  nxvarb=1,2
c            call gscale
c      do 60  nyvarb=1,8
c      if(iploxy(nxvarb,nyvarb).eq.0) go to 60
c            call gkappa
c   60 continue
c   70       call grapow
c      return
 9980    format('0',20x,"further plots aborted for lack of points")
         return
      end select
      end subroutine outgra
c
c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c
      subroutine op_file(i_unit)
      use Vparam
      use Vcraylh
      use Viorlh
      use Vceqdsk
      use kind_spec
      
      implicit none 

      integer :: i_unit
c
      select case (i_unit)
      case default
      iout = 6
      iounit1 = 7
      iout0 = 9
      iout2 = 12
      iout3 = 13
      iout4 = 14
      iout5 = 15
      iout6 = 16
      iout7 = 17
      iout8 = 18
      iout1 = 21
     
      case(1)
         iout = iounit(i_unit)
         open(iout, file='currayout', status='unknown')

      case(2)
         iout2 = iounit(i_unit)            
         open(iout2, file='rayop', status='unknown')

      case(3)
         iout3 = iounit(i_unit)
         if (icurdr == 1) then
            open(iout3, file='adjinp', status='unknown')
         else
            open(iout3, file='adjinp', status='old')
         endif

      case(4)
         iout4 = iounit(i_unit)
         open(iout4, file='scrach', status='unknown')

      case(5)
         iout5 = iounit(i_unit)
         if (icurdr == 1) then
            open(iout5, file='adjout', status='unknown')
         else
            open(iout5, file='adjout', status='old')
         endif

      case(6)
         iout6 = iounit(i_unit)
         open(iout6, file='joptab', status='unknown')

      end select
      return
      end subroutine op_file
