      subroutine hpcsd(funct, output)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:38:46   6/15/01
C...Switches: -p4 -yb
c
c *********************************************************************

c      This subroutine appears to be a modified version of an
c      ibm subroutine hpcs.

c
c     description of parameters
c           prmt(1)    - lower bound of the interval (input).
c           prmt(2)    - upper bound of the interval (input).
c           prmt(3)    - initial increment of the independent variable
c                        (input).
c           prmt(4)    - upper error bound (input). if absolute error
c                        is greater than prmt(4), increment gets halved
c                        if increment is less than prmt(3) and absolute
c                        error less than prmt(4)/50, increment gets
c                        doubled. the user may change prmt(4) by means
c                        of his output subroutine
c           prmt(5)    - no input parameter. subroutine hpcsd initiali-
c                        zes prmt(5) to zero. if the user wants to ter-
c                        minate subroutine hpcsd at any output point he
c                        has to change prmt(5) to non-zero by means of
c                        subroutine output.
c                        =-1   ray reflected
c                        =-2   ray hitting axis
c                        = 1   ray terminated
c           prmt(6)    - = 1   ray refreshed
c                        =-1   ray initial increment h halved
c           y          - input vector of initial values (destroyed).
c                        later on y is the resulting vector of depen-
c                        dent variables y computed at the intermediate
c                        points x.
c           dy         - input vector of error weights (destroyed),
c                        the sum of its components must be equal to 1.
c                        (The weights could be chosen proportional to
c                         typical values of the dependent variable.  Bob H).
c                        later on dy is the vector of the derivatives
c                        which belong to function values y at point x.
c           hlast      - output containing the current value of the
c                        indep. variable step
c           ndim       - an input value which specifies the number of
c                        equations in the system.
c           jhlf       - an output value which specifies the number of
c                        bisections of the initial increment. if jhlf
c                        gets greater than 20, subroutine hpcsd returns
c                        with error message jhlf=21 to main program.
c                        error message jhlf=22 or jhlf=23 appears in
c                        case prmt(3)=0 or in case sign(prmt(3)).ne.
c                        sign(prmt(2)-prmt(1)) respectively.
c           ind        - if ind >= 0 test is made on absolute error
c                        if ind < 0 test is made on relative error
c                        (I believe ind >=0 indicates relative error.
c                         See line 175 ff.  BobH 050791).
c           funct      - the name of an external subroutine used. it
c                        computes the right hand side dy of the system
c                        to given values of x and y. its parameter list
c                        is x. furthermore it must contain the labeled
c                        common/chpcsd/prmt(5),y(*),dy(*),w(16,*),ndim
c                        ,jhlf. this subroutine should not destroy:
c                        x,y,w,ndim,jhlf.
c           output     - the name of an external output subroutine used
c                        its parameter list is x. furthermore it must
c                        contain the labeled common/chpcsd/prmt(5),y(*)
c                        ,dy(*),w(16,*),ndim,jhlf. none of these para-
c                        meters (except prmt(4), prmt(5), if necessa-
c                        ry) should be changed by subroutine output. if
c                        prmt(5) is changed to non-zero, subroutine
c                        hpcsd is terminated
c
c
c     remarks
c           the procedure terminates and returns to calling program if
c           1) more than 20 bisections of the initial increment are
c              necessary to get satisfactory accuracy (error message
c              jhlf=21).
c           2) initial increment is equal to zero or has wrong sign
c              (error messages jhlf=22 or 23 respectively).
c           3) the whole integration interval is worked through.
c           4) subroutine output has changed prmt(5) to non-zero.
c
c
c *********************************************************************
c  SCC 10/20/94      2/7/95
c
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      use Vsizes
      use Vchpcsd
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
C...  /chpcsd/
!      common /chpcsd/ prmt(6), y(10), dy(10), dy6o, hlast, ndim, jhlf,
!     1   ind, serror, psilast, yin(10), dyin(10), mcnt, h, klim, irecmx
!      integer   ndim, jhlf, ind, mcnt, klim, irecmx
!      real   prmt, y, dy, dy6o, hlast, serror, psilast, yin, dyin, h
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: k0, n, k1, jsw, k2, k3, k4, k5, k6, k7, kcnt, k8, k9,
     1   l0, icnt, l1, l2, l3, l4, jstep, l6, l5, l7, l8, l9, m0, l10,
     2   jmod, m1, m2, m3, m4, l11
      real(kind=dp), dimension(40) :: ck
      real(kind=dp), dimension(16,10) :: w
      real(kind=dp), dimension(6) :: y0
      real(kind=dp) :: hlim, x, delta, q, ynorm, x0, t, qdelta, q1, q2
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
C      EXTERNAL funct, output
C-----------------------------------------------
c--------yin & dyin store initial y's and dy's
c----------SCC 3/2/95    5/5/95    add h,klim,irecmx
c
c    +              hlast,          ndim,           jhlf,
c *********************************************************************
c
c
c *********************************************************************
c
      data ck/.0E0, .5E0, .66666666666667E0, .375E0, .79166666666667E0,
     1   .20833333333333E0, .41666666666667E-1, .33333333333333E0, .4E0
     2   , .29697760924775E0, .15875964497103E0, .45573725421879E0,
     3   .21810038822592E0, .30509651486929E1, .38328647604670E1,
     4   .17476028226269E0, .55148066287873E0, .12055355993965E1,
     5   .17118478121952E0, .13333333333333E1, .92561983471074E0, .125E0
     6   , .9E1, .3E1, .74380165289256E-1, .01E0, .2E-1,
     7   .89629629629630E1, .33611111111111E1, .390625E-2, .8E2, .135E3
     8   , .4E2, .1171875E0, .6E1, .2E1, .12E2, .108E3, .234375E-1,
     9   .18E2/
