C RELKIN. RELATIVISTIC KINEMATICS ON THE GEC4070. FORMULA C FROM MINESOTA PROGRAM. SYMBOLIC ENTRY OF REACTION WITH C MASS AND QVALUE RETURNED FROM COPY OF THE NUCLEAR DATA C TABLES (1983) TABULATION OBTAINED FROM MANCHESTER. IMPLICIT REAL*8 (A-H,O-Z) CHARACTER ANSWER*1 INTEGER OPST LOGICAL*1 LINEIN(24),IBLANK,ISLASH,IZERO DIMENSION RM(4),EM(4),IA(4),IZ(4) EQUIVALENCE (A1,RM(1)),(A2,RM(2)),(A3,RM(3)),(A4,RM(4)) DATA RADIAN,IBLANK,ISLASH,IZERO/0.01745329D0,' ','/','0'/ OPST=6 WRITE(6,*) +'Do you want output redirected from screen to file relkin_out + on stream 8 Y/N ?' READ(5,'(A1)') ANSWER IF (ANSWER.EQ.'Y'.OR.ANSWER.EQ.'y') THEN OPEN (8,FILE='relkin_out') OPST=8 ENDIF C C ENTRY OF SYMBOLIC REACTION 1 WRITE(6,2) 2 FORMAT(' REACTION EG 28SI(12C,16O), 0 TO END OR / FOR PREVIOUS'/) READ(5,4)(LINEIN(I),I=1,24) 4 FORMAT(24A1) IF(LINEIN(1).EQ.IBLANK) GOTO 10 IF(LINEIN(1).EQ.ISLASH) GOTO 25 IF(LINEIN(1).EQ.IZERO) GOTO 170 CALL REACT(RM,QGS,QERROR,EM,IA,IZ,IFLAG,LINEIN) IF (IFLAG.NE.1) GOTO 25 WRITE(6,6) A2,A1,A3,A4 6 FORMAT('ELEMENT(S) (MASS=999.0) NOT ON MASS TABLE'/ 14(3X,F10.6)/' PLEASE ENTER'/) C READ INPUT OF MASSES IF NOT ON TABLE 10 WRITE(6,20) 20 FORMAT(' MT,MP,MS,MR (AMU) AND QGS(MEV)'/) C C NOTE REVERSED TARGET/PROJECTILE READ(5,*) A2,A1,A3,A4,QGS 25 WRITE(6,30) 30 FORMAT(' EXCITATION ENERGY(MEV)'/) READ(5,*) EX WRITE(6,40) 40 FORMAT(' BEAM ENERGY(MEV)'/) READ(5,*) ELAB WRITE(6,50) 50 FORMAT(' LAB ANGLES (START,STOP,STEP)'/) READ(5,*) ANG1,ANG2,ANG3 C C WRITE TITLE (STREAM 4) WRITE(OPST,54)(LINEIN(I),I=1,24),A2,A1,A3,A4 54 FORMAT(1X,24A1,3X,4(F10.6,1X)) WRITE(OPST,60) ELAB,EX,QGS,QERROR 60 FORMAT(1X,'ELAB=',F7.3,'MEV EX=',F7.3,'MEV QGS=', 1F7.3,'+/-',F5.3,'MEV'/) IF(IFLAG.EQ.2) WRITE(OPST,65) 65 FORMAT(' *********WARNING. YOU ARE USING INTERPOLATED MASSES'/) WRITE(OPST,70) 70 FORMAT(' LAB ANGLE CM ANGLE LAB ENERGY CM/LAB RATIO', 1' ASSOCIATED PARTICLE'/48X,'LAB ANGLE LAB ENERGY'/) C C CALCULATION Q=QGS-EX ECM=ELAB*A2/(A1+A2) IF(ECM+Q) 80,80,100 80 ETHRES=-1.*Q*(A1+A2)/A2 WRITE(OPST,90) ETHRES 90 FORMAT(' REACTION BELOW THRESHOLD (',F6.3,'MEV)'/) GOTO 1 100 ANGL=ANG1 C C LOOP THROUGH ANGLES 110 ANGLR=ANGL*RADIAN CALL LABTCM(A1,A2,A3,A4,ELAB,Q,ANGLR,ANGCM1,T3L1,G1, 1ANGCM2,T3L2,G2,ANG4L1,ANG4L2,T4L1,T4L2,NS) IF(ANGCM1.EQ.0.AND.ANGL.NE.0.) GOTO 150 ANGCM1=ANGCM1/RADIAN ANGCM2=ANGCM2/RADIAN ANG4L1=ANG4L1/RADIAN ANG4L2=ANG4L2/RADIAN WRITE(OPST,120) ANGL,ANGCM1,T3L1,G1,ANG4L1,T4L1 120 FORMAT(3X,F6.2,4X,F6.2,4X,F8.3,5X,F6.3,6X,F6.2,3X,F6.2) IF(NS.EQ.2) WRITE(OPST,130) ANGCM2,T3L2,G2,ANG4L2,T4L2 130 FORMAT(13X,F6.2,4X,F8.3,5X,F6.3,6X,F6.2,3X,F6.2) ANGL=ANGL+ANG3 IF(ANGL.LE.ANG2.AND.ANG3.NE.0.) GOTO 110 WRITE(OPST,140) 140 FORMAT(///) GOTO 1 150 WRITE(OPST,160) 160 FORMAT(//10X,' MAXIMUM SCATTERING ANGLE EXCEEDED'///) GOTO 1 170 STOP END C C SUBROUTINE LABTCM TO RETURN CM ANGLE, ENERGY AND JACOBIAN C FOR EJECTILE IN GIVEN REACTION. NS=2 IF DOUBLE SOLUTION. C MASSES ARE IN AMU, ENERGIES IN MEV C THIS ROUTINE FROM MINNESOTA AND PROVIDED BY J.S.LILLEY SUBROUTINE LABTCM(AA1,AA2,AA3,AA4,TIL,Q,ANGL, 1ANGCM1,T3L1,G1,ANGCM2,T3L2,G2,ANG4L1,ANG4L2,T4L1,T4L2,NS) IMPLICIT REAL*8 (A-H,O-Z) DATA AMU,PI/931.5016D0,3.1415926D0/ A1=AA1*AMU A2=AA2*AMU A3=AA3*AMU A4=AA4*AMU Y=A1+A2 BETAC=DSQRT(TIL*(TIL+2.*A1))/(Y+TIL) GAMCI2=1.-BETAC*BETAC ECMI=DSQRT(Y*Y+2.*TIL*A2) ECMF=ECMI+Q-Y+A3+A4 E3CM=(ECMF*ECMF+A3*A3-A4*A4)/(2.*ECMF) GAM3C2=(E3CM/A3)*(E3CM/A3) BETA3C=DSQRT(1.-1./GAM3C2) Y=GAM3C2*GAMCI2 COSAGL=DCOS(ANGL) B=-BETAC*COSAGL A=Y+B*B C=1.-Y NS=0 ANGCM1=0. T3L1=0. G1=0. ANGCM2=0. T3L2=0. G2=0. ANG4L1=0. ANG4L2=0. D=B*B-A*C IF(D) 10,10,1 1 D=DSQRT(D) DO 9 KJ=1,3,2 J=KJ-2 FJ=-DBLE(J) BETA3L=(-B+DSIGN(D,FJ))/A IF(BETA3L-0.0000001) 10,10,2 2 GAMM3L=1./DSQRT(1.-BETA3L*BETA3L) TL=(GAMM3L-1.)*A3 Y=BETA3L*COSAGL Y=(Y-BETAC)/((1.-BETAC*Y)*BETA3C) IF(DABS(Y)-1.) 5,5,3 3 IF(DABS(Y)-1.00001) 4,9,9 4 Y=DSIGN(1.0D0,Y) 5 AC=DACOS(Y) G=BETA3C*(1.+B/BETA3L)/(1.+BETAC*BETA3C*Y)/BETA3L IF(NS) 7,6,7 6 ANGCM1=AC T3L1=TL G1=G GOTO 8 7 ANGCM2=AC T3L2=TL G2=-G 8 NS=NS+1 C ASSOCIATED PARTICLE ANGLE CALCULATION C THIS CODE PUT IN BY B.R.FULTON 30/7/81 T4=TIL+Q-TL P32C2=TL*(TL+2.*A3) P42C2=T4*(T4+2.*A4) ANGL4=DASIN(DSQRT(P32C2/P42C2)*DSIN(ANGL)) P12C2=TIL*(TIL+2.*A1) TEST=P32C2*COSAGL*COSAGL IF(TEST.GT.P12C2.AND.ANGL.LT.PI/2) ANGL4=PI-ANGL4 IF(NS.EQ.1.) ANG4L1=ANGL4 IF(NS.EQ.2.) ANG4L2=ANGL4 IF(NS.EQ.1.) T4L1=T4 IF(NS.EQ.2.) T4L2=T4 9 CONTINUE 10 CONTINUE RETURN END C SUBROUTINE REACT TO INTERPRET A REACTION IN 28SI(12C,16O) C SYMBOLIC FORMAT AND RETURN REAL*8 VALUES OF THE MASSES, C QVALUE AND ERROR AS WELL AS THE RESIDUAL PARTICLE SYMBOL, C AND A FEW OTHER RELEVENT DETAILS. C INPUT:LINEIN(24) REACTION (READ AS A24 FORMAT) C OUTPUT:RM(4) MASSES(AMU)................DOUBLE PRECISION C Q REACTION Q-VALUE (MEV)........DOUBLE PRECISION C EQ ERROR ON Q-VALUE (MEV)........DOUBLE PRECISION C EM(4) ERROR IN MASSES (KEV)......DOUBLE PRECISION C IA(4) MASSES C IZ(4) ATOMIC NUMBER C IFLAG (0) O.K. C (1) ONE OR MORE REQUIRED SYMBOLS NOT IN FILE C (2) ONE OR MORE MASSES ARE INTERPOLATED VALUES C C SUBROUTINE REACT(RM,Q,EQ,EM,IA,IZ,IFLAG,LINEIN) LOGICAL*1 LINEIN(24),NUM(3),LET(2),NOS(10), +BLANK,OPEN,CLOSE,COMMA INTEGER*2 ATOM,NUCNAM(110),NAME INTEGER MAXIZ,IAMIN(0:4),IAMAX(0:4),IREC(0:4),INF,IINF CHARACTER FORMAT(3)*4,BUFF*24 REAL*8 RM(4),EM(4),Q,EQ,AM(4),X CHARACTER * (*) MASFIL REAL CKZ,DCZ,DELCKZ,DELPA,DELSN,DELWAH,JM,MEA,MJ, + MN,PA,SJ,SN,TEA,WAH DIMENSION IA(4),IZ(4) EQUIVALENCE (ATOM,LET(1)) DATA FORMAT /'(I1)','(I2)','(I3)'/ 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'/ PARAMETER (MASFIL='/home/oef/Research/anprogs/lib/m88lrb') DATA OPEN,COMMA,CLOSE,BLANK,IFIRST/'(',',',')',' ',0/ DATA MAXIZ/109/ DATA AMU/931501.6/ DATA NOS/'1','2','3','4','5','6','7','8','9','0'/ DATA ITYPE1/11/ CALL UCASE(LINEIN) IF (IFIRST.NE.0) GOTO 10 OPEN(7,STATUS='OLD',ACCESS='DIRECT',RECL=64,FILE=MASFIL) IFIRST=1 10 IFLAG=0 DO 20 IJ=1,4 RM(IJ)=0.0 EM(IJ)=0.0 IA(IJ)=0 IZ(IJ)=0 20 CONTINUE C C *READING ALONG REACTION TO FIND NUCLEI* C N1=1 N2=5 DO 170 J=1,4 IF (J.EQ.4) GOTO 130 DO 40 I=N1,N2 DO 30 K=1,10 IF (LINEIN(I).EQ.NOS(K)) GOTO 40 30 CONTINUE GOTO 50 40 CONTINUE 50 N=I-1 N3=N1+5 DO 60 L1=N1,N3 IF (LINEIN(L1).EQ.OPEN.OR.LINEIN(L1).EQ.COMMA +.OR.LINEIN(L1).EQ.CLOSE) GOTO 70 60 CONTINUE 70 J1=0 C C *OBTAINING A AND Z FROM REACTION FOR EACH NUCLEI* C DO 80 L=N1,N J1=J1+1 NUM(J1)=LINEIN(L) 80 CONTINUE LENFLD=J1 M=L1-1 J1=0 DO 90 I2=1,2 LET(I2)=BLANK 90 CONTINUE DO 100 L=I,M J1=J1+1 LET(J1)=LINEIN(L) 100 CONTINUE N1=M+2 N2=N1+4 C CALL DEFBUF(13,LENFLD,NUM) C READ(13,*)IA(J) WRITE(BUFF,'(3A1)') NUM READ(BUFF,FORMAT(LENFLD)) IA(J) IMAX=MAXIZ+1 DO 110 I1=1,IMAX IF (ATOM.EQ.NUCNAM(I1)) GOTO 120 110 CONTINUE GOTO 270 120 IZ(J)=I1-1 GOTO 140 C C *CALCULATING A AND Z OF 4TH NUCLEI* C 130 IZ(4)=IZ(1)+IZ(2)-IZ(3) IA(4)=IA(1)+IA(2)-IA(3) IF (IZ(4).LT.0.OR.IA(4).LT.0) GOTO 270 C C *OBTAINING DATA FROM MASS FILE* C 140 IF (IZ(J).GT.MAXIZ) GOTO 270 KEYPTR=IZ(J)/5 READ(7,REC=KEYPTR+2)(IREC(I),IAMIN(I),IAMAX(I),I=0,4) IPTR=IZ(J)-(KEYPTR*5) IF (IA(J).LT.IAMIN(IPTR).OR.IA(J).GT.IAMAX(IPTR)) GOTO 270 KEYPTR=IA(J)+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 C C *CALCULATION DATA PUT INTO ARRAYS* C IF (ERRM.LT.0.0) IFLAG=2 RM(J)=DBLE(RMASS/AMU)+DBLE(IA(J)) AM(J)=DBLE(RMASS) EM(J)=DBLE(ERRM) 170 CONTINUE C C *CONVERTING Z OF 4TH NUCLEI INTO NUCLEI SYMBOL* C * AND CHANGING INTEGER A INTO CHARACTER A * C IH=0 N4=IA(4) IF (IA(4).LT.100) GOTO 180 IH=N4/100 N4=N4-100*IH LINEIN(N1)=NOS(IH) N1=N1+1 180 IT=N4/10 IU=N4-10*IT IF (IT.EQ.0.AND.IH.NE.0) GOTO 190 IF (IT.NE.0.OR.IH.EQ.0) GOTO 200 190 LINEIN(N1)=NOS(10) GOTO 210 200 IF (IT.EQ.0) GOTO 220 LINEIN(N1)=NOS(IT) 210 N1=N1+1 220 IF (IU.NE.0) GOTO 230 LINEIN(N1)=NOS(10) GOTO 240 230 LINEIN(N1)=NOS(IU) 240 N1=N1+1 NF=N1+1 C CALL DEFBUF(13,2,NAME) C READ(13,250)(LINEIN(I),I=N1,NF) NAME =NUCNAM(IZ(4)+1) WRITE(BUFF,'(Z4)') NAME READ(BUFF,'(2Z2)') (LINEIN(I),I=N1,NF) 250 FORMAT(2A1) NF=NF+1 DO 251 IB=NF,24 LINEIN(IB)=BLANK 251 CONTINUE C C *CALCULATING QVALUE AND ERROR* C Q=(AM(1)+AM(2)-AM(3)-AM(4))/1000.0 EQ=DSQRT(EM(1)**2+EM(2)**2+EM(3)**2+EM(4)**2)/1000.0 C C *INTERCHANGING TARGET AND PROJECTILE POSITIONS IN ARRAYS* C 260 X=RM(1) RM(1)=RM(2) RM(2)=X X=EM(1) EM(1)=EM(2) EM(2)=X IX=IA(1) IA(1)=IA(2) IA(2)=IX IX=IZ(1) IZ(1)=IZ(2) IZ(2)=IX RETURN C C *ERROR MESSAGES* C 270 IFLAG=1 RM(J)=999.0 Q=999.0 EQ=999.0 EM(J)=999.0 IA(J)=0 IZ(J)=0 GOTO 260 END SUBROUTINE UCASE(LINEIN) * * CONVERT LOWER CASE TO UPPER CASE IF APPROPRIATE * LOGICAL*1 LINEIN(24) DO 20 J=1,24 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