      subroutine raytr
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:51:36   6/14/01
C...Switches: -p4 -yb
c
c ************ ************ ************ ************ ************
c
c  main subroutine for ray tracing implementation
c    This is normal version
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, iout, epsray, epspsw, epspfw, aiseed, powrq
      use Vcraylh
      use Vceqdsk, ONLY: ntitle, dat, ipestg, nxeqd, nzeqd, xdimeqd,
     1   zdimeqd, reqd, redeqd, zmideqd, xma, zma, psimag, psilim,
     2   beqd, toteqd, psimx1, psimx2, xax1, xax2, zax1, zax2, psisep,
     3   xsep, zsep, feqd, presseqd, ffpeqd, ppeqd, peqd, qeqd, xeqd,
     4   zeqd, psiadj, dpolflx, psieqd, tpsieqd, tpsifeqd, iounit1,
     5   inoperm1, nptsdm1, nptsd, torflux, tpsisav, ra, psifra,
     6   dpsifra, fra, fra1, cspln, pds, wnoperm, xcontr, zcontr,
     7   bpcontr, btcontr, dstarp, b_fld, jacob, pprime, vprime,
     8   chipsi, ncontr, dang, bperr, arcl, thet, anglex, csplnx,
     9   csplnz, pdsx, pdsz, nlim, rlim, zlim, nlimiter, rlimiter,
     .   zlimiter, lrz, nprim, nimp, nion, nti, zi, zeffz, r, raeqd,
     1   psifeqd, te, ti, ti1, ene, enp, bmod, rmd, btmd, bpmd, btpmd,
     2   roa
      use Vchpcsd
      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 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, initlh
      use Vcmnew, ONLY: wpi1c, wpi2c, wci1c, wci2c, wpi2, wci2, wci,
     1   conci, aziomi, rtzom, ay2, ay1, trate, tratte, ttle, concte,
     2   trati, tratti, ttli, concti, vdrfte, vdrfti, infi, gprm, cxet,
     3   czt, cztp, czetai, czi, czip, czetat, czti, cztip, cth, npar,
     4   nper, upar, uper, umax, dsfe, dsfi, fper2, fpar2, fpp2, intg,
     5   inc, incf, tnmaxe, tnmaxi, idrive, binb, boutb, boutbrd,
     6   binbrd, epsl, binbd, epsil, dlob, wte, eta0, eta, rprof,
     7   amprof, cprof, xjop, vloop, kboot, mboot, btbsp, ftbsps, pde,
     8   pdec, pdi, pdf, pwce, pwcm, pwcf, pwc, pwc1, pwc2, pwct,
     9   pwct1, pwct2, pwc0, pwcray, pwc1ray, pwc2ray, pweray, pwiray,
     .   pwfray, currf, currfe, currf1, currf2, curay, curay1, curay2,
     1   fpwray, fpowe, fpowf, fpowi, pwte0, pwti0, effcd, effcdt,
     2   ptot, ftpowe, ftpowi, ftpowf, ftpi, ftpf, ftedge, pwedge,
     3   wfrac, pwxwl, frpowi, frpowf, frpow, pwit, pwft, ptedge,
     4   ptot0, fpowt, tpowi, tpowf, wfrac0, ebkev, bmpwr, azf, atmf,
     5   densa, kalfa, nalfa, nharm0, pnfi, pnf, zetab, tnf, ecrit,
     6   taua0, wca, gamal, gamat, ibeam, abeam, dbeam, aneb, enbeam,
     7   wbeam, temsa, ptfi, ttf, wpf2c, wpf2, wcf2c, wcf1c, wcf2, wcf,
     8   cxc, czc, cy, denfa, eav, tausd, tau0, paf, sordt, ecrita,
     9   betaf, nfion, nminor, nsp1
      use Vcfdamp, only: inf
      use Vbesblk
      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 :: nbk, n, nzth, mstart, nrpt, isp, ip, neik, nzeik, ii,
     1   nzk, kkk, kk1, kk2, ind1, kmcon, ind2, ier5, isx1, jmcind,
     2   iermc, nslofa, imode, iter, ier, ih, insp, k, ien, ik, ij, l,
     3   iray, i1, i2, ir, k1, iu
      real(kind=dp), dimension(6) :: ypv
      real(kind=dp), dimension(nprofm,nions) :: pwc10
      real(kind=dp), dimension(nprofm,nfion) :: pwc20, pwff0
      real(kind=dp), dimension(nfion) :: pwtf0
      real(kind=dp), dimension(lmx + 1) :: wk1, wk2
      real(kind=dp) :: zpi, tzpi, zkpar, zkpol, theta0, x, cst1, cst2,
     1    cst3,
     1   deykpp, psistepp, anphpv, discr, pkp20, pkp21, pkp22, pkp23,
     2   disck2, a2k, pkpsi2, ss1, disp1, ddisp1, ss2, disp2, ddisp2
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
       external output1, deriv
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
c $$$$$$$ Added by 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-----------------SCC  7/24/95
c     dimension ypv(6)
c   TKMau   9/20/94
!      parameter (lmx=51,lmn=0)
!      parameter (lbes=lmx-lmn+1,nbsx=5001)
c     for vectorized bessel function subroutine besselj
c
c ************ ************ ************ ************ ************
c
      data zpi/3.14159265359/
      data tzpi/6.283185308/