c
c *********************************************************************
c
      mcnt = 0
      yin(:ndim+1) = y(:ndim+1)
      dyin(:ndim+1) = dy(:ndim+1)
c-------------SCC 5/5/95
      hlim = abs(prmt(2)-prmt(1))/klim
c---------------------
  400 continue
      mcnt = mcnt + 1
      y(:ndim+1) = yin(:ndim+1)
      dy(:ndim+1) = dyin(:ndim+1)
      n = 1
      jhlf = 0
      x = prmt(1)
      h = prmt(3)/2.**(mcnt - 1)
      prmt(5) = ck(1)
      prmt(6) = ck(1)
      w(16,:ndim) = ck(1)
      w(15,:ndim) = dy(:ndim)
      w(1,:ndim) = y(:ndim)
      if (h*(prmt(2)-x) >= 0.) then
         if (h*(prmt(2)-x) > 0.) go to 3
         jhlf = 22
         go to 3
      endif
      jhlf = 23
c
c           computation of dy for starting values
c           -------------------------------------
    3 continue
      call funct (x)
c********************SCC  10/20/94
      dy6o = dy(6)
c**********************************
c
c           recording of starting values
c           ----------------------------
      call output (x)
      if (prmt(5) == 0.) then
         if (jhlf <= 0) go to 6
      endif
    5 continue
      return
c     <><><>
    6 continue
      w(8,:ndim) = dy(:ndim)
c
c           computation of w(2,k2)
c           ----------------------
c************************SCC  1/16/95
      if (h*(x + 3.*h - prmt(2)) > 0.) h = (prmt(2)-x)/
     1   3.99999999999999999
c**********************************
      jsw = 1
      go to 21
    7 continue
      x = x + h
      w(2,:ndim) = y(:ndim)
c
c           increment is tested by means of bisection
c           -----------------------------------------
    8 continue
      jhlf = jhlf + 1
      x = x - h
      w(4,:ndim) = w(2,:ndim)
      h = h*ck(2)
      hlast = h
      n = 1
      jsw = 2
      go to 21
    9 continue
      x = x + h
      call funct (x)
      n = 2
      w(2,:ndim) = y(:ndim)
      w(9,:ndim) = dy(:ndim)
      jsw = 3
      go to 21
c
c           computation of test value delta.
c           --------------------------------
c           q is an auxiliary storage location.
   10 continue
      delta = ck(1)
      do k5 = 1, ndim
         q = y(k5) - w(4,k5)

c     There can be a problem when a dependent variable is near zero.
c     y(k5) may become smaller in proportion to reduction of the
c     step size, and the relative error will not become smaller
c     (may become constant) as the step size is halved.
c     This is accounted for in the following modification, by
c     the indicated replacement:

c                        if(ind.gt.0.and.y(k5).ne.ck(1)) q=q/y(k5)

         if (w(15,k5) == 0.0) then
            ynorm = largest                      ! was 1.e100
         else
            ynorm = abs(prmt(4)/w(15,k5))
         endif
         ynorm = max(ynorm,abs(y(k5)))
         if (ind>0 .and. y(k5)/=ck(1)) q = q/ynorm
         if (q <= ck(1)) q = -q
         delta = delta + w(15,k5)*q
      end do
      delta = delta*ck(3)
      if (delta - prmt(4) <= 0.) go to 14
      if (jhlf - 20 < 0) go to 8
      jhlf = 21
      x = x + h
      go to 3
