c
c  This module contains controlling routines
c
c---------------------------------------------------
      subroutine adjint(ientry)
      use Vdynamic
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:51:36   6/14/01  
C...Switches: -p4 -yb
c--------------------
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vdynamic
      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 Vceqdsk, ONLY: ntitle, dat, ipestg, nxeqd, nzeqd, xdimeqd, 
     1   zdimeqd, reqd, redeqd, zmideqd, xma, zma, psimag, psilim, 
     2   beqd, toteqd, psimx1, psimx2, xax1, xax2, zax1, zax2, psisep, 
     3   xsep, zsep, feqd, presseqd, ffpeqd, ppeqd, peqd, qeqd, xeqd, 
     4   zeqd, psiadj, dpolflx, psieqd, tpsieqd, tpsifeqd, iounit1, 
     5   inoperm1, nptsdm1, nptsd, torflux, tpsisav, ra, psifra, 
     6   dpsifra, fra, fra1, cspln, pds, wnoperm, xcontr, zcontr, 
     7   bpcontr, btcontr, dstarp, b_fld, jacob, pprime, vprime, 
     8   chipsi, ncontr, dang, bperr, arcl, thet, anglex, csplnx, 
     9   csplnz, pdsx, pdsz, nlim, rlim, zlim, nlimiter, rlimiter, 
     .   zlimiter, lrz, nprim, nimp, nion, nti, zi, zeffz, r, raeqd, 
     1   psifeqd, te, ti, ti1, ene, enp, bmod, rmd, btmd, bpmd, btpmd, 
     2   roa
      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      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 :: nw, nthp, ns, js, jp, jps
      real :: zef1, dt, alpha, rho
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   #option for n-T profile calculation: 1 if
c                        # calculated from prontp; else =0.
 
 
c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
c---------------------------
c   common block for Comraylh
c-------------------------
c
c
c$$$$$$$$     TKM    11/98
c*********    TKM   2/97, 6/99, 9/99
c*********    TKM   2/97
c*******   TK Mau   8/98
c*************************
c  SCC  3/7/95
 
c  Storage related to EQDSK:
c  Units used in the EQDSK are entirely MKSA.
c  Comeqdsk-->ceqdsk.i
 
c-------------------------
c  inputs from Comraylh:  nthp0,npsi0,psimx,psimn (bavorbt)
c                         nmax,umax1,imax,lmax,tmax     (subadj)
c                         nthp0,npsi0,psimx,psimn,nmax,umax,imax,
c                         lmax,nwp,wpmx,nthp1      (curadj)
c  open-close I/O channels: (i) iout3 (adjinp) (bavorbt,subadj)
c                           (ii)iout4 (scrach) (bavorbt,subadj,curadj)
c                          (iii)iout5 (adjout) (subadj,curadj)
c                           (v) iout6 (joptab)  (curint)
c                       (v)  iout7  (scrach1)  (runb: input chi-trial)
c                       (vi) iout8  (scrach2)  (runb: output chi-trial)
c
c outputs to Comraylh: If ientry=3, output jop(nwp,nthp1,npsi0),psis(npsi0),
c                        eden(npsi0),etem(npsi0),zefi(npsi0),
c                        thetp(nthp1),wp(nwp)
c                       use high beta approximation;
c                     (also outputs these to 'joptabh')
c
c----------------------------------
c------------------    1/22/96
c   set nwp,nthp1,npsi0
c
      select case (ientry) 
      case default
c----------------
c  assume nthp0,npsi0,psimx,psimn already known
c
         call bavorbt
c     fclose(iout3)
         return 
      case (2) 
c----------------
c  get Spitzer-function table
c
         call subadj (zef1, nmax, umax1, imax, nthp0, dt, tmax, alpha, 
     1      rho, lmax, iout3, iout5, iout4, iout7, iout8, iswchi, aerrmx
     2      , rerrmx)
c     fclose(iout3)
c     fclose(iout5)
         return 
      case (3) 