c
c ************ ************ ************ ************ ************
c   loop over the initial value of n parallel
c ************ ************ ************ ************ ************
c
c--------------------SCC  6/15/95
      epsray = 2.E-3
      if (islofa == 1) epsray = epspsw
      if (islofa == (-1)) epsray = epspfw
c----------------------SCC 2/7/95  3/7/95
      psilast = (1. - solrfl)*ppsi(nprofs) + 0.5*solrfl*ppsi(nprof)
      call cbesin
      if(kalfa>0)call bestab(lmx,lmn,nbsx,0.01,0.,bestb,wk1,wk2)
c*******************************SCC 12/21/95
c  calculate total no. of rays in curray go or read in from input-file
c  temperarily store in indgr, which will later on end up the same number.
c  write number of rays, nharm(for cql3d),freqcy (and nprof)
      indgr = 0
      do isign = 1, isimm
         if (igrill == (-3)) then
            nbk = nnkpol(isign)
         else
            nbk = nnkpar(isign)
         endif
         indgr = indgr + nbk*nthin
      end do
      call rayinout (1)
c***************************************************
c---------------------------------

      indgr = 0
      do isign = 1, isimm
         if (igrill == (-3)) then
            nbk = nnkpol(isign)
         else
            nbk = nnkpar(isign)
         endif
         if (nbk > 0) then
            do n = 1, nbk
               zkpar = anzin(isign,n)
               if (igrill == (-3)) zkpol = anplin(isign,n)
               if (abs(zkpar)>1. .or. islofa/=1) then
                  write (iout, 1010) zkpar
c
c ************ ************ ************ ************ ************
c   loop over the initial value of theta
c ************ ************ ************ ************ ************
c
                  do nzth = 1, nthin
c*********************************SCC  12/21/95
c     zero out the ray-data variable to rayop
                     call zeros
c***********************************************
                     indgr = indgr + 1
c $$$$$  Added by TK Mau on 11/18/91
                     irec = 0
c $$$$$ Added by TK Mau and SC Chiu on 10/16/91
                     pwedge(indgr) = 0.
c $$$$$$$$$$$$$$$$$$$$$$$$$
                     write (iout, 1000)
c
c ************ ************ ************ ************ ************
c  initialization for hpcsd (integrating subroutine)
c ************ ************ ************ ************ ************
c
                     mstart = 0
  120                continue
                     mstart = mstart + 1
                     write (iout, 2099) mstart, prmt(5), y(2)
 2099                format('$$ mstart=',i3,5x,'prmt(5)=',f4.0,
     1                  5x,'psi =',e12.4)
c******************* Change 2 to 3   SCC  5/5/95
                     if (mstart > 3) then
                        write (iout, 2001)
 2001                   format(1x,
     1'*****Ray terminated after failure of restart.'/1x,
     2                     '*****Need a different delthe')
                        go to 101
                     endif
c----------------7/5/95
                     spkpsi(:npdim) = 0.
                     sakpsi(:npdim) = 0.
                     sakth(:npdim) = 0.
                     jmcon(:npdim) = 0
c---------------------
                     if (initlh == 0) then
                        istart = 1
                        isxz = 0
                        jslofa = islofa
                        eikon = 0.
                        theta = zpi*thstrt(nzth,isign)/180.
c-------------SCC  6/16/95
                        if (mstart > 1) then
                           theta = zpi*thstrt(nzth,isign)/180. + delthe*
     1                        (mstart - 1)
                           pwtote = pwte0
                           pwtoti(:nspec) = pwti0(:nspec)
                           pwe(:nprof) = pwe0(:nprof)
                           pwc(:nprof) = pwc0(:nprof)
                           pwi(:nprof,:nspec) = pwii0(:nprof,:nspec)
                        endif
c----------------------------
c*******************************SCC   5/5/95  Changed above restart condition
                        phi = phi0
c $$$$  Altered by TK Mau on 11/20/91  SCCHiu 1/26/94
                        if (igrill == (-3)) then
                           pkphi = zkpar
                           pktau = zkpol
                        else
                           if (igrill == (-2)) then
                              pkphi = zkpar
                           else
                              pkpar = zkpar
                           endif
                        endif
c $$$$$$$$$$$$$$$$$$$$$$$$
                        pwx = pwcpl(isign,n)*fpwth(nzth)
                        jpe = 0
                        jpi = 0
