      subroutine grid3nit (ydl, ytl, ydr, ytr, radc, rw)
c
c***********************************************************************
c     grid initialization for SOD's shock tube
c***********************************************************************
c
      include'titan.imp'
      include'titan.par'
      include'titan.com'
c
      dimension dg(mgr), tg(mgr)
      dimension dlddlr00(mgr), dlddlrp1(mgr)
      dimension dltdlr00(mgr), dltdlrp1(mgr)
c
c=======================================================================
c     define functions
c=======================================================================
c
      f0 (x) = ( exp(x) - exp(-x) ) / ( exp(-x) + exp(x) )
      f1 (x) = + 2.0D0              / ( exp(-x) + exp(x) )
c
c=======================================================================
c     modify original code parameters
c=======================================================================
c
      iro = ir
      imo = im
      ido = id
      iuo = iu
      ito = it
      jro = jr
      jmo = jm
      jdo = jd
      juo = ju
      jto = jt
c
      ir = 1
      id = 2
      it = 3
      jr = ir
      jd = id
      jt = it
c
      lady2   = lady(2)
      lady(2) = 2
      lady5   = lady(5)
      lady(5) = 2
      lady6   = lady(6)
      lady(6) = 2
      lady9   = lady(9)
      lady(9) = 0
c
      wt2   = wt(2)
      wt(2) = 1.0D0
      wt5   = wt(5)
      wt(5) = 1.0D0
      wt6   = wt(6)
      wt(6) = 1.0D0
c
      neqo  = neqn
      neqn  = 3
      tauo  = tau
      tau   = 1.D-2
c
      dtime = tau
c
c=======================================================================
c     NEWTON-RAPHSON iteration
c=======================================================================
c
      iter = 1
c
c.......................................................................
c     calculate derivatives
c.......................................................................
c
        dg    (ngrs-2) = ydl
      dlddlr00(ngrs-2) = 0.0D0
      dlddlrp1(ngrs-2) = 0.0D0
        tg    (ngrs-2) = ytl
      dltdlr00(ngrs-2) = 0.0D0
      dltdlrp1(ngrs-2) = 0.0D0
      do 1 k = ngrs - 1, ngre + 1
c
      rmid   = ( 0.5D0 * ( rn(k) + rn(k+1) ) - radc ) / rw
      rmid   = max( -3.D+2, min( rmid, +3.D+2 ) )
      switch = cvmgt(0.5D0, 0.0D0, abs(f1 (rmid)) .lt. 1.D+150)
c
        tg    (k) = ytr + 0.5D0*( 1.0D0 - f0 (rmid) )*( ytl - ytr )
      dltdlr00(k) = - switch*( ytl - ytr ) * 0.5D0/rw * f1(rmid)**2
      dltdlrp1(k) = - switch*( ytl - ytr ) * 0.5D0/rw * f1(rmid)**2
c
        dg    (k) = ydr + 0.5D0*( 1.0D0 - f0 (rmid) )*( ydl - ydr )
      dlddlr00(k) = - switch*( ydl - ydr ) * 0.5D0/rw * f1(rmid)**2
      dlddlrp1(k) = - switch*( ydl - ydr ) * 0.5D0/rw * f1(rmid)**2
c
    1 continue
        dg    (ngre+2) = ydr
      dlddlr00(ngre+2) = 0.0D0
      dlddlrp1(ngre+2) = 0.0D0
        tg    (ngre+2) = ytr
      dltdlr00(ngre+2) = 0.0D0
      dltdlrp1(ngre+2) = 0.0D0
c
      do 2 k = ngrs - 2, ngre + 2
      dn  (k) = dg(k)
      tn  (k) = tg(k)
      ro  (k) = rn(k)
    2 continue
c
c.......................................................................
c     initialize all matrices to zero
c.......................................................................
c
  100 continue
      do 30 i = 1, meqn
      do 20 j = 1, meqn
      do 10 k = 1, mgr
      em2(i, j, k) = 0.0D0
      em1(i, j, k) = 0.0D0
      e00(i, j, k) = 0.0D0
      ep1(i, j, k) = 0.0D0
      ep2(i, j, k) = 0.0D0
   10 continue
   20 continue
   30 continue
c
      do 50 i = 1, meqn
      do 40 k = 1, mgr
      rhs(i, k) = 0.0D0
   40 continue
   50 continue
c
      do 70 i = 1, 3*mpd - 2
      do 60 j = 1, meqn*mgr
      bm(i, j) = 0.0D0
   60 continue
   70 continue
c
      do 80 i = 1, meqn*mgr
      br(i) = 0.0D0
   80 continue
c
c.......................................................................
c     calculate matrix elements in continuity and gas energy equation
c.......................................................................
c
      e00(id, jd, ngrs-2) =  1.0D0
      e00(it, jt, ngrs-2) =  1.0D0
c
      do 3 k = ngrs - 1, ngre + 1
c
      rhs(id,     k) =  dn(k) - dg(k)
      e00(id, jd, k) =  dn(k)
      e00(id, jr, k) =        - dlddlr00(k) * rn(k  )
      ep1(id, jr, k) =        - dlddlrp1(k) * rn(k+1)
c
      rhs(it,     k) =  tn(k) - tg(k)
      e00(it, jt, k) =  tn(k)
      e00(it, jr, k) =        - dltdlr00(k) * rn(k  )
      ep1(it, jr, k) =        - dltdlrp1(k) * rn(k+1)
    3 continue
c
      e00(id, jd, ngre+2) =  1.0D0
      e00(it, jt, ngre+2) =  1.0D0
c
c.......................................................................
c     calculate matrix elements in grid equation
c.......................................................................
c
      call grid
c
c.......................................................................
c     solve the system
c.......................................................................
c
      call matslv
c
c.......................................................................
c     find maximum changes
c.......................................................................
c
      kdmx = isamax(ngre - ngrs + 2, rhs(ir,ngrs), meqn)
      dmax = abs( rhs(ir,ngrs + kdmx - 1) ) + 1.0D-30
c
      do 4 k = ngrs, ngre
      cx  (k) = ( rhs(ir, k+1) * rn(k+1) - rhs(ir, k) * rn(k) )
     .        / (                rn(k+1) -              rn(k) )
    4 continue
      kcmx = isamax( ngre - ngrs + 1, cx(ngrs), 1 )
      cmax = abs( cx(ngrs + kcmx - 1) ) + 1.0D-30
c
      sc1 = min( 1.0D0, dtol / dmax )
      sc2 = min( 1.0D0, ctol / cmax )
      sc  = min( sc1, sc2 )
c
      do 5 k = ngrs, ngre + 1
      ro  (k) =   rn(k)
      rn  (k) = ( 1.0D0 + sc * rhs(ir,k) ) * ro(k)
      cx  (k) = ( rn(k) - ro(k) ) / ro(k)
    5 continue
      ksmx = isamax(ngre - ngrs + 2, cx(ngrs), 1)
      smax = abs( cx(ngrs + ksmx - 1) ) + 1.0D-30
c
      iter = iter + 1
c.......................................................................
c     summary output
c.......................................................................
c
      write(itty,998) iter,timen,ksmx,smax,kdmx,dmax
  998 format(" iter ="i3" time ="1pe10.3
     .       " d_r/ro("i3") ="e9.2" rhs("i3") ="e9.2 )
c
c-----------------------------------------------------------------------
c     check for monotonicity
c-----------------------------------------------------------------------
c
      do 6 k = ngrs, ngre + 1
      if ( rn(k+1) .le. rn(k) ) then
           write(itty,'(" grid extrapolation nonmonotonic")')
           write(iout,'(" grid extrapolation nonmonotonic")')
           call clzfil
           stop 'gridinit03'
           end if
    6 continue
c
c-----------------------------------------------------------------------
c     compute new timestep and update quantities
c-----------------------------------------------------------------------
c
      timeo = timen
      timen = timeo + dtime
c
        dg    (ngrs-2) = ydl
      dlddlr00(ngrs-2) = 0.0D0
      dlddlrp1(ngrs-2) = 0.0D0
        tg    (ngrs-2) = ytl
      dltdlr00(ngrs-2) = 0.0D0
      dltdlrp1(ngrs-2) = 0.0D0
      do 7 k = ngrs - 1, ngre + 1
c
      rmid   = ( 0.5D0 * ( rn(k) + rn(k+1) ) - radc ) / rw
      rmid   = max( -3.D+2, min( rmid, +3.D+2 ) )
      switch = cvmgt(0.5D0, 0.0D0, abs(f1 (rmid)) .lt. 1.D+150)
c
        tg    (k) = ytr + 0.5D0*( 1.0D0 - f0 (rmid) )*( ytl - ytr )
      dltdlr00(k) = - switch*( ytl - ytr ) * 0.5D0/rw * f1(rmid)**2
      dltdlrp1(k) = - switch*( ytl - ytr ) * 0.5D0/rw * f1(rmid)**2
c
        dg    (k) = ydr + 0.5D0*( 1.0D0 - f0 (rmid) )*( ydl - ydr )
      dlddlr00(k) = - switch*( ydl - ydr ) * 0.5D0/rw * f1(rmid)**2
      dlddlrp1(k) = - switch*( ydl - ydr ) * 0.5D0/rw * f1(rmid)**2
c
    7 continue
        dg    (ngre+2) = ydr
      dlddlr00(ngre+2) = 0.0D0
      dlddlrp1(ngre+2) = 0.0D0
        tg    (ngre+2) = ytr
      dltdlr00(ngre+2) = 0.0D0
      dltdlrp1(ngre+2) = 0.0D0
