c
c  This module contains routines initializing data
c
c------------------------------------------------------
c
      subroutine bram
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:55:53   6/14/01  
C...Switches: -p4 -yb
 
c ************ ************ ************ ************ ************
c
c   routine to set initial values of many variables
c   BRAM  for 'M. Brambilla' who wrote the original version
c   for lower hybrid waves.
c
c ************ ************ ************ ************ ************
c
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Viogrl
      use Viorlh
      use Vcraylh
!      use Viogrl, ONLY: calfa, px, sumpx, bk, refl, rtot, trans, 
!     1   aksupw, ddk, nnk, joutrf, ireout, jumpw, jtest, ispec, ngra, 
!     2   freqcy, width, dwall, heigth, dnedge, dndx, dxpl, phmin, phmax,
!     3   itrans, radius, nwguid, nmod, nphase, isimm, ndim0, ndim1
!      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, iout, iout1, iout2, nharm, nequil, isafa,
!     4   polasp
      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i, jout6, npart, nx, ny, j, ifrang
      real :: anzacc, edgabs, bzedge, aksups, zpsi, zdpsi, zdivne, 
     1   zdivte, zne, zti, zdecay, zdivni, zdivti
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real,EXTERNAL::furmaj,furrho,futria,fuelon,prone,prote,proti
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   common block for Comraylh
c-------------------------
c
c
c$$$$$$$$     TKM    11/98
c*********    TKM   2/97, 6/99, 9/99
c*********    TKM   2/97
c*******   TK Mau   8/98
c*************************
c  SCC  3/7/95
 
c
c ************ ************ ************ ************ ************
c
c      call dropfile(0)
c
c  title & date
c
      write (iout, 5000)
 5000 format('***',2x,"FW/SW raytracing code with current drive",/,5x,
     1   "Derived from RAYLH                 ",/,5x,
     2   "By Brambilla:22/11/85, BH:10/4/90, TKM/SCC/BH:11/21/91",/)
c
c ===============================================
c  plasma parameters
c ===============================================
c  toroidal magnetic field on axis (tesla)
      bzero = 2.17
      btsign = 1.
c  main and plasma radius (m)
      rzero = 1.68
      rplasm = 0.39
c  toroidal current (a)
      tcurr = 3.20E5
c  central electron density (cm-3)
c  from parameterization if <= 0
c      ignored if ifrang not equal to 0
      denc = 2.E13
c ------------------------------ (main only)
c  specify central (ifrang=0) or line averaged (ifrang=1) density
c      ifrang = -1 for exponentially parametrized profiles
c      if ifrang>0 specify the density per frange zdnfrg (cm-3)
C        ifrang = 0
C        zdnfrg = 1.4e18
c  simulation of the scrape-off layer (iedge=1)
c        iedge = 0
c ------------------------------ (end)
c  central electron temperature (kev)
c  from parameterization if <= 0
c      ignored if ifrang not equal to 0
      tempec = 1.200
c  n.of ion species  (up to nions species allowed)
      nspec = 1
c  reference species
      mainsp = 1
c  mass and charges (atomic units)
      atm(1) = 2.
      azi(1) = 1.
c        atm(2) = 1.
c        azi(2) = 1.
c  concentrations conc(j,nsp)=n(j,nsp)/conc(j,nsp)=n(e); charge neutrality will be
 
c          implemented by re-evaluating n(j,nsp)
c  central ion temperatures (kev)
c  all ion species will have same temperature;
c  if they are different, one should input from curray_go or eqdskex
      tempic(1) = 0.9
c        tempic(2) = 20.
c  nprof = n. of points in the radial profile
c      accepted if 11 <= nprof <= nprofn
c**bh    nprof = 41
c  specify here if a standard case has to be run:
c        nequil=1 - data entered by the user
c                   (equilibrium code or diagnostic)
c        nequil=0 - circular or elliptic cross-section
c                   (specify the plasma radius (m.), the
c                   poloidal aspect ratio and the relative
c                   shift of the magnetic axis)
      nequil = 0
c  poloidal cross-section dimension and shape
c        rshift - shift of the magnetic axis (m)
c        polasp - poloidal aspect ratio (b/a)
c                 (1): limit on the magnetic axis
c                 (2): of the external magn. surface
c        dtrian - triangularity of the external magn. surf.
c               - ignored if nequil = 1
      rshift = 0.0
      polasp(1) = 1.
      polasp(2) = 1.
      dtrian = 0.
c****************9/15/91   SCC
c    epserr=tolerence of error in dispersion relation in raytracing
c********************
      epserr = 0.01
c
c ===============================================
c  lh heating parameters
c ===============================================
c   frequency (hz)
      freqcy = 2.45E9
      omega = 2.*3.14159265359*freqcy
c  total power coupled (mw)
      power = 1.
      powers(1) = 1.
      powers(2) = 0.
c  thgril - central position of the antenna (deg.)
      thgril(:nspect) = 0.
c  igrill = 1 - grill code called
c  igrill = 0 - grill code not called
c  igrill = -1 - fit to P(n_parallel)
      igrill = 0
c  wave emitted by the antenna
c   islofa = 1 : slow wave
c   islofa = -1 : fast wave (igrill = 0)
      islofa = 1
c
c ===============================================
c  grill parameters  (ignored if igrill = 0)
c ===============================================
c number of waveguides
      nwguid = 8
c waveguide distance, cm.
      width = 2.1
c waveguide separation, cm.
      dwall = 0.80
c heigth of the guides
      heigth = 16.5
c total number of modes
      nmod = 3
c density gradient at the plasma edge, cm-4
      dndx = 1.E11
c density at the plasma edge, cm-3
      dnedge = 1.E11
c effective absorption for nonaccessible waves
c   between npar=1 and npar=anzacc
      anzacc = 0.
      edgabs = 0.1
c magnetic field near the antenna
      bzedge = 1.8
c distance of the plasma from the wall, cm.
      dxpl = 0.00