c
                        call iniwfr
                        if (scatd/=0.0 .and. iscat0/=0) then
                           call scatperp
                           y(1) = akpsi
                           y(3) = akth
                        endif
                        theta0 = theta*180./zpi
                        write (iout, 2010) pkphi, pktau, psi, theta0
 2010                   format(1x,'Initial pkphi=',e14.6,2x,
     1                     '; initial pktau=',e14.6/1x,'Initial psi=',
     2                     e14.6,2x,';  initial theta=',e14.6,1x,
     3                     'degrees')
c
                     else
c--------------------SCC  12/21/95
c   work is incomplete here. Need to call rayinout(4) and then rayinout(5)
c   to read in ray by ray
c   Need a different channel and different name for ray-data file
c   Label ray number by nrayno=indgr in rayinout
c--------------------------------
                        isxz = isimpl(indgr)
                        jslofa = jslofas(indgr)
                        eikon = seikon(isxz)
                        psi = spsi(isxz)
                        theta = atan2(szu(isxz)-zma,sxu(isxz))
                        if (mstart > 1) go to 101
c--------------------
c  ray is not restarted if data is read in from 'rayop'
c----------------------
                        phi = tzpi*sphi(isxz)
                        pkpar = skpar(isxz)
                        pkpar2 = pkpar*pkpar
                        pwx = spower(isxz)
                        y(1) = skpsi(indgr)
                        y(2) = psi
                        y(3) = skth(indgr)
                        y(4) = theta
                        y(5) = phi
                        y(6) = -100.
                        if (pwx > exp(-15.)) then
                           if(istarts(indgr)==(-1))istarts(indgr)=1
!                           y(6) = alog(pwx)
                           y(6) = log(pwx)
                        endif
                        istart = istarts(indgr)
                        jpe = jpes(indgr)
                        jpi = jpis(indgr)
                        isxz = isxz - 1
                        call coords
                        call profix
                        call disper (0)
                        anphi = skphi(indgr)
                     endif
c
c
c  istart: 0(no good start), 1(ok start), -1(absorbed).
                     if (istart > 0) then
c
                        if (initlh == 0) then
                           x = 0.
                           call deriv (x)
                           if (psistep /= 0.) then
                              cst1 = max(abs(pkpar)**pkexpnt,0.5_dp)
                              cst2 = min(abs(psistep/dy(2)/cst1),tzpi)
                              cst3 = 2.*deykpr
                          cst2 = min(0.25_dp*deykpr+0.75_dp*cst2,cst3)
                              deykpr = min(tzpi,cst2)
                           endif
                           keik = 1
                           eikref = deykpr
                           powold = pwx
                           nurefl = 0
                        else
                           x = sxx(indgr)
                           call deriv (x)
                           if (psistep /= 0.) then
                              cst1 = max(abs(pkpar)**pkexpnt,0.5_dp)
                              cst2 = min(abs(psistep/dy(2)/cst1),tzpi)
                              cst3 = 2.*deykpr
                         cst2 = min(0.25_dp*deykpr+0.75_dp*cst2,cst3)
                              deykpr = min(tzpi,cst2)
                           endif
                           keik = keiks(indgr)
                           eikref = x + deykpr
                           powold = pwx
                           nurefl = nurefls(indgr)
                        endif
c
   10                   continue
                        call deriv (x)
c
                        dkdrin = dy(2)/abs(dy(2))
                        akrini = y(1)
                        neik = keik
                        if (neik>nequip .and. nequip>0) stop 30
                        hlast = 0.5*dsteph
   12                   continue
                        if (abs(x - eikref) <= 1.E-6*abs(deykpr)) eikref
     1                      = eikref + deykpr
                        neik = keik
c
c ************ ************ ************ ************ ************
c  loop over equiphase surfaces
c ************ ************ ************ ************ ************
c
                        do nzeik = neik, nequip
                           deykpp = deykpr
                           psistepp = psistep
                           anphpv = anphi
                           ypv = y(:6)
                           keik = nzeik
                           prmt(1) = x
                           prmt(2) = eikref
                           prmt(3) = 2.*hlast
                           prmt(4) = accur
                           prmt(6) = 0.
c*********************SCC 10/20/94
c**************************************
                           dy(:6) = precdy(:6)
c******************
c
                           kkk = nzeik/30
                           kk1 = nzeik/100
                           kk2 = nzeik/5
                           call hpcsd (deriv, output1)
c
c     Record rays stopped for reasons other than that the
c     interval is completed, in istarts
                           if (prmt(5) <= (-2.)) go to 120
                           if (prmt(5)>0. .and. isxz<nps) then
                              if (pwx <= epsray*power/float(nnztot*nthin
     1                           )) then
                                 istarts(indgr) = -1
                              else
                                 istarts(indgr) = 0
                              endif
                           endif