c
      do 8 k = ngrs - 2, ngre + 2
      dn  (k) = dg(k)
      tn  (k) = tg(k)
    8 continue
c
      call eos
c
      if (smax .gt. 1.D-8) go to 100
c
c=======================================================================
c     restore original code parameters
c=======================================================================
c
      ir = iro
      im = imo
      id = ido
      iu = iuo
      it = ito
      jr = jro
      jm = jmo
      jd = jdo
      ju = juo
      jt = jto
c
      neqn  = neqo
      tau   = tauo
c
      lady(2) = lady2
      lady(5) = lady5
      lady(6) = lady6
      lady(9) = lady9
c
      wt(2) = wt2
      wt(5) = wt5
      wt(6) = wt6
c
c=======================================================================
c
      return
      end
      subroutine grid4nit (ydl1,ydl2,ytl1,ytl2,
     .                     ydr1,ydr2,ytr1,ytr2,x1,x2,xw)
c
c***********************************************************************
c     grid initialization for WOODWARD-COLLELA blast wave
c***********************************************************************
c
      include'titan.imp'
      include'titan.par'
      include'titan.com'
c
      dimension dg(mgr), tg(mgr)
      dimension dlddlr00(mgr), dlddlrp1(mgr)
      dimension dltdlr00(mgr), dltdlrp1(mgr)
c
c=======================================================================
c     define functions
c=======================================================================
c
      f0 (x) = ( exp(x) - exp(-x) ) / ( exp(-x) + exp(x) )
      f1 (x) = + 2.0D0              / ( exp(-x) + exp(x) )
c
c=======================================================================
c     modify original code parameters
c=======================================================================
c
      iro = ir
      imo = im
      ido = id
      iuo = iu
      ito = it
      jro = jr
      jmo = jm
      jdo = jd
      juo = ju
      jto = jt
c
      ir = 1
      id = 2
      it = 3
      jr = ir
      jd = id
      jt = it
c
      neqo  = neqn
      neqn  = 3
      tauo  = tau
      tau   = 1.D-2
c
      xw    = 1.3D-3
      x2    = 1.9D0
      x1    = 1.1D0
      dtime = tau
c
c=======================================================================
c     NEWTON-RAPHSON iteration
c=======================================================================
c
      iter = 1
c
c.......................................................................
c     calculate derivatives
c.......................................................................
c
        dg    (ngrs-2) = 1.0D0
      dlddlr00(ngrs-2) = 0.0D0
      dlddlrp1(ngrs-2) = 0.0D0
        tg    (ngrs-2) = ytl1
      dltdlr00(ngrs-2) = 0.0D0
      dltdlrp1(ngrs-2) = 0.0D0
        dg    (ngrs-1) = 1.0D0
      dlddlr00(ngrs-1) = 0.0D0
      dlddlrp1(ngrs-1) = 0.0D0
        tg    (ngrs-1) = ytl1
      dltdlr00(ngrs-1) = 0.0D0
      dltdlrp1(ngrs-1) = 0.0D0
      do 1 k = ngrs, ngre
c
      rmid1   =      (  0.5D0 * ( rn(k) + rn(k+1) ) - x1 ) / xw
      rmid1   =   max( -3.D+2, min( rmid1, +3.D+2 ) )      ! 6.90775D+2
      switch1 = cvmgt(  0.5D0, 0.0D0, abs(f1 (rmid1)) .lt. 1.D+150)
      rmid2   =      (  0.5D0 * ( rn(k) + rn(k+1) ) - x2 ) / xw
      rmid2   =   max( -3.D+2, min( rmid2, +3.D+2 ) )      ! 6.90775D+2
      switch2 = cvmgt(  0.5D0, 0.0D0, abs(f1 (rmid2)) .lt. 1.D+150)
c
      dg      (k) = 1.0D0
      dlddlr00(k) = 0.0D0
      dlddlrp1(k) = 0.0D0
c
      tg      (k) = ytr1 + 0.5D0*( 1.0D0 - f0 (rmid1) )*( ytl1 - ytr1 )
     .                   - 0.5D0*( 1.0D0 + f0 (rmid2) )*( ytl2 - ytr2 )
      dltdlr00(k) = - switch1*( ytl1 - ytr1 ) * 0.5D0/xw * f1(rmid1)**2
     .              - switch2*( ytl2 - ytr2 ) * 0.5D0/xw * f1(rmid2)**2
      dltdlrp1(k) = - switch1*( ytl1 - ytr1 ) * 0.5D0/xw * f1(rmid1)**2
     .              - switch2*( ytl2 - ytr2 ) * 0.5D0/xw * f1(rmid2)**2
c
    1 continue
        dg    (ngre+1) = 1.0D0
      dlddlr00(ngre+1) = 0.0D0
      dlddlrp1(ngre+1) = 0.0D0
        tg    (ngre+1) = ytr2
      dltdlr00(ngre+1) = 0.0D0
      dltdlrp1(ngre+1) = 0.0D0
        dg    (ngre+2) = 1.0D0
      dlddlr00(ngre+2) = 0.0D0
      dlddlrp1(ngre+2) = 0.0D0
        tg    (ngre+2) = ytr2
      dltdlr00(ngre+2) = 0.0D0
      dltdlrp1(ngre+2) = 0.0D0
c
      do 2 k = ngrs - 2, ngre + 2
      dn  (k) = dg(k)
      tn  (k) = tg(k)
      ro  (k) = rn(k)
    2 continue
c
c.......................................................................
c     initialize all matrices to zero
c.......................................................................
c
  100 continue
      do 30 i = 1, meqn
      do 20 j = 1, meqn
      do 10 k = 1, mgr
      em2(i, j, k) = 0.0D0
      em1(i, j, k) = 0.0D0
      e00(i, j, k) = 0.0D0
      ep1(i, j, k) = 0.0D0
      ep2(i, j, k) = 0.0D0
   10 continue
   20 continue
   30 continue
c
      do 50 i = 1, meqn
      do 40 k = 1, mgr
      rhs(i, k) = 0.0D0
   40 continue
   50 continue
c
      do 70 i = 1, 3*mpd - 2
      do 60 j = 1, meqn*mgr
      bm(i, j) = 0.0D0
   60 continue
   70 continue
c
      do 80 i = 1, meqn*mgr
      br(i) = 0.0D0
   80 continue
c
c.......................................................................
c     calculate matrix elements in continuity and gas energy equation
c.......................................................................
c
      e00(id, jd, ngrs-2) =  1.0D0
      e00(it, jt, ngrs-2) =  1.0D0
c
      do 3 k = ngrs - 1, ngre + 1
c
      rhs(id,     k) =  dn(k) - dg      (k)
      e00(id, jd, k) =  dn(k)
      e00(id, jr, k) =        - dlddlr00(k) * rn(k  )
      ep1(id, jr, k) =        - dlddlrp1(k) * rn(k+1)
c
      rhs(it,     k) =  tn(k) - tg      (k)
      e00(it, jt, k) =  tn(k)
      e00(it, jr, k) =        - dltdlr00(k) * rn(k  )
      ep1(it, jr, k) =        - dltdlrp1(k) * rn(k+1)
    3 continue
c
      e00(id, jd, ngre+2) =  1.0D0
      e00(it, jt, ngre+2) =  1.0D0
c
c.......................................................................
c     calculate matrix elements in grid equation
c.......................................................................
c
      call grid
c
c.......................................................................
c     solve the system
c.......................................................................
c
      call matslv
c
c.......................................................................
c     find maximum changes
c.......................................................................
c
      kdmx = isamax(ngre - ngrs + 2, rhs(ir,ngrs), meqn)
      dmax = abs( rhs(ir,ngrs + kdmx - 1) ) + 1.0D-30
c
      do 4 k = ngrs, ngre
      cx  (k) = ( rhs(ir, k+1) * rn(k+1) - rhs(ir, k) * rn(k) )
     .        / (                rn(k+1) -              rn(k) )
    4 continue
      kcmx = isamax( ngre - ngrs + 1, cx(ngrs), 1 )
      cmax = abs( cx(ngrs + kcmx - 1) ) + 1.0D-30
c
      sc1 = min( 1.0D0, dtol / dmax )
      sc2 = min( 1.0D0, ctol / cmax )
      sc  = min( sc1, sc2 )
c
      do 5 k = ngrs, ngre + 1
      ro  (k) =   rn(k)
      rn  (k) = ( 1.0D0 + sc * rhs(ir,k) ) * ro(k)
      cx  (k) = ( rn(k) - ro(k) ) / ro(k)
    5 continue
      ksmx = isamax(ngre - ngrs + 2, cx(ngrs), 1)
      smax = abs( cx(ngrs + ksmx - 1) ) + 1.0D-30
c
      iter = iter + 1
c.......................................................................
c     summary output
c.......................................................................
c
      write(itty,998) iter,timen,ksmx,smax,kdmx,dmax
  998 format(" iter ="i4" time ="1pe10.3
     .       " d_r/ro("i3") ="e9.2" rhs("i3") ="e9.2 )
c
c-----------------------------------------------------------------------
c     check for monotonicity
c-----------------------------------------------------------------------
c
      do 6 k = ngrs, ngre + 1
      if ( rn(k+1) .le. rn(k) ) then
           write(itty,'(" grid extrapolation nonmonotonic")')
           write(iout,'(" grid extrapolation nonmonotonic")')
           call clzfil
           stop 'gridinit04'
           end if
    6 continue
c
c-----------------------------------------------------------------------
c     compute new timestep
c-----------------------------------------------------------------------
c
      timeo = timen
      timen = timeo + dtime