c------------------------------------------------------------------
c phases for output
c        nphase > 0 - uniform excitation
c        nphase < 0 - excitations specified through subroutine
c                     config(calfa,ncall)
c                     in this case specify wether the config.
c                     is simmetric (isimm=1) or not (isimm=2)
      nphase = 1
      phmin = 180.
      phmax = 180.
c------------------------------------------------------------------
c output control
c       = 1  -  only reflection coefficients
c       = 2  -  also complex coefficients
      jout6 = 1
c  repetition of the waveguides parameters for each case
c     ireout = n. of cases - yes
c     ireout = 0 - no
      ireout = 0
c  max n-parallel for output
c remember: aksups should not be smaller than the largest of anzsup
      aksupw = 7.
      aksups = 7.
c  n. of points and mesh steps
      nnk(1) = 300
      ddk(1) = (aksups - 1.)/float(nnk(1))
      nnk(2) = 200
      ddk(2) = 0.1
c  jumpw = jump for print
      jumpw = 5
c  npart = n. of step in the unaccessible region
      npart = 5
c
c ===============================================
c  discretisation of the power spectre
c      for ray tracing purposes
c ===============================================
c  nnkpar(i) - n of values of nparallel in interval i.
c  anzsup - largest absolute value of k parallel
c  anzinf - smallest absolute value of k parallel
c    if nnkpar=1  anzinf(1) will be taken
c ****** actual
      nnkpar(1) = 40
      anzinf(1) = 1.05
      anzsup(1) = 3.00
c ******
      nnkpar(2) = 0
      anzinf(2) = -2.
      anzsup(2) = -4.
c ******
      nnkpar(3:nspect) = 0
      anzinf(3:nspect) = 0.0
      anzsup(3:nspect) = 0.0
c  nthin - n. of rays in the poloidal cross-section
c    (should not exceed ngr)
      nthin = 1
c  nequip - max. n. of equiphase surfaces with output
c    ignored if igraph not zero
c  deykpr - step of eikon for printing
      nequip = 200
      deykpr = 2.
c ************ ************ ************ ************
c independent variable
c  indvar = 0 - poloidal phase
c  indvar = 1 - toroidal phase
      indvar = 1
c ************ ************ ************ ************
c  maxref = n. of boundary reflections allowed
      maxref = 1
c ************ ************ ************ ************
c details of print
c  iprint = 0 - output suppressed
c  iprint = 1 - normal output
c         = 2 - more detailed output
c         = 3 - det. output at each call of output1(x)
c               for tests (no graphical output)
      iprint = 0
c  iplopr = 1  -  plots of the profiles
      iplopr = 0
c ************ ************ ************ ************
c  igraph = 0  no graphical output
      igraph = 0
      if (igraph /= 0) then
c ************ ************ ************ ************
c  wavefronts to be plotted every jwfr point
c      ignored if nthin=1
         jwfr = 1
c ************ ************ ************ ************
c  list of plots to be made
         iploxy(:,:8) = 0
c ===================================================================
c  npolxy(nxvarb,nyvarb) different from zero produces a plot
c                        according to the following table:
c ====================================================================
c  nxvarb=1  indep. var. seikon  (phase in the poloidal plane)
c         2              psi (magnetic surfaces label)
c ====================================================================
c  nyvarb=1  dep. var.   skp
c         2              skpar
c         3              skr
c         4              skth
c         5              skx
c         6              skz
c         7              spower
c         8              sphi
c ===================================================================
         iploxy(2,1) = 1
         iploxy(2,2) = 1
c        iploxy(2,8) = 1
      endif
c   parameters for spectre
c        iabs(ngra) = n of graphs of spectre per page
c        ngra.gt.0    integral of px also plotted
c        ngra.lt.0    only px plotted
c  ignored if igrill = 0
      ngra = 1
c ===============================================
c  mhd configuration parameters
c ===============================================
c  nmhd = n. of points in the radial profiles
c      of rmaj(psi), rrho(psi), triang(psi), ellipt(psi)
c      accepted if 11 <= nmhd <= nprofn
c
      nmhd = 11
c
      dpsimhd = 1./(nmhd - 1.)
c
      do i = 1, nmhd
         psimhd(i) = (i - 1.)*dpsimhd
         zpsi = psimhd(i)
         rmaj(i) = furmaj(zpsi)
         rrho(i) = furrho(zpsi)
         triang(i) = futria(zpsi)
         elong(i) = fuelon(zpsi)
      end do
c
c ************ ************ ************ ************ ************
c
c  standard case with analytic profiles for density & temperatures
c
c ************ ************ ************ ************ ************
c
      conc(:nprofs,:nspec) = 0.
      pni(:nprofs,:nspec) = 0.
      pti(:nprofs,:nspec) = 0.
      conc(:nprofs,mainsp) = 1.
c
      zdpsi = 1./float(nprofs - 1)
      print *,'nprofs = ',nprofs,' zdpsi = ',zdpsi,' ifrang = ',ifrang
c ======================================================================
c ====== only with the exponential version of the profiles =============
      zdivne = 1.
      zdivte = 1.
      if (ifrang == (-1)) then
         zdivne = 1.E14
         zdivte = 1.E-3
         zne = prone(0.)
         denc = 1.E14*zne
         tempec = 1.E-3*prote(0.)
         zti = amin1(1.0_dp,0.60_dp*zne + 0.40_dp)
         tempic(1) = zti*tempec
      endif
c ======================================================================
      do j = 1, nprofs
         print *,'j = ',j
         psi = float(j - 1)*zdpsi
         print *,'psi = ',psi
         ppsi(j) = psi
         pte(j) = prote(psi)*zdivte
         pne(j) = prone(psi)*zdivne
         pjavg(j) = pte(j)**1.5
         do i = 1, nspec
            pni(j,i) = pne(j)*conc(j,i)
            pti(j,i) = proti(psi)
         end do
      end do
      tempic(:nspec) = pti(1,:nspec)