c#########################
c  SCC  7/24/95    This section was re-written
c  mode conversion of LH-waves are allowed now.
c
                           if (jhlf >= 21) istarts(indgr) = 0
                           if (prmt(5) == (-1.)) then
                              jmcon(isxz) = -1
                              go to 89
                           endif
                           if (abs(y(2)-ypv(2))<=1.E-10 .and. abs(y(4)-
     1                        ypv(4))<=1.E-10) then
                              prmt(5) = 1
                              go to 101
                           endif
c-------------------
c  check for evanescence and/or mode-conversion;
c---------------------
   89                      continue
                           call disper (0)
                           call sub3d (discr, ind1, ichois)
c------------
c  if ind1=1, go back one step and do m-conversion.
c-------------
                           if (ind1 == 1) then
   80                         continue
                              kmcon = 1
                              call stpbak (kmcon, ind1, ind2, pkp20)
                              x = xx
c------------
c  update y(1),y(3) for mode-conversion
c----------
                              call sub5 (pkp20, ier5)
                              if (ier5 == 99) then
                                 isxz = isx1
                                 go to 80
                              endif
                              kmcon = 0
                              nurefl = nurefl + 1
                              if (nurefl > maxref) go to 101
                              call disper (1)
                              call coutgr
                              psistep = psistepp
                              deykpr = deykpp
                              eikref = x
                              istarts(indgr) = 1
                              go to 12
                           else
c-------------
c if ind1=0, first check if there were mode-conversion in previous
c five steps
c then check if close to evanescence
c if neither, then continue
c--------------
                              call chkpmc (jmcon, npdim, isxz, jmcind)
                              kmcon = 0
                              if (jmcind /= 1) then
                                 call sub4 (pkp21, pkp22, pkp23, ind2,
     1                              jslofa, ichois, kmcon, pkp20, iermc
     2                              , disck2, a2k, nslofa, imode
     3                              , tempe, xe, zxe2, cz, czp)
                                 if (iermc /= 0) then
                                    isx1 = isxz - 1
                                    jmcon(isx1) = 1
                                    jmcon(isxz) = 0
                                    sjslofa(isxz) = nslofa
                                    jslofa = nslofa
                                    kmcon = 0
                                    go to 32
                                 endif
c--------
c  Check if near m-c
c--------
                                 call subkmc (pkp21, pkp22, pkp23, ind2
     1                              , jslofa, ichois, kmcon, pkp20,
     2                              iermc, disck2, a2k, nslofa, imode)
                                 if (kmcon == 0) then
                                    if (abs(y(2)-ypv(2))<=1.E-6 .and.
     1                                 abs(y(4)-ypv(4))<=1.E-6) kmcon =
     2                                 -1
                                 endif
                                 jmcon(isxz) = kmcon
                                 select case (kmcon)
                                 case (0)
                                    go to 32
                                 case (-1)
                                    prmt(5) = -1.
                                    pkpsi2 = pkp20 - pkheta**2
                                    if (pkpsi2 < 0.) then
   85                               continue
                                    call stpbak (kmcon, ind1, ind2,
     1                                 pkp20)
                                    x = xx
                                    call sub5 (pkp20, ier5)
                                    if (ier5 == 99) then
                                    isxz = isxz - 1
                                    go to 85
                                    endif
                                    else
                                    call sub5 (pkp20, ier5)
                                    endif
                                    kmcon = 0
                                    nurefl = nurefl + 1
                                    if (nurefl > maxref) go to 101
                                    call disper (1)
                                    call coutgr
                                    psistep = psistepp
                                    deykpr = deykpp
                                    eikref = x
                                    istarts(indgr) = 1
                                    pkpsi = -pkpsi
                                    y(1) = (aj*pkpsi + ag*pktau)/antau
                                    akpsi = y(1)
                                    pwx = exp(y(6))
                                    call wloss
                                    pwxwl = (1. - wfrac)*pwx
                                    pwedge(indgr) = pwedge(indgr) +
     1                                 pwxwl
                                    pwx = wfrac*pwx
!                                    y(6) = alog(pwx)
                                    y(6) = log(pwx)
                                    powold = powold - pwxwl
                                    if (scatd /= 0.) then
                                    call scatperp
                                    y(1) = akpsi
                                    y(3) = akth
                                    endif
                                    go to 10
                                 case (1)
                                    pkpsi2 = pkp20 - pkheta**2
                                    if (pkpsi2 < 0.) then
   87                               continue
                                    call stpbak (kmcon, ind1, ind2,
     1                                 pkp20)
                                    x = xx
                                    call sub5 (pkp20, ier5)
                                    if (ier5 == 99) then
                                    isxz = isxz - 1
                                    go to 87
                                    endif
                                    else
                                    call sub5 (pkp20, ier5)
                                    endif
                                    kmcon = 0
                                    nurefl = nurefl + 1
                                    if (nurefl > maxref) go to 101
                                    call disper (1)
                                    call coutgr
                                    psistep = psistepp
                                    deykpr = deykpp
                                    eikref = x
                                    istarts(indgr) = 1
                                    go to 12
                                 end select
                              endif