c
c           there is satisfactory accuracy after < 11 bisections
c           ----------------------------------------------------
   14 continue
      x = x + h
      call funct (x)
      w(3,:ndim) = y(:ndim)
      w(10,:ndim) = dy(:ndim)
      n = 3
      jsw = 4
      go to 21
   15 continue
      n = 1
      x = x + h
      call funct (x)
      x = prmt(1)
      w(11,:ndim) = dy(:ndim)
      y(:ndim) = w(1,:ndim) + h*(ck(4)*w(8,:ndim)+ck(5)*w(9,:ndim)-ck(6)
     1   *w(10,:ndim)+ck(7)*dy(:ndim))
      if (y(2) <= 5.E-4) prmt(5) = -2.
      if (prmt(5) /= 0.) go to 5
   16 continue
      x = x + h
      n = n + 1
      call funct (x)
c*****************************SCC 10/20/94
      y(6) = y(6) + h*(dy6o + dy(6))/2.
      dy6o = dy(6)
c****************************  SCC  5/5/95
      kcnt = 0
c*************************
      call output (x)
      if (prmt(6) > 0.) go to 5
      if (prmt(6) < 0.) go to 400
      if (prmt(5) /= 0.) go to 5
      if (n - 4 >= 0) go to 22
      w(n,:ndim) = y(:ndim)
      w(n+7,:ndim) = dy(:ndim)
      if (n - 3 > 0) go to 22
      if (n - 3 == 0) go to 20
      do k9 = 1, ndim
         delta = w(9,k9) + w(9,k9)
         delta = delta + delta
         y(k9) = w(1,k9) + ck(8)*h*(w(8,k9)+delta+w(10,k9))
      end do
      if (y(2) <= 5.E-4) prmt(5) = -2.
      if (prmt(5) == 0.) go to 16
      go to 5
c                        go to 16
   20 continue
      do l0 = 1, ndim
         delta = w(9,l0) + w(10,l0)
         delta = delta + delta + delta
         y(l0) = w(1,l0) + ck(4)*h*(w(8,l0)+delta+w(11,l0))
      end do
      if (y(2) <= 5.E-4) prmt(5) = -2.
      if (prmt(5) == 0.) go to 16
      go to 5
c                        go to 16
c
c     the following part of the subroutine hpcsd computes by means of
c     a runge-kutta method starting values for the not self-starting
c     predictor-corrector method. t is an auxiliary storage location.
c
c**********************SCC 2/17/95
   21 continue
      icnt = 0
   64 continue
      icnt = icnt + 1
      x0 = x
      y0(:ndim) = y(:ndim)
      do l1 = 1, ndim
         t = h*w(n+7,l1)
         w(5,l1) = t
         y(l1) = w(n,l1) + ck(9)*t
      end do
      if (y(2) <= 5.E-4) prmt(5) = -2.
      if (prmt(5) /= 0.) go to 5
      if (y(2) < psilast) then
         t = x + ck(9)*h
         call funct (t)
         do l2 = 1, ndim
            t = h*dy(l2)
            w(6,l2) = t
            y(l2) = w(n,l2) + ck(10)*w(5,l2) + ck(11)*t
         end do
         if (y(2) <= 5.E-4) prmt(5) = -2.
         if (prmt(5) /= 0.) go to 5
         if (y(2) < psilast) then
            t = x + ck(12)*h
            call funct (t)
            do l3 = 1, ndim
               t = h*dy(l3)
               w(7,l3) = t
               y(l3)=w(n,l3)+ck(13)*w(5,l3)-ck(14)*w(6,l3)+ck(15)*t
            end do
            if (y(2) <= 5.E-4) prmt(5) = -2.
            if (prmt(5) /= 0.) go to 5
            if (y(2) < psilast) then
               t = x + h
               call funct (t)
               y(:ndim) = w(n,:ndim) + ck(16)*w(5,:ndim) - ck(17)*w(6,:
     1            ndim) + ck(18)*w(7,:ndim) + ck(19)*h*dy(:ndim)
            endif
         endif
      endif
      if (y(2)>=psilast .or. icnt>=2) then
         if (icnt>=3 .or. abs(y(2)-psilast)<1.E-3) go to 63
         h = (psilast - y0(2))*h/(y(2)-y0(2))
         y(:ndim) = y0(:ndim)
         call funct (x0)
         x = x0
         go to 64
   63    continue
         prmt(5) = -1
      endif
c
c           possible break-point for linkage
c           --------------------------------
      if (y(2) <= 5.E-4) prmt(5) = -2.
      if (prmt(5) /= 0.) go to 5
      go to (7,9,10,15,41) jsw
c
c********************************
c
c
c     starting values are computed. now starts hamming"s modified
c     -----------------------------------------------------------
c     predictor-corrector method.
c     ---------------------------
   22 continue
      jstep = 3
   23 continue
      if (h*(x + h - prmt(2)) < 0.) then
         if (n - 8 == 0) then
            w(:6,:ndim) = w(2:7,:ndim)
            w(8:13,:ndim) = w(9:14,:ndim)
            n = 7
c
c           n<8 causes n+1 to get n
c           -----------------------
         endif
         n = n + 1
