c
c  This module contains subroutines from adj
c
c----------------------------------------------------------

      function current (du, ua, c, nmax, dth0, th0a, imax, imax1,
     1   fm, chi, cur)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(kind=dp) current
      integer nmax, imax, imax1
      real(kind=dp) du, c, dth0
      real(kind=dp), dimension(0:nmax - 1) :: ua
      real(kind=dp), dimension(0:imax - 1) :: th0a
      real(kind=dp), dimension(0:nmax - 1) :: fm
      real(kind=dp), dimension(0:imax1 - 1,0:nmax - 1) :: chi
      real(kind=dp), dimension(0:imax - 1) :: cur
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n, i
      real(kind=dp) :: pi
C-----------------------------------------------

      pi = 4*atan(1.0E0)
      cur(:imax-1) = 0

      do n = 0, nmax - 1
         cur(:imax-1) = cur(:imax-1) + chi(:imax-1,n)*fm(n)*ua(n)**3/
     1      sqrt(1 + (ua(n)/c)**2)
      end do

      current = dot_product(sin(th0a(:imax-1))*cos(th0a(:imax-1)),cur(:
     1   imax-1))

      current = 4*pi*du*dth0*current

      return
      end function current


      subroutine decomp(chi, nmax, nmax1, imax, imax1, lmaxa, lmaxa1,
     1   th0a, dth0, legp, chil)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax, nmax1, imax, imax1, lmaxa, lmaxa1
      real(kind=dp) dth0
      real(kind=dp), dimension(0:imax1 - 1,0:nmax - 1) :: chi
      real(kind=dp), dimension(0:imax - 1) :: th0a
      real(kind=dp), dimension(0:imax1 - 1,lmaxa1) :: legp
      real(kind=dp), dimension(0:nmax1 - 1,lmaxa1) :: chil
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: la, l, n, i
      real(kind=dp) :: sn
C-----------------------------------------------

      do la = 1, lmaxa
         l = max(2*la - 1,0)

         chil(:nmax-1,la) = 0

         do i = 0, imax - 1
            sn = sin(th0a(i))*legp(i,la)
            chil(:nmax-1,la) = chil(:nmax-1,la) + chi(i,:nmax-1)*sn
         end do

         chil(:nmax-1,la) = (2*l + 1)*dth0*chil(:nmax-1,la)

      end do

      return
      end subroutine decomp


      function deltab (phi, eps)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(kind=dp) phi, eps
      real(kind=dp) deltab
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
C-----------------------------------------------

      deltab = 2*eps*sin(phi/2)**2/(1 + eps*cos(phi))

      return
      end function deltab

      subroutine error(du, ua, umax, nmax, dth0, th0a, th0max, imax,
     1   imax1, resid, chi, abserr, relerr, aerr, rerr)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax, imax, imax1
      real(kind=dp) du, umax, dth0, th0max, abserr, relerr
      real(kind=dp), dimension(0:nmax - 1) :: ua
      real(kind=dp), dimension(0:imax - 1) :: th0a
      real(kind=dp), dimension(0:imax1 - 1,0:nmax - 1) :: resid, chi
      real(kind=dp), dimension(0:imax - 1) :: aerr, rerr
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i, n
C-----------------------------------------------

      aerr(:imax-1) = 0
      rerr(:imax-1) = 0

      do n = 0, nmax - 1
         aerr(:imax-1) = aerr(:imax-1) + resid(:imax-1,n)**2*(ua(n)**2)
         rerr(:imax-1) =rerr(:imax-1)+(resid(:imax-1,n)/max(1.0E-16_dp,
     1      abs(chi(:imax-1,n))))**2*(ua(n)**2)
      end do

      abserr = dot_product(sin(th0a(:imax-1)),aerr(:imax-1))
      relerr = dot_product(sin(th0a(:imax-1)),rerr(:imax-1))

      abserr = sqrt(abserr*du*dth0/(umax**3/3*(1 - cos(th0max))))
      relerr = sqrt(relerr*du*dth0/(umax**3/3*(1 - cos(th0max))))

      return
      end subroutine error


      subroutine hinit(eps, kmax, lmaxa1, harr, garr, dthp, dl, bb)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer kmax, lmaxa1
      real(kind=dp) eps, dthp
      real(kind=dp), dimension(((lmaxa1 - 1)
     1 *lmaxa1*(2*lmaxa1-1))/6+(lmaxa1- 1)*lmaxa1+lmaxa1):: harr
      real(kind=dp),dimension((((lmaxa1+3)-1)*
     1   (lmaxa1+3))/2+(lmaxa1+1))::garr
      real(kind=dp), dimension(0:kmax - 1) :: dl, bb
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: k, la, la1, la2, l, l1
      real(kind=dp) :: b, pi
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real(kind=dp) , EXTERNAL :: deltab
C-----------------------------------------------

      pi = 4*atan(1.0E0)

C
C  Initialize |harr| and set the edge values of |garr| to zero.
C
      do la = 1, lmaxa1
         do la1 = 1, la
            harr((la-1)*la*(2*la-1)/6+(la1-1)*la+1:la*(la*(2*(la-1)-1)+1
     1         )/6+la1*la) = 0
         end do
      end do

      do la = -2, lmaxa1 - 1
         garr((((la+3)-1)*(la+3))/2+(0+1)) = 0
      end do
      do la = -1, lmaxa1 - 1
         garr((((la+3)-1)*(la+3))/2+(la+1+1)) = 0
         garr((((la+3)-1)*(la+3))/2+(la+2+1)) = 0
      end do
      garr((((1+3)-1)*(1+3))/2+(1+1)) = 1

      do k = 0, kmax - 1
c     phi=2*pi*(k+0.25e0)/kmax
         b = bb(k)
C
C  Use the recursion relation for 'g' to fill garr
C
         do la = 2, lmaxa1
            l = max(2*la - 1,0)
            do la1 = 1, la
               l1 = max(2*la1 - 1,0)
               garr((((la+3)-1)*(la+3))/2+(la1+1)) = (2*(2*l - 3)*(l**2
     1             - 3*l + 1)*garr((((la-1+3)-1)*(la-1+3))/2+(la1+1))-(l
     2            -3)*(l-2)*(2*l-1)*garr((((la-2+3)-1)*(la-2+3))/2+(la1+
     3            1)))/(l*(l - 1)*(2*l - 5)) + (2*l - 3)*(2*l - 1)*b*((
     4            l1 + 1)*(l1 + 2)*garr((((la-1+3)-1)*(la-1+3))/2+(la1+1
     5            +1))/((2*l1+3)*(2*l1+5))-2*(l1**2+l1-1)*garr((((la-1+3
     6            )-1)*(la-1+3))/2+(la1+1))/((2*l1-1)*(2*l1+3))+l1*(l1-1
     7            )*garr((((la-1+3)-1)*(la-1+3))/2+(la1-1+1))/((2*l1-3)*
     8            (2*l1-1)))/(l*(l - 1))
            end do
         end do

         do la = 1, lmaxa1
            do la1 = 1, la
               harr((la-1)*la*(2*la-1)/6+(la1-1)*la+1:la*(la*(2*(la-1)-1
     1            )+1)/6+la1*la) = harr((la-1)*la*(2*la-1)/6+(la1-1)*la+
     2            1:la*(la*(2*(la-1)-1)+1)/6+la1*la) + b*garr(((la+3)*(
     3            la+3)-3-la)/2+la1+1)*garr((la*(la+5)+6)/2+2:la+1+(la*(
     4            la+5)+6)/2)*dl(k)
            end do
         end do
      end do

      do la = 1, lmaxa1
         do la1 = 1, la
            do la2 = 1, la
               harr(((la-1)*la*(2*la-1))/6+(la1-1)*la+la2) = (2*max(2*la
     1             - 1,0) + 1)/real(2*max(2*la2 - 1,0) + 1)*harr(((la-1)
     2            *la*(2*la-1))/6+(la1-1)*la+la2)
            end do
         end do
      end do

      return
      end subroutine hinit


      subroutine initjy(ua, c, nmax, nmax1, lmaxa, lmaxa1, legjy, jarray
     1   , djarray, lmax1)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax, nmax1, lmaxa, lmaxa1, lmax1
      real(kind=dp) c
      real(kind=dp), dimension(0:nmax - 1) :: ua
      real(kind=dp), dimension(0:nmax1 - 1,0:6,0:3,0:lmaxa1) :: legjy
      real(kind=dp), dimension((-lmax1) - 1:lmax1,
     1   0:6) :: jarray, djarray
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n, mult, la, l, a
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      EXTERNAL legjn
C-----------------------------------------------

      do n = 0, nmax - 1
         call legjn(ua(n),c,max(2*lmaxa-1,0),jarray,djarray,lmax1)
         do la = 0, lmaxa
            l = max(2*la - 1,0,0)
            mult = (-1)**(l + 1)
            legjy(n,:6,0,la) = jarray(l,:6)
            legjy(n,:6,1,la) = mult*jarray((-l)-1,:6)
            legjy(n,:6,2,la) = djarray(l,:6)
            legjy(n,:6,3,la) = mult*djarray((-l)-1,:6)
         end do
      end do

      return
      end subroutine initjy


      subroutine initp(x, imax, imax1, lmaxa, lmaxa1, legp, leg0)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer imax, imax1, lmaxa, lmaxa1
      real(kind=dp), dimension(0:imax - 1) :: x
      real(kind=dp), dimension(0:imax1 - 1,lmaxa1) :: legp
      real(kind=dp), dimension(0:imax - 1) :: leg0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i, l, la
