c/* %W%      latest revision %G% %U% */
      Subroutine Vopt0A( Vll, k, kp, neles, k0 )
************************************************************************

c *** M.S. 12/87

c *** Calculates the optical potential for nucleons scattering from a
c     spin 0 nucleus and does a full t*rho projection

      implicit real*8  (a-h, k, m, o-z)

      Integer  code, xi, maxLs

      real*8   imUcl, imUsl, imVc, imVs

      logical  first

      Complex*16  Ucentl( 0:99), Uspinl( 0:99 ), zi
      Complex*16  Ucl, Usl, Uc, Us

      dimension   Vll( 0:99, 2, 6 )
      dimension   xis( 96 ), wt( 96 )
      dimension   Pl( 0:99 ), Plp( 0:99 )
      dimension   tapb(4), tamb(4), tcpd(4), tcmd(4), te(4)
      dimension   nifty(20)
      dimension   formf(4)

      common   /params/  hbarc, pi, Mp, MN, nZ, nA, nes, nwaves
      common   /switch/ nifty

      data  first / .True. /
      data  maxLs / 100 /

      if ( first ) then
         first = .False.
c ncos changed to 48 from 32 to maintain consistency for >32 pw
         ncos = 48
         write(6,*)' in vopt0A, ncos=',ncos,' may need up if nl gt ncos'
         nN = nA - nZ
         Amass = nA * MN
         AoverA = ( Amass - 1. )/Amass
         twopi2 = 2. * pi * pi
         if ( nifty(17) .eq. 1 ) AoverA = 1.
         a = -1.
         b = 1.
c     ******** 3/25/91 tm code = 0.0 for ghe gauss *********
         code = 0
         call GAUSS2( ncos, code, a, b, xis, wt )

c        *** assume that only one form factor will be needed ***
c        *** can be changed if situation calls for ***

         nff = 1
      endif

      zi = ( 0. , 1.)

      Do 10 l = 0, maxLs - 1
         Ucentl(l) = ( 0., 0. )
         Uspinl(l) = ( 0., 0. )
  10  continue

      Do 20 xi = 1, ncos
         x = xis( xi )
         cthNuc = x
         theta = acos( cthNuc ) * 180./pi
         call TNUCTH( kp, k, k0, cthNuc, MN, tapb, tamb, tcpd, tcmd, te)
         q2 = kp**2 + k**2 - 2.* kp * k * cthNuc
         if ( q2 .lt. 0 ) q2 = -q2
         call FFACT( q2, formf, nff )
         call LEGPOL( x, Pl, neles )
         call PLPRME( x, Plp, neles )

         Do 30 l = 0, neles
            if ( l .eq. 0 ) then
               Uspinl(l) = ( 0., 0. )
            else
               reUsl = nZ * te(3) * formf(1) + nN * te(4) * formf(1)
               reUsl = 1./( (2.*l) * (l + 1.) ) * reUsl
               reUsl = reUsl * SQRT(1.- x**2) * Plp(l) * wt(xi)
               imUsl = nZ * te(1) * formf(1) + nN * te(2) * formf(1)
               imUsl = -1./( (2.*l) * (l + 1.) ) * imUsl
               imUsl = imUsl * SQRT(1.- x**2) * Plp(l) * wt(xi)
               Uspinl(l) = Uspinl(l) + Cmplx( reUsl, imUsl )
            endif
            reUcl = nZ * tapb(1) * formf(1) + nN * tapb(2) * formf(1)
            reUcl = 1./2. * reUcl
            reUcl = reUcl * Pl(l) * wt(xi)
            imUcl = nZ * tapb(3) * formf(1) + nN * tapb(4) * formf(1)
            imUcl = 1./2. * imUcl
            imUcl = imUcl * Pl(l) * wt(xi)
            Ucentl(l) = Ucentl(l) + Cmplx( reUcl, imUcl )
  30     continue
         if (( kp .eq. k) .AND. ( kp .eq. k0 ) ) then
            if (xi .eq. 1 ) then
c              *** set up headers for write of resum ***
               write(6,1000)
               write(6,1001)
               write(6,*)
            endif
            Ucl = 0.
            Usl = 0.
            do 60 l = 0, neles
               Ucl = Ucl + Ucentl(l) * Pl(l) * (2*l+1.)
               Usl = Usl + Uspinl(l) * Plp(l) * (2*l+1.)
  60        continue
            reVc = nZ * tapb(1) * formf(1) + nN * tapb(2) * formf(1)
            imVc = nZ * tapb(3) * formf(1) + nN * tapb(4) * formf(1)
            reVs = nZ * te(3) * formf(1) + nN * te(4) * formf(1)
            imVs = -(nZ * te(1) * formf(1) + nN * te(2) * formf(1))
            Uc = cmplx( reVc, imVc )
            Us = cmplx( reVs, imVs )
            write(6,1002) theta, q2, abs(Ucl), abs(Uc),
     $                               abs(Usl), abs(Us)
         endif
  20  continue


      Do 40 l = 0, neles
         if ( l .eq. 0 ) then
            Vll(l,1,1) = twopi2 * Ucentl(l)
            Vll(l,2,1) = twopi2 * (-zi) * ( Ucentl(l) )
            Vll(l,1,2) = Vll(l,1,1)
            Vll(l,2,2) = Vll(l,2,1)
         else
            Vll(l,1,1) = twopi2 * ( Ucentl(l) + l * Uspinl(l) )
            Vll(l,2,1) = twopi2 * (-zi) * ( Ucentl(l) + l * Uspinl(l) )
            Vll(l,1,2) = twopi2 * ( Ucentl(l) - (l+1.) * Uspinl(l) )
            Vll(l,2,2) = twopi2*(-zi)*( Ucentl(l) - (l+1.) * Uspinl(l))
         endif
         Do 50 ir = 1,2
            do 50 nspin = 1, 2
               Vll(l, ir, nspin) = AoverA * Vll( l, ir, nspin )
  50     continue
  40  continue

      Return

c     *** FORMATS ***

 1000 format('1')
 1001 format(' ',' cos  ',9x,'q2',13x,'resum for Vcent',11x,'Vcent',
     $           11x,'resum for Vspin',11x,'Vspin')
 1002 format(' ',f5.1,5x,f12.3,9x,e13.6,3(8x,e13.6))
 1003 format(' ',31x,e13.6,3(8x,e13.6))
      End