c
c           computation of next vector y
c           ----------------------------
         w(n-1,:ndim) = y(:ndim)
         w(n+6,:ndim) = dy(:ndim)
         x = x + h
   26    continue
         jstep = jstep + 1
         do l8 = 1, ndim
            delta = w(n-4,l8) + ck(20)*h*(w(n+6,l8)+w(n+6,l8)-w(n+5,l8)+
     1         w(n+4,l8)+w(n+4,l8))
            y(l8) = delta - ck(21)*w(16,l8)
            w(16,l8) = delta
         end do
c
c           predictor is now generated in row 16 of w, modified predic-
c           tor is generated in y. delta means an auxiliary location.
c           the derivatives of the modified predictor will now be gene-
c           rated in dy.
         if (y(2) <= 5.E-4) prmt(5) = -2.
         if (prmt(5) /= 0.) go to 5
         call funct (x)
         do l9 = 1, ndim
            delta = ck(22)*(ck(23)*w(n-1,l9)-w(n-3,l9)+ck(24)*h*(dy(l9)+
     1         w(n+6,l9)+w(n+6,l9)-w(n+5,l9)))
            w(16,l9) = w(16,l9) - delta
            y(l9) = delta + ck(25)*w(16,l9)
         end do
c
c           test whether h must be halved or doubled
c           ----------------------------------------
         if (y(2) <= 5.E-4) prmt(5) = -2.
         if (prmt(5) /= 0.) go to 5
         delta = ck(1)
         do m0 = 1, ndim
            q = w(16,m0)
c                        if(ind.gt.0.and.y(m0).ne.ck(1)) q=q/y(m0)

            if (w(15,m0) == 0.0) then
               ynorm = largest                   ! was 1.e100
            else
               ynorm = abs(prmt(4)/w(15,m0))
            endif
            ynorm = max(ynorm,abs(y(m0)))
            if (ind>0 .and. y(m0)/=ck(1)) q = q/ynorm

            if (q < ck(1)) q = -q
            delta = delta + w(15,m0)*q
         end do
         if (delta - prmt(4) >= 0.) go to 38
   27    continue
         call funct (x)
c*****************************SCC 10/20/94
         y(6) = y(6) + h*(dy6o + dy(6))/2.
         dy6o = dy(6)
c****************************
         call output (x)
c******************SCC  5/5/95
         if (abs(h) < hlim) then
            kcnt = kcnt + 1
            if (kcnt > klim) prmt(5) = -3
         endif
c**************************
c               if (y(2).lt.0.98)         call mflag(6)
         if (prmt(6) /= 0.) go to 5
         if (prmt(5) /= 0.) go to 5
         if (jhlf - 21 >= 0) go to 5
         go to 30
   29    continue
         qdelta = (x - prmt(2))/h
         if (abs(qdelta) > ck(26)) go to 40
         y(:ndim) = y(:ndim) + qdelta*(w(n-1,:ndim)-y(:ndim))
         if (y(2) <= 5.E-4) prmt(5) = -2.
         if (prmt(5) /= 0.) go to 5
         x = x - h*qdelta
         call funct (x)
c*****************************SCC 10/20/94
         y(6) = y(6) + h*(dy6o + dy(6))/2.
         dy6o = dy(6)
c****************************
         call output (x)
         return
   30    continue
         if (h*(x - prmt(2)) >= 0.) go to 29
         q1 = x - prmt(2)
         if (q1 < ck(1)) q1 = -q1
         q2 = h
         if (q2 < ck(1)) q2 = -q2
         if (q1 - ck(26)*q2 < 0.) go to 29
         if (delta - ck(27)*prmt(4) > 0.) go to 23
         if (jhlf <= 0) go to 23
         if (n - 7 < 0) go to 23
         if (jstep - 4 < 0) go to 23
         jmod = jstep/2
         if (jstep - jmod - jmod /= 0) go to 23
         h = h + h
         hlast = h
         jhlf = jhlf - 1
         jstep = 0
         do m1 = 1, ndim
            w(n-1,m1) = w(n-2,m1)
            w(n-2,m1) = w(n-4,m1)
            w(n-3,m1) = w(n-6,m1)
            w(n+6,m1) = w(n+5,m1)
            w(n+5,m1) = w(n+3,m1)
            w(n+4,m1) = w(n+1,m1)
            delta = w(n+6,m1) + w(n+5,m1)
            delta = delta + delta + delta
            w(16,m1) = ck(28)*(y(m1)-w(n-3,m1)) - ck(29)*(dy(m1)+delta+w
     1         (n+4,m1))*h
         end do
         go to 23