C-----------------------------------------------

      if (lmaxa < 1) return

      la = 1
      leg0(:imax-1) = 1
      legp(:imax-1,la) = x(:imax-1)

      do la = 2, lmaxa
         l = max(2*la - 1,0)
         leg0(:imax-1) = (((2*l) - 3)*x(:imax-1)*legp(:imax-1,la-1)-(l-2
     1      )*leg0(:imax-1))/(l - 1)
         legp(:imax-1,la) = (((2*l) - 1)*x(:imax-1)*leg0(:imax-1)-(l-1)*
     1      legp(:imax-1,la-1))/l
      end do

      return
      end subroutine initp


      subroutine isotrop(ua, du, c, fm, chil, nmax, nmax1, legjy, psid,
     1   ze, zi, duug, fu, dtt, work)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax, nmax1
      real(kind=dp) du, c, ze, zi
      real(kind=dp), dimension(0:nmax - 1) :: ua, fm, chil
      real(kind=dp), dimension(0:nmax1 - 1,0:6,0:3) :: legjy
      real(kind=dp), dimension(0:nmax1 - 1,0:4,0:1) :: psid
      real(kind=dp), dimension(0:nmax) :: duug
      real(kind=dp), dimension(0:nmax - 1) :: fu, dtt
      real(kind=dp), dimension(0:nmax + (nmax1 + 1)*7*2 - 1) :: work
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      integer, parameter :: p0 = 0
      integer, parameter :: p02 = 1
      integer, parameter :: p022 = 2
      integer, parameter :: p1 = 3
      integer, parameter :: p11 = 4
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n
      real(kind=dp) :: pi, g, u
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      EXTERNAL pot
C-----------------------------------------------

      call pot (ua, du, c, fm, chil, nmax, nmax1, legjy, psid, work(0),
     1   work(nmax))

      pi = 4*atan(1.0E0)
      do n = 0, nmax - 1
         u = ua(n)
         g = sqrt(1 + (u/c)**2)
         duug(n) = ze*4*pi*g/u*(2*g**2*psid(n,p02,1)-u*psid(n,p0,0)-8*g
     1      **2/c**2*psid(n,p022,1)+8*u/c**4*psid(n,p022,0))
         dtt(n) = ze*4*pi/(g*u)*((-g**2*psid(n,p02,1))-u/c**2*psid(n,p02
     1      ,0)+4*g**2/c**2*psid(n,p022,1)-4*u/c**4*psid(n,p022,0)) + zi
     2      *g/(2*u)
         fu(n) = ze*4*pi*g*((-psid(n,p1,1))+2/c**2*psid(n,p11,1))
      end do



      duug(nmax) = (3*duug(nmax-1)-duug(nmax-2))/2
      duug(nmax-1:1:(-1)) = (duug(nmax-1:1:(-1))+duug(nmax-2:0:(-1)))/2
      duug(0) = duug(0)

      return
      end subroutine isotrop


      function lam1 (eps, th0, kmax, dthp, dl, b)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(kind=dp) lam1
      integer kmax
      real(kind=dp) eps, th0, dthp
      real(kind=dp), dimension(0:kmax - 1) :: dl, b
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: k
      real(kind=dp) :: deltabv, sum, costh
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real(kind=dp) , EXTERNAL :: deltab
C-----------------------------------------------

c     pi=4*atan(1.0e0)
      sum = 0
      do k = 0, kmax - 1
c     phi=2*pi*(k+0.25e0)/kmax
         deltabv = b(k) - 1.
         costh = sqrt(1 - min(1.0E0_dp,deltabv*tan(th0)**2))
         sum = sum + 1/costh*dl(k)
      end do
      lam1 = sum

      return
      end function lam1


      function lam2 (eps, th0, kmax, dthp, dl, b)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real(kind=dp) lam2
      integer kmax
      real(kind=dp) eps, th0, dthp
      real(kind=dp), dimension(0:kmax - 1) :: dl, b
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: k
      real(kind=dp) :: deltabv, sum, costh
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real(kind=dp) , EXTERNAL :: deltab
C-----------------------------------------------

c     pi=4*atan(1.0e0)
      sum = 0
      do k = 0, kmax - 1
c     phi=2*pi*(k+0.25e0)/kmax
         deltabv = b(k) - 1.
         costh = sqrt(1 - min(1.0E0_dp,deltabv*tan(th0)**2))
         sum = sum + costh/(1 + deltabv)*dl(k)/b(k)
      end do
      lam2 = sum

      return
      end function lam2


      subroutine legjn(u, c, lmax, jarray, djarray, lmax1)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer lmax, lmax1
      real(kind=dp) u, c
      real(kind=dp), dimension((-lmax1) - 1:lmax1,
     1   0:6) :: jarray, djarray
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      integer, parameter :: j0 = 0
      integer, parameter :: j1 = 1
      integer, parameter :: j2 = 2
      integer, parameter :: j02 = 3
      integer, parameter :: j11 = 4
      integer, parameter :: j22 = 5
      integer, parameter :: j022 = 6
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: l, a, amax
      real(kind=dp) :: scale, g
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      EXTERNAL legjs
C-----------------------------------------------

      amax = 2
      call legjs (u/c, lmax + 2, amax, jarray, lmax1)

      scale = 1
      do l = 1, lmax + 2
         scale = scale*u/(2*l + 1)
         jarray(l,:amax) = scale*jarray(l,:amax)
      end do

      scale = 1
      do l = -1, (-lmax) - 2, -1
         scale = scale/u*(2*l + 3)
         jarray(l,:amax) = scale*jarray(l,:amax)
      end do

      do l = (-lmax) - 2, lmax
         jarray(l,j02) = u/2*jarray(l+1,1)
         jarray(l,j11) = u/2*jarray(l+1,0)
         jarray(l,j22) = u/2*jarray(l+1,1) + (u/c)**2/2*jarray(l+2,0)
         jarray(l,j022) = u**2/8*jarray(l+2,0)
      end do

      g = sqrt(1 + (u/c)**2)
      do a = 0, 6
         do l = (-lmax) - 1, lmax
            djarray(l,a) = jarray(l-1,a)/g - (l + 1)/u*jarray(l,a)
         end do
      end do

      return
      end subroutine legjn


      subroutine legjs(z, lmax, amax, jarray, lmax1)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer lmax, amax, lmax1
      real(kind=dp) z
      real(kind=dp), dimension((-lmax1) - 1:lmax1,0:amax) :: jarray
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: l, a, lstart
      real(kind=dp) :: z2, g, ja0, ja1, ja2, ratio, sigma