c--------------------------
c  get j/p table
c
         iadj = 1
         call curadj (nthp0, npsi0, psimx, psimn, nmax, umax1, imax, 
     1      lmax, psis(1), eden(1), etem(1), zefi(1), sjop(1), nwp, wpmx
     2      , wpmn, dwp, wp(1), nthp1, thetp(1), iout4, iout5, iadj, 
     3      gwk2, gwk3, npnta)
         write (iout6, 1000) jopid
         write (iout6, 1010) nwp, nthp0, npsi0, nthp1
         write (iout6, 1020) psimx, psimn, wpmx, wpmn, dwp
         write (iout6, 1030) (wp(nw),nw=1,nwp)
         write (iout6, 1030) (thetp(nthp),nthp=1,nthp1)
         write (iout6, 1030) (psis(ns),ns=1,npsi0)
         write (iout6, 1030) (eden(ns),ns=1,npsi0)
         write (iout6, 1030) (etem(ns),ns=1,npsi0)
         write (iout6, 1030) (zefi(ns),ns=1,npsi0)
         do js = 1, npsi0
            do jp = 1, nthp1
               jps = (js - 1)*nthp1*nwp + (jp - 1)*nwp + 1
               write (iout6, 1030) (sjop(nw),nw=jps,jps + nwp - 1)
            end do
         end do
c--------------------------------
 1000    format(1x,1a40)
 1010    format(1x,4i8)
 1020    format(5(1x,e18.10))
 1030    format(5(1x,e18.10))
c------------------------
         return 
      end select
      end subroutine adjint
      subroutine master(ientry)
      use Vdynamic
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:51:36   6/14/01  
C...Switches: -p4 -yb
c
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      use Vdynamic
      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 Vceqdsk
      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      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 :: iercg, iercn, iercm, iercl, ierch
      real :: stat
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
c----------------------------
c       common block Comiorlh(1-8)
c
c  ipropt         integer   #option for n-T profile calculation: 1 if
c                        # calculated from prontp; else =0.
 
 
c--------SCC  5/23/95
c*******  TKM  06/97, 2/00
c*************************
c********    TKM    11/98
c*******************************
c  #   SCC 3/27/92   SCC 4/13/95
c---------------------------
c   common block for Comraylh
c-------------------------
c
c
c$$$$$$$$     TKM    11/98
c*********    TKM   2/97, 6/99, 9/99
c*********    TKM   2/97
c*******   TK Mau   8/98
c*************************
c  SCC  3/7/95
 
c
c
c ************ ************ ************ ************ ************
c
c   plasma parameters and initialisation
c
c ************ ************ ************ ************
c
c     Commented out: May 7,1991 (bh).  Put call in br_go, before call master.
c           if (initlh.ne.1)  call inital
c
      select case (ientry) 
      case default
c      call hpalloc(aspinptr,npsi0,iercg,1)
         if (.not.allocated(aspin)) then
            ALLOCATE(aspin(npsi0),stat=iercg)
            if (iercg /= 0) then
               print *, 'aspin could not be allocated in master'
               return 
            endif
         endif
         call adjint (1)
         call vbak
         rewind iout3
         if (idcur == 3) then
            call adjint (2)
            rewind iout3
            rewind iout5
            joplg = nwp*nthp1*npsi0
c        call hpalloc(sjopptr,joplg,iercn,1)
            if (.not.allocated(sjop)) then
               ALLOCATE(sjop(joplg),stat=iercn)
               if (iercn /= 0) then
                  print *, 'sjop could not be allocated in master'
                  return 
               endif
            endif
c        call hpalloc(aspinptr,npsi0,iercm,1)
            if (.not.allocated(aspin)) then
               ALLOCATE(aspin(npsi0),stat=iercm)
               if (iercm /= 0) then
                  print *, 'aspin could not be allocated in master'
                  return 
               endif
            endif
c        call hpalloc(wpptr,nwp,iercl,1)
            if (.not.allocated(wp)) then
               ALLOCATE(wp(nwp),stat=iercl)
               if (iercl /= 0) then
                  print *, 'wp could not be allocated in master'
                  return 
               endif
            endif
c        call hpalloc(thetpptr,nthp1,ierch,1)
            if (.not.allocated(thetp)) then
               ALLOCATE(thetp(nthp1),stat=ierch)
               if (ierch /= 0) then
                  print *, 'thetp could not be allocated in master'
                  return 
               endif
            endif
            call adjint (3)
            rewind iout4
            rewind iout5