c
c           h must be halved
c           ----------------
   38    continue
         jhlf = jhlf + 1
         if (jhlf - 20 > 0) go to 27
         h = ck(2)*h
         hlast = h
         jstep = 0
         y(:ndim) = ck(30)*(ck(31)*w(n-1,:ndim)+(ck(32)*w(n-2,:ndim))+ck
     1      (33)*w(n-3,:ndim)+w(n-4,:ndim)) - ck(34)*h*(w(n+6,:ndim)-ck(
     2      35)*w(n+5,:ndim)-w(n+4,:ndim))
         w(n-4,:ndim) = ck(30)*(ck(37)*w(n-1,:ndim)+(ck(32)*w(n-2,:ndim)
     1      )+ck(38)*w(n-3,:ndim)+w(n-4,:ndim)) - ck(39)*(w(n+6,:ndim)+
     2      ck(40)*w(n+5,:ndim)-ck(23)*w(n+4,:ndim))*h
         w(n-3,:ndim) = w(n-2,:ndim)
         w(n+4,:ndim) = w(n+5,:ndim)
         if (y(2) <= 5.E-4) prmt(5) = -2.
         if (prmt(5) /= 0.) go to 5
         x = x - h
         delta = x - (h + h)
         call funct (delta)
         w(n-2,:ndim) = y(:ndim)
         w(n+5,:ndim) = dy(:ndim)
         y(:ndim) = w(n-4,:ndim)
         if (y(2) <= 5.E-4) prmt(5) = -2.
         if (prmt(5) /= 0.) go to 5
         delta = delta - (h + h)
         call funct (delta)
         do m4 = 1, ndim
            delta = w(n+5,m4) + w(n+4,m4)
            delta = delta + delta + delta
            w(16,m4) = ck(28)*(w(n-1,m4)-y(m4)) - ck(29)*(w(n+6,m4)+
     1         delta+dy(m4))*h
            w(n+3,m4) = dy(m4)
         end do
         go to 26
      endif
   40 continue
      jsw = 5
      h = prmt(2) - x
      w(1,:ndim) = y(:ndim)
      w(8,:ndim) = dy(:ndim)
      n = 1
      go to 21
   41 continue
      x = x + h
      call funct (x)
c*****************************SCC 10/20/94
      y(6) = y(6) + h*(dy6o + dy(6))/2.
      dy6o = dy(6)
c****************************
      call output (x)
      return
      end subroutine hpcsd

      subroutine mflag(n)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:38:46   6/15/01
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      use Vsizes
!      USE Vcwavec
      use Vchpcsd
      use Vcraylh, only: akpsi, akth, anphi, pkpsi, pktau, pkphi,
     1    pkheta, pkx, pkz, pkpar, pkpar2, pkp, pkp2, pkp2x, pk
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer n
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
C...  /chpcsd/
!      common /chpcsd/ prmt(6), y(10), dy(10), dy6o, serror, psilast, yin
!     1   (10), dyin(10), hlast, ndim, jhlf, ind, mcnt, h, klim, irecmx
!      integer   ndim, jhlf, ind, mcnt, klim, irecmx
!      real   prmt, y, dy, dy6o, serror, psilast, yin, dyin, hlast, h
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
C-----------------------------------------------
c--------------------------
c  subroutine to set up flags to direct routing of the marching
c  routine. The flags are prmt(5:6)
c---------------------------
!      common/chpcsd/ prmt(6), y(10),dy(10),dy6o,hlast,
!     1               ndim,jhlf,ind,serror,psilast,yin(10),
!     2               dyin(10),mcnt,h,klim,irecmx
c
c
      select case (n)
      case default
         if (mcnt <= 12) then
            prmt(6) = -1.
         else
            prmt(5) = 1.
         endif
         return
      case (2)
         prmt(5) = -1.
         return
      case (3)
         prmt(5) = 1.
         return
      case (4)
         prmt(5) = 2.
         return
      case (5)
         prmt(6) = 1.
         return
      case (6)
c
c  Wake up ray
c
         if (abs(h) > 1.E-4) return
         if (abs(pkpsi)>0.1 .or. abs(pkheta)>0.1) then
            prmt(6) = 1.
            hlast = max(prmt(3)/2.0_dp,1.E-3_dp)
         else
            if (h*dy(2) > 0.) then
               prmt(5) = -1.
            else
               prmt(6) = 1.
               hlast = max(prmt(3)/2.0_dp,1.E-3_dp)
            endif
         endif
         return
      end select
      end subroutine mflag
      subroutine precrt(ss1, ss2, ier, kchois)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:38:46   6/15/01
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      use Vsizes
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer ier, kchois
      real(kind=dp) ss1, ss2
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer, dimension(51) :: jss
      integer :: j, indic, jss0, js, jcnt
      real(kind=dp), dimension(101) :: ss3, dsp
      real(kind=dp) :: ddisp1, psign, dss0, dss3, disp1, disp2, ddisp2,
     1    ss0,
     1   disp0, ddisp0