C-----------------------------------------------

      if (amax<0 .or. lmax<0) return
      if (lmax > lmax1) return

      z2 = z**2
      g = sqrt(1 + z2)

      do a = 1, amax
C**************a=0 is excluded
         ja2 = 1
C********ja(a-1,a)
         ja1 = g
C**********ja(a-2,a)
         do l = a - 3, lmax - 1, -1
C
C   Get things started by iterating down to $|lmax|-1$ if need be.
C   This is from equation (A29)
C
            ja0=g*ja1-z2*(l-a+2)*(l+a+2)*ja2/((2*l+3)*(2*l+5))
            ja2 = ja1
            ja1 = ja0
         end do
         l = min(lmax,a - 1)
         jarray(l,a) = ja2
         l = l - 1
         jarray(l,a) = ja1
         do l = min(lmax,a - 1) - 2, max((-a),(-lmax) - 1), -1
            jarray(l,a) = g*jarray(l+1,a) - z2*(l - a + 2)*(l + a + 2)*
     1         jarray(l+2,a)/((2*l + 3)*(2*l + 5))
         end do
      end do

C
C   Calculate the scaled Legendre functions for the other easy case, namely
C   $l<-a$.
C
      do a = 0, min(amax,lmax)
         l = (-a) - 1
         jarray(l,a) = 1
         l = l - 1
         if (l >= (-lmax) - 1) jarray(l,a) = g
         do l = (-a) - 3, (-lmax) - 1, -1
            jarray(l,a) = g*jarray(l+1,a) - z2*(l - a + 2)*(l + a + 2)*
     1         jarray(l+2,a)/((2*l + 3)*(2*l + 5))
         end do
      end do

C
C  Calculate scaled Legendre functions for -a.<= l <=a
C
C
C   Calculate $\ja{l\ge0,0}$.  Depending on the magnitude of the argument we
C  either use backwards recursion (for $z \le |lmax|+1$) or forwards
C  recursion using $\ja{-1,0}=1$ and $\ja{0,0} = (\sinh^{-1} z)/z$.
C
      a = 0
      if (abs(z) <= lmax + 1) then
C
C  Estimate where to start the recursion.  The 10 is a extra guard.
C
         lstart=lmax+log(1.0E-16)/(2*log((1.0E-16+abs(z))/(g+1)))+10
         ratio = 2/(g + 1)
         do l = lstart, lmax - 1, -1
            ratio=1/(g-z2*(l-a+2)*(l+a+2)*ratio/((2*l+3)*(2*l+5)))
C***At this point, |ratio| is approximation for $\ja{l+1,a}/\ja{l,a}$. **
         end do
         jarray(lmax,a) = ratio
         ja0 = 1
         do l = lmax - 2, -1, -1
            jarray(l+1,a) = ja0
            ja0 = g*jarray(l+1,a) - z2*(l - a + 2)*(l + a + 2)*jarray(l+
     1         2,a)/((2*l + 3)*(2*l + 5))
         end do
         ja0 = 1/ja0
         jarray(0:lmax,a) = ja0*jarray(0:lmax,a)
      else
C********** Use forward recurrence for $z>|lmax|+1$. **
         sigma = log(g + abs(z))
C******$\sinh^{-1}(\abs z)$ **
         l = 0
         jarray(l,a) = sigma/abs(z)
C********* Starting value.  We assume
C            that $\ja{-1,0}$ has already been set to $1$. */


         do l = 1, lmax
C***********Equation (A29)***************
            jarray(l,a) = (g*jarray(l-1,a)-jarray(l-2,a))*(2*l - 1)*(2*l
     1          + 1)/(z2*(l - a)*(l + a))
         end do
      endif
C
C   Do the other cases, i.e., $a>0$, $l\ge a$.
C
C  < Do the other cases, i.e., $a>0$, $l\ge a$ @>=
C
      do a = 1, min(lmax,amax)
         l = lmax
         jarray(l,a) = ((2*l + 1)*jarray(l-1,a-1)-(l+1-a)*g*jarray(l,a-1
     1      ))/(l + a)
         l = lmax - 1
         if (l == 0) then
C
C    implies that a=1. Use ja(-1,0)=1
C
            ja0 = ((2*l + 1) - (l + 1 - a)*g*jarray(l,a-1))/(l + a)
         else
            ja0=((2*l+1)*jarray(l-1,a-1)-(l+1-a)*g*jarray(l,a-1))/(l+a)
         endif
         do l = lmax - 2, a - 1, -1
            jarray(l+1,a) = ja0
            ja0 = g*jarray(l+1,a) - z2*(l - a + 2)*(l + a + 2)*jarray(l+
     1         2,a)/((2*l + 3)*(2*l + 5))
         end do
         ja0 = 1/ja0
         jarray(a:lmax,a) = ja0*jarray(a:lmax,a)
      end do

      return
      end subroutine legjs


      subroutine matinit(du, ua, ug, nmax, nmax1, dth0, th0a, th0g, imax
     1   , imax1, duug, fu, dtt, lam1a, lam2g, uinv, th0inv, rho)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax, nmax1, imax, imax1
      real(kind=dp) du, dth0, rho
      real(kind=dp), dimension(0:nmax - 1) :: ua
      real(kind=dp), dimension(0:nmax) :: ug
      real(kind=dp), dimension(0:imax - 1) :: th0a
      real(kind=dp), dimension(0:imax) :: th0g
      real(kind=dp), dimension(0:nmax) :: duug
      real(kind=dp), dimension(0:nmax - 1) :: fu, dtt
      real(kind=dp), dimension(0:imax - 1) :: lam1a
      real(kind=dp), dimension(0:imax) :: lam2g
      real(kind=dp), dimension(0:nmax1 - 1,-1:1) :: uinv
      real(kind=dp), dimension(0:imax1 - 1,-1:1) :: th0inv
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n, i
C-----------------------------------------------
C
C  Define matrices for inversion of diffusion and friction operator.  These
C  are one-dimensional because the operator is independent of $\theta_0$.
C
      uinv(:nmax-1,-1) = ug(:nmax-1)**2*duug(:nmax-1)/((ua(:nmax-1)**2)*
     1   (du**2))
      uinv(:nmax-1,1) = ug(1:nmax)**2*duug(1:nmax)/((ua(:nmax-1)**2)*(du
     1   **2))
      uinv(:nmax-1,0) = (-uinv(:nmax-1,-1)) - uinv(:nmax-1,1)
      uinv(:nmax-1,-1) = uinv(:nmax-1,-1) - fu(:nmax-1)/(2*du)
      uinv(:nmax-1,1) = uinv(:nmax-1,1) + fu(:nmax-1)/(2*du)
      n = 0
      uinv(n,0) = uinv(n,0) - uinv(n,-1)
      uinv(n,-1) = 0
      n = nmax - 1
      uinv(n,-1) = uinv(n,-1) - rho*uinv(n,1)
      uinv(n,0) = uinv(n,0) + (1 + rho)*uinv(n,1)
      uinv(n,1) = 0

      uinv(:nmax-1,-1) = uinv(:nmax-1,-1)*(ua(:nmax-1)**2)/dtt(:nmax-1)
      uinv(:nmax-1,0) = uinv(:nmax-1,0)*(ua(:nmax-1)**2)/dtt(:nmax-1)
      uinv(:nmax-1,1) = uinv(:nmax-1,1)*(ua(:nmax-1)**2)/dtt(:nmax-1)
