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
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real current
      integer nmax, imax, imax1
      real du, c, dth0
      real, dimension(0:nmax - 1) :: ua
      real, dimension(0:imax - 1) :: th0a
      real, dimension(0:nmax - 1) :: fm
      real, dimension(0:imax1 - 1,0:nmax - 1) :: chi
      real, 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 :: 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
      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 dth0
      real, dimension(0:imax1 - 1,0:nmax - 1) :: chi
      real, dimension(0:imax - 1) :: th0a
      real, dimension(0:imax1 - 1,lmaxa1) :: legp
      real, 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 :: 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
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real phi, eps
      real 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
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax, imax, imax1
      real du, umax, dth0, th0max, abserr, relerr
      real, dimension(0:nmax - 1) :: ua
      real, dimension(0:imax - 1) :: th0a
      real, dimension(0:imax1 - 1,0:nmax - 1) :: resid, chi
      real, 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
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer kmax, lmaxa1
      real eps, dthp
      real, dimension(((lmaxa1 - 1)
     1 *lmaxa1*(2*lmaxa1-1))/6+(lmaxa1- 1)*lmaxa1+lmaxa1):: harr
      real,dimension((((lmaxa1+3)-1)*
     1   (lmaxa1+3))/2+(lmaxa1+1))::garr
      real, 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 :: b, pi
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real , 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
      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 c
      real, dimension(0:nmax - 1) :: ua
      real, dimension(0:nmax1 - 1,0:6,0:3,0:lmaxa1) :: legjy
      real, dimension((-lmax1) - 1:lmax1,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
      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, dimension(0:imax - 1) :: x
      real, dimension(0:imax1 - 1,lmaxa1) :: legp
      real, 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
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax, nmax1
      real du, c, ze, zi
      real, dimension(0:nmax - 1) :: ua, fm, chil
      real, dimension(0:nmax1 - 1,0:6,0:3) :: legjy
      real, dimension(0:nmax1 - 1,0:4,0:1) :: psid
      real, dimension(0:nmax) :: duug
      real, dimension(0:nmax - 1) :: fu, dtt
      real, 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 :: 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
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real lam1
      integer kmax
      real eps, th0, dthp
      real, 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 :: deltabv, sum, costh
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real , 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
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      real lam2
      integer kmax
      real eps, th0, dthp
      real, 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 :: deltabv, sum, costh
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real , 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
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer lmax, lmax1
      real u, c
      real, dimension((-lmax1) - 1:lmax1,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 :: 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
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer lmax, amax, lmax1
      real z
      real, 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 :: 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
      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 du, dth0, rho
      real, dimension(0:nmax - 1) :: ua
      real, dimension(0:nmax) :: ug
      real, dimension(0:imax - 1) :: th0a
      real, dimension(0:imax) :: th0g
      real, dimension(0:nmax) :: duug
      real, dimension(0:nmax - 1) :: fu, dtt
      real, dimension(0:imax - 1) :: lam1a
      real, dimension(0:imax) :: lam2g
      real, dimension(0:nmax1 - 1,-1:1) :: uinv
      real, 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
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax
      real du, c, t
      real, 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 :: 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
      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
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax, nmax1
      real du, c
      real, dimension(0:nmax - 1) :: ua, fm, chil
      real, dimension(0:nmax1 - 1,0:6,0:3) :: legjy
      real, dimension(0:nmax1 - 1,0:4,0:1) :: psid
      real, dimension(0:nmax - 1) :: fla
      real, 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
      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 du, c, t, ze
      real, dimension(0:nmax - 1) :: ua, fm
      real, dimension(0:nmax1 - 1,lmaxa1) :: chil
      real, dimension(0:imax - 1) :: lam1a
      real, dimension(0:nmax1 - 1,0:6,0:3,lmaxa1) :: legjy
      real, dimension(0:nmax1 - 1,0:4,0:1) :: psid
      real, dimension(0:imax1 - 1,lmaxa1) :: legp
      real, dimension(((lmaxa1 - 1)*
     1  lmaxa1*(2*lmaxa1-1))/6+(lmaxa1-1)*lmaxa1+lmaxa1):: harr
      real, dimension(0:imax1 - 1,0:nmax - 1) :: react
      real, dimension(0:nmax - 1) :: reactl, chila
      real, 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
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nmax, nmax1, l
      real du, c, t, ze
      real, dimension(0:nmax - 1) :: ua, fm, chil
      real, dimension(0:nmax1 - 1,0:6,0:3) :: legjy
      real, dimension(0:nmax1 - 1,0:4,0:1) :: psid
      real, dimension(0:nmax - 1) :: reactl
      real, 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 :: 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
      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 c
      real, dimension(0:nmax - 1) :: ua
      real, dimension(0:imax - 1) :: csth0a
      real, dimension(0:imax1 - 1,0:nmax - 1) :: chi
      real, dimension(0:nmax - 1) :: dtt
      real, dimension(0:imax - 1) :: lam1a
      real, dimension(0:nmax1 - 1,-1:1) :: uinv
      real, dimension(0:imax1 - 1,-1:1) :: th0inv
      real, 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
      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 t, c2, ze, zi, eps, umax, dt, alpha, rho, psimx, psimn, 
     1   aerrmx, rerrmx
      real, dimension(0:kmax - 1) :: dla, ba
      real, dimension(npsi0) :: alenb
      real, dimension(0:kmax) :: thetps
      real, 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, memsize
      real, dimension(npsi0) :: bmax, bmin, psis
      real :: dene, teme
      real, allocatable, 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)
 
         call subpar (psis(np), dene, teme, zi)
         write (iout5, 3000) psis(np), dene, teme
c
c   teme in Kev
c
         c2 = 511.925/teme
 
 
         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)
      DEALLOCATE(memory)
 
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
      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 t, c2, ze, zi, eps, umax, dt, alpha, rho, aerrmx, rerrmx
      real, dimension(0:nmax - 1) :: ua
      real, dimension(0:nmax) :: ug
      real, dimension(0:imax - 1) :: th0a
      real, dimension(0:imax) :: th0g
      real, dimension(0:imax - 1) :: csth0a
      real, dimension(0:imax1 - 1,0:nmax - 1) :: chi
      real, dimension(0:nmax1 - 1,0:6,0:3,0:lmaxa1) :: legjy
      real, dimension(0:nmax1 - 1,lmaxa1) :: chil
      real, dimension(0:imax1 - 1,lmaxa1) :: legp
      real, dimension(0:nmax) :: duug
      real, dimension(0:nmax - 1) :: fu, dtt, fm
      real, dimension(0:nmax1 - 1,0:4,0:1) :: psid
      real, dimension(0:imax - 1) :: lam1a
      real, dimension(0:imax) :: lam2g
      real, dimension(((lmaxa1 - 1)*lmaxa1
     1  *(2*lmaxa1 - 1))/6+(lmaxa1-1)*lmaxa1+lmaxa1):: harr
      real, dimension(0:nmax1 - 1,-1:1) :: uinv
      real, dimension(0:imax1 - 1,-1:1) :: th0inv
      real, dimension(0:imax1 - 1,0:nmax - 1) :: resid, resida
      real, dimension(0:worksize - 1) :: work
      real, dimension(0:kmax - 1) :: dla, ba
      real, dimension(npsi0) :: alenb
      real, dimension(0:kmax) :: thetps
      real, dimension(0:kmax - 1) :: thetpe
      real, 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::dthp,du,dth0,th0max,pi,c,deltb,abserr,relerr,curv,cond,e
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      real , 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
      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 dt, alpha
      real, dimension(0:ms - 1,0:*) :: x
      real, dimension(0:n - 1) :: a, b, c
      real, 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 :: 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
      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 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 :: psimx, psimn, t, c2, ze, zi, eps, cpu, cpu0
      real,allocatable, 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
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer imx, nwk, ier
      real xmx, ymx, dymx
      real, dimension(nwk) :: wkt, wk
      real, dimension(nwk,3) :: wk1
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: it
      real, dimension(1) :: x0, y0, dy0, x1, y1, dy1
      real :: 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
