C PROGRAM RUTHER C C TO EVALUATE CROSS-SECTIONS FOR RUTHERFORD AND MOTT SCATTERING. C (MANNING 1981) C INTEGER OVDU,FLAG LOGICAL*1 NAME(5) REAL MTHETA,JTHETA,I,LAB,PI,RM(2) CHARACTER ANSWER*1 DIMENSION IA(2),IZ(2) DATA OVDU,IVDU,PI/6,5,3.1415926/ IDOP=6 C C SEE IF USER WANTS HARD COPY C WRITE(OVDU,*) 'Do you want output to go file ruther_out Y/N ?' READ(IVDU,'(A1)') ANSWER IF (ANSWER.EQ.'Y'.OR.ANSWER.EQ.'y') THEN IDOP=8 OPEN(8,FILE='ruther_out') ENDIF C IDENTIFY PROJECTILE AND TARGET. 10 DO 11 J=1,2 IF (J.EQ.2) GOTO 21 WRITE(OVDU,*) 'PLEASE TYPE THE SYMBOL OF THE ', 1'PROJECTILE E.G 12C' READ(IVDU,41) NAME GOTO 31 21 WRITE(OVDU,*) 'PLEASE TYPE THE SYMBOL OF THE TARGET' READ(IVDU,41) NAME 41 FORMAT(5A1) 31 CALL GETM(NAME,IZ(J),IA(J),RM(J),IFLAG) IF (IFLAG.EQ.0) GOTO 11 WRITE(OVDU,*) 'SORRY UNAVAILABLE PLEASE TYPE MASS(AMU) & CHARGE?' READ(IVDU,*) RM(J),IZ(J) 11 CONTINUE 30 Z1 = FLOAT(IZ(1)) Z2 =FLOAT(IZ(2)) WRITE(OVDU,*) 'PARTICLE ENERGY ?' 110 READ(IVDU,*) ENER IF(ENER.GT.0.0) GOTO 120 WRITE(OVDU,*) 'IMPOSSIBLE ENERGY LEVEL,PLEASE RETYPE' GOTO 110 C IF PARTICLES ARE IDENTICLE THEN GET SPIN. 120 IF(RM(1).NE.RM(2).OR.Z1.NE.Z2) GOTO 60 130 WRITE(OVDU,*) 'SPIN OF NUCLEI?' READ(IVDU,*) I 60 MTHETA = 90.0 IF(RM(1).LT.RM(2)) MTHETA = 180.0 IF(RM(1).LE.RM(2)) GO TO 20 MTHETA = ASIN(RM(2)/RM(1))*180.0/PI 20 WRITE(OVDU,1000) MTHETA 1000 FORMAT('MAXIMUM POSSIBLE ANGLE IS ',F6.2, 1' DEGREES'/'MIN,MAX,STEP') 90 READ(IVDU,*) AMIN,AMAX,ASTEP IF(AMIN.LE.MTHETA.AND.AMAX.LE.MTHETA) GOTO 70 WRITE(OVDU,3030) 3030 FORMAT('ANGLE TOO LARGE DESPITE WARNING!'/'PLEASE TYPE AGAIN') GOTO 90 70 IF(AMAX.LT.AMIN) AMAX = AMIN IF(ASTEP.LT.0.01) ASTEP = 0.01 WRITE(IDOP,3000) IA(1),IZ(1),IA(2),IZ(2),ENER,I 3000 FORMAT(///' PARTICLE 1 PARTICLE 2'/ 1 ' ',I3,' AMU ',I3,' Z ',I3, 1' AMU ',I3,' Z '//' ENERGY',G10.3, 1' SPIN ',G9.3/) WRITE(IDOP,*) 'ANGLE CROSS SECTN (MB/SR) (DEG)', 1' LAB/CM E 1 E 2' WRITE(IDOP,*) '(DEG) LAB CM CM ', 1' MEV MEV' DO 80 UTHETA=AMIN,AMAX,ASTEP C---------------------------------------------------------------------- C CALCULATE EONE,ETWO,THETACM,THETA2 & J(THETA) C AS THESE ARE COMMON TO BOTH RUTHERFORD & MOTT SCATTERING C---------------------------------------------------------------------- THETA = UTHETA * PI/180.0 TEMP = ENER*(RM(1)**2)/((RM(1)+RM(2))**2) EONE=TEMP*((COS(THETA)+SQRT((RM(2)/RM(1))**2-(SIN(THETA)**2)))**2) THETAC = THETA + ASIN((RM(1)/RM(2))*SIN(THETA)) JTHETA = ((SIN(THETA)**2)/(SIN(THETAC)**2))*COS(THETAC-THETA) ETWO = ENER-EONE THETA2 = (PI-THETAC)/2.0 C ARE THE PARTICLES IDENTICLE? IF(RM(1).EQ.RM(2).AND.Z1.EQ.Z2) GO TO 40 C--------------------------------------------------------------------- C CALCULATE CM AND LAB FOR RUTHERFORD SCATTERING. C--------------------------------------------------------------------- TEMP = 1.296*((Z1*Z2/ENER)**2) CM = TEMP*(((RM(1)+RM(2))/RM(2))**2)*(1.0/SIN(THETAC/2)**4) LAB = CM/JTHETA GO TO 50 C--------------------------------------------------------------------- C CALCULATE CM AND LAB FOR MOTT SCATTERING. C---------------------------------------------------------------------- 40 N = 0.1575*Z1*Z2*SQRT(RM(1)/ENER) SINTH = SIN(THETA) COSTH = COS(THETA) TEMP = 1.296 * ((Z1*Z2/ENER)**2) * (((RM(1)+RM(2))/RM(2))**2) II=IFIX(I) REM=I-II SIGN=1.0 IF(REM.GT.0.1) SIGN=-1.0 TEMP2 = SIGN/((2*I)+1) TEMP3 = TEMP2*2.0*COS(N*ALOG((TAN(THETAC/2.0))**2.)) CM = (1.0/(SINTH**4)) + (1.0/(COSTH**4)) CM = TEMP*(CM+(TEMP3/(SINTH**2)/(COSTH**2))) LAB = CM/JTHETA 50 WRITE(IDOP,3010) UTHETA,LAB,CM,THETAC*180.0/PI,JTHETA,EONE,ETWO 3010 FORMAT (F6.2,3X,G12.6,1X,G12.6,1X,F6.2,1X,F7.3,2X,F7.3,1X,F7.3) 80 CONTINUE WRITE(OVDU,3020) 3020 FORMAT(///'EXIT(1),NEW PARTICLES(2),NEW ANGLES(3),NEW ENERGY', 1'(4), NEW SPIN(5)') READ(IVDU,*) FLAG IF(FLAG.EQ.1) GO TO 999 IF(FLAG.EQ.5) GOTO 130 IF(FLAG - 3) 10,20,30 999 STOP END C ********************************************************* C * OBTAINS THE MASSES OF NUCLEI FROM A RANDOM ACCESS FILE* C ********************************************************* C C SUBROUTINE GETM(NAME,IZ,IA,RM,IFLAG) LOGICAL*1 NUM(3),LET(2),NOS(10),BLANK,NAME(5) INTEGER*2 ATOM,NUCNAM(110) INTEGER MAXIZ,IAMIN(0:4),IAMAX(0:4),IREC(0:4),INF,IINF CHARACTER FORMAT(3)*4,BUFF*24 CHARACTER * (*) MASFIL REAL CKZ,DCZ,DELCKZ,DELPA,DELSN,DELWAH,JM,MEA,MJ, + MN,PA,SJ,SN,TEA,WAH DATA FORMAT /'(I1)','(I2)','(I3)'/ EQUIVALENCE (ATOM,LET(1)) DATA NUCNAM/' N','H ','HE', +'LI','BE','B ','C ','N ','O ','F ','NE', +'NA','MG','AL','SI','P ','S ','CL','AR', +'K ','CA','SC','TI','V ','CR','MN','FE','CO', +'NI','CU','ZN','GA','GE','AS','SE','BR','KR', +'RB','SR','Y ','ZR','NB','MO','TC','RU','RH', +'PD','AG','CD','IN','SN','SB','TE','I ','XE', +'CS','BA','LA','CE','PR','ND','PM','SM', +'EU','GD','TB','DY','HO','ER','TM','YB', +'LU','HF','TA','W ','RE','OS','IR','PT', +'AU','HG','TL','PB','BI','PO','AT','RN', +'FR','RA','AC','TH','PA','U ','NP','PU', +'AM','CM','BK','CF','ES','FM','MD','NO', +'LR','RF','HA','NH','NS','UO','UE'/ DATA BLANK,IFIRST/' ',0/ DATA MAXIZ/109/ DATA AMU/931501.6/ DATA NOS/'0','1','2','3','4','5','6','7','8','9'/ DATA ITYPE1/11/ PARAMETER (MASFIL='/usr/local/libm/m88lrb') CALL UCASE(NAME) IFLAG=0 IF (IFIRST.EQ.1) GOTO 10 IFIRST=1 C CALL CONECT('LOCAL.USERPROG.DATA.MASS83',5) OPEN(7,STATUS='OLD',ACCESS='DIRECT',RECL=64,FILE=MASFIL) 10 DO 40 I=1,5 DO 30 K=1,10 IF (NAME(I).EQ.NOS(K)) GOTO 40 30 CONTINUE GOTO 50 40 CONTINUE C C *RECOGNISING A AND Z IN NAME* C 50 J1=0 DO 60 I2=1,2 LET(I2)=BLANK 60 CONTINUE M=I+1 J1=0 DO 70 L=I,M J1=J1+1 LET(J1)=NAME(L) 70 CONTINUE N=I-1 J1=0 DO 80 L=1,N J1=J1+1 NUM(J1)=NAME(L) 80 CONTINUE LENFLD=J1 C CALL DEFBUF(13,LENFLD,NUM) C READ(13,*)IA WRITE(BUFF,'(3A1)') NUM READ(BUFF,FORMAT(LENFLD)) IA C C *LOOKING FOR NUCLEI SYMBOL IN PERIODIC TABLE* C IMAX=MAXIZ+1 DO 90 I1=1,IMAX IF (ATOM.EQ.NUCNAM(I1)) GOTO 110 90 CONTINUE GOTO 180 110 IZ=I1-1 C C *SEARCHING MASSFILE FOR NUCLEI DATA* C IF (IZ.GT.MAXIZ) GOTO 180 C KEYPTR=IZ+1 C READ(5,REC=KEYPTR)IAMIN,IAMAX,MSTART,SYMB C IF (IA.LT.IAMIN.OR.IA.GT.IAMAX) GOTO 180 C KEYPTR=IA-IAMIN+MSTART C READ(5,REC=KEYPTR)RMASS,ERRM C RM=RMASS/AMU+FLOAT(IA) KEYPTR=IZ/5 READ(7,REC=KEYPTR+2)(IREC(I),IAMIN(I),IAMAX(I),I=0,4) IPTR=IZ-(KEYPTR*5) IF (IA.LT.IAMIN(IPTR).OR.IA.GT.IAMAX(IPTR)) GOTO 180 KEYPTR=IA+IREC(IPTR)-IAMIN(IPTR) READ(7,REC=KEYPTR)PA,DELPA,DCZ,MN,MEA,CKZ,DELCKZ,SN,DELSN, + TEA,SJ,JM,MJ,WAH,DELWAH,INF C C decode the INF word, which contains information on which C values are present for each nucleus..so dave love says C IINF=INF/2**(ITYPE1*2-2) IINF=MOD(IINF,4) IF (IINF.NE.0) THEN RMASS=WAH*1000.0 ERRM=DELWAH*1000.0 ELSE RMASS=MN*1000.0 IFLAG=2 ENDIF RM=(RMASS/AMU)+REAL(IA) RETURN 180 IFLAG=1 RETURN END SUBROUTINE UCASE(LINEIN) * * CONVERT LOWER CASE TO UPPER CASE IF APPROPRIATE * LOGICAL*1 LINEIN(5) DO 20 J=1,5 IF (LINEIN(J).GE.97.AND.LINEIN(J).LE.122) THEN LINEIN(J)=LINEIN(J)-32 ENDIF * WRITE(6,30) LINEIN(J),LINEIN(J) 20 CONTINUE 30 FORMAT(A1,I6) RETURN END