c
c ************ ************ ************ ************
c  profile averaged density
c
C     if(ifrang.eq.1)  then
C        zsum = pne(1)
C     do 510  n=2,nprofs,2
C 510    zsum = zsum + 4.*pne(n) + pne(n+1)
C        zfact = zdpsi*zsum/(3.*pne(1))
C        zdivne = 0.5*zdnfrg*float(ifrang)/zfact
C     do 520  n=1,nprofs
C 520    pne(n) = zdivne*pne(n)
C        denc = pne(1)
C     end if
c
c ************ ************ ************ ************
c  edge simulation
c
      if (iedge /= 0) then
         do j = nprofs + 1, nprof
            ppsi(j) = float(j - 1)*zdpsi
         end do
         zdivne = pne(nprofs)
         zdivte = pte(nprofs)
         do j = nprofs + 1, nprof
            zdecay = exp((-float(j - nprofs)/2.))
            pne(j) = zdivne*zdecay
            pte(j) = zdivte*zdecay
            pjavg(j) = 0.0
            pti(j,:nspec) = pti(nprofs,:nspec)*zdecay
            pni(j,:nspec) = pni(nprofs,:nspec)*zdecay
         end do
c  extend MHD
         nmhd = 11
         dpsimhd = ppsi(nprof)/(nmhd - 1.)
         do i = 1, nmhd
            psimhd(i) = (i - 1.)*dpsimhd
            zpsi = psimhd(i)
            rmaj(i) = furmaj(zpsi)
            rrho(i) = furrho(zpsi)
            triang(i) = futria(zpsi)
            elong(i) = fuelon(zpsi)
         end do
      endif
c
c ************ ************ ************ ************
 
      return 
      end subroutine bram
      subroutine inital
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:55:53   6/14/01  
C...Switches: -p4 -yb
c
c ************ ************ ************ ************ ************
c     June 25, 1991.
c
c  initialisation of the ray tracing program
c
c ************ ************ ************ ************ ************
c
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
      use Vparam
      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, isimm
      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, rplasm, iout, bzero, btsign, versid
      use Vcraylh
      use Vchpcsd, ONLY: irec, rec0, rec1, rec2, rec3, rec4, rec5, 
     1   rec6, rec7, rec8, rec9, rec10, rec11, rec12, rec13, rec14, 
     2   rec15, ndim, ind
      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 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, ieqdsk
      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, y1c, yhc, wpe1c, wpe2c, wce1c, wce2c, rtmime,
     .   nsp1
      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, k, i, n, l, nuk
      real::zpi,wlengt,ztot,thaper,zdth,zth0,arg10,zcos,znorm,zdk
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------------------------------
c   August 5, 1991.
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
c ************ ************ ************ ************ ************
c
c     data    versid    /'version:052291 '/
c
      zpi = 4.0*atan(1.0E0)
c
c ************ ************ ************ ************ ************
c
      write (iout, 9999) versid
c
c ************ ************ ************ ************ ************
c
      istop = 0
c
      wlengt = 2.997925E8/freqcy
      omega = 2.*zpi*freqcy
c        ukzero is free space wavenumber  (m**-1).
      ukzero = 2.*zpi/wlengt
c
c ************ ************ ************ ************
c   Initialize plasma equilibrium.
c   plasma shape and dimensions
c   magnetic field on the magnetic axis
c ************ ************ ************ ************
c
      if (ieqdsk < 3) then
         ipropt = 0
         call metrin
      else if (ieqdsk<5 .and. ieqdsk>=3) then
         call fiteqdsk
      else
         call mhdebm
      endif
      if (ipropt == 1) call prontp
c-------------------------------------
c
c ************ ************ ************ ************
c  consistency and charge neutrality
c ************ ************ ************ ************
c
      if (nspec <= 5) then
         light = 1
         if (nspec <= 1) then
            mainsp = 1
         else
            if (mainsp > nspec) go to 9000
c*****************SCC 12/12/95
c  impose charge neutrality
c
            do j = 1, nprof
               ztot = sum(conc(j,:nspec)*azi(:nspec))
               conc(j,:nspec) = conc(j,:nspec)/ztot
               pni(j,:nspec) = pni(j,:nspec)/ztot
            end do
c
c        zden = 1.
c        ztmax = tempic(1)/atm(1)
c     do 20 i=1,nspec
c        ztm = tempic(i)/atm(i)
c     if(ztm.lt.ztmax)  goto 15
c        ztmax = ztm
c        light = i
c  15 if(i.eq.mainsp)  go to 20
c        zden = zden - azi(i)*aconc(i)
c  20 continue
c     if(zden.le.0.) go to 9100
c  30    aconc(mainsp) = zden/azi(mainsp)
c
         endif
         amime = 1836.12
c------------------------------
c 6/25/91
         rtmime = sqrt(amime)
c-----------------------------------
c
c        heta = 0.
c        zeff = 0.
c
c-----------------------------
c  7/2/91
         y2c = 2.343E-18*freqcy*freqcy/(bzero*bzero)
c******************************SCC   12/12/95
         xpc = 4.3906E4/(freqcy*freqcy)
c***********************************************
         y1c = sqrt(y2c)
c*********************************
         yhc = 6.5596E-8*freqcy/bzero*btsign
c********************************  SCC  12/12/95
         wpe2c = 8.06162E7/freqcy**2
c*******************************
         wce1c = 2.79927E10*btsign*bzero/freqcy
c******************************
         wce2c = wce1c**2
         atpi(:nspec) = azi(:nspec)*azi(:nspec)/atm(:nspec)
c        heta = heta + atpi(i)
c        zeff = zeff + azi(i)*azi(i)*aconc(i)
         xxi(:nspec) = atpi(:nspec)/atm(:nspec)
         aziomi(:nspec) = azi(:nspec)/atm(:nspec)
         rtzom(:nspec) = sqrt(aziomi(:nspec))
         ay2(:nspec) = aziomi(:nspec)**2*5.446E-4
         ay1(:nspec) = rtzom(:nspec)*2.334E-2
         wpi2c(:nspec) = xpc*azi(:nspec)**2/atm(:nspec)
         wpi1c(:nspec) = sqrt(wpi2c(:nspec))
