home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTH / 4THPROG.ZIP / EDITS.FOR < prev    next >
Encoding:
Text File  |  1985-09-18  |  7.6 KB  |  257 lines
  1. $TITLE: 'EDIT Spectrum'
  2. $LARGE R,SPECT1,IPTS,IMAGE
  3. $NOFLOATCALLS
  4.       SUBROUTINE EDITS(IDLSP,R,SPECT1,IPTS,IMAGE,GMODE)
  5.       REAL*4 R(10,640),SPECT1(10,640)
  6.       CHARACTER*1 RCHR,ANSW,F2CHR*30,LABEL*60
  7.       LOGICAL IEXIST
  8.       INTEGER IPTS(10),GMODE
  9.       INTEGER*4 IMAGE(8000),SAVE(8000)
  10.       INTEGER*2  CH,L1,R1,FH,ST,BFIT,EFIT
  11.        REAL DUMSP(640),DUMX(640)
  12.        REAL*8 CDBLP(3,3),RSDBLP(3),QDBLP,QQDBLP
  13. C
  14. C  An interactive visual editor for changing the y values 
  15. C  of the data by simply moving a cursor around.
  16. C
  17. C
  18. C    The following functions can be performed by this subroutine:
  19. C
  20. C
  21. C    *start over with the original data
  22. C         command-    '-'  pressing this key erases everything and
  23. C                           starts over.
  24. C
  25. C    *exit the subroutine
  26. C         commands-    Q   quits and returns to main program as if 
  27. C                            nothing had been done to the data.
  28. C                      F   finish manipulating the data and display-
  29. C                          returns to the main program with the screen
  30. C                          image intact and with any changes made to the
  31. C                          data (e.g. background corrected, etc.).
  32. C
  33. C     *obtain printer output
  34. C         command-     G   dump screen image to printer
  35. C
  36. C
  37. C     *write the data to a disk file
  38. C         command-     W   you will be prompted for a file name.
  39. C
  40. C     *change y values of points on the screen image
  41. C         commands-    E   key to push so you will be able to change
  42. C                          the y position and value of the point at the 
  43. C                          current cursor position.
  44. C
  45. C                      8   move up        | With the NumLck key
  46. C                      9   move up fast   | is lit on the IBM
  47. C                      6   move right     | keyboard this key
  48. C                      +   move right fast| arrangement really
  49. C                      2   move down      | does make some
  50. C                      3   move down fast | sense
  51. C                      4   move left      |
  52. C                 <RETURN> move left fast |
  53. C
  54. C                      Q   quit editing this point.
  55. C
  56.  10    L1=1
  57.        R1=10
  58.        CH=1
  59.        BFIT=1
  60.        EFIT=IPTS(IDLSP)
  61.        IINT=IPTS(IDLSP)
  62. C
  63.        DO 50 J=1,IINT
  64.          DUMX(J)=R(IDLSP,J)
  65.  50      DUMSP(J)=SPECT1(IDLSP,J)
  66. C
  67.        CALL INQWOR(XW1,YW1,XW2,YW2)
  68.        CALL WORLDO
  69.        CALL INQDRA(IXMX,IYMX)
  70.        CALL MOVEFR(0,0,IXMX,IYMX,SAVE(1))
  71.        CALL INITHC(10,10,1)
  72.        CALL SETWOR(XW1,YW1,XW2,YW2)
  73.  100   CALL INKEY(RCHR)
  74.        X=R(IDLSP,CH)
  75.        Y=DUMSP(CH)
  76.        CALL MOVHCA(X,Y)
  77.        IF(RCHR.EQ.CHAR(0)) GO TO 100
  78.        IF(RCHR.EQ.'4') THEN
  79. C
  80. C        CURSOR LEFT
  81. C
  82.          CH=CH-1
  83.          IF (CH.LT.1) CH=1                                    
  84.          GO TO 100
  85.        ENDIF
  86.        IF(RCHR.EQ.CHAR(13)) THEN
  87.          CH=CH-5
  88.          IF(CH.LT.1) CH=1
  89.          GO TO 100
  90.        ENDIF
  91.        IF(RCHR.EQ.'6') THEN
  92. C
  93. C        CURSOR RIGHT
  94. C
  95.          CH=CH + 1
  96.          IF (CH.GT.IINT) CH=IINT
  97.          GO TO 100
  98.        ENDIF
  99.        IF(RCHR.EQ.'+') THEN
  100.          CH=CH+5
  101.          IF(CH.GT.IINT) CH=IINT
  102.          GO TO 100
  103.        ENDIF
  104. C-------------
  105. C
  106. C     Let's start over
  107.        IF(RCHR.EQ.'-') GO TO 200
  108.        IF((RCHR.EQ.'W').OR.(RCHR.EQ.'w')) GO TO 1380
  109.        IF((RCHR.EQ.'E').OR.(RCHR.EQ.'e')) GO TO 1600
  110.        IF((RCHR.EQ.'F').OR.(RCHR.EQ.'f')) GO TO 1900
  111.        IF((RCHR.EQ.'Q').OR.(RCHR.EQ.'q')) GO TO 2000
  112.        GO TO 100
  113. C
  114. C    START OVER
  115. C
  116.  200   CALL WORLDO
  117.        CALL MOVETO(0,0,SAVE(1),1)
  118.        CALL INITHC(10,10,1)
  119.        CALL SETWOR(XW1,YW1,XW2,YW2)
  120.        GO TO 10
  121. C
  122. C       REM WRITE RESULTS
  123. C
  124.  1380  CONTINUE
  125.        CALL INQWOR(XW1,YW1,XW2,YW2)
  126.        CALL WORLDO
  127.        CALL INQDRA(IXMX,IYMX)
  128.        CALL MOVEFR(0,0,IXMX,IYMX,IMAGE(1))
  129.  1385  WRITE(0,'(A\)')'  OUTPUT FILENAME: '
  130.        READ(0,'(A)') F2CHR
  131.        INQUIRE(FILE=F2CHR,EXIST=IEXIST)
  132.        IF(IEXIST) THEN
  133.          WRITE(0,'(A\)') ' File exists- overwrite it (Y/N): '
  134.          READ(0,'(A)')ANSW
  135.          IF((ANSW.EQ.'Y').OR.(ANSW.EQ.'y')) THEN
  136.            OPEN(4,FILE=F2CHR,STATUS='OLD')
  137.          ELSE
  138.            GO TO 1385
  139.          ENDIF
  140.        ELSE
  141.          OPEN(4,FILE=F2CHR,STATUS='NEW')
  142.        ENDIF
  143. C
  144.  1386  WRITE(0,'(A\)') ' 1 OR 2 COLUMN FILETYPE (1/2): '
  145.        READ(0,*,ERR=1386) IFLTYP
  146.        IF(IFLTYP.EQ.1) THEN
  147.          WRITE(4,*,ERR=1435) IFLTYP
  148.          DO 1430 J=1,IINT
  149.            WRITE(4,*,ERR=1435) DUMSP(J)
  150.  1430   CONTINUE
  151.        ELSEIF(IFLTYP.EQ.2) THEN
  152.          WRITE(4,*,ERR=1435) IFLTYP
  153.          DO 1433 J=1,IINT
  154.            WRITE(4,*,ERR=1435) R(IDLSP,J),DUMSP(J)
  155.  1433    CONTINUE
  156.        ELSE
  157.          GO TO 1386
  158.        ENDIF
  159.  1435  CLOSE(4,STATUS='KEEP')
  160.        CALL MOVETO(0,0,IMAGE(1),1)
  161.        CALL SETWOR(XW1,YW1,XW2,YW2)
  162.        GO TO 100
  163. C
  164. C   POINT EDITING ROUTINE
  165. C
  166.  1600 CONTINUE
  167.       CALL INQHCU(X,Y,IC)
  168.       CALL MAPWTD(X,Y,IX,IY)
  169.       CALL WORLDO
  170.       CALL INQDRA(IXMX,IYMX)
  171.       CALL MOVEFR(0,0,IXMX,IYMX,IMAGE(1))
  172.       ISTART=CH-1
  173.       ISTOP=CH +1
  174.       IPTH=0
  175.       MODE=0
  176.       CALL SETXOR(1)
  177.       CALL MOVHCA(IX,IY)
  178.  1610 CALL GETCHR(RCHR)
  179.       IF(RCHR.EQ.'2') THEN
  180.          CALL MOVHCR(0,1)
  181.          CALL INQHCU(IX,IY,IC)
  182.          CALL SETWOR(XW1,YW1,XW2,YW2)
  183.          CALL MAPDTW(IX,IY,X,Y)
  184.          CALL MOVABS(DUMX(ISTART),DUMSP(ISTART))
  185.          CALL POLYLA(DUMX(CH),DUMSP(CH),2)
  186.          DUMSP(CH)=Y
  187.          CALL MOVABS(DUMX(ISTART),DUMSP(ISTART))
  188.          CALL POLYLA(DUMX(CH),DUMSP(CH),2)
  189.          CALL WORLDO
  190.          CALL MOVHCA(IX,IY)
  191.       ELSEIF(RCHR.EQ.'3') THEN
  192.          CALL MOVHCR(0,5)
  193.          CALL INQHCU(IX,IY,IC)
  194.          CALL SETWOR(XW1,YW1,XW2,YW2)
  195.          CALL MAPDTW(IX,IY,X,Y)
  196.          CALL MOVABS(DUMX(ISTART),DUMSP(ISTART))
  197.          CALL POLYLA(DUMX(CH),DUMSP(CH),2)
  198.          DUMSP(CH)=Y
  199.          CALL MOVABS(DUMX(ISTART),DUMSP(ISTART))
  200.          CALL POLYLA(DUMX(CH),DUMSP(CH),2)
  201.          CALL WORLDO
  202.          CALL MOVHCA(IX,IY)
  203.       ELSEIF(RCHR.EQ.'8') THEN
  204.          CALL MOVHCR(0,-1)
  205.          CALL INQHCU(IX,IY,IC)
  206.          CALL SETWOR(XW1,YW1,XW2,YW2)
  207.          CALL MAPDTW(IX,IY,X,Y)
  208.          CALL MOVABS(DUMX(ISTART),DUMSP(ISTART))
  209.          CALL POLYLA(DUMX(CH),DUMSP(CH),2)
  210.          DUMSP(CH)=Y
  211.          CALL MOVABS(DUMX(ISTART),DUMSP(ISTART))
  212.          CALL POLYLA(DUMX(CH),DUMSP(CH),2)
  213.          CALL WORLDO
  214.          CALL MOVHCA(IX,IY)
  215.       ELSEIF(RCHR.EQ.'9') THEN
  216.          CALL MOVHCR(0,-5)
  217.          CALL INQHCU(IX,IY,IC)
  218.          CALL SETWOR(XW1,YW1,XW2,YW2)
  219.          CALL MAPDTW(IX,IY,X,Y)
  220.          CALL MOVABS(DUMX(ISTART),DUMSP(ISTART))
  221.          CALL POLYLA(DUMX(CH),DUMSP(CH),2)
  222.          DUMSP(CH)=Y
  223.          CALL MOVABS(DUMX(ISTART),DUMSP(ISTART))
  224.          CALL POLYLA(DUMX(CH),DUMSP(CH),2)
  225.          CALL WORLDO
  226.          CALL MOVHCA(IX,IY)
  227.       ELSEIF((RCHR.EQ.'Z').OR.(RCHR.EQ.'z')) THEN
  228.          CALL SETWOR(XW1,YW1,XW2,YW2)
  229.          CALL MOVABS(DUMX(ISTART),DUMSP(ISTART))
  230.          CALL POLYLA(DUMX(CH),DUMSP(CH),2)
  231.          DUMSP(CH)=SPECT1(IDLSP,CH)
  232.          CALL MOVABS(DUMX(ISTART),DUMSP(ISTART))
  233.          CALL POLYLA(DUMX(CH),DUMSP(CH),2)
  234.          CALL MOVHCA(DUMX(CH),DUMSP(CH))
  235.          CALL WORLDO
  236.       ELSEIF((RCHR.EQ.'Q').OR.(RCHR.EQ.'q')) THEN
  237.          GO TO 1620
  238.       ENDIF
  239.       GO TO 1610
  240.  1620 CONTINUE
  241.       CALL SETXOR(0)
  242.       CALL SETWOR(XW1,YW1,XW2,YW2)
  243.       GO TO 100
  244. C**********************  END POINT EDITING ROUTINE
  245. C
  246. C   EXIT
  247. C
  248.  1900  CONTINUE
  249.        DO 1905 J=1,IPTS(IDLSP)
  250.  1905    SPECT1(IDLSP,J)=DUMSP(J)
  251. C
  252. C   QUIT
  253. C
  254.  2000  CONTINUE
  255.        RETURN
  256.        END
  257.