$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        <RETURN> 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
