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