c
        dg    (ngrs-2) = 1.0D0
      dlddlr00(ngrs-2) = 0.0D0
      dlddlrp1(ngrs-2) = 0.0D0
        tg    (ngrs-2) = ytl1
      dltdlr00(ngrs-2) = 0.0D0
      dltdlrp1(ngrs-2) = 0.0D0
        dg    (ngrs-1) = 1.0D0
      dlddlr00(ngrs-1) = 0.0D0
      dlddlrp1(ngrs-1) = 0.0D0
        tg    (ngrs-1) = ytl1
      dltdlr00(ngrs-1) = 0.0D0
      dltdlrp1(ngrs-1) = 0.0D0
      do 7 k = ngrs, ngre
c
      rmid1   =      (  0.5D0 * ( rn(k) + rn(k+1) ) - x1 ) / xw
      rmid1   =   max( -3.D+2, min( rmid1, +3.D+2 ) )      ! 6.90775D+2
      switch1 = cvmgt(  0.5D0, 0.0D0, abs(f1 (rmid1)) .lt. 1.D+150)
      rmid2   =      (  0.5D0 * ( rn(k) + rn(k+1) ) - x2 ) / xw
      rmid2   =   max( -3.D+2, min( rmid2, +3.D+2 ) )      ! 6.90775D+2
      switch2 = cvmgt(  0.5D0, 0.0D0, abs(f1 (rmid2)) .lt. 1.D+150)
c
      dg      (k) = 1.0D0
      dlddlr00(k) = 0.0D0
      dlddlrp1(k) = 0.0D0
c
      tg      (k) = ytr1 + 0.5D0*( 1.0D0 - f0 (rmid1) )*( ytl1 - ytr1 )
     .                   - 0.5D0*( 1.0D0 + f0 (rmid2) )*( ytl2 - ytr2 )
      dltdlr00(k) = - switch1*( ytl1 - ytr1 ) * 0.5D0/xw * f1(rmid1)**2
     .              - switch2*( ytl2 - ytr2 ) * 0.5D0/xw * f1(rmid2)**2
      dltdlrp1(k) = - switch1*( ytl1 - ytr1 ) * 0.5D0/xw * f1(rmid1)**2
     .              - switch2*( ytl2 - ytr2 ) * 0.5D0/xw * f1(rmid2)**2
c
    7 continue
        dg    (ngre+1) = 1.0D0
      dlddlr00(ngre+1) = 0.0D0
      dlddlrp1(ngre+1) = 0.0D0
        tg    (ngre+1) = ytr2
      dltdlr00(ngre+1) = 0.0D0
      dltdlrp1(ngre+1) = 0.0D0
        dg    (ngre+2) = 1.0D0
      dlddlr00(ngre+2) = 0.0D0
      dlddlrp1(ngre+2) = 0.0D0
        tg    (ngre+2) = ytr2
      dltdlr00(ngre+2) = 0.0D0
      dltdlrp1(ngre+2) = 0.0D0
c
      do 8 k = ngrs - 2, ngre + 2
      dn  (k) = dg(k)
      tn  (k) = tg(k)
    8 continue
c
      call eos
c
      if (smax .gt. 1.D-7) go to 100
c
c=======================================================================
c     restore original code parameters
c=======================================================================
c
      ir = iro
      im = imo
      id = ido
      iu = iuo
      it = ito
      jr = jro
      jm = jmo
      jd = jdo
      ju = juo
      jt = jto
c
      neqn  = neqo
      tau   = tauo
c
c=======================================================================
c
      return
      end
      subroutine grid5nit (ytl, ytr, radc, rw)
c
c***********************************************************************
c     grid initialization for SEDOV-TAYLOR blast wave
c***********************************************************************
c
      include'titan.imp'
      include'titan.par'
      include'titan.com'
c
      dimension tg(mgr)
      dimension dltdlr00(mgr), dltdlrp1(mgr)
c
c=======================================================================
c     define functions
c=======================================================================
c
      f0 (x) = ( exp(x) - exp(-x) ) / ( exp(-x) + exp(x) )
      f1 (x) = + 2.0D0              / ( exp(-x) + exp(x) )
c
c=======================================================================
c     modify original code parameters
c=======================================================================
c
      iro = ir
      imo = im
      ido = id
      iuo = iu
      ito = it
      jro = jr
      jmo = jm
      jdo = jd
      juo = ju
      jto = jt
c
      ir = 1
      it = 2
      jr = ir
      jt = it
c
      lady1   = lady(1)
      lady(1) = 0
      lady2   = lady(2)
      lady(2) = 0
      lady5   = lady(5)
      lady(5) = 2
      lady6   = lady(6)
      lady(6) = 2
      lady9   = lady(9)
      lady(9) = 0
c
      wt2   = wt(2)
      wt(2) = 0.0D0
      wt5   = wt(5)
      wt(5) = 1.0D0
      wt6   = wt(6)
      wt(6) = 1.0D0
c
      neqo  = neqn
      neqn  = 2
      tauo  = tau
      tau   = 1.D-2
c
      dtime = tau
c
c=======================================================================
c     NEWTON-RAPHSON iteration
c=======================================================================
c
      iter = 1
c
c.......................................................................
c     calculate derivatives
c.......................................................................
c
        tg    (ngrs-2) = ytl
      dltdlr00(ngrs-2) = 0.0D0
      dltdlrp1(ngrs-2) = 0.0D0
        tg    (ngrs-1) = ytl
      dltdlr00(ngrs-1) = 0.0D0
      dltdlrp1(ngrs-1) = 0.0D0
        tg    (ngrs  ) = ytl
      dltdlr00(ngrs  ) = 0.0D0
      dltdlrp1(ngrs  ) = 0.0D0
      do 1 k = ngrs + 1, ngre + 1
c
      rmid   = ( 0.5D0 * ( rn(k) + rn(k+1) ) - radc ) / rw
      rmid   = max( -3.D+2, min( rmid, +3.D+2 ) )
      switch = cvmgt(0.5D0, 0.0D0, abs(f1 (rmid)) .lt. 1.D+150)
c
        tg    (k) = ytr + 0.5D0*( 1.0D0 - f0 (rmid) )*( ytl - ytr )
      dltdlr00(k) = - switch*( ytl - ytr ) * 0.5D0/rw * f1(rmid)**2
      dltdlrp1(k) = - switch*( ytl - ytr ) * 0.5D0/rw * f1(rmid)**2
c
    1 continue
        tg    (ngre+2) = ytr
      dltdlr00(ngre+2) = 0.0D0
      dltdlrp1(ngre+2) = 0.0D0
c
      do 2 k = ngrs - 2, ngre + 2
      tn  (k) = tg(k)
      ro  (k) = rn(k)
    2 continue
c
c.......................................................................
c     initialize all matrices to zero
c.......................................................................
c
  100 continue
      do 30 i = 1, meqn
      do 20 j = 1, meqn
      do 10 k = 1, mgr
      em2(i, j, k) = 0.0D0
      em1(i, j, k) = 0.0D0
      e00(i, j, k) = 0.0D0
      ep1(i, j, k) = 0.0D0
      ep2(i, j, k) = 0.0D0
   10 continue
   20 continue
   30 continue
c
      do 50 i = 1, meqn
      do 40 k = 1, mgr
      rhs(i, k) = 0.0D0
   40 continue
   50 continue
c
      do 70 i = 1, 3*mpd - 2
      do 60 j = 1, meqn*mgr
      bm(i, j) = 0.0D0
   60 continue
   70 continue
c
      do 80 i = 1, meqn*mgr
      br(i) = 0.0D0
   80 continue
c
c.......................................................................
c     calculate matrix elements in continuity and gas energy equation
c.......................................................................
c
      e00(it, jt, ngrs-2) =  1.0D0
c
      do 3 k = ngrs - 1, ngre + 1
c
      rhs(it,     k) =  tn(k) - tg(k)
      e00(it, jt, k) =  tn(k)
      e00(it, jr, k) =        - dltdlr00(k) * rn(k  )
      ep1(it, jr, k) =        - dltdlrp1(k) * rn(k+1)
    3 continue
c
      e00(it, jt, ngre+2) =  1.0D0
c
c.......................................................................
c     calculate matrix elements in grid equation
c.......................................................................
c
      call grid
c
c.......................................................................
c     solve the system
c.......................................................................
c
      call matslv
c
c.......................................................................
c     find maximum changes
c.......................................................................
c
      kdmx = isamax(ngre - ngrs + 2, rhs(ir,ngrs), meqn)
      dmax = abs( rhs(ir,ngrs + kdmx - 1) ) + 1.0D-30
c
      do 4 k = ngrs, ngre
      cx  (k) = ( rhs(ir, k+1) * rn(k+1) - rhs(ir, k) * rn(k) )
     .        / (                rn(k+1) -              rn(k) )
    4 continue
      kcmx = isamax( ngre - ngrs + 1, cx(ngrs), 1 )
      cmax = abs( cx(ngrs + kcmx - 1) ) + 1.0D-30
c
      sc1 = min( 1.0D0, dtol / dmax )
      sc2 = min( 1.0D0, ctol / cmax )
      sc  = min( sc1, sc2 )
c
      do 5 k = ngrs, ngre + 1
      ro  (k) =   rn(k)
      rn  (k) = ( 1.0D0 + sc * rhs(ir,k) ) * ro(k)
      cx  (k) = ( rn(k) - ro(k) ) / ro(k)
    5 continue
      ksmx = isamax(ngre - ngrs + 2, cx(ngrs), 1)
      smax = abs( cx(ngrs + ksmx - 1) ) + 1.0D-30