c---------------------
c*****************10/10/91 SCC refreshing process
c  refreshing process involves mltiplying akpsi and akth by a factor
c  ss2 which is determined by the Newton-Raphson method so that the
c  new k-vector satisfy the dispersion relation. akphi is kept constant
c  in the process.
c*******************************
                           endif
   32                      continue
                           if (prmt(6) >= 1.) then
                              call disper (0)
c----------------SCC   7/26/95
                              call sub4 (pkp21, pkp22, pkp23, ind2,
     1                           jslofa, ichois, kmcon, pkp20, iermc,
     2                           disck2, a2k, nslofa, imode,
     3                           tempe, xe, zxe2, cz, czp)
                              if (abs(disck2/a2k) <= 1.E-1) go to 88
                              ss1 = 1.00
                              call sub2 (ss1, disp1, ddisp1, ichois)
                              iter = 0
   26                         continue
                              ss2 = ss1 - disp1/ddisp1
                              if (ss2<=1.2 .and. ss2>=0.8) then
                                 if (abs(ss2 - ss1) > 1.E-6) then
                                    iter = iter + 1
c----------SCC  6/29/95
                                    if (iter > 100) then
                                    write (iout, 1112) iter, indgr
 1112                               format(2x,'no convergence in',i5,
     1                                 'iterations,abandon ray',i5)
                                    prmt(5) = 1.
                                    go to 101
                                    endif
                                    if (iter == 51) then
c-------------------
                                    write (59, 1111) iter, indgr
 1111                               format(2x,'no convergence in',i5,
     1                                 'iterations,continue ',
     2                                 'refreshing',i5)
                                    endif
   88                               continue
                                    ier = 0
                                    call precrt (ss1, ss2, ier, ichois)
                                    if (ier == 19) then
                                    write (iout, 1114) indgr, isxz, psi
     1                                 , theta
 1114                               format(2x,'ray no.=',i5,2x,
     1                                 'step no.=',i5,'psi=',e16.6,2x,
     2                                 'theta=',e16.6/2x,
     3'no solution of dispersion close to raypoint.')
                                    go to 101
                                    endif
                                    go to 91
                                 endif
c----------------SCC  6/29/95
                                 call sub2 (ss2, disp2, ddisp2, ichois)
c-----------------------
                                 ss1 = ss2
                                 disp1 = disp2
                                 ddisp1 = ddisp2
                                 go to 26
                              endif
                              if (abs(ss2 - 1.) > 0.5) then
                                 prmt(5) = 1.
                                 write(iout,1113)indgr,isxz,psi,theta
 1113                            format(2x,'Ray no.:',i5,3x,'step no.:',
     1                              i5,';  at psi=',e16.6,2x,
     2                              'and theta=',e16.6/2x,
     3'ray marching error too            large.')
                                 go to 101
                              endif
   91                         continue
                              akpsi = akpsi*ss2
                              akth = akth*ss2
                              y(1) = akpsi
                              y(3) = akth
                              call sub1
                              call deriv (x)
                           endif
c*********end refreshing
c#######################################################
c
                           x = tzpi*eikon
                           xx = x
c     Adjust step if psistep.ne.0.
                           if (psistep /= 0.) then
                              cst1 = max(abs(pkpar)**pkexpnt,0.5_dp)
c       cst0=abs(psilast-y(2)+0.002)
c       cst0=amin1(psistep,cst0)
                              cst2 = min(abs(psistep/dy(2)/cst1),tzpi)
                              cst3 = 2.*deykpr
                        cst2 = min(0.25_dp*deykpr+0.75_dp*cst2,cst3)
                              deykpr = min(tzpi,cst2)
                           endif
                           if (prmt(5) < 0.) go to 40
                           if (prmt(5) > 0.) go to 101
                           eikref = x + deykpr
                        end do
c
c ************ ************ ************ ************ ************
c  end of loop over equiphase surfaces
c ************ ************ ************ ************ ************
c
                        go to 101
c
c ************ ************ ************ ************ ************
c  specular reflection at the edge
c ************ ************ ************ ************ ************
c
   40                   continue
                        pkpsi = -pkpsi
                        y(1) = (aj*pkpsi + ag*pktau)/antau
                        akpsi = y(1)
                        nurefl = nurefl + 1
c $$$$$$$$ Added by TK Mau and SC Chiu on 10/16/91
c     To account for wall losses at each reflection
                        if (nurefl > maxref) go to 101
                        call wloss
                        pwx = exp(y(6))
                        pwxwl = (1. - wfrac)*pwx
                        pwedge(indgr) = pwedge(indgr) + pwxwl
                        pwx = wfrac*pwx