c**********************************
         wci1c(:nspec)=1.52449E7*azi(:nspec)*bzero/(atm(:nspec)*freqcy)
c******************************
         wci2c(:nspec) = wci1c(:nspec)**2
         nsp1 = nspec - nminor
c$$$$   TK Mau      06/00
         if (nalfa > 0) then
            wpf2c(:nalfa) = xpc*azf(:nalfa)**2/atmf(:nalfa)
            wcf1c(:nalfa) = 1.52449E7*azf(:nalfa)*bzero/(atmf(:nalfa)*
     1         freqcy)
            wcf2c(:nalfa) = wcf1c(:nalfa)**2
         endif
c$$$$$$$$$$$$$$$
c-----------------------------------------------
c
c
c ************ ************ ************ ************
c  normalization and splines for the plasma profiles
c ************ ************ ************ ************
c
         call profin
c
         if (istop /= 0) return 
c
c ************ ************ ************ ************
c  initialization for power deposition profiles
c ************ ************ ************ ************
c
         if (igrill /= (-3)) then
            do i = 1, nspect
               if (nthin <= 1) then
                  thstrt(1,i) = thgril(i)
                  fpwth(1) = 1.
                  go to 250
               endif
               thaper = 180.*heigth/(100.*zpi*rplasm)
               zdth = thaper/float(nthin - 1)
               zth0 = thgril(i) - thaper/2.
               do n = 1, nthin
                  thstrt(n,i) = zth0 + float(n - 1)*zdth
c $$$$ Altered by TK Mau on 11/20/91
                  arg10 = zpi*(thstrt(n,i)-thgril(i))/180.
                  if (igrill /= (-2)) then
                     zcos = cos(arg10)
                  else
                     zcos = cos(ukzero*rplasm*arg10)
                  endif
c $$$$$$$$$$$$$$$$$$$$
                  fpwth(n) = zcos*zcos
               end do
            end do
c
            znorm = sum(fpwth(:nthin))
            fpwth(:nthin) = fpwth(:nthin)/znorm
c
  250       continue
            isimm = nspect
            if (thgril(1)==0. .or. thgril(1)==180.) then
               if (phase==0. .or. phase==180.) isimm = 1
            endif
            if (isimm == 1) nnkpar(2) = 0
            if (nnkpar(2) == 0) isimm = 1
            nnztot = 0
            nnztot = sum(nnkpar(:nspect))
c
c $$$$  Added by TK Mau on 11/22/91
c     if(igrill.eq.-2) go to 421
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
            do i = 1, isimm
               anzin(i,1) = anzinf(i)
               nuk = nnkpar(i)
               if (nuk > 1) then
                  zdk = (anzsup(i)-anzinf(i))/float(nuk - 1)
                  do n = 2, nuk
                     anzin(i,n) = anzinf(i) + float(n - 1)*zdk
                  end do
               endif
            end do
c $$$$  Added by TK Mau on 11/22/91
c 421 continue
c $$$$$$$$$$$$$$$$$$$$$$
c
            do i = 1, isimm
               nuk = nnkpar(i)
               pwtra(i,:nspray) = 0.
            end do
         else
c*************************
c  for igrill=-3; read in toroidal and poloidal spectrum
c   nspect is # kphi's
c   nnkpol(i=1:nspect) is # of kpol's in each kphi
c
c**************************
            do i = 1, nspect
               nnkpar(i) = 1
               if (nthin <= 1) then
                  thstrt(1,i) = thgril(i)
                  fpwth(1) = 1.
                  go to 450
               endif
               thaper = 180.*heigth/(100.*zpi*rplasm)
               zdth = thaper/float(nthin - 1)
               zth0 = thgril(i) - thaper/2.
               do n = 1, nthin
                  thstrt(n,i) = zth0 + float(n - 1)*zdth
                  arg10 = zpi*(thstrt(n,i)-thgril(i))/180.
c          zcos = cos(ukzero*rplasm*arg10)
                  zcos = cos(arg10)
                  fpwth(n) = zcos*zcos
               end do
            end do
            znorm = sum(fpwth(:nthin))
            fpwth(:nthin) = fpwth(:nthin)/znorm
c
  450       continue
            isimm = nspect
            nnztot = 0
            nnztot = sum(nnkpol(:nspect))
            do i = 1, isimm
               anzin(i,:nnkpol(i)) = (anzinf(i)+anzsup(i))/2.
               anplin(i,1) = anpinf(i)
               nuk = nnkpol(i)
               if (nuk > 1) then
                  poldk = (anpsup(i)-anpinf(i))/float(nuk - 1)
                  do j = 2, nuk
                     anplin(i,j) = anpinf(i) + float(j - 1)*poldk
                  end do
               endif
            end do
            pwtra(:isimm,:nspray) = 0.
 
         endif
         power = 0.0
         power = power + sum(powers(:isimm), mask=nnkpar(:isimm)>0)
c
c**bh      if(islofa.eq.-1)  igrill = 0
c
c**bh      if(nnztot.le.2)  igrill = 0
c
c ************ ************ ************ ************
c  initialisation of the output tables
c ************ ************ ************ ************
c
         pwtote = 0.
         pwtoti(:nspec) = 0.
         pwe(:nprof) = 0.
c $$$$$$$$$$$$$$$$$$$
c   8/5/91   T.K. Mau
         pwc(:nprof) = 0.
c $$$$$$$$$$$$$$$$$$$
         pwi(:nprof,:nspec) = 0.
c
c ************ ************ ************ ************
c  parameters for the integration
c ************ ************ ************ ************
c
c        accur = 1.e-5      (default put into var.br).
         ind = 1