C
C   Define matrices for inversion of pitch-angle scattering operator.  These
C  are one-dimensional because, after divided out $D_{\theta\theta,0}/u^2$,
C  the operator is independent of $u$.
C
      th0inv(:imax-1,-1) = sin(th0g(:imax-1))*lam2g(:imax-1)/((lam1a(:
     1   imax-1)*(sin(th0a(:imax-1))))*(dth0**2))
      th0inv(:imax-1,1) = sin(th0g(1:imax))*lam2g(1:imax)/((lam1a(:imax-
     1   1)*(sin(th0a(:imax-1))))*(dth0**2))
      th0inv(:imax-1,0) = (-th0inv(:imax-1,-1)) - th0inv(:imax-1,1)
      i = 0
      i = imax - 1
      th0inv(i,0) = th0inv(i,0) - th0inv(i,1)
      th0inv(i,1) = 0


C* :86 *
*line 1805 "adj.web"


      return
      end subroutine matinit



      subroutine maxwel(ua, du, c, nmax, fm, t)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax
      real(kind=dp) du, c, t
      real(kind=dp), dimension(0:nmax - 1) :: ua, fm
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n
      real(kind=dp) :: sum, pi
C-----------------------------------------------

      fm(:nmax-1) = exp((-ua(:nmax-1)**2/(sqrt(1+(ua(:nmax-1)/c)**2)+1)/
     1   t))
      sum = dot_product(ua(:nmax-1)**2,fm(:nmax-1))
      pi = 4*atan(1.0E0)
      sum = 4*pi*du*sum
      fm(:nmax-1) = fm(:nmax-1)/sum

      return
      end subroutine maxwel

      subroutine operinit
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
C-----------------------------------------------

      open(unit=20, file='adjout', form='unformatted', status='unknown')
      open(unit=29, file='adjinp', form='unformatted', status='old')

      return
      end subroutine operinit


      subroutine pot(ua,du,c,fm,chil,nmax,nmax1,legjy,psid,fla,ijy)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax, nmax1
      real(kind=dp) du, c
      real(kind=dp), dimension(0:nmax - 1) :: ua, fm, chil
      real(kind=dp), dimension(0:nmax1 - 1,0:6,0:3) :: legjy
      real(kind=dp), dimension(0:nmax1 - 1,0:4,0:1) :: psid
      real(kind=dp), dimension(0:nmax - 1) :: fla
      real(kind=dp), dimension(0:nmax1,0:6,0:1) :: ijy
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      integer, parameter :: p0 = 0
      integer, parameter :: p02 = 1
      integer, parameter :: p022 = 2
      integer, parameter :: p1 = 3
      integer, parameter :: p11 = 4
      integer, parameter :: j0 = 0
      integer, parameter :: j1 = 1
      integer, parameter :: j2 = 2
      integer, parameter :: j02 = 3
      integer, parameter :: j11 = 4
      integer, parameter :: j22 = 5
      integer, parameter :: j022 = 6
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n, a
C-----------------------------------------------


C   Define various indefinite integrals needed in the definition of the
C  potentials.  First do the integration to cell edges and then interpolate
C  to the cell centers.

      fla(:nmax-1) = fm(:nmax-1)*chil(:nmax-1)*ua(:nmax-1)**2/sqrt(1 + (
     1   ua(:nmax-1)/c)**2)*du/2

      do a = 0, 6
         ijy(1:nmax,a,0) = fla(:nmax-1)*legjy(:nmax-1,a,0)
         ijy(:nmax-1,a,1) = fla(:nmax-1)*legjy(:nmax-1,a,1)
         ijy(0,a,0) = 0
         ijy(nmax,a,1) = 0
      end do

      do n = 1, nmax
         ijy(n,:6,0) = ijy(n-1,:6,0) + ijy(n,:6,0)
      end do
      do n = nmax - 1, 0, -1
         ijy(n,:6,1) = ijy(n+1,:6,1) + ijy(n,:6,1)
      end do

      ijy(:nmax-1,:6,0) = ijy(:nmax-1,:6,0) + ijy(1:nmax,:6,0)
      ijy(:nmax-1,:6,1) = ijy(:nmax-1,:6,1) + ijy(1:nmax,:6,1)