c        rewind iout6
         endif
         return 
      case (2) 
         joplg = nwp*nthp1*npsi0
c        call hpalloc(sjopptr,joplg,iercn,1)
         if (.not.allocated(sjop)) then
            ALLOCATE(sjop(joplg),stat=iercn)
            if (iercn /= 0) then
               print *, 'sjop could not be allocated in master'
               return 
            endif
         endif
c        call hpalloc(aspinptr,npsi0,iercm,1)
         if (.not.allocated(aspin)) then
            ALLOCATE(aspin(npsi0),stat=iercm)
            if (iercm /= 0) then
               print *, 'aspin could not be allocated in master'
               return 
            endif
         endif
c        call hpalloc(wpptr,nwp,iercl,1)
         if (.not.allocated(wp)) then
            ALLOCATE(wp(nwp),stat=iercl)
            if (iercl /= 0) then
               print *, 'wp could not be allocated in master'
               return 
            endif
         endif
c        call hpalloc(thetpptr,nthp1,ierch,1)
         if (.not.allocated(thetp)) then
            ALLOCATE(thetp(nthp1),stat=ierch)
            if (ierch /= 0) then
               print *, 'thetp could not be allocated in master'
               return 
            endif
         endif
         call adjint (3)
         rewind iout4
         rewind iout5
         return 
      case (3) 
         if (istop /= 0) go to 9000
c***************************************
c   SCC  5/20/96  for tabulation
c
         if (idcur == 3) then
            dpsis = (psimx - psimn)/(npsi0 - 1)
            dwp = (wpmx - wpmn)/(nwp - 1)
            dthp1 = 8.E0*atan(1.E0)/(nthp1 - 1)
            mthwp = nthp1*nwp
            nthp11 = nthp1 - 1
            nthp12 = nthp1 - 2
            npsi01 = npsi0 - 1
            npsi02 = npsi0 - 2
            nwp1 = nwp - 1
            nwp2 = nwp - 2
         endif
c----------------------
c    idcur=1    Ehst-Karney model
c         =2    not working
c         =3    direct adj integration
c------------------------
c
c ************ ************ ************ ************
c
c   printout of the run parameters
c
c ************ ************ ************ ************
c
         call outrun (1)
c
         if (igraph /= 0) call outgra(1)
         call pwicpl
c
c ************ ************ ************ ************
c
c   main ray tracing subroutine
c
c ************ ************ ************ ************
c
         call raytr
c
c ************ ************ ************ ************
c
c   print out of the power deposition profiles and
c             graphical output
c
c ************ ************ ************ ************
c
         call outrun (2)
c
         if (igraph == 0) return 
c
         call outgra(3)
c
         return 
      case (4) 
c        call hpalloc (aspinptr, npsi0, iercg, 1)
c        call hpalloc(thetpptr,nthp1,ierch,1)
         if (.not.allocated(aspin)) then
            ALLOCATE(aspin(npsi0),stat=ierch)
            if (ierch /= 0) then
               print *, 'aspin could not be allocated in master'
               return 
            endif
         endif
         call adjint (1)
         call vbak
         rewind iout3
         return 
      end select
c
c ************ ************ ************ ************
c
c   break point in case of inconsistent data
c
c ************ ************ ************ ************
c
 9000 continue
      stop 
c
c ************ ************ ************ ************
c
      end subroutine master
c
      subroutine output1(x)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:51:36   6/14/01  
C...Switches: -p4 -yb
c
c ************ ************ ************ ************ ************
c
c         Revised by S.C.Chiu July 10,1991.
c         test for modified F-S-wave turning point
c         provision for IBW-FW mode conversion reserved in FWIBMC
c     Normal version
C--------------------------------
c   output of the integrating subroutine
c   tests for confluence,lin. turning point, absorption
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, epserr, epser1, epsray, iout
      use Vcraylh
      use Vceqdsk
      use Vchpcsd
      use Vcmnew
      use Vcgraphs, only: initlh, nraypts
      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real x
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i, ly
      real, dimension(nions) :: zgami
      real :: zpi, znpol, zntor, zconf, error, thg, phg, zgame