c*******************************SCC 10/20/94
         ndim = 5
c********************************************
         precdy(:5) = 0.2
         precdy(6) = 0.
         dsteph = 0.2
c
c ************ ************ ************ ************
c  control of the printed and graphical output
c ************ ************ ************ ************
c
         if (iprint == 3) igraph = 0
         deykpr = 2.*zpi*deykpr
c
         if (nnztot/=1 .or. nthin<=1) then
            igraph = -igraph
            if (nnztot>ngdim .and. igraph/=0) igraph = -2
c
         endif
         return 
c
c ************ ************ ************ ************
c  failure diagnostics
c ************ ************ ************ ************
c
      endif
 9000 continue
      write (iout, 9990)
 9990 format('0',20x,"the plasma composition is inconsistent")
      go to 9900
 9980 format('0',20x,"charge neutrality cannot be satisfied")
 9999 format(1a40)
 
 9900 continue
      istop = 1
c
c ************ ************ ************ ************ ************
c
      return 
      end subroutine inital
c
      subroutine iniwfr
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:55:53   6/14/01  
C...Switches: -p4 -yb
c
c ************ ************ ************ ************ ************
c
c  initial wavefront - evaluation of k
c      the function psiwfr must be provided by the user:
c      psiwfr(theta,zdpsdt) = psi(theta) on the 1st wavefront
c      zdpsdt = d(psi)/d(theta)
c
c ************ ************ ************ ************ ************
c
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
      use Vparam
      use Viogrl
      use Viorlh, ONLY: nprofn, psimhd, dpsimhd, rmaj, rrho, triang, 
     1   elong, nmhd, denc, tempec, atm, azi, conc, tempic, nspec, 
     2   mainsp, pavtne, pavtte, pavtti, pavpp, beta, betap, ali3, 
     3   ppsi, pjavg, pne, pte, nprofs, nprof, iedge, ipropt, pni, pti, 
     4   psinm, tani, nspect, omega, anzin, anzsup, anzinf, anplin, 
     5   anpsup, anpinf, pwcpl, pwtra, specfac, power, powers, thgril, 
     6   delthe, phase, rgrill, nnkpar, nnkpol, poldk, nthin, maxref, 
     7   igrill, islofa, irayio, ioread, nraypic, deykpr, psistep, 
     8   pkexpnt, nequip, iprint, indvar, iploxy, igraph, iplopr, jwfr, 
     9   pwe, pwe0, pwi, pwii0, pwev, pwiv, wkarea, pwal, ffast, tite, 
     .   alpene1, alpte1, frcte, frcne, frcti, gamte1, gamti1, alpti1, 
     1   gamene1, presfr, iout
      use Vcraylh
      use Vchpcsd, ONLY: irec, rec0, rec1, rec2, rec3, rec4, rec5, 
     1   rec6, rec7, rec8, rec9, rec10, rec11, rec12, rec13, rec14, 
     2   rec15, y
      use Vcgraphs
      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 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, psi0
      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 :: itipsi, niter
      real :: zdpsdt, zdiscr, zroot1, zroot2, zpkp2f, zpkp2s, zpkp2, 
     1   zsinz, zcosz, znormz, za, zb, zc, zdiff, zkappa, zdkp2, pkpsi2
     2   , pwinit
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real , EXTERNAL :: psiwfr
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   #option for n-T profile calculation: 1 if
c                        # calculated from prontp; else =0.
 
 
c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
c
c
c   Comhpcsd
c
c
c---------------------------
c   common block for Comraylh
c-------------------------
c
c
c$$$$$$$$     TKM    11/98
c*********    TKM   2/97, 6/99, 9/99
c*********    TKM   2/97
c*******   TK Mau   8/98
c*************************
c  SCC  3/7/95
 
c
c  Storage related to EQDSK:
c  Units used in the EQDSK are entirely MKSA.
c  Comeqdsk-->ceqdsk.i
 
c
c********************************************
c  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
      istart = 0
      itipsi = 0
c
c ************ ************ ************ ************ ************
c  initial position along the ray
c ************ ************ ************ ************ ************
c
      psi = psiwfr(theta,zdpsdt)
c
   10 continue
      y(2) = psi
      y(4) = theta
c
      call coords
c
      call profix
c
c $$$$  Altered by TK Mau on 11/20/91   SC Chiu 1/26/94
      if (igrill == (-3)) then
         pkpar = pktau*asintq + pkphi*acostq
         pkheta = pktau*acostq - pkphi*asintq
      else
         if (igrill == (-2)) then
            pkpar = pkphi*acostq
         else
            pkphi = pkpar/acostq
         endif
      endif
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
      pkpar2 = pkpar*pkpar
      anphi = pkphi*urhs
c
      call disper (0)
c
      zdiscr = hb*hb - 4.*ha*hc
c
      if (zdiscr > 0.) then
c
         zroot1 = 0.5*(hb + sqrt(zdiscr))/ha
         zroot2 = 0.5*(hb - sqrt(zdiscr))/ha
c
c ************ ************ ************ ************ ************
c  choice of the wave
c ************ ************ ************ ************ ************
c
c     ha is taken to be equal to Stix's s.  ha.lt.0 corresponds to
c     freqcy .gt. the LH frequency.  If ha.gt.0, only the fast wave
c     is possibly propagating.
c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c    August 9, 1991   T.K. Mau
         if (ichois /= 1) then
            if (abs(zroot1) < abs(zroot2)) then
               zpkp2f = zroot1
               zpkp2s = zroot2
            else
               zpkp2f = zroot2
               zpkp2s = zroot1
            endif
         else
c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
            if (ha >= 0.) then
               zpkp2s = amax1(zroot1,zroot2)
               zpkp2f = amin1(zroot1,zroot2)
            else
               zpkp2s = amin1(zroot1,zroot2)
               zpkp2f = amax1(zroot1,zroot2)
            endif
         endif
