 
c/* @(#)optp.f	1.1      latest revision 6/23/89 14:55:12 */
      subroutine OPTP1 (kpts, n1, lpia, lmaxin, lborn, aovera)
************************************************************************
c *** see dimensions + equivalence statements
c *** Need to reset dimensions and equivalences as max # grid increase
c     should use n = ngp + 1 for scattering.
c     Also see initialize statements which now change with dimensions
c
c *** Do all l values on 1st call, then store on tape9, ft is for temp
c
        include '/usr/local/include/fpvm3.h'
      implicit real*8 (a-h, k, o-z)
      real*8  imtij, Mp, MN, k, kp, kpts, k1, imwave
      real*8  Rcut, Rcoul

      integer mytid, consti, tids, bufid
      Logical  spin0
      character*16 pilgrim
c
c %%% changed dimension of f(600,6) to f(3201,6) to match fr(98,98),fi(98,98)
c %%% in common /fopt/  with dummy(2) added  - LB 10 Dec 88
c *** Variable completely rewritten to avoid dump to disk and sequential
c *** read, IN A DIFFERENT ORDER!, Data is now stored in memory.

      dimension   Vcoull(100)
      dimension   nifty(20)
      dimension   bnuc(40), bnucf(40), bn(40), bnf(40)
      dimension   retij(40), imtij(40)
      dimension   kpts(97), tids(97), consti(30), constr(30)
      dimension   Vr(7), Vi(7), f(43,88,7,43), Vll(100,2,7)
      dimension   dummy(2), taxwve(7,160), kap(160)
      dimension   rewave(40,160), imwave(40,160), tawave(7,160)

      common /bandt/    bnuc, bn, bnucf, bnf, retij, imtij
      common /params/   hbarc, pi, Mp, MN, nz, na, nes, nwaves
      common /switch/   nifty
      common /parallel/ f
      common /sizes/    achp, acmp, wsp, achn, acmn, wsn
      common /ranges/   Rcoul, Rcut
      common /tape/  rewave, imwave, tawave, taxwve, kap

      data  Vcoull      /100 * 0.0d+00/
      data  nota        /1/
      data  nint        /0/
      data  maxLs                     / 100 /

c >>> FIRST EXECUTABLE STATEMENT <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
c *** 1st call to optp, calculate all U's
c *** Initialize (can't use data for this due to commons)
c %%% changed dimension of f(600,6) to f(3201,6) to match fr(98,98),fi(98,98)
c %%% so that initialization of f must be changed

      nint = 1
      i1 = nm1 * nm1 * 4
      k = -200.
      call TNCM( k )
      IF (kpts(n1) .gt. 0.) then
         k1 = kpts(n1)
      else
         k1 = kpts(1)
      ENDIF
      n2 = 2 * n1
      nn = na - nz
c *** Make sure lmax = 1 case does not run into indef on initial runs
      ldmax = lmaxin
      IF (ldmax .eq. 1) ldmax = 2
      rhl3 = (achp/hbarc)**2/2.
      rhl4 = (achn/hbarc)**2/2.
c *** Added terms for C-13 spin...may want to change size here
      rhl5 = (wsn/hbarc)**2/2.
      as = 1./6.
      IF (nz .ne. 0) ap = (nz - 2.)/6./nz * (acmp/achp)**2
      IF (nz .le. 2) ap = 0.
      IF (nn .ne. 0) an = (nn - 2.)/6./nn * (acmn/achn)**2
      IF (nn .le. 2) an = 0.
c *** Special C-13, add in p1/2 n and rescale
      IF (na .eq. 13) an = (nn - 3.)/6./(nn - 1.) * (acmn/achn)**2
c *** Do loop over all grid points
      IF (nifty(6) .eq. 6) nifty(17) = 1
      aovera = (na - 1.)/na
      IF (nifty(17) .eq. 1) aovera = 1.
      IF (na .le. 2) aovera = 1.
c *** Set U(strong) = 0
      IF (nifty(6) .eq. 4)  aovera = 0.
      xhl = aovera * 2. * pi * pi
      aparam = 1.
      IF (nifty(1) .eq. 9)  aparam = 0.
      IF (Rcoul .lt. 1.e-10 ) Rcoul = 1.e-6
      aparam = (1.5 * nz * aparam/Rcoul) * hbarc * 7.29735e-3
      xhl1 = Rcoul/hbarc
      xhl2 = Rcut/hbarc
c********* \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/********************
c ************ Begin Phase I parallelization     ********************
c*****  Ready to send out slaves to calculate optical potential ******
          pilgrim = 'Pilgrim'
c ****    Collect parameters into linear matrix ********************
          do 211 ii =1, 30
          if (ii.eq.1) consti(ii) = n1
          if (ii.eq.1) constr(ii) = Mp
          if (ii.eq.2) consti(ii) = ldmax
          if (ii.eq.2) constr(ii) = MN
          if (ii.eq.3) consti(ii) = lborn
          if (ii.eq.3) constr(ii) = k1
          if (ii.eq.4) consti(ii) = nwaves
          if (ii.eq.4) constr(ii) = Rcut
          if (ii.eq.5) consti(ii) = nz
          if (ii.eq.5) constr(ii) = Rcoul
          if (ii.eq.6) consti(ii) = na
          if (ii.eq.6) constr(ii) = hbarc
          if (ii.eq.7) consti(ii) = nes
          if (ii.eq.7) constr(ii) = pi
          if (ii.eq.8) constr(ii) = achp
          if (ii.eq.9) constr(ii) = acmp
          if (ii.eq.10) constr(ii) = wsp
          if (ii.eq.11) constr(ii) = achn
          if (ii.eq.12) constr(ii) = acmn
          if (ii.eq.13) constr(ii) = wsn
          if (ii.gt.7.and.ii.lt.28) then
          consti(ii) = nifty(ii-7)
          endif
 211      continue
          
c ****   Enroll program in PVM and establish Master Process I.D. Number
       call pvmfmytid( mytid )
        call pvmfcatchout(1)
c  ****    Spawn  slaves to other processors ****************************
        call pvmfspawn('Pilgrim', PVMDEFAULT, '*', n1, tids, numt)
c *********** Send each slave the parameters and data it needs ************
c ***********   The loop is over each slave process  **********************
      do 240 i1 = 1,n1
           iteight = 28
           consti(iteight) = i1
           call pvmfinitsend(PVMRAW,bufid)
           call pvmfpack( INTEGER4, consti(1), 28, 1, info)
           call pvmfpack( REAL8, constr(1), 13, 1, info)
           call pvmfpack( REAL8, rewave(1,1), 6400, 1, info)
           call pvmfpack( REAL8, imwave(1,1), 6400, 1, info)
           call pvmfpack( REAL8, tawave(1,1), 1120, 1, info)
           call pvmfpack( REAL8, taxwve(1,1), 1120, 1, info)
           call pvmfpack( REAL8, kpts(1), n1, 1, info)
           call pvmfpack( REAL8, kap(1), 160, 1, info)
           call pvmfsend( tids(i1), 1, info)

x~<~< 240      continue

          infoger = n1 * 7 * ldmax * 2
          do 245 i1 = 1,n1
c ************* Ready to receive slave results ******************

          call pvmfrecv(tids(i1), i1, bufid)
          call pvmfunpack( REAL8, testy, 1, 1, info)
          call pvmfunpack( REAL8, f(1,1,1,i1), infoger, 1, info)

 245      continue
           call pvmfexit(info)

c *******    Optical potential received from slaves *******************
c ******* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^*****************

       return
c ***

      end