C
C  Define various indefinite integrals needed in the definition of
C   the potentials. First do the integration to cell edges and then
C   interpolate to the cell centers.
C
      psid(:nmax-1,p0,0) = legjy(:nmax-1,j0,1)*ijy(:nmax-1,j0,0) + ijy(:
     1   nmax-1,j0,1)*legjy(:nmax-1,j0,0)
      psid(:nmax-1,p02,0) = legjy(:nmax-1,j0,1)*ijy(:nmax-1,j02,0) +
     1   legjy(:nmax-1,j02,1)*ijy(:nmax-1,j2,0) + ijy(:nmax-1,j0,1)*
     2   legjy(:nmax-1,j02,0) + ijy(:nmax-1,j02,1)*legjy(:nmax-1,j2,0)
      psid(:nmax-1,p022,0) = legjy(:nmax-1,j0,1)*ijy(:nmax-1,j022,0) +
     1   legjy(:nmax-1,j02,1)*ijy(:nmax-1,j22,0) + legjy(:nmax-1,j022,1)
     2   *ijy(:nmax-1,j2,0) + ijy(:nmax-1,j0,1)*legjy(:nmax-1,j022,0) +
     3   ijy(:nmax-1,j02,1)*legjy(:nmax-1,j22,0) + ijy(:nmax-1,j022,1)*
     4   legjy(:nmax-1,j2,0)
      psid(:nmax-1,p1,0) = legjy(:nmax-1,j1,1)*ijy(:nmax-1,j1,0) + ijy(:
     1   nmax-1,j1,1)*legjy(:nmax-1,j1,0)
      psid(:nmax-1,p11,0) = legjy(:nmax-1,j1,1)*ijy(:nmax-1,j11,0) +
     1   legjy(:nmax-1,j11,1)*ijy(:nmax-1,j1,0) + ijy(:nmax-1,j1,1)*
     2   legjy(:nmax-1,j11,0) + ijy(:nmax-1,j11,1)*legjy(:nmax-1,j1,0)

      psid(:nmax-1,p0,1) = legjy(:nmax-1,j0,3)*ijy(:nmax-1,j0,0) + ijy(:
     1   nmax-1,j0,1)*legjy(:nmax-1,j0,2)
      psid(:nmax-1,p02,1) = legjy(:nmax-1,j0,3)*ijy(:nmax-1,j02,0) +
     1   legjy(:nmax-1,j02,3)*ijy(:nmax-1,j2,0) + ijy(:nmax-1,j0,1)*
     2   legjy(:nmax-1,j02,2) + ijy(:nmax-1,j02,1)*legjy(:nmax-1,j2,2)
      psid(:nmax-1,p022,1) = legjy(:nmax-1,j0,3)*ijy(:nmax-1,j022,0) +
     1   legjy(:nmax-1,j02,3)*ijy(:nmax-1,j22,0) + legjy(:nmax-1,j022,3)
     2   *ijy(:nmax-1,j2,0) + ijy(:nmax-1,j0,1)*legjy(:nmax-1,j022,2) +
     3   ijy(:nmax-1,j02,1)*legjy(:nmax-1,j22,2) + ijy(:nmax-1,j022,1)*
     4   legjy(:nmax-1,j2,2)
      psid(:nmax-1,p1,1) = legjy(:nmax-1,j1,3)*ijy(:nmax-1,j1,0) + ijy(:
     1   nmax-1,j1,1)*legjy(:nmax-1,j1,2)
      psid(:nmax-1,p11,1) = legjy(:nmax-1,j1,3)*ijy(:nmax-1,j11,0) +
     1   legjy(:nmax-1,j11,3)*ijy(:nmax-1,j1,0) + ijy(:nmax-1,j1,1)*
     2   legjy(:nmax-1,j11,2) + ijy(:nmax-1,j11,1)*legjy(:nmax-1,j1,2)

      return
      end subroutine pot


      subroutine reactall(ua, du, c, fm, t, chil, nmax, nmax1, imax,
     1   imax1, lam1a, legjy, psid, legp, harr, ze, lmaxa, lmaxa1, react
     2   , reactl, chila, work)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax, nmax1, imax, imax1, lmaxa, lmaxa1
      real(kind=dp) du, c, t, ze
      real(kind=dp), dimension(0:nmax - 1) :: ua, fm
      real(kind=dp), dimension(0:nmax1 - 1,lmaxa1) :: chil
      real(kind=dp), dimension(0:imax - 1) :: lam1a
      real(kind=dp), dimension(0:nmax1 - 1,0:6,0:3,lmaxa1) :: legjy
      real(kind=dp), dimension(0:nmax1 - 1,0:4,0:1) :: psid
      real(kind=dp), dimension(0:imax1 - 1,lmaxa1) :: legp
      real(kind=dp), dimension(((lmaxa1 - 1)*
     1  lmaxa1*(2*lmaxa1-1))/6+(lmaxa1-1)*lmaxa1+lmaxa1):: harr
      real(kind=dp), dimension(0:imax1 - 1,0:nmax - 1) :: react
      real(kind=dp), dimension(0:nmax - 1) :: reactl, chila
      real(kind=dp), dimension(0:nmax + (nmax1 + 1)*7*2 - 1) :: work
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: la, la1, la2, n, i
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      EXTERNAL reaction
C-----------------------------------------------

      react(:imax-1,:nmax-1) = 0

      do la1 = 1, lmaxa
         reactl(:nmax-1) = 0
         do la = la1, lmaxa
            chila(:nmax-1) = 0
            do la2 = 1, la
               chila(:nmax-1) = chila(:nmax-1) + harr(((la-1)*la*(2*la-1
     1            ))/6+(la1-1)*la+la2)*chil(:nmax-1,la2)
            end do
            call reaction (ua, du, c, fm, t, chila, nmax, nmax1, legjy(0
     1         ,0,0,la), psid, ze, reactl, max(2*la - 1,0), work)
         end do

         do n = 0, nmax - 1
            react(:imax-1,n) = react(:imax-1,n) + reactl(n)*legp(:imax-1
     1         ,la1)
         end do
      end do

      do n = 0, nmax - 1
         react(:imax-1,n) = react(:imax-1,n)/lam1a(:imax-1)
      end do

      return
      end subroutine reactall


      subroutine reaction(ua, du, c, fm, t, chil, nmax, nmax1, legjy,
     1   psid, ze, reactl, l, work)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax, nmax1, l
      real(kind=dp) du, c, t, ze
      real(kind=dp), dimension(0:nmax - 1) :: ua, fm, chil
      real(kind=dp), dimension(0:nmax1 - 1,0:6,0:3) :: legjy
      real(kind=dp), dimension(0:nmax1 - 1,0:4,0:1) :: psid
      real(kind=dp), dimension(0:nmax - 1) :: reactl
      real(kind=dp), dimension(0:nmax + (nmax1 + 1)*7*2 - 1) :: work
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      integer, parameter :: p0 = 0
      integer, parameter :: p02 = 1
      integer, parameter :: p022 = 2
      integer, parameter :: p1 = 3
      integer, parameter :: p11 = 4
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n
      real(kind=dp) :: pi, u, g
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      EXTERNAL pot
C-----------------------------------------------

      call pot (ua, du, c, fm, chil, nmax, nmax1, legjy, psid, work(0),
     1   work(nmax))

      pi = 4*atan(1.0E0)
      do n = 0, nmax - 1
         u = ua(n)
         g = sqrt(1 + (u/c)**2)
         reactl(n) = reactl(n) + ze*4*pi*(fm(n)*chil(n)/g-u/t*psid(n,p1,
     1      1)-2/(c**2*g)*psid(n,p1,0)+2*u/(c**2*t)*psid(n,p11,1)+u/t*
     2      psid(n,p0,1)-(u**2/(g*t**2)-1/t)*psid(n,p0,0)+(2*g*u/t**2-2*
     3      u/(c**2*t))*psid(n,p02,1)-(l*(l+1)/(g*t**2)-2/(c**2*t))*psid
     4      (n,p02,0)-8*g*u/(c**2*t**2)*psid(n,p022,1)+4*((l+2)*(l-1)/g+
     5      2*g)/(c**2*t**2)*psid(n,p022,0))
      end do

      return
      end subroutine reaction


      subroutine residue(ua, nmax, nmax1, csth0a, imax, imax1, chi, dtt
     1   , c, lam1a, uinv, th0inv, resid)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax, nmax1, imax, imax1
      real(kind=dp) c
      real(kind=dp), dimension(0:nmax - 1) :: ua
      real(kind=dp), dimension(0:imax - 1) :: csth0a
      real(kind=dp), dimension(0:imax1 - 1,0:nmax - 1) :: chi
      real(kind=dp), dimension(0:nmax - 1) :: dtt
      real(kind=dp), dimension(0:imax - 1) :: lam1a
      real(kind=dp), dimension(0:nmax1 - 1,-1:1) :: uinv
      real(kind=dp), dimension(0:imax1 - 1,-1:1) :: th0inv
      real(kind=dp), dimension(0:imax1 - 1,0:nmax - 1) :: resid
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n, i
C-----------------------------------------------
C   Add in electric field term
C  $$\frac{v \cos\theta_0}{\lambda_1}. $$
C
      do n = 0, nmax - 1
         resid(:imax-1,n) = resid(:imax-1,n) + csth0a(:imax-1)/lam1a(:
     1      imax-1)*ua(n)/sqrt(1 + (ua(n)/c)**2)
      end do
C
C   Normalize to pitch-angle diffusion coefficient and add in
C   differential terms.
C
      do n = 0, nmax - 1
         resid(:imax-1,n) = resid(:imax-1,n)*ua(n)**2/dtt(n) + chi(:imax
     1      -1,n-1)*uinv(n,-1) + chi(:imax-1,n)*uinv(n,0) + chi(:imax-1,
     2      n+1)*uinv(n,1) + chi(-1:imax-2,n)*th0inv(:imax-1,-1) + chi(:
     3      imax-1,n)*th0inv(:imax-1,0) + chi(1:imax,n)*th0inv(:imax-1,1
     4      )
      end do

      return
      end subroutine residue


      subroutine runa(t, c2, ze, zi, eps, nmax, umax, imax, kmax, dt,
     1   tmax, alpha, rho, lmax, tskip, npsi0, dla, ba, alenb, thetps,
     2   thetpe, psimx, psimn, iout3, iout4, iout5, iout7, iout8, iswchi
     3   , aerrmx, rerrmx)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