c
      iter = iter + 1
c.......................................................................
c     summary output
c.......................................................................
c
      write(itty,998) iter,timen,ksmx,smax,kdmx,dmax
  998 format(" iter ="i4" time ="1pe10.3
     .       " d_r/ro("i3") ="e9.2" rhs("i3") ="e9.2 )
c
c-----------------------------------------------------------------------
c     check for monotonicity
c-----------------------------------------------------------------------
c
      do 6 k = ngrs, ngre + 1
      if ( rn(k+1) .le. rn(k) ) then
           write(itty,'(" grid extrapolation nonmonotonic")')
           write(iout,'(" grid extrapolation nonmonotonic")')
           call clzfil
           stop 'gridinit05'
           end if
    6 continue
c
c-----------------------------------------------------------------------
c     compute new timestep and update quantities
c-----------------------------------------------------------------------
c
      timeo = timen
      timen = timeo + dtime
c
        tg    (ngrs-2) = ytl
      dltdlr00(ngrs-2) = 0.0D0
      dltdlrp1(ngrs-2) = 0.0D0
        tg    (ngrs-1) = ytl
      dltdlr00(ngrs-1) = 0.0D0
      dltdlrp1(ngrs-1) = 0.0D0
        tg    (ngrs  ) = ytl
      dltdlr00(ngrs  ) = 0.0D0
      dltdlrp1(ngrs  ) = 0.0D0
      do 7 k = ngrs + 1, ngre + 1
c
      rmid   = ( 0.5D0 * ( rn(k) + rn(k+1) ) - radc ) / rw
      rmid   = max( -3.D+2, min( rmid, +3.D+2 ) )
      switch = cvmgt(0.5D0, 0.0D0, abs(f1 (rmid)) .lt. 1.D+150)
c
        tg    (k) = ytr + 0.5D0*( 1.0D0 - f0 (rmid) )*( ytl - ytr )
      dltdlr00(k) = - switch*( ytl - ytr ) * 0.5D0/rw * f1(rmid)**2
      dltdlrp1(k) = - switch*( ytl - ytr ) * 0.5D0/rw * f1(rmid)**2
c
    7 continue
        tg    (ngre+2) = ytr
      dltdlr00(ngre+2) = 0.0D0
      dltdlrp1(ngre+2) = 0.0D0
c
      do 8 k = ngrs - 2, ngre + 2
      tn  (k) = tg(k)
    8 continue
c
      call eos
c
      if (smax .gt. 1.D-5) go to 100
c
c=======================================================================
c     restore original code parameters
c=======================================================================
c
      ir = iro
      im = imo
      id = ido
      iu = iuo
      it = ito
      jr = jro
      jm = jmo
      jd = jdo
      ju = juo
      jt = jto
c
      neqn  = neqo
      tau   = tauo
c
      lady(1) = lady1
      lady(2) = lady2
      lady(5) = lady5
      lady(6) = lady6
      lady(9) = lady9
c
      wt(2) = wt2
      wt(5) = wt5
      wt(6) = wt6
c
c=======================================================================
c
      return
      end
      subroutine grid6nit (yfl, yfr, radc, rw)
c
c***********************************************************************
c     grid initialization for radiative equilibrium
c***********************************************************************
c
      include'titan.imp'
      include'titan.par'
      include'titan.com'
c
      dimension  tg     (mgr)
      dimension dltdlr00(mgr), dledlr00(mgr), dledlrp1(mgr)
c
c=======================================================================
c     define functions
c=======================================================================
c
      f0 (x) = ( exp(x) - exp(-x) ) / ( exp(-x) + exp(x) )
      f1 (x) = + 2.0D0              / ( exp(-x) + exp(x) )
c
c=======================================================================
c     modify original code parameters
c=======================================================================
c
      iro = ir
      ito = it
      ieo = ie
      ifo = if
      iuo = iu
      jro = jr
      jto = jt
      jeo = je
      jfo = jf
      juo = ju
      jbo = jb
c
      ir = 1
      if = 2
      ie = 3
      jr = ir
      jf = if
      je = ie
      jb = if
c
      neqo  = neqn
      neqn  = 3
      tauo  = tau
      tau   = 1.D-2
c
      dtime = tau
c
      ern0 = yfr / (4.0D0 * cpi * cc * rn(ngre)**2 ) * sqrt(3.0D0)
      con  = yfr / (4.0D0 * cpi * cc)* chif0 * 3.0D0
c
c=======================================================================
c     NEWTON-RAPHSON iteration
c=======================================================================
c
      iter = 1
c
c.......................................................................
c     calculate derivatives
c.......................................................................
c
      do 1 k = ngrs - 1, ngre + 1
c
      rmid   =      (  rn(k) - radc ) / rw
      rmid   = max  ( -3.D+2, min( rmid, +3.D+2 ) )
      switch = cvmgt(  0.5D0,  0.0D0, abs(f1 (rmid)) .lt. 1.D+150)
c
        tg    (k) = yfr + 0.5D0*( 1.0D0 - f0 (rmid) )*( yfl - yfr )
      dltdlr00(k) = - switch*( yfl - yfr ) * 0.5D0/rw * f1(rmid)**2
c
      rmid = ( rn(k) + rn(k+1) )
c
        er    (k) =  ern0 + con * (2.D0 / rmid - 1.D0 / rn(ngre+2))
      dledlr00(k) =       - con *  2.D0 / rmid**2
      dledlrp1(k) =       - con *  2.D0 / rmid**2
c
    1 continue
        tg    (ngre+2) = yfr
      dltdlr00(ngre+2) = 0.0D0
        er    (ngre+2) = ern0
      dledlr00(ngre+2) = 0.0D0
        tg    (ngrs-2) = yfl
      dltdlr00(ngrs-2) = 0.0D0
        er    (ngrs-2) = er(ngrs-1)
      dledlr00(ngrs-2) = 0.0D0
c
      do 2 k = ngrs - 1, ngre + 1
      bri (k) = tg(k)
      ern (k) = er(k)
      ro  (k) = rn(k)
    2 continue
      bri (ngre+2) = bri(ngre+1)
      ern (ngre+2) = ern0
      bri (ngrs-2) = bri(ngrs-1)
      ern (ngrs-2) = ern(ngrs-1)
c
c.......................................................................
c     initialize all matrices to zero
c.......................................................................
c
  100 continue
      do 30 i = 1, meqn
      do 20 j = 1, meqn
      do 10 k = 1, mgr
      em2(i, j, k) = 0.0D0
      em1(i, j, k) = 0.0D0
      e00(i, j, k) = 0.0D0
      ep1(i, j, k) = 0.0D0
      ep2(i, j, k) = 0.0D0
   10 continue
   20 continue
   30 continue
c
      do 50 i = 1, meqn
      do 40 k = 1, mgr
      rhs(i, k) = 0.0D0
   40 continue
   50 continue
c
      do 70 i = 1, 3*mpd - 2
      do 60 j = 1, meqn*mgr
      bm(i, j) = 0.0D0
   60 continue
   70 continue
c
      do 80 i = 1, meqn*mgr
      br(i) = 0.0D0
   80 continue
c
c.......................................................................
c     calculate matrix elements in continuity and gas energy equation
c.......................................................................
c
      e00(if, jf, ngrs-2) =  1.0D0
      e00(ie, je, ngrs-2) =  1.0D0
c
      do 3 k = ngrs - 1, ngre + 1
c
      rhs(if,     k) =  bri(k) - tg(k)
      e00(if, jf, k) =  bri(k)
      e00(if, jr, k) =         - dltdlr00(k) * rn(k)
c
      rhs(ie,     k) =  ern(k) - er(k)
      e00(ie, je, k) =  ern(k)
      e00(ie, jr, k) =         - dledlr00(k) * rn(k  )
      ep1(ie, jr, k) =         - dledlrp1(k) * rn(k+1)
    3 continue
c
      e00(if, jf, ngre+2) =  1.0D0
      e00(ie, je, ngre+2) =  1.0D0
c
c.......................................................................
c     calculate matrix elements in grid equation
c.......................................................................
c
      call grid
c
c.......................................................................
c     solve the system
c.......................................................................
c
      call matslv
c
c.......................................................................
c     find maximum changes
c.......................................................................
c
      kdmx = isamax(ngre - ngrs + 2, rhs(ir,ngrs), meqn)
      dmax = abs( rhs(ir,ngrs + kdmx - 1) ) + 1.0D-30
c
      do 4 k = ngrs, ngre
      cx  (k) = ( rhs(ir, k+1) * rn(k+1) - rhs(ir, k) * rn(k) )
     .        / (                rn(k+1) -              rn(k) )
    4 continue
      kcmx = isamax( ngre - ngrs + 1, cx(ngrs), 1 )
      cmax = abs( cx(ngrs + kcmx - 1) ) + 1.0D-30
c
      sc1 = min( 1.0D0, dtol / dmax )
      sc2 = min( 1.0D0, ctol / cmax )
      sc  = min( sc1, sc2 )
c
      do 5 k = ngrs, ngre + 1
      ro  (k) =   rn(k)
      rn  (k) = ( 1.0D0 + sc * rhs(ir,k) ) * ro(k)
      cx  (k) = ( rn(k) - ro(k) ) / ro(k)
    5 continue
      ksmx = isamax(ngre - ngrs + 2, cx(ngrs), 1)
      smax = abs( cx(ngrs + ksmx - 1) ) + 1.0D-30
c
      iter = iter + 1