C-----------------------------------------------
c-----------------------
c  root finding by bisection
c-----------------------
c
      do j = 1, 51
         ss3(j) = 0.90 + 0.004*j
         call sub2 (ss3(j), dsp(j), ddisp1, kchois)
      end do
      indic = 0
      do j = 1, 50
         psign = dsp(j)*dsp(j+1)
c------------------SCC   6/29/95
         if (psign <= 0.) then
            indic = indic + 1
            jss(indic) = j
         endif
c--------------------------
      end do
      if (indic == 0) then
         ier = 19
      else
c----------------------SCC   6/29/95
         jss0 = jss(1)
         dss0 = abs(1. - ss3(jss(1)))
         do js = 2, indic
            dss3 = abs(1. - ss3(jss(js)))
            if (dss3 < dss0) then
               jss0 = jss(js)
               dss0 = dss3
            endif
         end do
         ss1 = ss3(jss0)
         call sub2 (ss1, disp1, ddisp1, kchois)
         ss2 = ss3(jss0+1)
         call sub2 (ss2, disp2, ddisp2, kchois)
         do jcnt = 1, 20
            ss0 = 0.5*(ss1 + ss2)
            call sub2 (ss0, disp0, ddisp0, kchois)
            if (disp0*disp1 <= 0.) then
               ss2 = ss0
               disp2 = disp0
               ddisp2 = ddisp0
            else
               ss1 = ss0
               disp1 = disp0
               ddisp1 = ddisp0
            endif
         end do
      endif
      return
      end subroutine precrt

      subroutine sub4(pkp21, pkp22, pkp23, ind2, kslofa, jchois, kmcon,
     1   pkp20, iermc, disck2, a2k, nslofa, imode, tempe, xe,
     2   zxe2, cz, czp)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:38:46   6/15/01
C...Switches: -p4 -yb
c
c ************ ************ ************ ************ ************
c
c  check exact pkp2 for evanescence
c  jchois=1  high freq. dispersion
c        =2  cold plasma dispersion
c  kslofa: designates mode of current step; -1 cold FW, 1 cold SW, 2 WPW
c  nslofa designates the mode closest to the current branch;
c  nslofa is determined in sub4, while kslofa is input
c  if nslofa ne. kslofa, mode conversion has already taken place
c
c  pkp21: k-perp**2 of odd real root (zero if jchois=2)
c  pkp22,pkp23: paired k-perp**2 (mode conversion)
c  assumed all roots are real
c  ind2=0--fw-sw m-c; =1--sw-wp m-c
c  kmcon=0 no m-c in current step
c       =1 m-c in current step
c  pkp20: exact k-perp**2 of current step
c  if kmcon=1, pkp20 is set to appropriate mode-converted branch
c  if kmcon=0, pkp20 is set to current step
c  iermc: error flag to indicate wrong assignment of ind2 or kslofa
c        = n indicates error at kslofa=n
c        = 0 means no error
c  imode identifies mode# of pkp20 with (pkp21,2,3)
c---------------------------------
c-------July 5,1995.
c---------------------------
c
c ************ ************ ************ ************ ************
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      use Vsizes
      use Vdissub
      use Vcmnew, only: wpe2, apzz, asxy, adxy, asxye, asxy1, adxy1
      use Vcraylh, only: akpsi, akth, anphi, pkpsi, pktau, pkphi,
     1    pkheta, pkx, pkz, pkpar, pkpar2, pkp, pkp2, pkp2x, pk,
     2    nions,  del0, delxp, del1, dhni, dhti, delm,
     3    disph, dhkp2, dhkz, dhne, dhte, dhom, ha, hb, hc, alfa,
     4    xx, eikon, psi, theta, ux, uz, urhs, xu, zu, acosth, asinth,
     5    acostq, asintq, phi, phi0, pwx, dpwri, dpwrf, dsperr


      use kind_spec

      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer ind2, kslofa, jchois, kmcon, iermc, nslofa, imode
      real(kind=dp) pkp21, pkp22, pkp23, pkp20, disck2, a2k, tempe, xe,
     1    zxe2, hzf
      complex cz, czp
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, dimension(3) :: imd
      integer :: j, iout0
      real(kind=dp), dimension(5) :: cwork
      real(kind=dp), dimension(6) :: wrk
      real(kind=dp), dimension(3) :: wrk1
      real(kind=dp) :: zpi, zdsqpi, zcalf, rt3o2, pkpr11, pkpr21,
     1    zxmin, eps3r,
     1   eps3i, ceps3, aeps32, vte, pk2ms, wrk5, wrk9, wrk2, wrk3, wrk4
     2   , wrk6, a4, a2, a0, discr, dk22, dk23, cwork2, a6, bb0, bb1,
     3   bb2, qu1, rq1, ak2mx, ak2mn, dk2mn
      complex, dimension(6) :: cwrk
      complex :: cai
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 $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c  7/10/91   T.K. Mau
c  Complex and real array declaration for ICRF damping
c

