c$debug c*********************************************************************** SUBROUTINE ELSIG(dtemp,d,plm,SigPlt,angle,fk,eta,rsig,alpha 1 ,idat,is,icon,lplus,isym) c c Subroutine to print out elastic scattering cross sections c*********************************************************************** c IMPLICIT REAL*8(A-H,O-Z) complex*16 SUM(25),dtemp(*),d(*) logical isym(2), i_open20, i_out20 DIMENSION plm(1000),SigPlt(200) 1,angle(3),fk(2),eta(2),rsig(2),alpha(15),idat(6),is(2),icon(20) 2,POL(12) DATA NX, N2, Pi/200, 1, 3.141592654/ c i_open20 = .false. i_out20 = .false. C NTHETA=angle(1) theta1=angle(2) dtheta=angle(3) IF(NTHETA.EQ.0) return c ICNT=0 IC1=0 DO 200 N=1,N2 ISS=IS(N)+1 IS2=IS(N) IQ=LPLUS*ISS**2 C Clear Amplitude Storage DO 3 IP=1,IQ DTEMP(IP)=0.0 3 CONTINUE C C CONSTRUCT TABLE OF SCATTERING AMPLITUDES WITH ANG-MOM COEFFICENTS C DO 25 LL=1,LPLUS L=LL-1 LK=LL+LL-1 L2=LK-1 FL=LK J1=L2-IS2 J2=L2+IS2 IQ=IC1+LL c DO 20 JJ2=J1,J2,2 IP=LL DO 15 MS2=-IS2,IS2,2 VCI=VCC(L2,IS2,JJ2,0,MS2)*FL DO 14 MS1=-IS2,IS2,2 ML2=MS2-MS1 ML=IABS(ML2/2) IF(ML .LE. L) THEN VCF=VCC(L2,IS2,JJ2,ML2,MS1) DTEMP(IP)=DTEMP(IP)+D(IQ) 1 *VCI*VCF*SQRT(YXFCT(L+ML,L-ML)) ENDIF IP=IP+LPLUS 14 CONTINUE 15 CONTINUE IQ=IQ+LPLUS 20 CONTINUE 25 CONTINUE IC1=IC1+LPLUS*ISS C C CALCULATE ELASTIC CROSS SECTION C THETA=THETA1 if(ETA(N) .ne. 0.0) then WRITE(6,9027) else WRITE(6,9028) endif DO 100 NTH=1,NTHETA CALL LGNDR(PLM,ISS,LPLUS,THETA) Nss = ISS**2 DO 30 I=1,Nss SUM(I)=0.0 30 CONTINUE DO 40 LL=1,LPLUS IP=LL DO 35 I=1,ISS DO 34 J=1,ISS MP = iabs(J-I)*LPLUS+LL index = (I-1)*ISS + J Phas = 1.0 if(I .lt. J) Phas = phasef(I-J) SUM(index) = SUM(index) + DTEMP(IP)*PLM(MP)*Phas IP=IP+LPLUS 34 CONTINUE 35 CONTINUE 40 CONTINUE C C CALCULATE COULOMB AMPLITUDE C if(theta.lt.0.0625 1 .or. (isym(N) .and. abs(theta-180.).lt. 0.0625)) then CL=0.0 SL=0.0 else ARG =THETA*(Pi/360.) S =SIN(ARG)**2 ARG =ETA(N)*LOG(S) FFACT=ETA(N)/(2.0*FK(N)*S) CL = COS(ARG)*FFACT SL = SIN(ARG)*FFACT if(isym(N) .and. is(N).eq.0) then ARG =THETA*(Pi/360.) C =COS(ARG)**2 ARG =ETA(N)*LOG(C) GFACT=ETA(N)/(2.0*FK(N)*C) CL =CL+COS(ARG)*GFACT SL =SL+SIN(ARG)*GFACT endif endif c Add Coulomb amplitude DO 60 I=1,ISS index = (I-1)*ISS + I SUM(index) = SUM(index) - cmplx(CL, -SL) 60 CONTINUE c CALL POLFCT(1,1,ISS,ISS, theta,POL,SUM 1 ,i_open20,i_out20, nth,nthetra, ALPHA,IDAT) if(eta(n).eq.0.0) then Ratio = 1.0 SigPlt(NTH) = Pol(1) else if(theta.lt.0.0625 1 .or. (isym(N) .and. abs(theta-180.).lt.0.0625)) then Ratio = 1.0 Pol(1) = 0.0 else Ratio = Pol(1)/(CL**2+SL**2) endif SigPlt(nth) = Ratio endif cs = cos(theta*(Pi/180.)) if(ETA(N) .ne. 0.0) then WRITE(6,9030)THETA,Ratio,(POL(I),I=1,7),THETA,cs else WRITE(6,9031)THETA, (POL(I),I=1,7),THETA,cs endif 90 CONTINUE THETA=THETA+DTHETA 100 CONTINUE WRITE(6,9002)RSIG(N) NTH=MIN0(NTHETA,NX) c IF(ICON(6).ne.0) then WRITE(6,9999)ALPHA,(IDAT(I),I=1,3) CALL DWPLOT(NTH,ICON(6),SigPlt,DTHETA,THETA1) endif 200 continue RETURN c 9002 FORMAT('0REACSIG ',1PE13.4) 9027 FORMAT('0 Theta Sig(1)/Coul Sigma(1) ',' Pol ' 1 ,' Asy ',' Ayy ',' A22 ',' A21 ' 2 ,' A20 ',' Theta ','Cos(Theta)') 9028 FORMAT('0 Theta Sigma(1) ',' Pol ' 1 ,' Asy ',' Ayy ',' A22 ',' A21 ' 2 ,' A20 ',' Theta ','Cos(Theta)') 9030 FORMAT(0PF8.2,2X,1P2E13.4,0P6F10.4,0PF10.2,0pf10.3) 9031 FORMAT(0PF8.2,2X,1P1E13.4,0P6F10.4,0PF10.2,0pf10.3) 9999 FORMAT('1',15A4,I4,2('/',I2.2),I4,2('.',I2.2)) END