c.......................................................................
c     summary output
c.......................................................................
c
      write(itty,998) iter,timen,ksmx,smax,kdmx,dmax
  998 format(" iter ="i4" time ="1pe10.3
     .       " d_r/ro("i3") ="e9.2" rhs("i3") ="e9.2 )
c
c-----------------------------------------------------------------------
c     check for monotonicity
c-----------------------------------------------------------------------
c
      do 6 k = ngrs, ngre + 1
      if ( rn(k+1) .le. rn(k) ) then
           write(itty,'(" grid extrapolation nonmonotonic")')
           write(iout,'(" grid extrapolation nonmonotonic")')
           call clzfil
           stop 'gridinit06'
           end if
    6 continue
c
c-----------------------------------------------------------------------
c     compute new timestep and update quantities
c-----------------------------------------------------------------------
c
      timeo = timen
      timen = timeo + dtime
c
      do 7 k = ngrs - 1, ngre + 1
c
      rmid   =      (  rn(k) - radc ) / rw
      rmid   = max  ( -3.D+2, min( rmid, +3.D+2 ) )
      switch = cvmgt(  0.5D0,  0.0D0, abs(f1 (rmid)) .lt. 1.D+150)
c
        tg    (k) = yfr + 0.5D0*( 1.0D0 - f0 (rmid) )*( yfl - yfr )
      dltdlr00(k) = - switch*( yfl - yfr ) * 0.5D0/rw * f1(rmid)**2
c
      rmid = ( rn(k) + rn(k+1) )
c
        er    (k) =  ern0 + con * (2.D0 / rmid - 1.D0 / rn(ngre+2))
      dledlr00(k) =       - con *  2.D0 / rmid**2
      dledlrp1(k) =       - con *  2.D0 / rmid**2
c
    7 continue
        tg    (ngre+2) = yfr
      dltdlr00(ngre+2) = 0.0D0
        er    (ngre+2) = ern0
      dledlr00(ngre+2) = 0.0D0
        tg    (ngrs-2) = yfl
      dltdlr00(ngrs-2) = 0.0D0
        er    (ngrs-2) = er(ngrs-1)
      dledlr00(ngrs-2) = 0.0D0
c
      do 8 k = ngrs - 1, ngre + 1
      bri (k) = tg(k)
      ern (k) = er(k)
    8 continue
      bri (ngre+2) = bri(ngre+1)
      ern (ngre+2) = ern0
      bri (ngrs-2) = bri(ngrs-1)
      ern (ngrs-2) = ern(ngrs-1)
c
      if (smax .gt. 1.D-4) go to 100
c
      do 9 k = ngrs - 1, ngre + 1
      frn (k) = tg(k) / ( 4.D0 * cpi * rn(k)**2 )
    9 continue
      frn (ngre+2) = frn(ngre+1)
      frn (ngrs-2) = frn(ngrs-1)
c
c=======================================================================
c     restore original code parameters
c=======================================================================
c
      ir = iro
      it = ito
      ie = ieo
      if = ifo
      iu = iuo
      jr = jro
      jt = jto
      je = jeo
      jf = jfo
      ju = juo
      jb = jbo
c
      neqn  = neqo
      tau   = tauo
c
c=======================================================================
c
      return
      end
      subroutine grid9nit (radc, rw)
c
c***********************************************************************
c     grid initialization for sub- and supercritical radiation
c***********************************************************************
c
      include'titan.imp'
      include'titan.par'
      include'titan.com'
c
      dimension   tg    (mgr),   ug    (mgr)
      dimension dltdlr00(mgr), dludlr00(mgr)
c
c=======================================================================
c     define functions
c=======================================================================
c
      f0 (x) = ( exp(x) - exp(-x) ) / ( exp(-x) + exp(x) )
      f1 (x) = + 2.0D0              / ( exp(-x) + exp(x) )
c
c=======================================================================
c     modify original code parameters
c=======================================================================
c
      iro = ir
      imo = im
      ido = id
      iuo = iu
      ito = it
      ieo = ie
      ifo = if
      jro = jr
      jmo = jm
      jdo = jd
      juo = ju
      jto = jt
      jeo = je
      jfo = jf
      jbo = jb
c
      ir = 1
      it = 2
      iu = 3
      jr = ir
      jt = it
      ju = iu
      jb = iu
c
      lady2   = lady(2)
      lady(2) = 0
      lady4   = lady(4)
      lady(4) = 0
c
      tauo  = tau
      tau   = 1.D-2
      neqo  = neqn
      neqn  = 3
c
      uextro = uextr
      uextr  = 1.D-10
c
      dtime = tau
c
c=======================================================================
c     NEWTON-RAPHSON iteration
c=======================================================================
c
      iter = 1
c
c.......................................................................
c     calculate derivatives
c.......................................................................
c
        rn    (ngrs-2) = 1.0D0
        tg    (ngrs-2) = 85.D0
      dltdlr00(ngrs-2) = 1.0D0
        ug    (ngrs-2) = uextl
      dludlr00(ngrs-2) = 1.0D0
        tg    (ngrs-1) = 85.D0
      dltdlr00(ngrs-1) = 1.0D0
        ug    (ngrs-1) = uextl
      dludlr00(ngrs-1) = 1.0D0
      do 1 k = ngrs, ngre
c
        tg    (k) =     10.D0 + 75.D0 * ( rn(k   )-rn(ngre) )
     .                                / ( rn(ngrs)-rn(ngre) )
      dltdlr00(k) =             75.D0 / ( rn(ngrs)-rn(ngre) ) / tg(k)
c
      rmid   =      (  rn(k) - radc ) / rw
      rmid   = max  ( -3.D+2, min( rmid, +3.D+2 ) )
      switch = cvmgt(  0.5D0, 0.0D0, abs(f1 (rmid)) .lt. 1.D+150)
c
        ug    (k) = uextr + 0.5D0*( 1.0D0 - f0 (rmid) )*(uextl - uextr)
      dludlr00(k) = - switch*( uextl - uextr ) * 0.5D0/rw * f1(rmid)**2
c
    1 continue
        tg    (ngre+1) = 10.D0
      dltdlr00(ngre+1) = 1.0D0
        ug    (ngre+1) = uextr
      dludlr00(ngre+1) = 1.0D0
        tg    (ngre+2) = 10.D0
      dltdlr00(ngre+2) = 1.0D0
        ug    (ngre+2) = uextr
      dludlr00(ngre+2) = 1.0D0
c
      do 2 k = ngrs - 2, ngre + 2
      tn  (k) = tg(k)
      un  (k) = ug(k)
      bri (k) = abs(ug(k))
      ro  (k) = rn(k)
    2 continue
c
c.......................................................................
c     initialize all matrices to zero
c.......................................................................
c
  100 continue
      do 30 i = 1, meqn
      do 20 j = 1, meqn
      do 10 k = 1, mgr
      em2(i, j, k) = 0.0D0
      em1(i, j, k) = 0.0D0
      e00(i, j, k) = 0.0D0
      ep1(i, j, k) = 0.0D0
      ep2(i, j, k) = 0.0D0
   10 continue
   20 continue
   30 continue
c
      do 50 i = 1, meqn
      do 40 k = 1, mgr
      rhs(i, k) = 0.0D0
   40 continue
   50 continue
c
      do 70 i = 1, 3*mpd - 2
      do 60 j = 1, meqn*mgr
      bm(i, j) = 0.0D0
   60 continue
   70 continue
c
      do 80 i = 1, meqn*mgr
      br(i) = 0.0D0
   80 continue
c
c.......................................................................
c     calculate matrix elements in continuity and gas energy equation
c.......................................................................
c
      e00(it, jt, ngrs-2) =  1.0D0
      e00(id, jd, ngrs-2) =  1.0D0
c
      do 3 k = ngrs - 1, ngre + 1
c
      rhs(it,     k) =  tn(k) - tg      (k)
      e00(it, jt, k) =  tn(k)
      e00(it, jr, k) =        - dltdlr00(k) * rn(k)
c
      rhs(iu,     k) =  un(k) - ug      (k)
      e00(iu, ju, k) =  un(k)
      e00(iu, jr, k) =        - dludlr00(k) * rn(k)
    3 continue
c
      e00(it, jt, ngre+2) =  1.0D0
      e00(iu, ju, ngre+2) =  1.0D0
c
c.......................................................................
c     calculate matrix elements in grid equation
c.......................................................................
c
      call grid
c
c.......................................................................
c     solve the system
c.......................................................................
c
      call matslv
c
c.......................................................................
c     find maximum changes
c.......................................................................
c
      kdmx = isamax(ngre - ngrs + 2, rhs(ir,ngrs), meqn)
      dmax = abs( rhs(ir,ngrs + kdmx - 1) ) + 1.0D-30
c
      do 4 k = ngrs, ngre
      cx  (k) = ( rhs(ir, k+1) * rn(k+1) - rhs(ir, k) * rn(k) )
     .        / (                rn(k+1) -              rn(k) )
    4 continue
      kcmx = isamax( ngre - ngrs + 1, cx(ngrs), 1 )
      cmax = abs( cx(ngrs + kcmx - 1) ) + 1.0D-30
c
      sc1 = min( 1.0D0, dtol / dmax )
      sc2 = min( 1.0D0, ctol / cmax )
      sc  = min( sc1, sc2 )
c
      do 5 k = ngrs, ngre + 1
      ro  (k) =   rn(k)
      rn  (k) = ( 1.0D0 + sc * rhs(ir,k) ) * ro(k)
      cx  (k) = ( rn(k) - ro(k) ) / ro(k)
    5 continue
      ksmx = isamax(ngre - ngrs + 2, cx(ngrs), 1)
      smax = abs( cx(ngrs + ksmx - 1) ) + 1.0D-30
