subroutine vstovl (vll, tk, tkp, nneles, k0) *********************************************************************** c *** Changes the potential from the third component of spin rep. c *** to the ll' representation. Here: c *** c *** v = c * m c *** c *** where, v is calculated in voptll (replace old voptna) c *** c are the coefficients involving l's in goddard's thesis c *** m are the m's in same thesis, solution by matrix inversion c *** c *** vll = c(inverse) * vss(j,jj,lj) c *** where, j corresponds to l = 0,1,2,3,....; c *** jj = 1 for real part protons and neutrons c *** jj = 2 for imaginary part for protons and neutrons. c *** c *** lj = 1: i11,2 = i10, 3 = i1-1, 4 = i01, 5 = i00, 6 = iss c *** 7 = i1s implicit real*8 (a-h, i, k, m, o-z) integer kode, maxLs dimension a(5,5), b(5,5), vss(100,2,7) dimension e(4,4), d(4,4), vtt(4), vst(4), vll(100,2,7) dimension pl(100), plp(100), plpp(100), oops(100) dimension xcos(192),wgt(192),suma(7) dimension i00(100,2), i11(100,2), i1m1(100,2) dimension iss(100,2), i10(100,2), i01(100,2) dimension i1s(100,2) common /params/ hbarc, pi, mpi, xmn, nz, na, nes, nwaves common /switch/ nifty(20) data maxLs / 100 / c >>> FIRST EXECUTABLE STATEMENT <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< mn = xmn neles = nneles twopi2 = 2. * pi**2 call voptll (neles,tkp,tk,k0,i11, i00, i1m1, i10, i01, iss, i1s) do 436 l = 1,7 suma(l) = 0.0 436 continue do 11 j = 1,neles do 12 jj = 1,2 vss(j, jj, 1) = i11(j, jj) vss(j, jj, 2) = i10(j, jj) vss(j, jj, 3) = i1m1(j, jj) vss(j, jj, 4) = i01(j, jj) vss(j, jj, 5) = i00(j, jj) vss(j, jj, 6) = iss(j, jj) vss(j, jj, 7) = i1s(j, jj) if(nifty(4).eq.1) vss(j,jj,7) = 0. 12 continue 11 continue 611 nn = 5 c *** Set imaginary part of matrix = 0. do 20 ls = 1,5 do 20 lj = 1,5 20 b(ls, lj) = 0. c *** Set imaginary part of matrix = 0. do 160 ls = 1,4 do 160 lj = 1,4 160 d(ls, lj) = 0. c *** Do loop over all l = j do 280 j = 1,neles nd = j call COES2L( a , j ) c *** jj = 1, for real part neutrons and protons c *** jj = 2, for imaginary part neutrons and protons do 300 jj = 1,2 c *** Special case need to check if ((nd .eq. 1) .or. (nd .eq. 2)) go to 10 if (jj .eq. 1) then call cmatin (a, b, nn, nn) endif c *** vll is determined. First, is necessary to multiply c *** by LPT factors, and by associated leg. pol. orth. factors at = j - 1 fc = (2. * at + 1.0)/2.0 vss(j, jj, 1) = vss(j, jj, 1) * 2. * twopi2 * fc vss(j, jj, 2) = vss(j, jj, 2) * dsqrt(2.d0) * twopi2 * fc $ /(at * (at + 1.0)) vss(j, jj, 3) = vss(j, jj, 3) * 2. * twopi2 * fc $ /(at + 2.)/(at + 1.)/at/(at - 1.) vss(j, jj, 4) = vss(j, jj, 4) * dsqrt(2.d0) * twopi2 * fc $ /(at * (at + 1.0)) vss(j, jj, 5) = vss(j, jj, 5) * twopi2 * fc vss(j, jj, 6) = vss(j, jj, 6) * twopi2 * 0.5 ******** New T-Mat 9/1/92 tvm here it is, sing.-trip. ********* vss(j, jj, 7) = -vss(j, jj, 7) * dsqrt(2.d0) * twopi2 / 2. $ / sqrt( at * (at + 1.)) ***************************************************************** c *** Singlet = pi * pi * iss c *** Conversion to be made c *** c *** vll = a**-1 * vss do 80 ls = 1,5 sum = 0. do 90 lj = 1,5 sum = sum + a(ls, lj) * vss(j, jj, lj) 90 continue vll(j, jj, ls) = sum 80 continue c *** Spin and l basis same for singlet c *** Form vll, nd = j = 1, special case, need pi**2 again vll(j, jj, 6) = vss(j, jj, 6) vll(j, jj, 7) = vss(j, jj, 7) 10 if (nd .gt. 2) go to 330 c *** nd = j = 2 special case again for l= 0,1 c *** c *** l = 0 if (nd .eq. 2) go to 110 vll(1, jj, 1) = 0. vll(1, jj, 2) = (2. * vss(1, jj, 5) - 2. * vss(1, jj, 1)) $ * twopi2/6.0/dsqrt(2.d0) vll(1, jj, 3) = (2. * vss(1, jj, 1) + vss(1, jj, 5)) $ * twopi2/6. vll(1, jj, 4) = 0. vll(1, jj, 5) = 0. vll(1, jj, 6) = 0.5 * twopi2 * vss(1, jj, 6) vll(1, jj, 7) = 0. if ((neles .eq. 1) .and. (jj .eq. 2)) go to 100 if (nd .ne. 2) go to 330 c *** l = 1 110 lap = 0 do 120 l = 1,4 do 130 ll = 1,4 if (l .eq. 3) lap = 1 lm = l + lap l2 = ll + 1 e(l, ll) = a(lm, l2) 130 continue 120 continue ne = 4 call cmatin (e, d, ne, ne) vll(2, jj, 1) = 0. c *** vtt is temporary vtt(1) = vss(2, jj, 1) * 6. * twopi2 /2. vtt(2) = vss(2, jj, 2) * dsqrt(2.d0) * twopi2 * 3./4. vtt(3) = vss(2, jj, 4) * dsqrt(2.d0) * twopi2 * 3./4. vtt(4) = vss(2, jj, 5) * 3.0 * twopi2 /2. do 997 lo = 1,4 vst(lo) = 0. 997 continue do 200 ls = 1,4 sum = 0. do 210 lj = 1,4 temp = e(ls, lj) sum = sum + temp * vtt(lj) vst(ls) = sum 210 continue 200 continue c *** Mult as not yet done for this special case c *** convert back to reg vll(2, jj, 6) = vss(2, jj, 6) * twopi2 /2. ******** New T-Mat 9/1/92 tvm here it is, sing.-trip. ********* at = nd - 1 vll(2, jj, 7) = -vss(2, jj, 7) * dsqrt(2.d0) * twopi2 * .5 $ / sqrt( at * (at + 1.)) ***************************************************************** do 230 lj = 2,5 jt = lj - 1 vll(2, jj, lj) = vst(jt) 230 continue c-----end special l=0,1 check --------------------------------- 330 continue 300 continue 280 continue c *** Do loop over l end c *** c *** Print out resummation as a check c *** 100 if (tkp .ne. tk .or. tkp .ne. k0) then go to 430 endif ne = 96 c ncoss changed to 48 from 32 to maintain consistency for >32 pw c ncoss = 48 ncoss = 96 c write(6,*)' ****************' c write(6,*)' in vs2vl, ncoss=',ncoss,' may need up if nl gt this' c write(6,*)' ****************' ag = 1. bg = -1. c tm 11/14/90 use 0 for ghe gauss kode = 0 call gauss2 (ncoss, kode, ag, bg, xcos, wgt) if( nifty(20) .eq. 1 .OR. nifty(20) .eq. 3 ) then c write(6,451) endif do 443 jj = 1,2 do 445 ncos = 1,ncoss do 448 lina = 1,7 suma(lina) = 0.0 448 continue sumas = 0.0 x = xcos(ncos) seno = +sqrt(1 - x*x) seno2 = seno * seno call plprme (x, plp, ne) call legpol (x, pl, ne) call pldblp (x, plpp, ne) uggie = -1.0 call legpol (uggie, oops, ne) do 432 l8 = 1,neles call COES2L( a , l8 ) al = l8 - 1 do 444 l9 = 1,5 suma(1) = suma(1) + a(1, l9) * vll(l8, jj, l9) $ * pl(l8)/(2. * twopi2) suma(2) = suma(2) + a(2, l9) * vll(l8, jj, l9) * seno $ * plp(l8)/(dsqrt(2.d0) * twopi2) suma(3) = suma(3) + a(3, l9) * vll(l8, jj, l9) * seno2 $ * plpp(l8)/(2. * twopi2) suma(4) = suma(4) + a(4, l9) * vll(l8, jj, l9) * seno $ * plp(l8)/(dsqrt(2.d0) * twopi2) suma(5) = suma(5) + a(5, l9) * vll(l8, jj, l9) $ * pl(l8)/twopi2 444 continue suma(6) = suma(6) + (2. * al + 1.) * vll(l8, jj, 6) $ * pl(l8)/twopi2 if (l8.ne.1) then suma(7) = suma(7)+(2.*al+1.)*vll(l8,jj,7)*dsqrt(2.d0)/2. $ /sqrt(al * (al + 1.)) * plp(l8) * seno /twopi2 endif sumas = sumas + vss(l8, jj, 1) * pl(l8)/(2. * twopi2) 432 continue if( nifty(20) .eq. 1 .OR. nifty(20) .eq. 3) then c write(6,450) x, (suma(l9), l9=1,7) endif 445 continue 443 continue 430 return 450 format(' ',f10.3,7e12.3) 451 format(' resum of on-shell Vll to form Vss(th) in sub VsToVl' $ /,' costh V11 V10 V1-1 Vo1 Voo Vss V1s' ) 3211 format (' Vll(1,2,6)= ', e12.6) end