$TITLE:' MANIPUTLATE AND LABEL SPECTRUM' $LARGE R,SPECT1,IPTS,IMAGE $NOFLOATCALLS SUBROUTINE MANSPT(IDLSP,R,SPECT1,IPTS,IMAGE,GMODE) REAL*4 R(10,640),SPECT1(10,640) CHARACTER*1 RCHR,ANSW,F2CHR*30,LABEL*60,FONTXT*20,CHR LOGICAL IEXIST INTEGER IPTS(10),GMODE,GXM,GYM INTEGER*4 IMAGE(8000),SAVE(8000) INTEGER*2 CH,L1,R1,FH,ST,BFIT,EFIT REAL DUMSP(640) REAL*8 CDBLP(3,3),RSDBLP(3),QDBLP,QQDBLP C C The following functions can be performed by this subroutine: C C *fit the spectrum background to a 2nd order curve C C commands- B begin fit at current cursor position C L set current cursor position as the left C side of the peak. C R set current cursor position as the right C side of the peak. C E end fit at current cursor position. C C compute the polynomial fit. C X remove the background from the data between C the points B and E and display the C corrected data. C O overlay the background curve between the C points B and E. C A compute the area between the points L and R C taking into account the background curve C fit. (Function X does not have to have been C done for this to work, however, function C C must have been performed.) C C The data points between B and E (except those points between C L and R) are fitted to a 2nd order polynomial C y= AA*X**2 + BB*X + CC C using a weighted least squares routine. The weighting is C just 1/(square root of the counts). NOTE: the fit will fail C unless B is less than L is less than R is less than E. C C *start over with the original data C command- '-' pressing this key erases everything and C starts over. C C *exit the subroutine C commands- Q quits and returns to main program as if C nothing had been done to the data. C F finish manipulating the data and display- C returns to the main program with the screen C image intact and with any changes made to the C data (e.g. background corrected, etc.). C C *obtain printer output C command- G dump screen image to printer C C C *write the data to a disk file C command- W you will be prompted for a file name. C C *place labels on the screen image C commands- C T first key to push. you will be prompted C for the text of the label. NOTE the first and C last charachters must be unique: C C \peak area = 19654 counts\ C !the exclamation points are unique! C C C 8 move up | With the NumLck key C 9 move up fast | is lit on the IBM C 6 move right | keyboard this key C + move right fast| arrangement really C 2 move down | does make some C 3 move down fast | sense C 4 move left | C move left fast | C C L display the label starting at cursor position. C E erase the label. If the label is not displayed C the results are unpredictable. C Z allows you to change the height, width, writing C direction(path), and writing mode. C height and width can be 1,2,3 but not 1.5,2.3 C direction 0 horizontal C 1 at 90 deg to horizontal C 2 upside down and backwards C 3 at 270 deg to horizontal C mode 0 or 1 unboxed or boxed. C Q quit the labeling routine. C 10 L1=1 R1=10 CH=1 BFIT=1 EFIT=IPTS(IDLSP) IINT=IPTS(IDLSP) C C default label text parameters IHT=1 IWDTH=1 IPTH=0 MODE=0 C DO 50 J=1,IINT 50 DUMSP(J)=SPECT1(IDLSP,J) C CALL INQWOR(XW1,YW1,XW2,YW2) CALL WORLDO CALL INQDRA(GXM,GYM) CALL MOVEFR(0,0,GXM,GYM,SAVE(1)) CALL INITHC(10,10,1) CALL SETWOR(XW1,YW1,XW2,YW2) 100 CALL INKEY(RCHR) X=R(IDLSP,CH) Y=DUMSP(CH) CALL MOVHCA(X,Y) IF(RCHR.EQ.CHAR(0)) GO TO 100 IF(RCHR.EQ.'4') THEN C C CURSOR LEFT C CH=CH-1 IF (CH.LT.1) CH=1 GO TO 100 ENDIF IF(RCHR.EQ.CHAR(13)) THEN CH=CH-5 IF(CH.LT.1) CH=1 GO TO 100 ENDIF IF(RCHR.EQ.'6') THEN C C CURSOR RIGHT C CH=CH + 1 IF (CH.GT.IINT) CH=IINT GO TO 100 ENDIF IF(RCHR.EQ.'+') THEN CH=CH+5 IF(CH.GT.IINT) CH=IINT GO TO 100 ENDIF IF((RCHR.EQ.'R').OR.(RCHR.EQ.'r')) R1=CH IF((RCHR.EQ.'L').OR.(RCHR.EQ.'l')) L1=CH IF((RCHR.EQ.'B').OR.(RCHR.EQ.'b')) BFIT=CH IF((RCHR.EQ.'E').OR.(RCHR.EQ.'e')) EFIT=CH IF((RCHR.EQ.'C').OR.(RCHR.EQ.'c')) GO TO 450 IF((RCHR.EQ.'X').OR.(RCHR.EQ.'x')) GO TO 1130 IF(RCHR.EQ.'-') GO TO 200 IF((RCHR.EQ.'A').OR.(RCHR.EQ.'a')) GO TO 1210 IF((RCHR.EQ.'O').OR.(RCHR.EQ.'o')) GO TO 1300 IF((RCHR.EQ.'W').OR.(RCHR.EQ.'w')) GO TO 1380 IF((RCHR.EQ.'T').OR.(RCHR.EQ.'t')) GO TO 1600 IF((RCHR.EQ.'G').OR.(RCHR.EQ.'g')) GO TO 1700 IF((RCHR.EQ.'F').OR.(RCHR.EQ.'f')) GO TO 1900 IF((RCHR.EQ.'Q').OR.(RCHR.EQ.'q')) GO TO 2000 GO TO 100 C C START OVER C 200 CALL WORLDO CALL MOVETO(0,0,SAVE(1),1) CALL INITHC(10,10,1) GO TO 10 C C DO 2ND ORDER FIT 450 CONTINUE DO 490 J=1,3 RSDBLP(J)=0. DO 490 I=1,3 CDBLP(J,I)=0. 490 CONTINUE FH=L1 ST=BFIT IF (ST.GT.FH) ST=1 C C REM COMPUTE COEF. AND RHS C DO 500 J=ST,FH QDBLP=0. IF(DUMSP(J).NE.0.)QDBLP=1./SQRT(DUMSP(J)) CDBLP(3,3)=CDBLP(3,3)+QDBLP RSDBLP(3)=RSDBLP(3) +DUMSP(J)*QDBLP QDBLP=QDBLP*R(IDLSP,J) CDBLP(2,3)=CDBLP(2,3) + QDBLP RSDBLP(2)=RSDBLP(2) + DUMSP(J)*QDBLP QDBLP=QDBLP*R(IDLSP,J) CDBLP(1,3)=CDBLP(1,3) + QDBLP RSDBLP(1)=RSDBLP(1) + DUMSP(J)*QDBLP QDBLP=R(IDLSP,J)*QDBLP CDBLP(1,2)=CDBLP(1,2) + QDBLP CDBLP(1,1)=CDBLP(1,1) + QDBLP*R(IDLSP,J) 500 CONTINUE C FH=EFIT ST=R1 IF (FH.LT.ST) FH=IINT C DO 600 J=ST,FH QDBLP=0. IF(DUMSP(J).NE.0.) QDBLP=1./SQRT(DUMSP(J)) CDBLP(3,3)=CDBLP(3,3)+QDBLP RSDBLP(3)=RSDBLP(3) +DUMSP(J)*QDBLP QDBLP=QDBLP*R(IDLSP,J) CDBLP(2,3)=CDBLP(2,3) + QDBLP RSDBLP(2)=RSDBLP(2) + DUMSP(J)*QDBLP QDBLP=QDBLP*R(IDLSP,J) CDBLP(1,3)=CDBLP(1,3) + QDBLP RSDBLP(1)=RSDBLP(1) + DUMSP(J)*QDBLP QDBLP=R(IDLSP,J)*QDBLP CDBLP(1,2)=CDBLP(1,2) + QDBLP CDBLP(1,1)=CDBLP(1,1) + QDBLP*R(IDLSP,J) 600 CONTINUE C CDBLP(2,1)=CDBLP(1,2) CDBLP(2,2)=CDBLP(1,3) CDBLP(3,1)=CDBLP(1,3) CDBLP(3,2)=CDBLP(2,3) DO 740 J=1,2 QQDBLP=CDBLP(J,J) DO 660 I=J,3 CDBLP(J,I)=CDBLP(J,I)/QQDBLP 660 CONTINUE RSDBLP(J)=RSDBLP(J)/QQDBLP DO 740 I=J+1,3 QQDBLP=CDBLP(I,J) DO 720 M=1,3 CDBLP(I,M)=CDBLP(I,M) - QQDBLP*CDBLP(J,M) 720 CONTINUE RSDBLP(I)=RSDBLP(I) - QQDBLP*RSDBLP(J) 740 CONTINUE CC=RSDBLP(3)/CDBLP(3,3) BB=RSDBLP(2) - CC*CDBLP(2,3) AA=RSDBLP(1) - BB*CDBLP(1,2) - CC*CDBLP(1,3) C CALL INQWOR(XW1,YW1,XW2,YW2) CALL WORLDO CALL INQDRA(GXM,GYM) CALL MOVEFR(0,0,GXM,GYM,IMAGE(1)) WRITE(0,*) AA,BB,CC CALL GETCHR(CHR) CALL MOVETO(0,0,IMAGE(1),1) CALL SETWOR(XW1,YW1,XW2,YW2) GO TO 100 C C REM SUBTRACT BACKGROUND C 1130 CONTINUE DO 1190 J=BFIT,EFIT DUMSP(J)=DUMSP(J) - ((AA*R(IDLSP,J) + BB)*R(IDLSP,J) +CC) IF (DUMSP(J).LT.0) DUMSP(J)=0 1190 CONTINUE CALL REPLOT(IDLSP,R,DUMSP,IPTS,GMODE) CALL WORLDO CALL INQDRA(GXM,GYM) CALL MOVEFR(0,0,GXM,GYM,IMAGE(1)) CALL SETWOR(XW1,YW1,XW2,YW2) X=R(IDLSP,CH) Y=DUMSP(CH) CALL MOVHCA(X,Y) GO TO 100 C C REM COMPUTE AREA OF PEAK C 1210 AR=0 DO 1250 J=L1,R1 AR=SPECT1(IDLSP,J) - ((AA*R(IDLSP,J) +BB)*R(IDLSP,J) + CC)+AR 1250 CONTINUE C CALL INQWOR(XW1,YW1,XW2,YW2) CALL WORLDO CALL INQDRA(GXM,GYM) CALL MOVEFR(0,0,GXM,GYM,IMAGE(1)) WRITE(0,*)'PEAK AREA =',AR CALL GETCHR(CHR) CALL MOVETO(0,0,IMAGE(1),1) CALL SETWOR(XW1,YW1,XW2,YW2) GO TO 100 C C REM OVERLAY BACKGROUND C 1300 CONTINUE CALL SETLNS(2) DO 1360 J=BFIT,EFIT Y=(AA*R(IDLSP,J) +BB)*R(IDLSP,J) + CC X=R(IDLSP,J) IF(J.EQ.BFIT) THEN CALL MOVABS(X,Y) ELSE CALL LNABS(X,Y) ENDIF 1360 CONTINUE CALL SETLNS(1) GO TO 100 C C REM WRITE RESULTS C 1380 CONTINUE CALL INQWOR(XW1,YW1,XW2,YW2) CALL WORLDO CALL INQDRA(GXM,GYM) CALL MOVEFR(0,0,GXM,GYM,IMAGE(1)) WRITE(0,'(A\)')' OUTPUT FILENAME: ' READ(0,'(A)') F2CHR INQUIRE(FILE=F2CHR,EXIST=IEXIST) IF(IEXIST) THEN WRITE(0,'(A\)') ' File exists- overwrite it (Y/N): ' READ(0,'(A)')ANSW IF((ANSW.EQ.'Y').OR.(ANSW.EQ.'y')) THEN OPEN(4,FILE=F2CHR,STATUS='OLD') ELSE GO TO 1380 ENDIF ELSE OPEN(4,FILE=F2CHR,STATUS='NEW') ENDIF C 1383 WRITE(0,'(A\)') ' 1 OR 2 COLUMN TYPE FILE (1/2): ' READ(0,*,ERR=1383) IFLTYP IF(IFLTYP.EQ.1) THEN WRITE(4,*,ERR=1435) IFLTYP DO 1430 J=1,IINT WRITE(4,'(1X,F8.1)',ERR=1435) DUMSP(J) 1430 CONTINUE ELSEIF(IFLTYP.EQ.2) THEN WRITE(4,*,ERR=1435) IFLTYP DO 1432 J=1,IINT WRITE(4,'(1X,F10.5,1X,F8.1)',ERR=1435) R(IDLSP,J),DUMSP(J) 1432 CONTINUE ELSE GO TO 1383 ENDIF 1435 CLOSE(4,STATUS='KEEP') CALL MOVETO(0,0,IMAGE(1),1) CALL SETWOR(XW1,YW1,XW2,YW2) GO TO 100 C C LABELING ROUTINE C 1600 CONTINUE CALL WORLDO CALL INQDRA(GXM,GYM) CALL MOVEFR(0,0,GXM,GYM,IMAGE(1)) 1605 WRITE(0,'(A\)') ' TYPE IN TEXT FOR LABEL:' READ(0,'(A)') LABEL CALL MOVETO(0,0,IMAGE(1),1) CALL SETTEX(IHT,IWDTH,IPTH,MODE) CALL SETTCL(1,0) CALL INITTC(8,8,1) CALL SETXOR(1) 1610 CALL GETCHR(RCHR) IF(RCHR.EQ.'2') THEN CALL MOVTCR(0,1) ELSEIF(RCHR.EQ.'3') THEN CALL MOVTCR(0,5) ELSEIF(RCHR.EQ.'6') THEN CALL MOVTCR(1,0) ELSEIF(RCHR.EQ.'+') THEN CALL MOVTCR(5,0) ELSEIF(RCHR.EQ.'8') THEN CALL MOVTCR(0,-1) ELSEIF(RCHR.EQ.'9') THEN CALL MOVTCR(0,-5) ELSEIF(RCHR.EQ.'4') THEN CALL MOVTCR(-1,0) ELSEIF(RCHR.EQ.CHAR(13)) THEN CALL MOVTCR(-5,0) ELSEIF((RCHR.EQ.'L').OR.(RCHR.EQ.'l')) THEN CALL INQTCU(IX,IY,ICOL) CALL TEXT(LABEL) ELSEIF((RCHR.EQ.'E').OR.(RCHR.EQ.'e')) THEN CALL MOVTCA(IX,IY) CALL TEXT(LABEL) CALL MOVTCA(IX,IY) ELSEIF((RCHR.EQ.'Z').OR.(RCHR.EQ.'z')) THEN CALL INQDRA(GXM,GYM) CALL MOVEFR(0,0,GXM,GYM,IMAGE(1)) 1606 WRITE(0,'(A\)') ' HEIGHT(int),WIDTH(int),PATH(int),MODE(int):' READ(0,*,ERR=1606) IHT,IWDTH,IPTH,MODE CALL MOVETO(0,0,IMAGE(1),1) CALL SETTEX(IHT,IWDTH,IPTH,MODE) ELSEIF((RCHR.EQ.'Q').OR.(RCHR.EQ.'q')) THEN GO TO 1620 ENDIF GO TO 1610 1620 CONTINUE CALL DELTCU CALL SETXOR(0) CALL SETWOR(XW1,YW1,XW2,YW2) GO TO 100 C********************** END LABELING ROUTINE C C GRAPH TO PRINTER C 1700 CONTINUE CALL WORLDO CALL DELHCU CALL INQDRA(GXM,GYM) CALL MOVEFR(0,0,GXM,GYM,IMAGE(1)) WRITE(0,*) ' READY PRINTER AND PRESS ANY KEY' CALL GETCHR(RCHR) WRITE(0,'(A\)')' Half of Full height dump (H/F): ' READ(0,'(A)') RCHR CALL MOVETO(0,0,IMAGE(1),1) IF((RCHR.EQ.'H').OR.(RCHR.EQ.'h')) THEN CALL PLOT1 ELSE CALL PLOT2 ENDIF CALL INITHC(10,10,1) CALL SETWOR(XW1,YW1,XW2,YW2) GO TO 100 C C EXIT C 1900 CONTINUE DO 1905 J=1,IPTS(IDLSP) 1905 SPECT1(IDLSP,J)=DUMSP(J) C C QUIT C 2000 CONTINUE RETURN END SUBROUTINE REPLOT(ID,R,DUMSP,IPTS,GMODE) INTEGER GMODE DIMENSION R(10,640),DUMSP(640),IPTS(10),DUMX(640) CALL INQWOR(XW1,YW1,XW2,YW2) CALL WORLDO CALL CLOSEG CALL INITGR(GMODE) CALL SETIEE(1) CALL INQDRA(IXM,IYM) CALL MOVABS(0,0) CALL LNABS(0,IYM) CALL LNABS(IXM,IYM) JMAX=IPTS(ID)-1 CALL SETWOR(XW1,YW1,XW2,YW2) CALL MOVABS(R(ID,1),DUMSP(1)) DO 255 J=1,IPTS(ID) 255 DUMX(J)=R(ID,J) CALL POLYLA(DUMX(2),DUMSP(2),JMAX) CALL SETGPR(2) RETURN END