C
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax, imax, kmax, tmax, lmax, tskip, npsi0, iout3, iout4,
     1   iout5, iout7, iout8, iswchi
      real(kind=dp) t, c2, ze, zi, eps, umax, dt, alpha, rho, psimx,
     1    psimn,
     1   aerrmx, rerrmx
      real(kind=dp), dimension(0:kmax - 1) :: dla, ba
      real(kind=dp), dimension(npsi0) :: alenb
      real(kind=dp), dimension(0:kmax) :: thetps
      real(kind=dp), dimension(0:kmax - 1) :: thetpe
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n, np, nmax1, imax1, lmaxa, lmaxa1, worksize, pwork,
     1   pua, pug, pth0a, pth0g, pcsth0a, pchi, plegjy, pchil, plegp,
     2   pduug, pfu, pdtt, pfm, ppsid, plam1a, plam2g, pharr, puinv,
     3   pth0inv, presid, presida, ierc, ierd, memsize
      real(kind=dp), dimension(npsi0) :: bmax, bmin, psis
      real(kind=dp) :: dene, teme
      real(kind=dp), allocatable, save, dimension(:) :: memory
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      EXTERNAL runb
C-----------------------------------------------
c
c   Common block for Comdynray
c

C
C
C
C  indices for ua,ug,th0a,th0g,csth0a,chi,legjy,chil,legp,duug,
C               fu,dtt,fm,psid,lam1a,lam2g,harr,uinv,th0inv,resid,
C               resida







C
C  allocate memory
C


      nmax1 = nmax
      imax1 = imax
      if (mod(nmax1,2) == 1) nmax1 = nmax1 + 1
      if (mod(imax1,2) == 0) imax1 = imax1 + 1

C  |nmax1| and |imax1| are the allocated dimensions for two-dimensional
C  arrays.These might differ from |nmax| and |imax| on the Crays, where
C   strides are inefficiently handled.
C   To avoid memory conflicts on the Crays
C   Make even for accessing
C              |ijy(0:nmaxa1,0:6,0:1)| by row in |potential|
C    Make odd for accessing
C        |chi(0:imax1-1,0:nmax-1)| by row in |decomp|


C |lmaxa1| is the allocated dimension for the |la| index.  This is
C  usually |lmaxa| but must be at least $1$ to ensure that dimension
C  specifications such as |1:lmaxa1| are legal.  Also $H_{1,1,1}$ is needed
C        even when |lmaxa=0|.


C  Round |lmax| down to an odd number
C  |lmaxa1| needs to be at least 1
C
      if (mod(lmax,2) == 0) lmax = lmax - 1
      lmaxa = (lmax + 1)/2
      lmaxa1 = lmaxa
      if (lmaxa1 == 0) lmaxa1 = 1

C  count memory size
C
      memsize = 0
      worksize = 0
C
      pua = memsize
      memsize = memsize + nmax
C
      pug = memsize
      memsize = memsize + nmax + 1
C
      pth0a = memsize
      memsize = memsize + imax
C
      pth0g = memsize
      memsize = memsize + imax + 1
C
      pcsth0a = memsize
      memsize = memsize + imax
C
      pchi = memsize
      memsize = memsize + imax1*nmax
C
      plegjy = memsize
      memsize = memsize + nmax1*7*4*(lmaxa1 + 1)
C
C Figure the workspace for |initjy| (|jarray| and |djarray|).
C
      worksize = max(worksize,2*(max(2*lmaxa - 1,0) + 2 + 1)*7*2)
C
C   Workspace for |potential| (|fla| and |ijy|)
C
      worksize = max(worksize,nmax + (nmax1 + 1)*7*2)
C
C  indices for chil, legp
C
      pchil = memsize
      memsize = memsize + nmax1*lmaxa1

      plegp = memsize
      memsize = memsize + imax1*lmaxa1
C
C  Workspace for |initp|  (|leg0|).
C
      worksize = max(worksize,imax)
C
C  Indices for duug,fu,dtt,fm,psid

      pduug = memsize
      memsize = memsize + nmax + 1

      pfu = memsize
      memsize = memsize + nmax

      pdtt = memsize
      memsize = memsize + nmax

      pfm = memsize
      memsize = memsize + nmax

      ppsid = memsize
      memsize = memsize + nmax1*5*2
C
C  Workspace for |reactall| (|reactl| and |chila|) and for |potential|
C  (|fla| and |ijy|).
C
      worksize = max(worksize,nmax*2 + nmax + (nmax1 + 1)*7*2)
C
C  Indices of lam1a,lam2g,harr
C
      plam1a = memsize
      memsize = memsize + imax

      plam2g = memsize
      memsize = memsize + imax + 1

      pharr = memsize
      memsize = memsize + (((lmaxa1 - 1)*lmaxa1*(2*lmaxa1 - 1))/6 + (
     1   lmaxa1 - 1)*lmaxa1 + lmaxa1)
C
C  Workspace for |hinit| (|garr|).
C
      worksize = max(worksize,(((lmaxa1 + 3) - 1)*(lmaxa1 + 3))/2 + (
     1   lmaxa1 + 1))
C
C  Workspace for |error| (|aerr| and |rerr|).
C
      worksize = max(worksize,2*imax)
C
C  Indices for uinv,th0inv,resid,resida
C
      puinv = memsize
      memsize = memsize + nmax1*3

      pth0inv = memsize
      memsize = memsize + imax1*3

      presid = memsize
      memsize = memsize + imax1*nmax

      presida = memsize
      memsize = memsize + imax1*nmax
C
C  Workspace for |current| (|cur|).
C
      worksize = max(worksize,imax)
C
C  Sum memsize and worksize
C
      pwork = memsize
      memsize = memsize + worksize
C
C  allocate memory
C
c      call hpalloc(memptr,memsize,ierc,1)
      if (.not.allocated(memory)) then
         ALLOCATE(memory(memsize),stat=ierc)
         if (ierc /= 0) then
            print *, 'memory could not be allocated in runa'
            return
         endif
      endif
c      call bcast (memory, memsize)
      memory = 0.
      read (iout3, 2020) thetps
      read (iout3, 2020) thetpe
      do np = 1, npsi0
         read (iout3, 2010) psis(np)
         read (iout3, 2020) dla
         read (iout3, 2020) ba
         read (iout3, 2010) alenb(np), bmax(np), bmin(np)
c
         call subpar (psis(np), dene, teme, zi)
         write (iout5, 3000) psis(np), dene, teme
c
c   teme in Kev
c
         c2 = 511.925/teme
c
         call runb (t, c2, ze, zi, eps, nmax, umax, imax, kmax, dt, tmax
     1      , alpha, rho, lmax, tskip, nmax1, imax1, lmaxa, lmaxa1,
     2      worksize, memory(pua), memory(pug), memory(pth0a), memory(
     3      pth0g), memory(pcsth0a), memory(pchi), memory(plegjy),
     4      memory(pchil), memory(plegp), memory(pduug), memory(pfu),
     5      memory(pdtt), memory(pfm), memory(ppsid), memory(plam1a),
     6      memory(plam2g), memory(pharr), memory(puinv), memory(pth0inv
     7      ), memory(presid), memory(presida), memory(pwork), npsi0,
     8      dla, ba, alenb, thetps, thetpe, np, bmax, bmin, iout3, iout4
     9      , iout5, iout7, iout8, iswchi, aerrmx, rerrmx)
C
C  Deallocate memory
C
      end do
c      call hpdeallc(memptr,ierc,0)
c     if (allocated(memory)) then
c        print *, 'memory still allocated'
c        DEALLOCATE(memory, stat=ierd)
c        print *, 'ierd=', ierd
c     endif
c     print *, 'memory deallocated'
c-----------------------------
 2010 format(4(2x,e20.12))
 2020 format(5(2x,e20.12))
 3000 format(4(2x,e20.12))

      return
      end subroutine runa

      subroutine runb(t, c2, ze, zi, eps, nmax, umax, imax, kmax, dt,
     1   tmax, alpha, rho, lmax, tskip, nmax1, imax1, lmaxa, lmaxa1,
     2   worksize, ua, ug, th0a, th0g, csth0a, chi, legjy, chil, legp,
     3   duug, fu, dtt, fm, psid, lam1a, lam2g, harr, uinv, th0inv,
     4   resid, resida, work, npsi0, dla, ba, alenb, thetps, thetpe, np
     5   , bmax, bmin, iout3, iout4, iout5, iout7, iout8, iswchi, aerrmx
     6   , rerrmx)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
