c/* %W%      latest revision %G% %U% */
      subroutine TBornA( aovera, psfac, ld, ldum, lBorn, nspin, n1 )
**********************************************************************

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

      complex*16  zi , ztan
      complex*16  zrb34 , zrb56 , zrbmix , ztbjm , ztbjp , ztbj

      real*8      MN , Mp

c *** N.B. need to match dimensions and # of entries in data statement
c *** for the IBM.
c *** t's enlarged 3/84 for cex  (m.s.)

      dimension tbr(100,12), tbi(100,12), tr(100,12),ti(100,12)

c *** dimension of u/f depends on ngp (only need change in main)
c *** double size for spin 0 case,so can up n grid pts

      dimension   ur(97,97,8) , ui(97,97,8)

      common /nlspfl/   ur, ui
      common /params/   hbarc, pi, Mp, MN, nz, na, nes, nwaves
      common /Rcomn/   rr , ri , rrb , rib
      common /spins/    nspina , nspinb , nspinc , nspind , nspine
      common /Tcomn/     tr , ti , tbr , tbi

********************************************************************************

c ***
c       ---------------born  approximation   ------------------
c ***

      zi = ( 0. , 1. )
      ztan = (0.0, 0.0)

      n = nspin
      if (nspin .gt. 3) go to 341
      rbr = -ur(n1,n1,n) * psfac
      rbi = -ui(n1,n1,n) * psfac
      tbr(ld,n) = rbr * aovera
      tbi(ld,n) = rbi * aovera
      etab = sqrt(1. + 4. *
     $            (tbr(ld,n)**2 + tbi(ld,n)**2 - tbi(ld,n)))
      deltb = 0.5 * atan2(2. * tbr(ld,n),
     $                    (1. - 2. * tbi(ld,n))) * 180./pi
      write(6,1080)
      write(6,1979) ur(n1,n1,n), ui(n1,n1,n)
      write(6,930)  rbr, rbi
      write(6,1030) tbr(ld,n),   tbi(ld,n)
      write(6,1010) etab, deltb
 341  if (nspin .ne. 4) go to 342

c ***
c *** born approx for coupled 34 56 spin 1/2 1/2
c ***

      write(6,1080)
      rbr = -ur(n1,n1,nspina) * psfac
      rbi = -ui(n1,n1,nspina) * psfac
      write(6,1979) ur(n1,n1,nspina), ui(n1,n1,nspina)
      write(6,930)  rbr, rbi
      zrb34 = rbr + zi * rbi
 342  if (nspin .ne. 6)go to 370

c *** nspin=6 calc t s now , in b.a.

      write(6,1080)
      rbr = -ur(n1,n1,nspina) * psfac
      rbi = -ui(n1,n1,nspina) * psfac
      write(6,1979) ur(n1,n1,nspina), ui(n1,n1,nspina)
      write(6,930)  rbr, rbi
      zrb56 = rbr + zi * rbi
      rbrmix = -ur(n1,n1,nspinb) * psfac
      rbimix = -ui(n1,n1,nspinb) * psfac
      zrbmix = rbrmix + zi * rbimix

      call rtot (zrb34, zrb56, zrbmix, ztbjp, ztbjm,
     $           ztbj, aovera, 1)

      tbr(ld,4) = ztbj
      tbi(ld,4) = -zi * ztbj
      tbr(ld,5) = ztbjp
      tbr(ld,6) = ztbj
      tbr(ld,3) = ztbjm
      tbi(ld,5) = -zi*(ztbjp)
      tbi(ld,6) = -zi*(ztbj)
      tbi(ld,3) = -zi*(ztbjm)
      write(6,3335) (tbr(ld,l9), tbi(ld,l9), l9=3,6)
 370  continue
      if (ldum .le. lBorn) then
         RETURN
      endif

c *** use b.a. fo these l*s  and then send back

      ri = rbi
      rr = rbr
      rrb = rbrmix
      rib = rbimix

      RETURN

c *** FORMATS ***

  930 format (1h ,26h  normalized r(k,k..k)=   ,24x,2e14.7)
 1010 format (1h+,85x,4heta=,f10.4,8h  delta=,f10.4)
 1030 format (1h ,15h  t(k,k,k)=    ,35x,4e14.7)
 1080 format (1h ,8x,23h  born  approximation  )
 1979 format(1h ,17h ur ui(k0,k0,k0)=   ,2e13.5)
 3335 format(1h ,19h tr ti (nspin=3-6)=,8e13.5)

      end