C-----------------------------------------------
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
c      real , EXTERNAL :: exp, alog
c      real :: exp, alog
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 ************ ************ ************ ************ ************
c
c
c ************ ************ ************ ************ ************
c
      data zpi/3.14159265359/
c
c ************ ************ ************ ************ ************
c  phase and position in m
c ************ ************ ************ ************
      eikon = x/(2.*zpi)
      pwx = y(6)
      pwx = exp(y(6))
      znpol = theta/(2.*zpi)
      zntor = phi/(2.*zpi)
c $$$$$$$$$$$$ Added by TK Mau, 8/28/91.
      irec = irec + 1
      if (irec < nraym) then
         rec0(irec) = psi
c     rec1(irec) = znpol
         rec1(irec) = gami(2)
c     rec2(irec) = zntor
         rec2(irec) = gamip(2)
         rec3(irec) = serror
         rec4(irec) = pkpar
         rec5(irec) = pkp2
         rec6(irec) = pwx
         rec7(irec) = game
         rec8(irec) = gamit
         rec12(irec) = 1./wci(1)
         rec13(irec) = dense*1.E-13
         rec14(irec) = tempe
         rec15(irec) = xe
      else
         if (irec < nplus) rec6(irec) = pwx
      endif
c $$$$$$$$$$$$
c ************ ************ ************ ************
c   failure to maintain the required accuracy
c ************ ************ ************ ************
      zconf = amax1(abs(hc),abs(hb*pkp2))
      error = abs(disph/zconf)
      serror = error
      if (error>=epser1 .and. error<=epserr) call mflag (5)
      if (jhlf>20 .or. error>epserr) then
         call mflag (1)
c     if(abs(dy(2)/dy(4)).lt.0.001)  go to 60
         write (iout, 9010) znpol, zntor, psi, error, hlast, jhlf
c ************ ************ ************ ************
c   power deposited since the last step
c ************ ************ ************ ************
c
      endif
      call absorb
c******************SCC  5/5/95
      if (irec > irecmx) call mflag (3)
c******************************
c####################################
c  July 8,1991
      if (ichois == 1) then
c####################################
c
         if (iprint /= 3) then
            if (x > prmt(2) + 0.001*hlast) return 
c ************ ************ ************ ************
c   the ray reaches the wall
c ************ ************ ************ ************
c**************2/14/95  SCC
         endif
         if (y(2) < psilast) go to 30
         if (dy(2) <= 0.) go to 30
         write (iout, 1150) eikon, znpol, zntor, psi
         call mflag (2)
c        nurefl =nurefl+1
c     if(nurefl.ge.maxref)  call mflag(3)
         go to 100
c ************ ************ ************ ************
c  tests for radial reflection
c ************ ************ ************ ************
   30    continue
         if (dy(2)/dkdrin <= 0.) then
            dkdrin = -dkdrin
c ************ ************ ************ ************
c  wispering gallery reflection
c ************ ************ ************ ************
c     if(pkpsi*akrini.gt.0.) go to 60
            if (pkpsi*akrini <= 0.) then
               akrini = -akrini
               if (dkdrin >= 0.) then
c  internal
                  write (iout, 1110) eikon, znpol, zntor, psi
               else
c  at cutoff
                  write (iout, 1115) eikon, znpol, zntor, psi
                  nurefl = nurefl + 1
                  if (nurefl >= maxref) call mflag (3)
c ************ ************ ************ ************
c   test on the kind of confluence (eliminated 7/17/95)
c ************ ************ ************ ************
c##############  SCC 6/01/92  7/17/95
c 60      if (ichois.eq.1) then
c        twoqu = ha/(3.*alfa) - pkp2
c         else
c          twoqu = atwo**2 - 4.*asxy1*azero
c         endif
c######################
c     if(twoqu)  70,70,80
c ************ ************ ************ ************
c   linear turning point
c ************ ************ ************ ************
c  70 write(iout,1120)  eikon,znpol,zntor,psi
c         call mflag(4)
c
c           call absorb
c
c     go to 100
c ************ ************ ************ ************
c   confluence slow-fast wave
c ************ ************ ************ ************
c  80 write(iout,1130)  eikon,znpol,zntor,psi
c        jslofa = -jslofa
c ************ ************ ************ ************
c   is the power completely absorbed
c ************ ************ ************ ************
c---------------SCC  6/15/95
               endif
            endif
         endif
         if (pwx > epsray*power/float(nnztot*nthin)) go to 100