!                        y(6) = alog(pwx)
                        y(6) = log(pwx)
                        powold = powold - pwxwl
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

c ************ ************ ************ ************ ************
c   angular scattering of perp wavevector according to
c   optical depth for the process scatd:
c ************ ************ ************ ************ ************
                        if (scatd /= 0.) then
                           call scatperp
                           y(1) = akpsi
                           y(3) = akth
                        endif
                        keik = isxz + 1

                        go to 10
c
c ************ ************ ************ ************ ************
c  ray ended
c ************ ************ ************ ************ ************
c
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c   Added by T.K. Mau on Oct. 9, 991.
c  Modified by TK Mau  on 4/19/94
c    pweray : electron power deposition profile for each ray
c    pwcray : driven current density profile for each ray
c    curay : driven current (MA) for each ray
c    curay1 : driven minority current profile (A/cm**2)
c    curay2 : driven fast ion current profile (A/cm**2)
c    currfe : driven electron current (MA)
c    currf1 : driven minority current (MA)
c    currf2 : driven fast ion current (MA)
c    currf  : total current driven
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c
                     endif
  101                continue
c-----------------SCC  7/26/95
                     if (inf /= (-2)) then
c--------------
                        if (indgr == 1) then
c-------SCC  3/27/91
                           pwc10(:nprof,:nspec) = 0.
                           pwii0(:nprof,:nspec) = 0.
c---------------------------.
                           pwe0(:nprof) = 0.
                           pwc0(:nprof) = 0.
c----- Modified 10/16/91.
                           pwte0 = 0.
                           pwti0(:nspec) = 0.
                           if (kalfa > 0) then
                              pwtf0(:nalfa) = 0.
                              pwff0(:nprof,:nalfa) = 0.
                              pwc20(:nprof,:nalfa) = 0.
                           endif
c-------------------------
                        endif
                        curay(indgr) = 0.
c--------- SCC  3/27/92
                        pwiray(:nprof,:nspec,indgr) = pwi(:nprof,:nspec)
     1                      - pwii0(:nprof,:nspec)
                        pwii0(:nprof,:nspec) = pwi(:nprof,:nspec)
                        pwc1ray(:nprof,:nspec,indgr) = pwc1(:nprof,:
     1                     nspec) - pwc10(:nprof,:nspec)
                        pwc10(:nprof,:nspec) = pwc1(:nprof,:nspec)
c----------------------------
                        pweray(:nprof,indgr)=pwe(:nprof)-pwe0(:nprof)
                        pwcray(:nprof,indgr)=pwc(:nprof)-pwc0(:nprof)
                        pwe0(:nprof) = pwe(:nprof)
                        pwc0(:nprof) = pwc(:nprof)
                        if (kalfa > 0) then
                           pwfray(:nprof,:nalfa,indgr) = pwal(:nprof,:
     1                        nalfa) - pwff0(:nprof,:nalfa)
                           pwff0(:nprof,:nalfa) = pwal(:nprof,:nalfa)
                           pwc2ray(:nprof,:nalfa,indgr) = pwc2(:nprof,:
     1                        nalfa) - pwc20(:nprof,:nalfa)
                           pwc20(:nprof,:nalfa) = pwc2(:nprof,:nalfa)
                        endif
c---------Modified 0n 10/16/91.
                        fpwray(indgr) = (spower(1)-pwx)/spower(1)
                        if (fpwray(indgr) >= 1.E-12) then
                           fpowe(indgr) = (pwtote - pwte0)/(spower(1)-
     1                        pwx)
                           frpowi(indgr) = 0.
                           fpowi(:nspec,indgr) = (pwtoti(:nspec)-pwti0(:
     1                        nspec))/(spower(1)-pwx)
                           frpowi(indgr) = frpowi(indgr) + sum(fpowi(:
     1                        nspec,indgr))
                           if (kalfa > 0) then
                              frpowf(indgr) = 0.
                              fpowf(:nalfa,indgr) = (pwtotf(:nalfa)-
     1                           pwtf0(:nalfa))/(spower(1)-pwx)
                              frpowf(indgr) = frpowf(indgr) + sum(fpowf(
     1                           :nalfa,indgr))
                           endif
                           frpow(indgr) = fpowe(indgr) + frpowi(indgr)
     1                         + frpowf(indgr)
                           if (frpow(indgr) >= 1.E-14) then
c     if(fpowe(indgr).lt.1.e-14) go to 56
                              pweray(:nprof,indgr) = pweray(:nprof,indgr
     1                           )/fpwray(indgr)
                              pwcray(:nprof,indgr) = pwcray(:nprof,indgr
     1                           )/fpwray(indgr)