c
c $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c
c ************ ************ ************ ************ ************
c
      data zpi/3.14159265359/
      data zdsqpi/1.77245385/
      data zcalf/3.198E-6/
      data rt3o2/0.86602540/
      data cai/(0.,1.)/
c
c ************ ************ ************ ************ ************
c
c-----------------------------
c  6/25/91

      iermc = 0
      imd = 0
      pkpr11 = pktau*asintq + pkphi*acostq
      pkpr21 = pkpr11*pkpr11

      select case (jchois)
      case default
         xe = 15.984/(abs(pkpr11)*sqrt(tempe))
         zxmin = abs(xe)
         zxe2 = xe*xe
c         call zfun(0,xe,cz,czp,zfn,zfc,xzz,nptzf,nptzfa,hzf,iout0)
         call zfun(xe, cz, czp)
         eps3r = 2.*wpe2*zxe2*(1. + xe*real(cz))
         eps3i = 2.*wpe2*zxe2*xe*aimag(cz)
         ceps3 = 2.*wpe2*zxe2*(1. + xe*cz)
         aeps32 = eps3r*eps3r + eps3i*eps3i
         vte = 0.0625*sqrt(tempe)
         del1 = pkpr11*delxp
         delm = asxye*vte**2*xe*cz
         pk2ms = pkpr21 - asxy1
         wrk5 = real(delm)
         wrk9 = real((1. - wrk5)/ceps3)
         wrk2 = real(1./ceps3)
         wrk3 = 1. + del0
         wrk4 = pkpr21*wrk3*wrk3 - pk2ms
         wrk6 = adxy1*adxy1 - pk2ms*pk2ms + pkpr21*wrk3*wrk3*pk2ms
         a4 = wrk4*wrk9
         a2 = pk2ms*(1. + del1*del1*eps3r - wrk5) - 2.*pkpr11*del1*wrk3*
     1      adxy1 + wrk6*wrk2
         a0 = pk2ms**2 - adxy1**2
         discr = a2**2 - 4.*a4*a0
         disck2 = sqrt(discr)/2./a4
         a2k = -a2/2./a4
         wrk(2) = a2k + disck2
         wrk(3) = a2k - disck2
         if (abs(wrk(2)) < abs(wrk(3))) then
            wrk(4) = wrk(2)
            wrk(2) = wrk(3)
            wrk(3) = wrk(4)
         endif
         pkp21 = 0.
         pkp22 = wrk(2)
         pkp23 = wrk(3)
         ind2 = 0
         dk22 = abs(pkp2 - pkp22)
         dk23 = abs(pkp2 - pkp23)
         if (dk22 < dk23) then
            nslofa = 1
            pkp20 = pkp22
            imode = 2
         else
            nslofa = -1
            pkp20 = pkp23
            imode = 3
         endif
         if (nslofa /= kslofa) iermc = kslofa
         if (iermc /= 0) then
c----------
c m-c already has taken place
c------------
            kmcon = 1
            return
         endif
         if (kmcon == 1) then
            if (kslofa == 1) then
               pkp20 = wrk(3)
               nslofa = -1
               imode = 3
            else
               pkp20 = wrk(2)
               nslofa = 1
               imode = 2
            endif
c         kslofa=-kslofa
c     else
c       if (kslofa.eq.1) then
c         pkp20=wrk(2)
c         imode=2
c       else
c         pkp20=wrk(3)
c         imode=3
c       endif
         endif
         return
c
      case (1)
         cwork(1) = asxy - pkpr21
         cwork(2) = apzz + cwork(1)
         cwork(3) = alfa*cwork(2)
         cwork(4) = apzz*cwork(1)
         cwork(5) = alfa*cwork(4)
         a2 = (-(asxy + apzz)*cwork(1)) + adxy**2
         cwork2 = cwork(1)**2 - adxy**2
         a0 = apzz*cwork2
         a2 = a2 - cwork(5)
         a4 = asxy + cwork(3)
         a6 = -alfa
c---------------SCC  6/29/95
         bb0 = a0/a6
         bb1 = a2/a6
         bb2 = a4/a6
         qu1 = bb1/3. - bb2**2/9.
         rq1 = (bb1*bb2 - 3.*bb0)/6. - bb2**3/27.
         discr = qu1**3 + rq1**2
         cwrk(6) = cmplx(discr,0.)
         cwrk(5) = csqrt(cwrk(6))
         cwrk(1) = rq1 + cwrk(5)
         cwrk(2) = rq1 - cwrk(5)
         wrk(:2) = cabs(cwrk(:2))
         where (abs(wrk(:2)) <= 1.E-15)
            cwrk(5:6) = (0.,0.)
         elsewhere
            cwrk(5:6) = cwrk(:2)**(1./3.)
         end where
         wrk(6) = bb2/3.
         cwrk(4) = cwrk(5) + cwrk(6)
         cwrk(5) = cwrk(5) - cwrk(6)
         cwrk(1) = cwrk(4) - wrk(6)
         cwrk(2) = (-0.5*cwrk(4)) - wrk(6)
         cwrk(6) = cai*rt3o2*cwrk(5)
         disck2 = cabs(cwrk(6))
         a2k = cabs(cwrk(2))
         cwrk(3) = cwrk(2) - cwrk(6)
         cwrk(2) = cwrk(2) + cwrk(6)