C
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax, imax, kmax, tmax, lmax, tskip, nmax1, imax1, lmaxa,
     1   lmaxa1, worksize, npsi0, np, iout3, iout4, iout5, iout7, iout8
     2   , iswchi
      real(kind=dp) t, c2, ze, zi, eps, umax, dt, alpha, rho,
     1    aerrmx, rerrmx
      real(kind=dp), dimension(0:nmax - 1) :: ua
      real(kind=dp), dimension(0:nmax) :: ug
      real(kind=dp), dimension(0:imax - 1) :: th0a
      real(kind=dp), dimension(0:imax) :: th0g
      real(kind=dp), dimension(0:imax - 1) :: csth0a
      real(kind=dp), dimension(0:imax1 - 1,0:nmax - 1) :: chi
      real(kind=dp), dimension(0:nmax1 - 1,0:6,0:3,0:lmaxa1) :: legjy
      real(kind=dp), dimension(0:nmax1 - 1,lmaxa1) :: chil
      real(kind=dp), dimension(0:imax1 - 1,lmaxa1) :: legp
      real(kind=dp), dimension(0:nmax) :: duug
      real(kind=dp), dimension(0:nmax - 1) :: fu, dtt, fm
      real(kind=dp), dimension(0:nmax1 - 1,0:4,0:1) :: psid
      real(kind=dp), dimension(0:imax - 1) :: lam1a
      real(kind=dp), dimension(0:imax) :: lam2g
      real(kind=dp), dimension(((lmaxa1 - 1)*lmaxa1
     1  *(2*lmaxa1 - 1))/6+(lmaxa1-1)*lmaxa1+lmaxa1):: harr
      real(kind=dp), dimension(0:nmax1 - 1,-1:1) :: uinv
      real(kind=dp), dimension(0:imax1 - 1,-1:1) :: th0inv
      real(kind=dp), dimension(0:imax1 - 1,0:nmax - 1) :: resid, resida
      real(kind=dp), dimension(0:worksize - 1) :: work
      real(kind=dp), dimension(0:kmax - 1) :: dla, ba
      real(kind=dp), dimension(npsi0) :: alenb
      real(kind=dp), dimension(0:kmax) :: thetps
      real(kind=dp), dimension(0:kmax - 1) :: thetpe
      real(kind=dp), dimension(npsi0) :: bmax, bmin
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: itim, n, i, time
      real(kind=dp)::dthp,du,dth0,th0max,pi,c,deltb,abserr,relerr,curv,
     1   cond,e
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real(kind=dp) , EXTERNAL :: deltab, lam1, lam2, current
      EXTERNAL initjy, initp, maxwel, isotrop, hinit, matinit, decomp,
     1   reactall, residue, error, solve
C-----------------------------------------------
C
C  Velocity space meshes
C

C
C   Array holding Legendre functions
C
C
C  Legendre decomposition of chi
C
C
C

C
C
C   Arrays to hold various flux averaged quantities.
C
C
C  Matrices for inversion
C
C
C  Time advancement;  residues
C
C
C   Current and conductivity
C  The conductivity is define as $J_{0\parallel}/E_{0\parallel}$ where
C    $$E_{0\parallel} = B_0\frac{\int E_{\parallel} dl}{\int B\,dl}.$$
C    Substituting $E_\parallel = (B_\zeta/B) \Phi/(2\pi R)$ and
C    $\Phi=TQ/L$ gives $E_\parallel = T/\int b \,dl/L$.
C

C
C
C  Initialize velocity meshes, chi etc.
C
      du = umax/nmax
      do n = 0, nmax - 1
         ua(n) = (n + 0.5E0)*du
         ug(n) = n*du
      end do
      ug(nmax) = umax

      pi = 4*atan(1.0E0)
      deltb = (bmax(np)-bmin(np))/bmin(np)
      th0max = atan2(1.0E0_dp,sqrt(deltb))
      eps = deltb/(2. + deltb)
      dth0 = th0max/imax
      do i = 0, imax - 1
         th0a(i) = (i + 0.5E0)*dth0
         csth0a(i) = cos(th0a(i))
         th0g(i) = i*dth0
      end do
      th0g(imax) = th0max

C
C  Set up trial chi-function
C
      if (np == 1) then
         if (iswchi == 0) then
            chi(:imax-1,:nmax-1) = 0
         else
            read (iout7, 3030) ((chi(i,n),i=0,imax - 1),n=0,nmax - 1)
         endif
      endif
C
C   Fill the arrays
C
      c = sqrt(c2)
      lmaxa = (lmax + 1)/2
      call initjy (ua, c, nmax, nmax1, lmaxa, lmaxa1, legjy, work(0),
     1   work(2*(max(2*lmaxa-1,0)+2+1)*7), max(2*lmaxa - 1,0) + 2)
C
C  Initialize legp
C
      call initp (csth0a, imax, imax1, lmaxa, lmaxa1, legp, work)
C
C  Initialize isotropic terms.
C
      call maxwel (ua, du, c, nmax, fm, t)

      chil(:nmax-1,1) = 1

      call isotrop (ua, du, c, fm, chil(0,1), nmax, nmax1, legjy(0,0,0,0
     1   ), psid, ze, zi, duug, fu, dtt, work)
C
C  Initialize lam1a,lam2g,harr
C
      dthp = thetpe(1) - thetpe(0)
      do i = 0, imax - 1
         lam1a(i) = lam1(eps,th0a(i),kmax,dthp,dla(0),ba(0))
      end do

      do i = 0, imax
         lam2g(i) = lam2(eps,th0g(i),kmax,dthp,dla(0),ba(0))
      end do

      call hinit (eps, kmax, lmaxa1, harr, work, dthp, dla(0), ba(0))
C
C  Initialize matrices for inversion.
C
      call matinit (du, ua, ug, nmax, nmax1, dth0, th0a, th0g, imax,
     1   imax1, duug, fu, dtt, lam1a, lam2g, uinv, th0inv, rho)
C
C  time evolution of solution
C
      itim = 0
      do time = 0, tmax
         if (itim /= 1) then
C
C  Calculate reaction term.
C
            call decomp (chi, nmax, nmax1, imax, imax1, lmaxa, lmaxa1,
     1         th0a, dth0, legp, chil)
            call reactall (ua, du, c, fm, t, chil, nmax, nmax1, imax,
     1         imax1, lam1a, legjy(0,0,0,1), psid, legp, harr, ze, lmaxa
     2         , lmaxa1, resid, work(0), work(nmax), work(2*nmax))
C
C  Calculate residue and its norm
C
            call residue (ua, nmax, nmax1, csth0a, imax, imax1, chi, dtt
     1         , c, lam1a, uinv, th0inv, resid)
            if (mod(time,tskip) == 0) call error (du, ua, umax, nmax,
     1         dth0, th0a, th0max, imax, imax1, resid, chi, abserr,
     2         relerr, work(0), work(imax))
C
C  Advance chi
C
            call solve (resida, imax1, nmax, 1, imax, uinv(0,-1), uinv(0
     1         ,0), uinv(0,1), resid, dt, alpha)
            call solve (resid, 1, imax, imax1, nmax, th0inv(0,-1),
     1         th0inv(0,0), th0inv(0,1), resida, dt, alpha)

            chi(:imax-1,:nmax-1) = chi(:imax-1,:nmax-1) + dt*resid(:imax
     1         -1,:nmax-1)
