288 lines
8.3 KiB
Fortran
288 lines
8.3 KiB
Fortran
c$debug
|
|
subroutine polfct(max1,maxi,jr,js,theta,Pol,sr
|
|
1 ,iopen20,iout20,nth,ntheta,ALPHA,IDAT)
|
|
c -------------------------------------------------------------
|
|
c max1 initial target multiplicity
|
|
c maxi final target multiplicity
|
|
c jr initial projectile multiplicity
|
|
c js final projectile multiplicity
|
|
c sr(1...jr, 1...js, 1...max1, 1...maxi)
|
|
c -------------------------------------------------------------
|
|
c Double precision statements -------------------------------
|
|
c implicit real*8 (a-h,o-z)
|
|
c double complex sr(js,jr,maxi,max1), a(3,3), b(3,3), c(3,3)
|
|
c 1 , d(3,3,4), e(3,3,3)
|
|
c real*8 Knn
|
|
c -------------------------------------------------------------
|
|
c Single precision statements --------------------------------
|
|
complex sr(js,jr,maxi,max1), a(3,3), b(3,3), c(3,3)
|
|
1 , d(3,3,4), e(3,3,3)
|
|
real*4 Knn
|
|
c -------------------------------------------------------------
|
|
parameter (nsig = 4, npol = 10, nay = 4, nty = 3
|
|
1 , rads = 3.141592/180.)
|
|
logical iopen20, iout20
|
|
|
|
dimension s(2,2,3), ii(nsig), jj(nsig)
|
|
1 , Pol(npol), Sy(3,3,3), Sij(3,3,4), IDAT(6), ALPHA(15)
|
|
2 ,csig(nsig), Cij(nsig), Dij(nsig), dsig(nsig)
|
|
c
|
|
c spin 1/2 matrices for Spin correlation coefficients
|
|
c s stored as S_z, S_x and S_y
|
|
c
|
|
data s /-1., 0., 0., 1.
|
|
1 , 0., 1., 1., 0.
|
|
2 , 0.,-1., 1., 0./
|
|
C
|
|
c SY MATRIX FOR SPIN 0, 1/2 and 1
|
|
c
|
|
DATA Sy/0.0,0.0,0.0, 0.0,0.0,0.0, 0.0,0.0,0.0
|
|
1, 0.0,-1.0,0.0, 1.0,0.0,0.0, 0.0,0.0,0.0
|
|
2, 0.0,-.707106781,0.0, .707106781,0.0,-.707106781
|
|
3, 0.0,.707106781,0.0/
|
|
C
|
|
C SYY = ( 3*SY*SY - S*S )
|
|
C S22 = ( S^*S^ )*SQRT(3)/4
|
|
C S21 = ( S^*SZ + SZ*S^)*SQRT(3)/2
|
|
C S20 = ( 3*SZ*SZ - S*S )/SQRT(2)
|
|
C
|
|
DATA Sij/-0.5,0.0,-1.5, 0.0,1.0,0.0, -1.5,0.0,-0.5
|
|
1, 0.0,0.0,0.0, 0.0,0.0,0.0, 1.73205081,0.0,0.0
|
|
2, 0.0,0.0,0.0, -1.2247449,0.0,0.0, 0.0,1.2247449,0.0
|
|
3, 0.70710678,0.0,0.0,0.0,-1.4124214,0.0
|
|
4, 0.0,0.0,0.70710678/
|
|
C
|
|
data ii/1, 2, 3, 1/
|
|
data jj/1, 2, 3, 2/
|
|
data zero/0.0/
|
|
c
|
|
c write(20,'(1p8e12.4)')sr
|
|
cs=cos(theta*rads)
|
|
ss=sin(theta*rads)
|
|
do 20 n=1,nsig
|
|
csig(n)=0.0
|
|
dsig(n)=0.0
|
|
20 continue
|
|
do 30 i=1,npol
|
|
Pol(i) = 0.0
|
|
30 continue
|
|
Dnn = 0.0
|
|
Knn = 0.0
|
|
c
|
|
if(jr.gt.3 .or. js.gt.3) go to 1000
|
|
c
|
|
c Calculate Dnn = < S_y(initial) * S_y(final) >
|
|
c Calculate pol = < S_y(final ) >
|
|
c Calculate asy = < S_y(initial) >
|
|
c
|
|
do 200 mx=1,max1
|
|
do 190 my=1,maxi
|
|
c
|
|
do 180 m =1,jr
|
|
do 170 mp=1,js
|
|
a(mp,m ) = 0.0
|
|
b(mp, m) = 0.0
|
|
c(mp, m) = 0.0
|
|
if(jr .eq. 3) then
|
|
do 115 i=1,nay
|
|
d(mp,m ,i) = 0.0
|
|
115 continue
|
|
endif
|
|
do 130 m1=1,jr
|
|
do 120 m2=1,js
|
|
c Dnn coefficient -------------------------------------------
|
|
c(mp,m )=c(mp,m ) + sr(m2,m1,my,mx) * cmplx(zero, Sy(m2,mp,js))
|
|
1 *cmplx(zero, Sy(m ,m1,jr))
|
|
120 continue
|
|
c Asymmetry --------------------------------------------
|
|
b(mp,m )=b(mp,m ) + sr(mp,m1,my,mx) * cmplx(zero, Sy(m ,m1,jr))
|
|
if(jr .eq. 3) then
|
|
do 125 i=1,nay
|
|
d(mp,m ,i)=d(mp,m ,i) + sr(mp,m1,my,mx) * Sij(m ,m1,i)
|
|
125 continue
|
|
endif
|
|
130 continue
|
|
do 140 m2=1,js
|
|
c Polarization --------------------------------------------
|
|
a(mp,m )=a(mp,m ) + sr(m2,m ,my,mx) * cmplx(zero, Sy(m2,mp,js))
|
|
if(js .eq. 3) then
|
|
do 135 i=1,nty
|
|
e(mp,m ,i)=e(mp,m ,i) + sr(m2,m ,my,mx) * Sij(m2,mp,1)
|
|
135 continue
|
|
endif
|
|
140 continue
|
|
c
|
|
Pol(1) =Pol(1) + conjg(sr(mp,m ,my,mx)) * sr(mp,m ,my,mx)
|
|
Pol(2) =Pol(2) + conjg(sr(mp,m ,my,mx)) * a(mp,m )
|
|
Pol(3) =Pol(3) + conjg(sr(mp,m ,my,mx)) * b(mp,m )
|
|
if(jr .eq. 3) then
|
|
do 160 i=1,nay
|
|
pol(i+3)=Pol(i+3) + conjg(sr(mp,m ,my,mx)) * d(mp,m ,i)
|
|
160 continue
|
|
endif
|
|
if(js .eq. 3) then
|
|
do 165 i=1,nty
|
|
pol(i+7)=Pol(i+7) + conjg(sr(mp,m ,my,mx)) * e(mp,m ,i)
|
|
165 continue
|
|
endif
|
|
Dnn =Dnn + conjg(sr(mp,m ,my,mx)) * c(mp,m )
|
|
170 continue
|
|
180 continue
|
|
190 continue
|
|
200 continue
|
|
c
|
|
if(Pol(1) .eq. 0.0) go to 1000
|
|
IF(iout20) THEN
|
|
if(jr.eq.2 .and. maxi.eq.2) then
|
|
c
|
|
c Calculate Knn = < S_y(initial) * I_y(final) >
|
|
c
|
|
do 300 mx=1,max1
|
|
do 290 mp=1,js
|
|
c
|
|
do 280 my=1,maxi
|
|
do 270 m = 1,jr
|
|
c(m ,my) = 0.0
|
|
do 260 m1=1,maxi
|
|
do 250 m2=1,jr
|
|
c Knn coefficient
|
|
c(m ,my)=c(m ,my) + sr(mp,m1,m2,mx) * cmplx(zero, Sy(my,m2,2))
|
|
1 *cmplx(zero, Sy(m1,m ,2))
|
|
250 continue
|
|
260 continue
|
|
Knn = Knn + conjg(sr(mp,m ,my,mx)) * c(m ,my)
|
|
270 continue
|
|
280 continue
|
|
290 continue
|
|
300 continue
|
|
endif
|
|
c
|
|
if(jr .eq. 2 .and. js .eq.2) then
|
|
c
|
|
c Calculate Dij = < S_i(initial) * S_j(final) >
|
|
c
|
|
|
|
do 600 mx=1,max1
|
|
do 580 my=1,maxi
|
|
do 500 n=1,nsig
|
|
i1=ii(n)
|
|
j1=jj(n)
|
|
do 490 m =1,jr
|
|
do 480 mp=1,js
|
|
a(mp,m )=0.0
|
|
do 440 m1=1,jr
|
|
do 420 m2=1,js
|
|
a(mp,m )=a(mp,m ) + sr(m2,m1,my,mx) * s(m2,mp,i1)*s(m ,m1,j1)
|
|
420 continue
|
|
440 continue
|
|
c
|
|
c Dij correlation coefficients
|
|
dsig(n)=dsig(n)+conjg(sr(mp,m ,my,mx))*a(mp,m )
|
|
480 continue
|
|
490 continue
|
|
500 continue
|
|
580 continue
|
|
600 continue
|
|
endif
|
|
c
|
|
Dsig(3) = -Dsig(3)
|
|
do 610 n=1,nsig
|
|
dsig(n) = dsig(n)/Pol(1)
|
|
610 continue
|
|
c
|
|
if(js .eq. 2 .and. maxi .eq. 2) then
|
|
c
|
|
c Spin correlation coefficients (final state target and projectile)
|
|
c Calculate Cij = < S_y(final) * I_y(final) >
|
|
c
|
|
do 800 mx=1,max1
|
|
do 780 m =1,jr
|
|
c
|
|
do 700 n=1,nsig
|
|
i1=ii(n)
|
|
j1=jj(n)
|
|
do 690 my=1,maxi
|
|
do 680 mp=1,js
|
|
a(mp,my)=0.0
|
|
do 640 m1=1,maxi
|
|
do 620 m2=1,js
|
|
a(mp,my)=a(mp,my)+sr(m2,m ,m1,mx)*s(m2,mp,i1)*s(m1,my,j1)
|
|
620 continue
|
|
640 continue
|
|
c
|
|
csig(n)=csig(n)+conjg(sr(mp,m ,my,mx))*a(mp,my)
|
|
680 continue
|
|
690 continue
|
|
700 continue
|
|
c
|
|
780 continue
|
|
800 continue
|
|
do 820 n=1,nsig
|
|
csig(n) = csig(n)/Pol(1)
|
|
820 continue
|
|
csig(3)=-csig(3)
|
|
c
|
|
c rotate operators to outgoing particle direction
|
|
c
|
|
c Minus signs on C_zz, C_xx and C_xz make output agree with the data
|
|
c where the z and x axes for the target are in opposite directions
|
|
c to those of the projectile
|
|
c
|
|
Cij(3) = -(csig(1)*cs**2 + csig(2)*ss**2 + 2.0*csig(4)*cs*ss)
|
|
Cij(1) = -(csig(1)*ss**2 + csig(2)*cs**2 - 2.0*csig(4)*cs*ss)
|
|
Cij(4) = -(csig(4)*(cs**2-ss**2) + (csig(2)-csig(1))*cs*ss)
|
|
Cij(2) = csig(3)
|
|
endif
|
|
c
|
|
c Singlet fraction
|
|
ssum = (1.0-(csig(1)+csig(2)+csig(3)))/4.0
|
|
Dij(3) = dsig(1)
|
|
Dij(1) = dsig(2)
|
|
Dij(4) = dsig(4)
|
|
Dij(2) = dsig(3)
|
|
ENDIF
|
|
900 continue
|
|
c
|
|
do 980 i=2,npol
|
|
Pol(i) = Pol(i)/Pol(1)
|
|
980 continue
|
|
Dnn = Dnn /Pol(1)
|
|
Knn = Knn /Pol(1)
|
|
Pol(1) = Pol(1)/float(max1*jr)
|
|
1000 continue
|
|
c
|
|
c --------------------------------------------------------
|
|
c output to disk file 20 and file 21
|
|
c
|
|
if(iopen20) then
|
|
open(unit = 20, file = 'for020.dat', status = 'unknown')
|
|
open(unit = 21, file = 'for021.dat', status = 'unknown')
|
|
iopen20 = .false.
|
|
endif
|
|
c
|
|
if(iout20) then
|
|
c Write header to file
|
|
if(nth .eq. 1) then
|
|
WRITE(20,9010)ALPHA,IDAT
|
|
write(20,9020) ntheta
|
|
WRITE(21,9010)ALPHA,IDAT
|
|
write(21,9021) ntheta
|
|
endif
|
|
c
|
|
write(20,'(2(0pf8.3,1h,), 1pe12.4, 9(1h,,0pf8.4))')
|
|
1 theta, cs, (Pol(i),i=1,3), Dnn, Knn
|
|
c
|
|
write(21,'(0pf8.3,1h,,0pf8.3, 9(1h,,0pf8.4))')
|
|
1 theta, cs, Cij, Dij, ssum
|
|
endif
|
|
c
|
|
return
|
|
c
|
|
9010 FORMAT(' (',15A4,I4.2,2(1H/,I2.2),I4.2,2(1H:,I2.2))
|
|
9020 FORMAT(' (',i2,',angle cos[th] Sigma Pol Asy'
|
|
1 ,' Dnn Knn')
|
|
9021 FORMAT(' (',i2,',angle cos[th] Cxx Cyy Czz'
|
|
1 ,' Cxz Dxx Dyy Dzz Dxz fsingl')
|
|
c
|
|
end
|