c--------------         SCC  3/27/92
                              pwiray(:nprof,:nspec,indgr) = pwiray(:
     1                           nprof,:nspec,indgr)/fpwray(indgr)
                              pwc1ray(:nprof,:nspec,indgr) = pwc1ray(:
     1                           nprof,:nspec,indgr)/fpwray(indgr)
c---------------------------.
                              if (kalfa > 0) then
                                 pwc2ray(:nprof,:nalfa,indgr) = pwc2ray(
     1                              :nprof,:nalfa,indgr)/fpwray(indgr)
                                 pwfray(:nprof,:nalfa,indgr) = pwfray(:
     1                              nprof,:nalfa,indgr)/fpwray(indgr)
                              endif
                           endif
                        endif
c-----------------------------------
c$$$$$$$$$$$$$$$   TK MAU  9/3/92
c--------Driven current (MA) for each ray for 100% absorption

c     dra = 1./float(nprof-1)
c     ajold = tzpi*pqr(1,1)*pwcray(1,indgr)*bttra(1)
c    1 /bttra2(1)*dpsifra(1)
c     do 51 ij = 2,nprof
c     ajnew = tzpi*pqr(ij,1)*pwcray(ij,indgr)*bttra(ij)/
c    2 bttra2(ij)*dpsifra(ij)
c     curay(indgr) = curay(indgr)+0.5e-2*(ajnew+ajold)*dra
c     ajold = ajnew
c51    continue
                        curay(indgr) = curay(indgr) + sum(0.5*(pwcray(2:
     1                     nprof,indgr)*zsurf(2:nprof)+pwcray(:nprof-1,
     2                     indgr)*zsurf(:nprof-1))*1.E-2)
c-----Modified on 10/16/91.
                        effcd(indgr) = curay(indgr)/spower(1)
                        pwte0 = pwtote
                        pwti0(:nspec) = pwtoti(:nspec)
                        pwtf0(:nalfa) = pwtotf(:nalfa)
c $$$$$$$$$$$$$$$$$$$$$$$$$
                        pwtra(isign,n) = pwtra(isign,n) + pwx
c $$$$$  Added by TK Mau on 11/18/91
                        if (iprint < 0) call outrun (3)
c $$$$$$$$$$$$$$$$$$$$
c*****************************SCC  12/21/95
                        call rayinout (2)
c********************************************
                     endif
                  end do
c  Should check on restart operation of pwtra (091289:bh)
c
               endif
            end do
c
         endif
      end do
c
c $$$$$$$$$$Added by T.K. Mau on Oct. 10, 1991.
c---------------SCC 3/27/92
      pwe(:nprof) = 0.
      pwc(:nprof) = 0.
      pwi(:nprof,:nspec) = 0.
      do iray = 1, indgr
         pwe(:nprof) = pwe(:nprof) + pweray(:nprof,iray)
      end do
      do iray = 1, indgr
         pwc(:nprof) = pwc(:nprof) + pwcray(:nprof,iray)
      end do
      do iray = 1, indgr
         pwi(:nprof,:nspec) = pwi(:nprof,:nspec) + pwiray(:nprof,:nspec,
     1      iray)
      end do
c----------------------------
c ---- Do minority and fast ion current accounting;  TK Mau  4/19/94
      currf1 = 0.
      currf2 = 0.
      if (nminor > 0) then
         do k = nsp1 + 1, nspec
            curay1(k) = 0.
            do ip = 1, nprof
               pwc1(ip,k) = 0.
               pwc1(ip,k) = pwc1(ip,k) + sum(pwc1ray(ip,k,:indgr))
               if (ip /= 1) curay1(k) = curay1(k) + 0.5E-2*(pwc1(ip,k)*
     1            zsurf(ip)+pwc1(ip-1,k)*zsurf(ip-1))
            end do
            currf1 = currf1 + curay1(k)
         end do
         do i1 = 1, nprof
            pwct1(i1) = 0.
            pwct1(i1) = pwct1(i1) + sum(pwc1(i1,nsp1+1:nspec))
         end do
      endif
      if (kalfa > 0) then
         do k = 1, nalfa
            curay2(k) = 0.
            do ip = 1, nprof
               pwal(ip,k) = 0.
               pwc2(ip,k) = 0.
               pwal(ip,k) = pwal(ip,k) + sum(pwfray(ip,k,:indgr))
               pwc2(ip,k) = pwc2(ip,k) + sum(pwc2ray(ip,k,:indgr))
               if (ip /= 1) curay2(k) = curay2(k) + 0.5E-2*(pwc2(ip,k)*
     1            zsurf(ip)+pwc2(ip-1,k)*zsurf(ip-1))
            end do
            currf2 = currf2 + curay2(k)
         end do
         do i2 = 1, nprof
            pwct2(i2) = 0.
            pwct2(i2) = pwct2(i2) + sum(pwc2(i2,:nalfa))
         end do
      endif