c
         if (islofa <= 0) then
            if (islofa == 0) go to 9050
            zpkp2 = zpkp2f
         else
            zpkp2 = zpkp2s
c
         endif
         if (zpkp2>=1 .or. ichois==1) then
            if (zpkp2 >= 5.) then
c
c ************ ************ ************ ************ ************
c  exact evaluation of the initial value of kpsi & ktheta
c ************ ************ ************ ************ ************
c
               zsinz = -aj*zdpsdt
               zcosz = antau*antau + ag*zdpsdt
               znormz = sqrt(zsinz*zsinz + zcosz*zcosz)
               zsinz = zsinz/znormz
               zcosz = zcosz/znormz
               za = zcosz*zcosz + zsinz*zsinz*acostq*acostq
               zb = zsinz*acostq*asintq*pkphi
c
               pkp2 = zpkp2
               if (igrill /= (-3)) then
                  do niter = 1, 100
                     zc = pkphi*pkphi*asintq*asintq - pkp2
                     zdiff = zb*zb - za*zc
c
                     if (zdiff <= 0.) go to 9030
                     zkappa = ((-zb) + sqrt(zdiff))/za
                     pkpsi = float(islofa)*abs(zkappa*zcosz)
                     pktau = zkappa*zsinz
                     akpsi = (aj*pkpsi + ag*pktau)/antau
                     akth = antau*pktau
c
                     call wavect
c
                     call disper (0)
c
                     zdkp2 = disph/dhkp2
                     if (abs(zdkp2/pkp2) < 0.1*accur) go to 60
                     pkp2 = pkp2 - zdkp2
                  end do
c -------------------------------------
c  accuracy not obtained
                  go to 9040
c -------------------------------------
               endif
               pkpsi2 = pkp2 - pkheta*pkheta
               if (pkpsi2 <= 0.) go to 100
c----------------SCC  6/26/95
c     pkpsi=-sqrt(pkpsi2)
               pkpsi = float(islofa)*sqrt(pkpsi2)
c-----------------------
               akpsi = (aj*pkpsi + ag*pktau)/antau
               akth = antau*pktau
   60          continue
               istart = 1
               y(1) = akpsi
               y(3) = akth
               y(5) = phi
               pwinit = pwx
               y(6) = alog(pwinit)
c
c ************ ************ ************ ************ ************
c
               return 
c
c ************ ************ ************ ************ ************
c
            endif
         endif
      endif
  100 continue
      if (itipsi > 6) go to 9000
      itipsi = itipsi + 1
      psi = psi - 0.05
      go to 10
c -------------------------------------
 9000 continue
      if (zdiscr <= 0.) then
c
         write (iout, 9910)
 9910    format('0',5x,"roots of the cold plasma dispersion relation",
     1      " not real",/6x,"starting point beyond confluence")
         return 
c -------------------------------------
      endif
      write (iout, 9920) psi, zpkp2
 9920 format('0',5x,"starting point too close to the p-cutoff",/16x,
     1   "psi =",f10.4," pkp2 =",e13.4)
      return 
c -------------------------------------
 9030 continue
      write (iout, 9930) psi, pkp2, zpkp2
 9930 format('0',5x,"starting point too close to the r-cutoff",/16x,
     1   "psi =",f10.4," pkp2 =",e13.4," qf2 =",e13.4)
      return 
c -------------------------------------
 9040 continue
      write (iout, 9940) pkp2, zdkp2, disph
 9940 format('0',5x,"search for the initial n perp not convergent",/6x,
     1   "last values: kp2 =",e14.4,"  dkp2 =",e14.4,"  disph =",e14.4)
      return 
c -------------------------------------
 9050 continue
      write (iout, 9950)
 9950 format('0',5x,"type of radiated wave not specified")
      return 
c
c ************ ************ ************ ************ ************
c
      end subroutine iniwfr
      function psiwfr (ztheta, dpsdth)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:55:53   6/14/01  
C...Switches: -p4 -yb
c ************ ************ ************ ************
c  shape of the initial wavefront:
c           psiwfr = psi(theta)
c           dpsdth = d(psi)/d(theta)
c ************ ************ ************ ************
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
      use Vparam
      use Viogrl
      use Viorlh
      use Vcraylh
      use Vchpcsd
      use Vcgraphs
      use Vceqdsk
      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, psi0
      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real psiwfr
      real ztheta, dpsdth
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c********************************************
c  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********************
 
      psiwfr = psi0
      dpsdth = 0.
      return 
      end function psiwfr
      subroutine pwicpl
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:55:53   6/14/01  
C...Switches: -p4 -yb
c
c ************ ************ ************ ************ ************
c
c interface subroutine for coupling the grill code to ray tracing
c
c ************ ************ ************ ************ ************
c
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
      use Vparam
      use Viogrl, ONLY: calfa, px, sumpx, bk, refl, rtot, trans, 
     1   aksupw, ddk, nnk, joutrf, ireout, jumpw, jtest, ispec, ngra, 
     2   itrans, radius, isimm
      use Viorlh, ONLY: nprofn, psimhd, dpsimhd, rmaj, rrho, triang, 
     1   elong, nmhd, denc, tempec, atm, azi, conc, tempic, nspec, 
     2   mainsp, pavtne, pavtte, pavtti, pavpp, beta, betap, ali3, 
     3   ppsi, pjavg, pne, pte, nprofs, nprof, iedge, ipropt, pni, pti, 
     4   psinm, tani, nspect, omega, anzin, anzsup, anzinf, anplin, 
     5   anpsup, anpinf, pwcpl, pwtra, specfac, power, powers, thgril, 
     6   delthe, phase, rgrill, nnkpar, nnkpol, poldk, nthin, maxref, 
     7   igrill, islofa, irayio, ioread, nraypic, deykpr, psistep, 
     8   pkexpnt, nequip, iprint, indvar, iploxy, igraph, iplopr, jwfr, 
     9   pwe, pwe0, pwi, pwii0, pwev, pwiv, wkarea, pwal, ffast, tite, 
     .   alpene1, alpte1, frcte, frcne, frcti, gamte1, gamti1, alpti1, 
     1   gamene1, presfr
      use Vcraylh
      use Vchpcsd
      use Vcgraphs
      use Vceqdsk
      use Vcmnew
      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i, nk, jk, i1, i2, j
      real::zpi,zfact,zdk,ak,ak1,ak2,anwdth,an0,dan,anorm,anp
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
      data zpi/3.14159265359/