c
      iter = iter + 1
c.......................................................................
c     summary output
c.......................................................................
c
      write(itty,998) iter,timen,ksmx,smax,kdmx,dmax
  998 format(" iter ="i3" time ="1pe10.3
     .       " d_r/ro("i3") ="e9.2" rhs("i3") ="e9.2 )
c
c-----------------------------------------------------------------------
c     check for monotonicity
c-----------------------------------------------------------------------
c
      do 6 k = ngrs, ngre + 1
      if ( rn(k+1) .le. rn(k) ) then
           write(itty,'(" grid extrapolation nonmonotonic")')
           write(iout,'(" grid extrapolation nonmonotonic")')
           call clzfil
           stop 'gridinit09'
           end if
    6 continue
c
c-----------------------------------------------------------------------
c     compute new timestep and update quantities
c-----------------------------------------------------------------------
c
      timeo = timen
      timen = timeo + dtime
c
        rn    (ngrs-2) = 1.0D0
        tg    (ngrs-2) = 85.D0
      dltdlr00(ngrs-2) = 1.0D0
        ug    (ngrs-2) = uextl
      dludlr00(ngrs-2) = 1.0D0
        tg    (ngrs-1) = 85.D0
      dltdlr00(ngrs-1) = 1.0D0
        ug    (ngrs-1) = uextl
      dludlr00(ngrs-1) = 1.0D0
      do 7 k = ngrs, ngre
c
        tg    (k) =     10.D0 + 75.D0 * ( rn(k   )-rn(ngre) )
     .                                / ( rn(ngrs)-rn(ngre) )
      dltdlr00(k) =             75.D0 / ( rn(ngrs)-rn(ngre) ) / tg(k)
c
      rmid   =      (  rn(k) - radc ) / rw
      rmid   = max  ( -3.D+2, min( rmid, +3.D+2 ) )
      switch = cvmgt(  0.5D0, 0.0D0, abs(f1 (rmid)) .lt. 1.D+150)
c
        ug    (k) = uextr + 0.5D0*( 1.0D0 - f0 (rmid) )*(uextl - uextr)
      dludlr00(k) = - switch*( uextl - uextr ) * 0.5D0/rw * f1(rmid)**2
c
    7 continue
        tg    (ngre+1) = 10.D0
      dltdlr00(ngre+1) = 1.0D0
        ug    (ngre+1) = uextr
      dludlr00(ngre+1) = 1.0D0
        tg    (ngre+2) = 10.D0
      dltdlr00(ngre+2) = 1.0D0
        ug    (ngre+2) = uextr
      dludlr00(ngre+2) = 1.0D0
c
      do 8 k = ngrs - 2, ngre + 2
      tn  (k) = tg(k)
      un  (k) = ug(k)
      bri (k) = abs(ug(k))
    8 continue
c
      if (smax .gt. 5.D-4) go to 100
c
c=======================================================================
c     restore original code parameters
c=======================================================================
c
      ir = iro
      im = imo
      id = ido
      iu = iuo
      it = ito
      ie = ieo
      if = ifo
      jr = jro
      jm = jmo
      jd = jdo
      ju = juo
      jt = jto
      je = jeo
      jf = jfo
      jb = jbo
c
      neqn  = neqo
      tau   = tauo
      uextr = uextro
c
      lady(2) = lady2
      lady(4) = lady4
c
c=======================================================================
c
      return
      end