c----------------------------
      do ip = 1, nprof
         pwit(ip) = 0.
         pwit(ip) = pwit(ip) + sum(pwi(ip,:nspec))
         pwft(ip) = 0.
         pwft(ip) = pwft(ip) + sum(pwal(ip,:nalfa))
      end do
      ptedge = 0.
      currfe = 0.
      currfe = sum(curay(:indgr))
      ptedge = sum(pwedge(:indgr))
c $$$$$ Added by T.K. Mau on 10/16/91.
      tpowi = 0.
      tpowi = sum(pwtoti(:nspec))
      tpowf = 0.
      tpowf = sum(pwtotf(:nalfa))
      ptot0 = 0.
      ptot = pwtote + tpowi + tpowf + ptedge
      isign = 1
      if (isimm > 0) then
         ptot0 = sum(powers(:isimm))
         isign = isimm + 1
      endif
      if (inf == (-2)) return
      ftpowe = pwtote/ptot
      ftpowi(:nspec) = pwtoti(:nspec)/ptot
      ftpowf(:nalfa) = pwtotf(:nalfa)/ptot
      ftpf = tpowf/ptot
      ftpi = tpowi/ptot
      ftedge = ptedge/ptot
      fpowt = ptot/ptot0
c $$$$$  TK Mau   4/19/94
c     Total driven current for 100% absorption
      do ir = 1, nprof
         pwct(ir) = pwc(ir)
         if (nminor > 0) then
            pwct(ir) = pwct(ir) + sum(pwc1(ir,nsp1+1:nspec))
         endif
         if (kalfa > 0) then
            pwct(ir) = pwct(ir) + sum(pwc2(ir,:nalfa))
         endif
      end do
      currf = currfe + currf1 + currf2
      effcdt = currf/ptot0
c $$$$$  Added by TK Mau on 10/29/91.
c     Total driven current for 100% absorption
c     do 65 ir = 1,nprof
c     pwct(ir) = 0.
c     do 65 iq = 1,indgr
c  65 pwct(ir) = pwct(ir)+pwcray(ir,iq)
c************************SCC 4/13/95
c $$$$$  Altered by TK Mau on 05/95
c     Total driven current profile for 100% absorption
c ---- Calculate <j.B>_cd and <j_tor>_cd
c                                                ! A-T/m**2
      ajrfb(:nprof) = 1.E4*pwct(:nprof)*dbt1(:nprof)
c     pwct(ir) = ajrfb(ir)*bttra(ir)/dbt2(ir)   ! A/m**2
      pwiv(0,:nspec) = 0.
      pwev(0) = 0.
      do ip = 1, nprof
         pwev(ip) = pwev(ip-1) + pwe(ip)*volume(ip)
         pwiv(ip,:nspec) = pwiv(ip-1,:nspec) + pwi(ip,:nspec)*volume(ip)
      end do
c ----  TKM   05/02
      go to 555
c $$$$     TKM   06/97     for ARIES study
c     Calculate power reqd. for driving forward seed current on axis.
      if (irayio <= 0) then
         if (ioread <= 0) then
            if (islofa < 0) then
               powrq = abs(aiseed(1)/effcdt)
            else
               powrq = abs(aiseed(1)/effcdt)
            endif
c     Recalculate RF absorbed power and driven current profiles
            pwe(:nprof) = (powrq/ptot0)*pwe(:nprof)
            pwit(:nprof) = (powrq/ptot0)*pwit(:nprof)
            pwct(:nprof) = (powrq/ptot0)*pwct(:nprof)
            pwft(:nprof) = (powrq/ptot0)*pwft(:nprof)
            ajrfb(:nprof) = (powrq/ptot0)*ajrfb(:nprof)
            ajdrv(:nprof) = ajbst(:nprof) + pwct(:nprof)
         endif
      endif
c $$$$$$$$$$$$$$$$$$$$$$$
 555  continue
c ----  05/02
c*********************************SCC  12/21/95
      call rayinout (3)
c**********************************************
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
      return
c ************ ************ ************ ************ ************
 1000 format('0',
     1   "===========================================================")
 1010 format('0',/,45x,"------- n parallel =",f9.4," -------",/)
c ************ ************ ************ ************ ************
      end subroutine raytr

      subroutine zeros
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:58:46   6/14/01
C...Switches: -p4 -yb
c
c  zero out the s-variables
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      use Vparam
      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 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-----------------------------------------------
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c----------------------------

      seikon = 0
      spsi = 0
      sxu = 0
      szu = 0
      skp = 0
      skpar = 0
      stheta = 0
      sphi = 0
      spower = 0
      sbtot = 0
      sene = 0
      salphac = 0
      salphal = 0
      sdpwri = 0
      spol = 0
      sdkpar = 0
      scepx = 0
      scepy = 0
      scepz = 0
      sztpol = 0
      sjslofa = 0
      serrors = 0
      return
      end subroutine zeros