c--------------------
         call mflag (3)
         write (iout, 1140) eikon, znpol, zntor, psi
         go to 100
c############################################
c  July 8,1991
      endif
      if (iprint /= 3) then
         if (x > prmt(2) + 0.001*hlast) return 
c ************ ************ ************ ************
c   the ray reaches the wall
c ************ ************ ************ ************
c*****************SCC  2/16/95
      endif
      if (y(2) < psilast) go to 230
      if (dy(2) <= 0.) go to 230
      write (iout, 1150) eikon, znpol, zntor, psi
      call mflag (2)
c         nurefl = nurefl+1
c     if(nurefl.ge.maxref)  call mflag(3)
      go to 100
c ************ ************ ************ ************
c  tests for radial reflection
c ************ ************ ************ ************
  230 continue
      if (dy(2)/dkdrin <= 0.) then
         dkdrin = -dkdrin
c ************ ************ ************ ************
c  wispering gallery reflection
c ************ ************ ************ ************
c     if(pkpsi*akrini.gt.0.) go to 260
         if (pkpsi*akrini <= 0.) then
            akrini = -akrini
            if (dkdrin >= 0.) then
c  internal
               write (iout, 1110) eikon, znpol, zntor, psi
            else
c  at cutoff
               write (iout, 1115) eikon, znpol, zntor, psi
               nurefl = nurefl + 1
               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
               if (nurefl >= maxref) call mflag (3)
c ************ ************ ************ ************
c   test on the kind of confluence
c ************ ************ ************ ************
c260      continue
c        if (ichkmc.eq.1) then
c ************ ************ ************ ************
c   check for
c   linear turning point
c ************ ************ ************ ************
c     call FWIBMC(iflg)
c     if (iflg.eq.1) then
c 270 write(iout,1120)  eikon,znpol,zntor,psi
c         call mflag(4)
c
c           call absorb
c             endif
c
c     go to 100
c      else
c        twoqu=pkp2-0.5*atwo/asxy1
c        if (twoqu.ge.0.) then
c ************ ************ ************ ************
c   confluence slow-fast wave
c ************ ************ ************ ************
c 280 write(iout,1130)  eikon,znpol,zntor,psi
c        jslofa = -jslofa
c        endif
c     endif
c ************ ************ ************ ************
c   is the power completely absorbed
c ************ ************ ************ ************
c-------------SCC  6/15/95
            endif
         endif
      endif
      if (pwx <= epsray*power/float(nnztot*nthin)) then
c----------------------
         call mflag (3)
         write (iout, 1140) eikon, znpol, zntor, psi
c#########################################
c **************************************************
c  printout control
c ************ ************ ************ ************
      endif
  100 continue
      xu = ux/ukzero
      zu = uz/ukzero
      if (prmt(5)/=0. .or. x==0.) go to 120
      if (iprint > 2) go to 120
      if (x > prmt(1)) return 
c 110 if(iprint.eq.0)  go to 170
      if (iprint <= 0) go to 170
c ************ ************ ************ ************
c   normal output
c ************ ************ ************ ************
  120 continue
      thg = theta*180./zpi
      phg = phi*180./zpi
      write (iout, 1010) eikon, psi, thg, phg, xu, zu
      write (iout, 1030) pkpar, pkp, pkpsi, pktau, pwx
      if (iprint > 1) then
         write (iout, 1040) pkheta, pkx, pkz, pkp2
         write (iout, 1020) dense, tempe, tempi(mainsp), btor, bpol