c------roots are cwrk(1:3)
c------identify the branch of the current step: assume roots are real
         wrk(:3) = real(cwrk(:3))
         if (abs(wrk(2)) < abs(wrk(3))) then
            wrk(4) = wrk(2)
            wrk(2) = wrk(3)
            wrk(3) = wrk(4)
         endif
         if (abs(wrk(1)) > abs(wrk(2))) then
            ind2 = 0
         else
            ind2 = 1
         endif
         pkp21 = wrk(1)
         pkp22 = wrk(2)
         pkp23 = wrk(3)
c---------------
         wrk1 = abs(wrk(:3))
         ak2mx = max(wrk1(1),wrk1(2),wrk1(3))
         ak2mx = ak2mx - 1.E-10
         ak2mn = min(wrk1(1),wrk1(2),wrk1(3))
         ak2mn = ak2mn + 1.E-10
         where (wrk1 >= ak2mx) imd = 2
         where (wrk1 <= ak2mn) imd = -1
         where (imd == 0) imd = 1
         wrk1 = abs(pkp2 - wrk(:3))
         dk2mn = min(wrk1(1),wrk1(2),wrk1(3))
         dk2mn = dk2mn + 1.E-10
         nslofa = imd(1)
         dk2mn = wrk1(1)
         imode = 1
         do j = 2, 3
            if (wrk1(j) < dk2mn) then
               dk2mn = wrk1(j)
               nslofa = imd(j)
               imode = j
            endif
         end do
         pkp20 = wrk(imode)
         if (nslofa /= kslofa) iermc = kslofa
         if (iermc /= 0) then
c----------
c m-c already has taken place
c------------
            kmcon = 1
            return
         endif
c-----------------
         if (kmcon == 1) then
            if (kslofa == (-1)) then
c          if (ind2.eq.1) iermc=-1
               pkp20 = wrk(2)
               nslofa = -kslofa
               imode = 2
            else if (kslofa == 2) then
c          if (ind2.eq.0) iermc=2
               pkp20 = wrk(3)
               nslofa = 1
               imode = 3
            else if (ind2 == 0) then
c          if (kslofa.ne.1) iermc=1
               pkp20 = wrk(3)
               nslofa = -1
               imode = 3
            else if (ind2 == 1) then
c          if (kslofa.ne.1) iermc=1
               pkp20 = wrk(2)
               nslofa = 2
               imode = 2
            endif
c     else
c       pkp20=0.
         endif
c------------------------------
         return
      end select
      end subroutine sub4

      subroutine sub5(pkp22, ier)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:38:46   6/15/01
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      use Vsizes
      use Vchpcsd
      use Vcraylh, only: akpsi, akth, anphi, pkpsi, pktau, pkphi,
     1    pkheta, pkx, pkz, pkpar, pkpar2, pkp, pkp2, pkp2x, pk,
     2    aj, antau, ag, dxpsi, dxth, dzpsi, dzth, djp, djt, dgp,
     3    dgt, dntaup, dntaut, dompsi, domth, dqpsi, dqth
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer ier
      real(kind=dp) pkp22
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
C...  /chpcsd/
!      common /chpcsd/ prmt(6), y(10), dy(10), dy6o, hlast, ndim, jhlf,
!     1   ind, serror, psilast, yin(10), dyin(10), mcnt, h, klim, irecmx
!      integer   ndim, jhlf, ind, mcnt, klim, irecmx
!      real   prmt, y, dy, dy6o, hlast, serror, psilast, yin, dyin, h
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      real(kind=dp) :: sigkps, pkpsi2
C-----------------------------------------------
c-----------July 5,1995   SCC
c  update y(1),y(3) in backstep procedure
c  pkp22 is pkp2 of step isxz
c----------------------
c
c
c
      ier = 0
      call wavect
      sigkps = pkpsi/abs(pkpsi)
      pkpsi2 = pkp22 - pkheta**2
      if (pkpsi2 < 0.) then
         ier = 99
         return
      endif
      pkpsi = sqrt(pkpsi2)*sigkps
      akpsi = (aj*pkpsi + ag*pktau)/antau
      akth = antau*pktau
      y(1) = akpsi
      y(3) = akth
      call wavect
      return
      end subroutine sub5