C
C  compute current and conductivity.
C
            if (mod(time,tskip) == 0) then
               curv = current(du,ua,c,nmax,dth0,th0a,imax,imax1,fm,chi,
     1            work)
               e = t/harr(((1-1)*1*(2*1-1))/6+(1-1)*1+1)
               cond = curv*zi/(t*sqrt(t)*e)
               write (iout4, 4020) time, cond, abserr, relerr
 4020          format(2x,i5,3x,e20.12,2x,e16.8,2x,e16.8)
            endif
            if (abserr<aerrmx .and. relerr<rerrmx) itim = 1
         endif
      end do
C
C  Write out results.
C
      write (iout5, 3010) nmax, imax, kmax, lmax
      write (iout5, 3020) t, c2, ze, zi, eps
      write(iout5,3020)umax,th0max,du,dth0,rho,deltb,bmin(np),bmax(np)
      write (iout5, 3040) dt, tmax, alpha
      write (iout5, 3020) cond, abserr, relerr
      write (iout5, 3030) ua
      write (iout5, 3030) ug
      write (iout5, 3030) th0a
      write (iout5, 3030) th0g
      write (iout5, 3030) lam1a
      write (iout5, 3030) fm
      write (iout5, 3030) ((chi(i,n),i=0,imax - 1),n=0,nmax - 1)
      if(np==1)write(iout8,3030)((chi(i,n),i=0,imax-1),n=0,nmax-1)
c-----------------------------
c
 3010 format(1x,4i8)
 3020 format(4(1x,e20.12))
 3030 format(5(1x,e20.12))
 3040 format(1x,e20.12,2x,i8,2x,e20.12)
C
      return
      end subroutine runb


      subroutine solve(x, ns, n, ms, m, a, b, c, z, dt, alpha)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
C
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer ns, n, ms, m
      real(kind=dp) dt, alpha
      real(kind=dp), dimension(0:ms - 1,0:*) :: x
      real(kind=dp), dimension(0:n - 1) :: a, b, c
      real(kind=dp), dimension(0:ms - 1,0:*) :: z
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i, k
      real(kind=dp) :: dt2, den
C-----------------------------------------------

      dt2 = -alpha*dt

      i = 0
      den = 1 + dt2*b(i)
      x(ns*i,:m-1) = z(ns*i,:m-1)/den
      z(ns*i,:m-1) = -dt2*c(i)/den

      do i = 1, n - 2
         do k = 0, m - 1
            den = 1 + dt2*(b(i)+a(i)*z(ns*(i-1),k))
            x(ns*i,k) = (z(ns*i,k)-dt2*a(i)*x(ns*(i-1),k))/den
            z(ns*i,k) = -dt2*c(i)/den
         end do
      end do

      i = n - 1
      do k = 0, m - 1
         den = 1 + dt2*(b(i)+a(i)*z(ns*(i-1),k))
         x(ns*i,k) = (z(ns*i,k)-dt2*a(i)*x(ns*(i-1),k))/den
         z(ns*i,k) = 0
      end do





      do i = n - 2, 0, -1
         x(ns*i,:m-1) = z(ns*i,:m-1)*x(ns*(i+1),:m-1) + x(ns*i,:m-1)
      end do

      return
      end subroutine solve
      subroutine subadj(zef1, nmax, umax, imax, nthp0, dt, tmax, alpha,
     1   rho, lmax, iout3, iout5, iout4, iout7, iout8, iswchi, aerrmx,
     2   rerrmx)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
C
C  calculates the Spitzer function chi(theta,ua) and output to adjout
C
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax, imax, nthp0, tmax, lmax, iout3, iout5, iout4, iout7
     1   , iout8, iswchi
      real(kind=dp) zef1, umax, dt, alpha, rho, aerrmx, rerrmx
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer::tskip, dlaptr, baptr, alnptr, ndum
      integer::thsptr, theptr, ii, npsi0, iercd
      real(kind=dp) :: psimx, psimn, t, c2, ze, zi, eps, cpu, cpu0
      real(kind=dp),allocatable,save, dimension(:) :: dum
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      EXTERNAL runa
C-----------------------------------------------
c
c   Common block for Comdynray
c
c     pointer(dumptr,dum(1))
C
C
      read (iout3, 2000) nthp0, npsi0
      read (iout3, 2010) psimx, psimn
      ii = 1
      dlaptr = ii
      ii = ii + nthp0
      baptr = ii
      ii = ii + nthp0
      alnptr = ii
      ii = ii + npsi0
      thsptr = ii
      ii = ii + nthp0 + 1
      theptr = ii
      ii = ii + nthp0
      ndum = ii
c      call hpalloc(dumptr,ndum,iercd,1)
      if (.not.allocated(dum)) then
         ALLOCATE(dum(ndum),stat=iercd)
         if (iercd /= 0) then
            print *, 'dum could not be allocated in subadj'
            return
         endif
      endif
      write (iout5, 2000) nthp0, npsi0
      write (iout5, 2010) psimx, psimn
      t = 1.E0
      ze = 1.E0
      dt = 1
c     tmax=250
      alpha = 0.55
      rho = 1
C     lmax=21
C     nmax=100
C     umax=10
C     imax=200
C
      tskip = 10
!      call second (cpu0)
      call runa (t, c2, ze, zi, eps, nmax, umax, imax, nthp0, dt, tmax,
     1   alpha, rho, lmax, tskip, npsi0, dum(dlaptr), dum(baptr), dum(
     2   alnptr), dum(thsptr), dum(theptr), psimx, psimn, iout3, iout4,
     3   iout5, iout7, iout8, iswchi, aerrmx, rerrmx)
!      call second (cpu)
!      write (iout4, 4030) cpu - cpu0
c      call hpdeallc(dumptr,iercd,0)
      DEALLOCATE(dum)
 4030 format(1x,'adj CPU time: ',f8.4,' secs.')
c----------------------
 2000 format(1x,2i8)
 2010 format(4(2x,e20.12))
      return
      end subroutine subadj
      subroutine xtrema(imx, xmx, ymx, dymx, nwk, wkt, wk, wk1, ier)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  09:55:56   6/14/01
C...Switches: -p4 -yb
C
      use kind_spec

      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer imx, nwk, ier
      real(kind=dp) xmx, ymx, dymx
      real(kind=dp), dimension(nwk) :: wkt, wk
      real(kind=dp), dimension(nwk,3) :: wk1
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: it
      real(kind=dp), dimension(1) :: x0, y0, dy0, x1, y1, dy1
      real(kind=dp) :: h, dx
C-----------------------------------------------
      x0(1) = wkt(imx)
      y0(1) = wk(imx)
      h = wkt(2) - wkt(1)
      call mcsevu1 (h, wkt(1), wk, nwk, wk1, nwk, 1, dy0, x0, ier)
      dx = 0.5*h
      it = 0
      ier = 0
   50 continue
      x1(1) = x0(1) + dx
      call mcsevu (h, wkt(1), wk, nwk, wk1, nwk, 1, y1, x1, ier)
      call mcsevu1 (h, wkt(1), wk, nwk, wk1, nwk, 1, dy1, x1, ier)
      dx = (x1(1)-x0(1))*dy1(1)/(dy0(1)-dy1(1))
      x0(1) = x1(1)
      y0(1) = y1(1)
      dy0(1) = dy1(1)
      it = it + 1
      if (it > 50) then
         ier = 19
         return
      endif
      if (abs(dx)<1.E-8*h .or. abs(dy0(1))<1.E-8) go to 100
      go to 50
  100 continue
      xmx = x0(1)
      ymx = y0(1)
      dymx = dy0(1)
      return
      end subroutine xtrema
