C PROGRAMME FOR GENERAL Q VALUES C REACTION T(P,A,B,C,D......) WHERE A... ARE FROM 0 TO 6 PARTICLES REAL*8 M(12),QGS,QERROR,RMERR(12) CHARACTER ANSWER*1 INTEGER ISIP,ISOP,IDOP LOGICAL*1 LINEIN(64),IBLANK DIMENSION IM(12),IZ(12) DATA IBLANK/' '/ ISIP=5 ISOP=6 IDOP=6 WRITE(ISOP,*) +'Do you want output redirected from screen to stream 8 Y/N ?' READ(ISIP,'(A1)') ANSWER IF (ANSWER.EQ.'Y'.OR.ANSWER.EQ.'y') THEN OPEN (8,FILE='qvalue_out') IDOP=8 ENDIF 10 WRITE(ISOP,1000) 1000 FORMAT(1H ,'ENTER REACTION T(P,A,B,C,....) OR RETURN TO END',/ 1,' WHERE T=TARGET, P=PROJECTILE, AND A,B,C.... ARE FROM 0 TO 6 OU 1TGOING PARTICLES',/,' E.G. 12C(1H), 28SI(12C,16O), 118SN(40AR,1 +1 N,1 N,1 N,1 N) (A 4N REACTION)') READ(ISIP,1010) (LINEIN(I),I=1,64) 1010 FORMAT(64A1) IF(LINEIN(1).EQ.IBLANK) GO TO 200 CALL GREACT(M,QGS,QERROR,RMERR,IM,IZ,IFLAG,NPART,LINEIN) IF(IFLAG.EQ.1) WRITE(IDOP,1020) 1020 FORMAT(1H ,'ONE OR MORE REQUIRED SYMBOLS NOT IN MASS FILE') IF(IFLAG.EQ.1) GO TO 10 WRITE(IDOP,1040) (LINEIN(I),I=1,64) 1040 FORMAT(1H ,//,80(1H-),/,64A1) WRITE(IDOP,1050) IZ(2),IZ(1),(IZ(I),I=3,NPART) 1050 FORMAT(1H 'Z ',9I10) WRITE(IDOP,1060) M(2),M(1),(M(I),I=3,NPART) 1060 FORMAT(1H ,'M(AMU) ',9F10.5) WRITE(IDOP,1070) RMERR(2),RMERR(1),(RMERR(I),I=3,NPART) 1070 FORMAT(1H ,'ERR(KEV)',9F10.2) WRITE(IDOP,1080) QGS,QERROR 1080 FORMAT(1H ,'QGS=',F8.3,' +/-',F8.4,' MEV') IF(IFLAG.EQ.2) WRITE(IDOP,1030) 1030 FORMAT(1H ,'ONE OR MORE MASSES ARE INTERPOLATED VALUES WITH ASSIGN 1ED ERROR NEGATIVE') WRITE(IDOP,1090) 1090 FORMAT(1H ,79(1H-),//) GO TO 10 200 CONTINUE STOP 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(64) REACTION (READ AS 64A1 FORMAT) C OUTPUT:RM(12) MASSES(AMU)................DOUBLE PRECISION C Q REACTION Q-VALUE (MEV)........DOUBLE PRECISION C EQ ERROR ON Q-VALUE (MEV)........DOUBLE PRECISION C EM(12) ERROR IN MASSES (KEV)......DOUBLE PRECISION C IA(12) MASSES C IZ(12) 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 NPART NUMBER OF PARTICLES IN REACTION C C SUBROUTINE GREACT(RM,Q,EQ,EM,IA,IZ,IFLAG,J,LINEIN) LOGICAL*1 LINEIN(64),NUM(3),LET(2),NOS(10), +BLANK,OPEN,CLOSE,COMMA INTEGER*2 ATOM,NUCNAM(110),NAME INTEGER MAXIZ,IAMIN(0:12),IAMAX(0:12),IREC(0:12),INF,IINF CHARACTER FORMAT(3)*4,BUFF*24 REAL*8 RM(12),EM(12),Q,EQ,AM(12),X,RMASS,ERRM CHARACTER * (*) MASFIL REAL CKZ,DCZ,DELCKZ,DELPA,DELSN,DELWAH,JM,MEA,MJ, + MN,PA,SJ,SN,TEA,WAH DIMENSION IA(12),IZ(12) 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='/usr/local/libm/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 * CALL CONECT('LOCAL.USERPROG.DATA.MASS83',5) OPEN(7,STATUS='OLD',ACCESS='DIRECT',RECL=64,FILE=MASFIL) IFIRST=1 10 IFLAG=0 IFIN=0 DO 20 IJ=1,12 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 J=0 21 J=J+1 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 IF (LINEIN(L1).EQ.CLOSE) IFIN=1 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 * CALL DEFBUF(13,LENFLD,NUM) * 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 RESIDUAL NUCLEI* C 130 IF (IFIN.EQ.1.AND.J.EQ.2) GOTO 132 IZT=0 IAT=0 DO 131 IT=3,J IZT=IZT+IZ(IT) IAT=IAT+IA(IT) 131 CONTINUE IFIN=2 J=J+1 IZ(J)=IZ(1)+IZ(2)-IZT IA(J)=IA(1)+IA(2)-IAT GOTO 140 132 IFIN=2 J=J+1 IZ(J)=IZ(1)+IZ(2) IA(J)=IA(1)+IA(2) C C *OBTAINING DATA FROM MASS FILE* C 140 IF (IZ(J).LT.0.OR.IA(J).LT.0) GOTO 270 IF (IZ(J).GT.MAXIZ) GOTO 270 * KEYPTR=IZ(J)+1 * READ(5,REC=KEYPTR)IAMIN,IAMAX,MSTART,NAME * IF (IA(J).LT.IAMIN.OR.IA(J).GT.IAMAX) GOTO 270 * KEYPTR=IA(J)-IAMIN+MSTART * READ(5,REC=KEYPTR)RMASS,ERRM 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=DBLE(WAH)*1000.0D0 ERRM=DBLE(DELWAH)*1000.0D0 ELSE RMASS=DBLE(MN)*1000.0D0 IFLAG=2 ENDIF C C *CALCULATION DATA PUT INTO ARRAYS* C IF (ERRM.LT.0.0) IFLAG=2 RM(J)=RMASS/DBLE(AMU)+DBLE(IA(J)) AM(J)=RMASS EM(J)=ERRM IF (IFIN.EQ.1) GOTO 130 IF (IFIN.EQ.2) GOTO 170 GOTO 21 C C *CONVERTING Z OF RESIDUAL NUCLEI INTO NUCLEI SYMBOL* C * AND CHANGING INTEGER A INTO CHARACTER A * C 170 IH=0 N4=IA(J) IF (IA(J).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 * CALL DEFBUF(13,2,NAME) * READ(13,250)(LINEIN(I),I=N1,NF) NAME=NUCNAM(IZ(J)+1) WRITE(BUFF,'(Z4)') NAME READ(BUFF,'(2Z2)') (LINEIN(I),I=N1,NF) 250 FORMAT(2A1) NF=NF+1 DO 251 IB=NF,64 LINEIN(IB)=BLANK 251 CONTINUE C C *CALCULATING QVALUE AND ERROR* C Q=AM(1)+AM(2) EQ=EM(1)**2+EM(2)**2 DO 252 IQ=3,J Q=Q-AM(IQ) EQ=EQ+EM(IQ)**2 252 CONTINUE Q=Q/1000.0 EQ=DSQRT(EQ)/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(64) DO 20 J=1,64 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