c ************ ************ ************ ************ ************
c
      if (igrill > 0) then
         igrill = 0
         ispec = 1
         if (igraph == 0) ngra = 0
c
c ********** ********** ********** ********** ********** **********
c
c call to the grill code and transfer of the spectre
c
c ********** ********** ********** ********** ********** **********
c
         call grill
c
c ********** ********** ********** ********** ********** **********
c
         zfact = power
         if (isimm == 1) zfact = 2.*zfact
         do i = 1, isimm
            nk = nnkpar(i)
            if (nk /= 0) then
               zdk = anzin(i,2) - anzin(i,1)
               do jk = 1, nk
                  ak = anzin(i,jk)
                  ak1 = ak - zdk/2.
                  ak2 = ak + zdk/2.
                  i1 = ifix((ak1 - 1.)/ddk(i)) + 1
                  i2 = ifix((ak2 - 1.)/ddk(i)) + 1
                  pwcpl(i,jk) = zfact*(sumpx(i,i2)-sumpx(i,i1))
               end do
            endif
         end do
c
c ********** ********** ********** ********** ********** **********
c
         return 
c
c ********** ********** ********** ********** ********** **********
c
      endif
      if (igrill /= (-3)) then
         if (igrill == 0) then
            do i = 1, isimm
               nk = nnkpar(i)
               if (nk /= 0) then
                  pwcpl(i,:nk) = powers(i)/float(nk)
               endif
            end do
c $$$$  altered by TK Mau on 11/21/91
         else
c     if(igrill.eq.-1) then
c $$$$$$$$$$$$$$$$$$$$$$$$$$$
            do i = 1, isimm
               nk = nnkpar(i)
               if (nk /= 0) then
c$$$$$$$$$$$$$$$   scc 3/19/92
                  anwdth = 2.*zpi/abs(anzsup(i)-anzinf(i))*specfac
                  an0 = 0.5*(anzinf(i)+anzsup(i))
c$$$$$$$$$$$$$$$$$$$$  scc 3/19/92
                  if (nk == 1) then
                     dan = (anzsup(i)-anzinf(i))/nk
                  else
                     dan = (anzsup(i)-anzinf(i))/(nk - 1.)
                  endif
                  anorm = 0.0
                  do j = 1, nk
c$$$$$$$$$$$$$$$  scc  3/19/92
                     anp = anzinf(i) + (j - 1.)*dan
c**            pwcpl(i,j) = sin(anwdth*(anp-an0))**2/
c**       1             anp**2/abs(anp**2-1.)**(2./3.)
                     if (anp /= an0) then
                        pwcpl(i,j) = sin(anwdth*(anp - an0))**2/(anp - 
     1                     an0)**2
                     else
                        if (anwdth /= 0.) then
                           pwcpl(i,j) = anwdth**2
                        else
                           pwcpl(i,j) = 1.0
                        endif
                     endif
                     anorm = anorm + pwcpl(i,j)
                  end do
                  pwcpl(i,:nk) = pwcpl(i,:nk)/anorm*powers(i)
c**            pwcpl(i,j) = sin(anwdth*(anp-an0))**2/
c**       1             anp**2/abs(anp**2-1.)**(2./3.)
               endif
            end do
c $$$$$  Added by TK Mau on 11/21/91
c     else
c     do 521 i=1,isimm
c     nk = nnkpar(i)
c     if(nk.eq.0) go to 521
c     anorm = 0.0
c     do 531 j=1,nk
c     anorm = anorm+pwcpl(i,j)
c 531 continue
c     do 541 j=1,nk
c     pwcpl(i,j)=pwcpl(i,j)/anorm*powers(i)
c 541 continue
c 521 continue
c     endif
c $$$$$$$$$$$$$$$$$$$$$$$
         endif
         return 
c
c
      endif
      do i = 1, isimm
         nk = nnkpol(i)
         if (nk /= 0) then
c$$$$$$$$$$$$$$$   scc 3/19/92
            if (anpinf(i) == anpsup(i)) then
               anwdth = 2.*zpi
               go to 305
            endif
            anwdth = 2.*zpi/abs(anpsup(i)-anpinf(i))*specfac
  305       continue
            an0 = 0.5*(anpinf(i)+anpsup(i))
c$$$$$$$$$$$$$$$$$$$$  scc 3/19/92
            if (nk == 1) then
               dan = (anpsup(i)-anpinf(i))/nk
            else
               dan = (anpsup(i)-anpinf(i))/(nk - 1.)
            endif
            anorm = 0.0
            do j = 1, nk
c$$$$$$$$$$$$$$$  scc  3/19/92
               anp = anpinf(i) + (j - 1.)*dan
c**            pwcpl(i,j) = sin(anwdth*(anp-an0))**2/
c**       1             anp**2/abs(anp**2-1.)**(2./3.)
               if (anp /= an0) then
                  pwcpl(i,j) = sin(anwdth*(anp - an0))**2/(anp - an0)**2
               else
                  if (anwdth /= 0.) then
                     pwcpl(i,j) = anwdth**2
                  else
                     pwcpl(i,j) = 1.0
                  endif
               endif
               anorm = anorm + pwcpl(i,j)
            end do
            pwcpl(i,:nk) = pwcpl(i,:nk)/anorm*powers(i)
c**            pwcpl(i,j) = sin(anwdth*(anp-an0))**2/
c**       1             anp**2/abs(anp**2-1.)**(2./3.)
         endif
      end do