C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  SPHERP     SPHERICAL TRANSFORM TO A POINT
C   PRGMMR: KANAMITSU     ORG: NP23          DATE: 1992-04-16
C
C ABSTRACT: TRANSFORMS A SPECTRAL FIELD TO A POINT ON THE GLOBE.
C
C PROGRAM HISTORY LOG:
C 1992-04-16  IREDELL
C
C USAGE:    CALL SPHERP(WAVE,MAXWV,IROMB,IDY,MLT,FAC,RLAT,RLON,VALUE)
C
C   INPUT ARGUMENT LIST:
C     WAVE     - IF IDIR < 0, COMPLEX (KMAX) FIELD TO TRANSFORM,
C                WHERE KMAX=(MAXWV+1)*(IROMB+1)*MAXWV+2)/2.
C                WAVE STARTS AT THE GLOBAL MEAN COMPONENT AND THEN
C                CONTAINS THE ZONALLY SYMMETRIC COMPONENTS.
C     MAXWV    - SPECTRAL TRUNCATION OF THE WAVE
C     IROMB    - IROMB = 0 FOR TRIANGULAR TRUNCATION
C                IROMB = 1 FOR RHOMBOIDAL TRUNCATION
C     IDIR     - 0 FOR NORMAL, 1 FOR LEGENDRE DERIVATIVE
C     MLT      - MULTIPLICATION OPTION ON WAVE VALUES.
C                MLT = 0 FOR NO MULTIPLICATION,
C                MLT = 1 TO MULTIPLY WAVE BY FAC
C                MLT = -1 TO MULTIPLY WAVE BY SQRT(-1)*FAC
C     FAC      - IF MLT.NE.0, REAL (KMAX) FIELD TO MULTIPLY WAVE.
C     RLAT     - LATITUDE IN DEGREES NORTH
C     RLON     - LONGITUDE IN DEGREES EAST
C
C   OUTPUT ARGUMENT LIST:
C     VALUE    - TRANSFORMED VALUE
C
C   SUBPROGRAMS CALLED:
C     (LEGENDR2) - COMPUTE LEGENDRE POLYNOMIALS
C
C   REMARKS: FORTRAN 9X EXTENSIONS ARE USED.
C     FPP CAN BE USED TO INLINE SUBPROGRAMS.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$
CFPP$ EXPAND(LEGENDR2)
      SUBROUTINE SPHERP(WAVE,MAXWV,IROMB,IDY,MLT,FAC,RLAT,RLON,VALUE)
      REAL WAVE((MAXWV+1)*((IROMB+1)*MAXWV+2))
      REAL FAC((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL PNM((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL DNM((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL FR(0:MAXWV),FI(0:MAXWV)
      PARAMETER(PI=3.1415926535898,PI180=PI/180.)
      SINLAT=SIN(RLAT*PI180)
      CALL LEGENDR2(SINLAT,MAXWV,IROMB,PNM,DNM)
      IF(IDY.NE.0) THEN
        PNM=DNM
      ENDIF
      IF(MLT.NE.0) THEN
        PNM=PNM*FAC
      ENDIF
      K=0
      DO M=0,MAXWV
        FR(M)=0.
        FI(M)=0.
      ENDDO
      DO M=0,MAXWV
        DO N=M,IROMB*M+MAXWV
          FR(M)=FR(M)+WAVE(2*K+1)*PNM(K+1)
          FI(M)=FI(M)+WAVE(2*K+2)*PNM(K+1)
          K=K+1
        ENDDO
      ENDDO
      VALUE=0.
      RLAM=RLON*PI180
      IF(MLT.GE.0) THEN
        DO M=1,MAXWV
          VALUE=VALUE+FR(M)*COS(RLAM*M)-FI(M)*SIN(RLAM*M)
        ENDDO
      ELSE
        DO M=1,MAXWV
          VALUE=VALUE-FI(M)*COS(RLAM*M)-FR(M)*SIN(RLAM*M)
        ENDDO
      ENDIF
      VALUE=FR(0)+2.*VALUE
      RETURN
      END
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  LEGENDR2   COMPUTE LEGENDRE POLYNOMIALS.
C   PRGMMR: IREDELL       ORG: NP23          DATE: 1992-04-16
C
C ABSTRACT: EVALUATES THE NORMALIZED ASSOCIATED LEGENDRE POLYNOMIALS
C   AT A GIVEN COSINE OF COLATITUDE.
C
C PROGRAM HISTORY LOG:
C 1992-04-16  IREDELL
C
C USAGE:    CALL LEGENDR2(COSCLT,MAXWV,IROMB,PNM,DNM)
C
C   INPUT ARGUMENT LIST:
C     COSCLT   - COSINE OF COLATITUDE AT WHICH TO EVALUTATE.
C     MAXWV    - SPECTRAL TRUNCATION
C     IROMB    - IROMB = 0 FOR TRIANGULAR TRUNCATION
C                IROMB = 1 FOR RHOMBOIDAL TRUNCATION
C
C   OUTPUT ARGUMENT LIST:
C     PNM      - REAL (KMAX) POLYNOMIAL VALUES,
C     DNM      - REAL (KMAX) POLYNOMIAL DERIVATIVES,
C                WHERE KMAX=(MAXWV+1)*(IROMB+1)*MAXWV+2)/2.
C
C   REMARKS: FORTRAN 9X EXTENSIONS ARE USED.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$
      SUBROUTINE LEGENDR2(COSCLT,MAXWV,IROMB,PNM,DNM)
      DIMENSION PNM((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      DIMENSION DNM((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      DIMENSION EPS(0:100)
      SINCLT=SQRT(1.-COSCLT**2)
      NM=0
      K=1
      PNM(K)=SQRT(0.5)
CDIR$ NEXTSCALAR
      DO M=1,MAXWV-NM*(1-IROMB)
        PNMK=PNM(K)
        K=M*(2*MAXWV+2+(1-M)*(1-IROMB))/2+(NM+1)
        PNM(K)=PNMK*SINCLT*SQRT(FLOAT(2*M+1)/FLOAT(2*M))
      ENDDO
      NM=1
CDIR$ IVDEP
      DO M=0,MAXWV-NM*(1-IROMB)
        N=M+NM
        EPSNM=SQRT(FLOAT(N**2-M**2)/FLOAT(4*N**2-1))
        K=M*(2*MAXWV+2+(1-M)*(1-IROMB))/2+(NM+1)
        PNM(K)=COSCLT*PNM(K-1)/EPSNM
        DNM(K-1)=EPSNM*PNM(K)*(N-1)
        EPS(M)=EPSNM
      ENDDO
      DO NM=2,MAXWV
CDIR$ IVDEP
        DO M=0,MAXWV-NM*(1-IROMB)
          N=M+NM
          EPSNM=SQRT(FLOAT(N**2-M**2)/FLOAT(4*N**2-1))
          K=M*(2*MAXWV+2+(1-M)*(1-IROMB))/2+(NM+1)
          PNM(K)=(COSCLT*PNM(K-1)-EPS(M)*PNM(K-2))/EPSNM
          DNM(K-1)=EPSNM*PNM(K)*(N-1)-EPS(M)*PNM(K-2)*N
          EPS(M)=EPSNM
        ENDDO
      ENDDO
CDIR$ IVDEP
      DO M=0,MAXWV
        NM=MAXWV-M*(1-IROMB)
        N=M+NM
        EPS(M)=SQRT(FLOAT(N**2-M**2)/FLOAT(4*N**2-1))
        N=N+1
        EPSNM=SQRT(FLOAT(N**2-M**2)/FLOAT(4*N**2-1))
        K=M*(2*MAXWV+2+(1-M)*(1-IROMB))/2+(NM+1)
        K=K+1
        PNMK=(COSCLT*PNM(K-1)-EPS(M)*PNM(K-2))/EPSNM
        DNM(K-1)=EPSNM*PNMK*(N-1)-EPS(M)*PNM(K-2)*N
      ENDDO
      RETURN
      END


      FUNCTION TEMLO(ALTU,C)
C
C------
C
C PURPOSE:
C
C     THE FUNCTION TEMLO  EVALUATES  THE  TEMPERATURE AT THE
C     LOCAL REGION.
C
C INPUTS:
C       ALTU     ALTITUDE OF THE POINT, IN KM (90 TO 2000).
C       C        ARRAY THAT CONTAINS THE PARAMETERS USED  IN
C                THE EVALUATION OF EQUATIONS 3 AND 4, AS GI-
C                VEN BY JACCHIA.
C
C OUTPUTS:
C       TEMLO    LOCAL TEMPERATURE AS  DEFINED  IN EQUATIONS
C                3 AND 4, IN KELVIN.
C
C REFERENCES:
C       [1]      JACCHIA, L. G. "THERMOSPHERIC  TEMPERATURE,
C                DENSITY AND COMPOSITION: NEW MODELS."  CAM-
C                BRIDGE, MA, SAO 1977. (SAO  SPECIAL  REPORT
C                375).
C
C AUTHOR:    VALDEMIR CARRARA  APR/87    V 1.0
C
      IMPLICIT REAL*8 (A-H,O-Z)

      DIMENSION C(7)
C
C------
C
      DATA ZX   /125.D0/
      DATA ZO   /90.0D0/
      DATA TO   /188.D0/

      HIGX   = ALTU - ZX
      HIGO   = ALTU - ZO
      TEMLO  = TO

      IF(HIGO.EQ.0.D0) RETURN

      IF(HIGX.GT.0.D0) THEN
       TEMLO = C(7) +
     1         C(4)*ATAN(C(5)*HIGX + C(6)*HIGX*HIGX*HIGX)
      ELSE
       AUXI  = HIGX/HIGO
       TEMLO = C(7) +
     1         C(1)*ATAN(C(2)*HIGX + C(3)*HIGX*AUXI*AUXI)
      ENDIF

      RETURN
      END

      SUBROUTINE SEALAT(TYFR,SUDC,RLAT,ALTU,AL)
C
C------
C
C PURPOSE:
C
C     THE SUBROUTINE SEALAT  OBTAINS  THE VARIATIONS  ON THE
C
C     NUMBER DENSITY OF THE ATMOSPHERE, DUE TO THE SEAZONAL-
C                                                  ---
C     LATITUDINAL EFFECT.
C     ---
C
C INPUTS:
C
C       TYFR     FRACTION OF THE TROPIC YEAR, IN  THE  RANGE
C                0. TO 1., STARTING ON JAN. 1ST.
C       SUDC     SUN DECLINATION IN RADIANS (-PI TO PI).
C       RLAT     DECLINATION (GEOCENTRIC  LATITUDE)  OF  THE
C                POINT, IN RADIANS (-PI TO PI).
C       ALTU     GEOCENTRIC ALTITUDE  IN KM,  IN  THE  RANGE
C                90. TO 2000..
C
C OUTPUTS:
C
C       AL       ARRAY CONTAINING  THE  SEAZONAL-LATITUDINAL
C                VARIATIONS FOR THE HE (HELIUM), O2 (MOLECU-
C                LAR OXYGEN), N2  (MOLECULAR  NITROGEN),  AR
C                (ARGON), O (ATOMIC OXYGEN)  AND  H  (ATOMIC
C                HYDROGEN) NUMBER DENSITY, RESPECTIVELY.
C
C
C REFERENCES:
C
C       [1]      JACCHIA, L. G. "THERMOSPHERIC  TEMPERATURE,
C                DENSITY AND COMPOSITION: NEW MODELS."  CAM-
C                BRIDGE, MA, SAO 1977. (SAO  SPECIAL  REPORT
C                375).
C
C AUTHOR:    VALDEMIR CARRARA       APR/87             V 1.0
C            BENTO SILVA DE MATOS
C
      IMPLICIT REAL*8 (A-H,O-Z)

      DIMENSION AL(6)
      DIMENSION CR(6)
C
C------
C
      DATA PITW /6.28318530718D0/

      DATA CR   /-0.79D0,0.D0,0.D0,0.D0,-.16D0,0.D0/

      SILA   = SIN(RLAT)
      DSLT   = SUDC*SILA/0.409157536545D0
      DELZ   = ALTU - 91.D0
      ESSE   = 0.014D0*DELZ*DEXP(-0.0013D0*DELZ*DELZ)
      PCAP   = DSIN(PITW*TYFR + 1.72D0)
      DSLM   = SIGN(SILA*SILA*ESSE*PCAP,RLAT)

      DO   I = 1, 6
       AL(I) = DSLT*CR(I) + DSLM
      ENDDO

      RETURN
      END

      SUBROUTINE SEMIAN(TYFR,ALTU,ALCO)
C
C------
C
C PURPOSE:
C
C     THE SUBROUTINE SEMIAN GIVES THE CORRECTION FACTOR ALCO
C
C     FOR   THE  ATMOSPHERE   NUMBER  DENSITY,  DUE  TO  THE
C
C     SEMIANNUAL EFFECT.
C     ------
C
C INPUTS:
C
C       TYFR     FRACTION OF THE TROPIC  YEAR,  IN THE RANGE
C                0. TO 1., STARTING ON JAN. 1ST.
C       ALTU     GEOCENTRIC ALTITUDE  IN KM,  IN  THE  RANGE
C                90. TO 2000..
C
C OUTPUTS:
C
C       ALCO     THE SEMIANNUAL VARIATION OF THE  ATMOSPHERE
C                NUMBER DENSITY.
C
C REFERENCES:
C
C       [1]      JACCHIA, L. G. "THERMOSPHERIC  TEMPERATURE,
C                DENSITY AND COMPOSITION: NEW MODELS."  CAM-
C                BRIDGE, MA, SAO 1977. (SAO  SPECIAL  REPORT
C                375).
C
C AUTHOR:    VALDEMIR CARRARA        APR/87            V 1.0
C            BENTO SILVA DE MATOS
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
C------
C
      DATA PITW /6.28318530718D0/

      AUXI   = 0.04D0*ALTU*ALTU/1.D+04 + 0.05D0
      FOFT   = AUXI*DEXP(-0.25D-02*ALTU)
      AUXI   = (0.5D0+0.5D0*DSIN(PITW*TYFR+6.04D0))**1.65D0
      TAUC   = 0.0954D0*(AUXI - 0.5D0) + TYFR
      AUXI   = DSIN(2.D0*PITW*TAUC + 4.26D0)*(1.D0 +
     1         0.467D0*DSIN(PITW*TAUC + 4.14D0))
      GOFT   = AUXI*0.382D0 + 0.0284D0
      ALCO   = FOFT*GOFT

      RETURN
      END

      FUNCTION DATANH(X)
C
C------
C
C PURPOSE:
C
C     THE DATANH FUNCTION CALCULATES THE HYPERBOLIC  TANGENT
C     ARC OF AN ARGUMENT X, IN DOUBLE PRECISION.
C
C INPUTS:
C       X        HYPERBOLIC TANGENT VALUE (-1<X<1).
C
C OUTPUTS:
C       DATANH   HYPERBOLIC TANGENT ARC.
C
C AUTHOR:    VALDEMIR CARRARA  APR/87    V 1.0
C            DAVIDE AMATO      MAY/18    V 1.1 (fix a WRITE(*) statement)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
C------
C
      IF(ABS(X).GT.1.D0) THEN
        WRITE(6,*) 'INVALID HYPERBOLIC TANGENT ARC ARGUMENT'
        STOP
      END IF

      ARGU   = (1.D0 + X)/(1.D0 - X)

      DATANH = LOG(ARGU)/2.D0

      RETURN
      END


      subroutine irev_eqrpib2(ctfm,ctfmp,n_a1,n_alpha,n_b1,n_beta,n_rPIb
     &2,n_rpsi,nm1_rPIb2,np1_rPIb2,octfmp,Nx,ht,hx,mass,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 hx
      real*8 mass
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_a1(Nx)
      real*8 n_alpha(Nx)
      real*8 n_b1(Nx)
      real*8 n_beta(Nx)
      real*8 n_rPIb2(Nx)
      real*8 n_rpsi(Nx)
      real*8 nm1_rPIb2(Nx)
      real*8 np1_rPIb2(Nx)
      real*8 octfmp(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=2, Nx-1, 1
      qb = 0.5000000000000000D0 * (-0.1D1 * nm1_rPIb2(i) + np1_rPIb2(i))
     # / ht + n_a1(i) * mass * n_rpsi(i) * n_alpha(i) * n_b1(i) ** 2 - 0
     #.1D1 * (-0.5000000000000000D0 * n_rPIb2(i) * (n_beta(i - 1) - 0.1D
     #1 * n_beta(i + 1)) / hx + 0.5000000000000000D0 * n_beta(i) * (-0.1
     #D1 * n_rPIb2(i - 1) + n_rPIb2(i + 1)) / hx - 0.5000000000000000D0
     #/ n_a1(i) * (-0.1D1 * n_rpsi(i - 1) + n_rpsi(i + 1)) / hx * octfmp
     #(i) * n_alpha(i) * n_b1(i) ** 2) / ctfmp(i) - 0.1D1 * (0.250000000
     #0000000D0 / n_a1(i) ** 2 * (-0.1D1 * n_rpsi(i - 1) + n_rpsi(i + 1)
     #) / hx ** 2 * (n_a1(i - 1) - 0.1D1 * n_a1(i + 1)) * n_alpha(i) * n
     #_b1(i) ** 2 + 0.2500000000000000D0 / n_a1(i) * (-0.1D1 * n_rpsi(i
     #- 1) + n_rpsi(i + 1)) / hx ** 2 * (-0.1D1 * n_alpha(i - 1) + n_alp
     #ha(i + 1)) * n_b1(i) ** 2 + 0.5000000000000000D0 / n_a1(i) * (-0.1
     #D1 * n_rpsi(i - 1) + n_rpsi(i + 1)) / hx ** 2 * (-0.1D1 * n_b1(i -
     # 1) + n_b1(i + 1)) * n_alpha(i) * n_b1(i) + 0.1D1 / n_a1(i) * (n_r
     #psi(i - 1) - 0.2D1 * n_rpsi(i) + n_rpsi(i + 1)) / hx ** 2 * n_alph
     #a(i) * n_b1(i) ** 2) / ctfmp(i) ** 2 - 0.1D1 * (0.2D1 * n_rPIb2(i)
     # * n_beta(i) + 0.1D1 / n_a1(i) * n_alpha(i) * n_b1(i) ** 2 * (-0.1
     #D1 * n_rpsi(i - 1) + n_rpsi(i + 1)) / hx / ctfmp(i)) / ctfm(i)
      res(i)=qb
      end do
      END


C*DK ocgrid
C*DF unicos
      subroutine ocgrid(xn,i4,n)
C
C
C#######################################################################
C
C      PURPOSE -
C
C         THIS ROUTINE
C
C      INPUT ARGUMENTS -
C
C         input_message - CHARACTER STRING CONTAINING THE INPUT
C                            MESSAGE.
C
C      OUTPUT ARGUMENTS -
C
C         ierror_return - ERROR RETURN CODE (==0 ==> OK, <>0 ==> ERROR)
C
C      CHANGE HISTORY -
C
C        $Log: ocgrid.f,v $
C        Revision 2.00  2007/11/05 19:46:02  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.2   30 Sep 2004 10:57:02   dcg
CPVCS    make pi5 double precision
CPVCS
CPVCS       Rev 1.1   Mon Apr 14 16:56:04 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.0   01/17/95 16:38:54   pvcs
CPVCS     Original version
C
C#######################################################################
C
      implicit real*8 (a-h, o-z)
      character*132 logmess
C
C#######################################################################
C
c
c        This routine constructs an icosahedral grid for
c        diamond i4 on the unit sphere.
c
      real xn(0:n+1,0:n+1,3)
      integer ip(10)
      ip( 1)=-1
      ip( 2)= 1
      ip( 3)= 3
      ip( 4)= 5
      ip( 5)=-3
      ip( 6)= 0
      ip( 7)= 2
      ip( 8)= 4
      ip( 9)=-4
      ip(10)=-2
      pi5   =0.62831853071796d0
c
      lv   = 1.45*alog(float(n))
      nn   = (n+2)**2
      sgn  = sign(1.0,5.5-i4)
      phi  = ip(i4)*pi5
      w    = 2.*acos(1./(2.*sin(pi5)))
      cosw = cos(w)
      sinw = sin(w)
c
      xn(0,  1,1) =  0.
      xn(0,  1,2) =  0.
      xn(0,  1,3) =  sgn
      xn(n,  1,1) =  sinw*cos(phi)
      xn(n,  1,2) =  sinw*sin(phi)
      xn(n,  1,3) =  cosw*sgn
      xn(0,n+1,1) =  sinw*cos(phi+pi5+pi5)
      xn(0,n+1,2) =  sinw*sin(phi+pi5+pi5)
      xn(0,n+1,3) =  cosw*sgn
      xn(n,n+1,1) =  sinw*cos(phi+pi5)
      xn(n,n+1,2) =  sinw*sin(phi+pi5)
      xn(n,n+1,3) = -cosw*sgn
c
c        Construct the hexagonal grid.
c
      do 80 k=0,lv-1
         m  = 2**k
         l  = n/m
         l2 = l/2
c
c     rows of diamond--
         do 20 j1=1,m+1
         do 20 j2=1,m
             i1 = (j1-1)*l
             i2 = (j2-1)*l + l2 + 1
 20      call ocmidpt(xn(i1,i2,1),xn(i1,i2-l2,1),xn(i1,i2+l2,1),nn)
c
c     columns of diamond--
         do 40 j1=1,m+1
         do 40 j2=1,m
             i1 = (j2-1)*l + l2
             i2 = (j1-1)*l + 1
 40      call ocmidpt(xn(i1,i2,1),xn(i1-l2,i2,1),xn(i1+l2,i2,1),nn)
c
c     diagonals of diamond--
         do 60 j1=1,m
         do 60 j2=1,m
             i1 = (j1-1)*l + l2
             i2 = (j2-1)*l + l2 + 1
 60      call ocmidpt(xn(i1,i2,1),xn(i1-l2,i2+l2,1),xn(i1+l2,i2-l2,1),
     *  nn )
 80   continue
c
      call ocgrdedg(xn,n)
c
ccht
      goto 9999
 9999 continue
      return
      end


!
!     -------------------------------------------------------------
!      C 1 E 1 S M
!     -------------------------------------------------------------
!
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF FOLLOWING              *
!                                                 ---         ---  *
!                                                 I  Q   1  C   I  *
!     CLEBSCH - GORDAN COEFFICIENT:               I             I  *
!                                                 I  QM  1  CM  I  *
!                                                 ---         ---  *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vilnius,  Lithuania                          December 1993   *
!
      SUBROUTINE C1E1SM(Q, QM, SM, C, CM, A)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONSTS_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  07:48:27  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ittk_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      REAL(DOUBLE) , INTENT(IN) :: Q
      REAL(DOUBLE) , INTENT(IN) :: QM
      REAL(DOUBLE) , INTENT(IN) :: SM
      REAL(DOUBLE) , INTENT(IN) :: C
      REAL(DOUBLE) , INTENT(IN) :: CM
      REAL(DOUBLE) , INTENT(OUT) :: A
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: IIQ, IIC, IE
      REAL(DOUBLE), DIMENSION(2) :: GC
!-----------------------------------------------
      GC(1) = ONE
      GC(2) = -ONE
      A = ZERO
      IIQ = TWO*Q + TENTH
      IIC = TWO*C + TENTH
      IF (ITTK(IIQ,IIC,2) == 0) RETURN
      IF (ABS(QM + SM - CM) > EPS) RETURN
      IF (Q + TENTH < ABS(QM)) RETURN
      IF (C + TENTH < ABS(CM)) RETURN
      IE = 0
      IF (ABS(SM - ONE) < EPS) IE = 1
      IF (ABS(SM + ONE) < EPS) IE = 2
      IF (IE == 0) RETURN
      IF (ABS(Q + ONE - C) >= EPS) THEN
         IF (ABS(Q - C) < EPS) GO TO 2
         IF (ABS(Q - ONE - C) > EPS) RETURN
         A = SQRT((C - GC(IE)*CM+ONE)*(C-GC(IE)*CM+TWO)/((TWO*C+TWO)*(TWO*C+&
            THREE)))
         RETURN
      ENDIF
      A = SQRT((C + GC(IE)*CM-ONE)*(C+GC(IE)*CM)/((TWO*C-ONE)*TWO*C))
      RETURN
    2 CONTINUE
      A = -GC(IE)*SQRT((C + GC(IE)*CM)*(C-GC(IE)*CM+ONE)/((C+ONE)*TWO*C))
      RETURN
      END SUBROUTINE C1E1SM


      double precision function Li3(x)
      implicit none
C     returns Li_3(x) for real x, minf < x < 1
      double precision x
      double complex wgplg

      if (x .gt. 1d0) then
        write(6,*) 'x>1 in Li3 function, src/Lib/Li3.f'
        stop
      endif

      Li3 = dble(wgplg(2,1,x))
      end