c 130 if(iprint.eq.0.or.gamma.eq.0.) go to 160
      endif
      if (iprint>0 .and. gamma/=0.) then
         if (game /= 0.) then
            zgame = game/gamma
            write (iout, 1050) xe, zgame
         endif
         do i = 1, nspec
            if (gami(i) /= 0.) then
               zgami(i) = gami(i)/gamma
               write (iout, 1060) i, xi(i), zgami(i)
            endif
         end do
c ************ ************ ************ ************
c   detailed output
c ************ ************ ************ ************
         if (iprint <= 1) go to 170
         write (iout, 1240) epx, epy, epz, poyntn
      endif
      if (iprint > 1) then
         write (iout, 1210) xp, y2
         write (iout, 1220) alfa, ha, hb, hc
         write (iout, 1230) (dy(ly),ly=1,ndim)
         write (iout, 1250) disph, error, hlast
c ************ ************ ************ ************
c   storage for graphical output
c ************ ************ ************ ************
      endif
  170 continue
      if (prmt(5) /= 0.) return 
      if (igraph == 0) return 
      isxz = isxz + 1
c
      call outgra(2)
c
c ************ ************ ************ ************
 1010 format('0',"phase  =",f10.2,3x,"psi    =",f10.4,3x,"theta  =",
     1   f10.2,3x,"phi    =",f10.2,3x,"x      =",f10.3,3x,"z      =",
     2   f10.3)
 1020 format(' ',21x,"ne   =",1pe11.3,3x,"te     =",0pf10.3,3x,
     1   "ti     =",f10.3,3x,"b tor. =",f10.3,3x,"b pol. =",f10.3)
 1030 format(' ',21x,"n par  =",f10.2,3x,"n perp =",f10.2,3x,"n psi  =",
     1   f10.2,3x,"n tau  =",f10.2,3x,"power  =",f10.3)
 1040 format(' ',21x,"n xhi  =",f10.3,3x,"n x    =",f10.3,3x,"n z    =",
     1   f10.3,3x,"n p2   =",1pe11.3)
 1050 format(' ',21x,"electrons:  xe  =",e15.5,3x,"power (fract) =",
     1   e15.3)
 1060 format(' ',21x,"species",i2,":  xi =",1pe15.3,4x,"power(i) =",
     1   e15.3)
c ************ ************ ************ ************
 1110 format(' ',5x,"wispering gallery reflection , phase =",f9.3,
     1   "  n pol =",f9.3,"  n tor =",f9.3,"  psi =",f9.3)
 1115 format(' ',5x,"near wall cut off            , phase =",f9.3,
     1   "  n pol =",f9.3,"  n tor =",f9.3,"  psi =",f9.3)
 1120 format(' ',5x,"linear turning point         , phase =",f9.3,
     1   "  n pol =",f9.3,"  n tor =",f9.3,"  psi =",f9.3)
 1130 format(' ',5x,"confluence point             , phase =",f9.3,
     1   "  n pol =",f9.3,"  n tor =",f9.3,"  psi =",f9.3)
 1140 format(' ',5x,"absorption complete          , phase =",f9.3,
     1   "  n pol =",f9.3,"  n tor =",f9.3,"  psi =",f9.3)
 1150 format(' ',5x,"the ray is reaching the wall , phase =",f9.3,
     1   "  n pol =",f9.3,"  n tor =",f9.3,"  psi =",f9.3)
c ************ ************ ************ ************
 1210 format(' ',21x,"xp     =",1pe15.4,"  y2     =",e15.4)
 1220 format(' ',21x,"alfa   =",1pe13.4,2x,"a      =",e13.4,2x,
     1   "b      =",e13.4,2x,"c      =",e13.4)
 1230 format(' ',21x,"dy =",6e13.4)
 1240 format(' ',21x,"pol. vect =",3e13.4," poyntn =",e13.4)
 1250 format(' ',21x,"disph  =",1pe11.3," error  =",e11.3," step   =",
     1   e11.3)
c ************ ************ ************ ************ ************
 9010 format(' ',5x,"integration failed,","  n pol =",f9.3,"  n tor =",
     1   f9.3,"  psi =",f9.3/20x,"error =",e13.4," step =",e13.4,
     2   " jhlf =",i4)
c ************ ************ ************ ************ ************
c
      return 
c
      end subroutine output1