c
c ********** ********** ********** ********** ********** **********
c
      return 
c
c ********** ********** ********** ********** ********** **********
c
      end subroutine pwicpl
      subroutine tmpdata(ientry)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:55:53   6/14/01  
C...Switches: -p4 -yb
c
c ************ ************ ************ ************ ************
c
c Temprarily store the absorption and driven current in 'wkarea'
c
c
c ************ ************ ************ ************ ************
c
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
      use Vparam
      use Viogrl, ONLY: calfa, px, sumpx, bk, refl, rtot, trans, 
     1   aksupw, ddk, nnk, joutrf, ireout, jumpw, jtest, ispec, ngra, 
     2   itrans, radius, isimm
      use Viorlh, ONLY: nprofn, psimhd, dpsimhd, rmaj, rrho, triang, 
     1   elong, nmhd, denc, tempec, atm, azi, conc, tempic, nspec, 
     2   mainsp, pavtne, pavtte, pavtti, pavpp, beta, betap, ali3, 
     3   ppsi, pjavg, pne, pte, nprofs, nprof, iedge, ipropt, pni, pti, 
     4   psinm, tani, nspect, omega, anzin, anzsup, anzinf, anplin, 
     5   anpsup, anpinf, pwcpl, pwtra, specfac, power, powers, thgril, 
     6   delthe, phase, rgrill, nnkpar, nnkpol, poldk, nthin, maxref, 
     7   igrill, islofa, irayio, ioread, nraypic, deykpr, psistep, 
     8   pkexpnt, nequip, iprint, indvar, iploxy, igraph, iplopr, jwfr, 
     9   pwe, pwe0, pwi, pwii0, pwev, pwiv, wkarea, pwal, ffast, tite, 
     .   alpene1, alpte1, frcte, frcne, frcti, gamte1, gamti1, alpti1, 
     1   gamene1, presfr
      use Vcraylh
      use Vchpcsd, ONLY: irec, rec0, rec1, rec2, rec3, rec4, rec5, 
     1   rec6, rec7, rec8, rec9, rec10, rec11, rec12, rec13, rec14, 
     2   rec15
      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 Vceqdsk
      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
      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 :: i, j
      real :: tmp1, tmp2
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********************************************
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 (ientry) 
      case default
c
c   zero out wkarea
c
         wkarea(:nprofm,:nwka) = 0.
         return 
      case (2) 
c
c    Store absorption and j profiles in wkarea
         wkarea(:nprof,1) = pwe(:nprof) + wkarea(:nprof,1)
         wkarea(:nprof,2) = pwev(1:nprof) + wkarea(:nprof,2)
         wkarea(:nprof,3) = pwit(:nprof) + wkarea(:nprof,3)
         wkarea(:nprof,4) = pwc(:nprof) + wkarea(:nprof,4)
         wkarea(:nprof,5) = pwct(:nprof) + wkarea(:nprof,5)
         wkarea(:nprof,6:nspec+5) = pwi(:nprof,:nspec) + wkarea(:nprof,6
     1      :nspec+5)
         wkarea(:nprof,6+nspec:2*nspec+5) = pwiv(1:nprof,:nspec) + 
     1      wkarea(:nprof,6+nspec:2*nspec+5)
         tmp1 = ptot0 + wkarea(1,nwka)
         wkarea(2,nwka) = (fpowt*ptot0 + wkarea(1,nwka)*wkarea(2,nwka))/
     1      tmp1
         wkarea(3,nwka) = (ftpowe*ptot0 + wkarea(1,nwka)*wkarea(3,nwka))
     1      /tmp1
         wkarea(4,nwka) = (ftpi*ptot0 + wkarea(1,nwka)*wkarea(4,nwka))/
     1      tmp1
         wkarea(5,nwka) = (ftedge*ptot0 + wkarea(1,nwka)*wkarea(5,nwka))
     1      /tmp1
         wkarea(6,nwka) = currf + wkarea(6,nwka)
         wkarea(7,nwka) = wkarea(6,nwka)/tmp1
         wkarea(1,nwka) = tmp1
         return 
      case (3) 
c
c   Sum the contribution of all RF sources
c
         pwe(:nprof) = pwe(:nprof) + wkarea(:nprof,1)
         pwev(1:nprof) = pwev(1:nprof) + wkarea(:nprof,2)
         pwit(:nprof) = pwit(:nprof) + wkarea(:nprof,3)
         pwc(:nprof) = pwc(:nprof) + wkarea(:nprof,4)
         pwct(:nprof) = pwct(:nprof) + wkarea(:nprof,5)
         pwi(:nprof,:nspec)=pwi(:nprof,:nspec)+wkarea(:nprof,6:nspec+5)
         pwiv(1:nprof,:nspec) = pwiv(1:nprof,:nspec) + wkarea(:nprof,6+
     1      nspec:2*nspec+5)
         tmp1 = ptot0 + wkarea(1,nwka)
         fpowt = (fpowt*ptot0 + wkarea(1,nwka)*wkarea(2,nwka))/tmp1
         ftpowe = (ftpowe*ptot0 + wkarea(1,nwka)*wkarea(3,nwka))/tmp1
         ftpi = (ftpi*ptot0 + wkarea(1,nwka)*wkarea(4,nwka))/tmp1
         ftedge = (ftedge*ptot0 + wkarea(1,nwka)*wkarea(5,nwka))/tmp1
         currf = currf + wkarea(6,nwka)
         effcdt = currf/tmp1
         ptot0 = tmp1
         return 
c
c
      case (4) 
c
c   ptot0 is total input power in MW
c   here powers(isimm) will be renormalized to ptot0
c
         tmp1 = 0.
         tmp1 = sum(powers(:isimm))
         tmp2 = ptot0/tmp1
         powers(:isimm) = powers(:isimm)*tmp2
         return 
      case (5) 
         call outrun (1)
         return 
c
      case (6) 
         call outrun (4)
c
         return 
      end select
      end subroutine tmpdata
