home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTH / 4THPROG.ZIP / EFFIXSP.FOR < prev    next >
Encoding:
Text File  |  1985-07-17  |  11.3 KB  |  337 lines
  1. $DEBUG
  2. $LARGE
  3. $NOFLOATCALLS
  4.       DIMENSION R(10,640),SCAT1(10,640),IPTS(10)
  5.       REAL DUMX(640),DUMY(640),KEVPC
  6.       CHARACTER*64 FNAME(10),ANSW(128)*1,CHR*1,F2CHR,ANSW1*1
  7.       INTEGER IMAGE(4009),KEEP(4009),IFUN
  8.       LOGICAL IEXIST
  9. C
  10. C  IPTS(j)         Number of points in spectrum j
  11. C  NSPT            Number of spectrums
  12. C  FNAME(j)        File name of spectrum j
  13. C  R,SCAT1         X and Y data for each spectrum
  14. C  DUMX,DUMY       Dummy vectors used when calling
  15. C                     some of the HALO routines.
  16. C  BASE,KEVPC      Two types of data files are used: 1) file has
  17. C                  two columns of numbers representing the X and
  18. C                  Y values, and 2) file has only one column of 
  19. C                  numbers representing the Y values.  When file
  20. C                  type 2 is read the X values are computed assuming
  21. C                  the points are equally spaced.  BASE is the X value
  22. C                  of the first point and KEVPC is the distance between
  23. C                  successive points.
  24. C
  25. C  IMAGE           Copy of the last graphics screen image
  26. C                      automatically saved each time.
  27. C  KEEP            Copy of a graphics screen image manually
  28. C                      saved by the user.
  29. C  GETCHR          Is a function which uses a machine language routine
  30. C                  to poll the keyboard for input.  The user does not
  31. C                  need to press the RETURN key as when a READ statement
  32. C                  is used.  Most important when using the graphics 
  33. C                  interactively----no extraneous characters are printed
  34. C                  on the screen when getting input from the keyboard.
  35. C
  36. C    LINK:
  37. C                (.OBJ): EFFIXSP+DOSFN+DOSFUNC
  38. C         (EFFIXSP.EXE): <RETURN>
  39. C             (NUL.MAP): <RETURN>
  40. C                (.LIB): A:+A:HALOF  (assuming the libraries are on A:)
  41. C
  42.       IFLGZ=0
  43.       NSPT=0
  44.       DO 10 I=1,10
  45.       DO 5 J=1,640
  46.         R(I,J)=0.
  47.         SCAT1(I,J)=0.
  48.   5     CONTINUE
  49.  10     IPTS(I)=0
  50. C
  51.  9000 FORMAT(10X,'Read in a spectrum file',/,
  52.      1       10x,'Plot spectrums',/,
  53.      2       10x,'Set max/min limits',/,
  54.      4       10X,'Overlay Keep spectrum with another',/,
  55.      5       10X,'Last screen recall',/,
  56.      6       10X,'Write spectrum to disk',/
  57.      8       10x,'Efficiency correct spectrum',/
  58.      7       10X,'Keep last screen',/,
  59.      3       10x,'Quit',/,1X)
  60.  20   WRITE(0,9000)
  61.       WRITE(0,'(A\)') '       COMMAND: '
  62.       CALL GETCHR(CHR)
  63.       ANSW(1)=CHR
  64.       WRITE(0,*)CHR
  65. C
  66. C
  67.       IF((ANSW(1).EQ.'R').OR.(ANSW(1).EQ.'r')) THEN
  68.    30   WRITE(0,'(A\)') ' ID NUMBER OF SPECTRUM TO READ '
  69.         READ(0,*,ERR=30) ID
  70.         WRITE(0,'(A\)') ' INPUT FILE NAME? '
  71.         READ(0,'(A)',ERR=30) FNAME(ID)
  72.         INQUIRE(FILE=FNAME(ID),EXIST=IEXIST)
  73.         IF(IEXIST) THEN
  74.           OPEN(7,FILE=FNAME(ID),STATUS='OLD')
  75.         ELSE
  76.           WRITE(0,*) ' FILE DOES NOT EXIST--- TRY AGAIN'
  77.           GO TO 30
  78.         ENDIF
  79. C--------------
  80.         READ(7,*) IFLTYP
  81.         IF(IFLTYP.EQ.1) THEN
  82. C--------------
  83.  31       WRITE(0,'(A\)')'  Energy of first channel and keV/channel: '
  84.           READ(0,*,ERR=31) BASE,KEVPC
  85. C
  86.           DO 90 J=1,640
  87.             READ(7,*,ERR=107,END=100) SCAT1(ID,J)
  88.             R(ID,J)=BASE + (J-1)*KEVPC
  89.   90      CONTINUE
  90.         ELSE
  91.           DO 95 J=1,640
  92.             READ(7,*,ERR=107,END=100) R(ID,J),SCAT1(ID,J)
  93.   95      CONTINUE
  94.         ENDIF
  95.  100    CLOSE(7,STATUS='KEEP')
  96.         J=J-1
  97.         IF(IPTS(ID).EQ.0) NSPT=NSPT + 1
  98.         IPTS(ID)=J
  99.         GO TO 20
  100. C
  101. C   error in reading file-- treat as if file was never opened.
  102. C
  103. 107     CLOSE(7,STATUS='KEEP')
  104.         IF(IPTS(ID).NE.0) NSPT=NSPT-1
  105.         IPTS(ID)=0
  106.         GO TO 20
  107. CCCCCCCCCCCC
  108. CCCCCCCCCCC
  109.       ELSEIF((ANSW(1).EQ.'P').OR.(ANSW(1).EQ.'p')) THEN
  110.  249    DO 250 I=1,10
  111.           IF(IPTS(I).NE.0) WRITE(0,'(10X,I2,1X,A)') I,FNAME(I)
  112.  250    CONTINUE
  113.         WRITE(0,'(1X,/,1X,A\)') 'Spectrum number to plot '
  114.         READ(0,*,ERR=249) ID
  115. C
  116. C                          initialize graphics - 640x200 mono
  117.         CALL INITGR(1)
  118.         CALL SETIEE(1)
  119. C
  120. C                           draw X- and Y-axis
  121.         CALL MOVABS(0,0)
  122.         CALL LNABS(0,199)
  123.         CALL LNABS(639,199)
  124.         JMAX=IPTS(ID)-1
  125.         CALL SETWOR(XMIN,RMIN,XMAX,RMAX)
  126. C
  127. C                           move graphics cursor to first point
  128. C
  129.         CALL MOVABS(R(ID,1),SCAT1(ID,1))
  130.         DO 255 J=1,IPTS(ID)
  131.           DUMY(J)=SCAT1(ID,J)
  132.  255      DUMX(J)=R(ID,J)
  133. C
  134. C                           graph the points
  135. C
  136.         CALL POLYLA(DUMX(2),DUMY(2),JMAX)
  137.         CALL SETGPR(2)
  138.         CALL WORLDO
  139. C
  140. C                           save a copy of the image
  141. C
  142.         CALL MOVEFR(0,0,639,199,IMAGE(1))
  143.         IDLSP=ID
  144.         CALL GETCHR(CHR)
  145.         CALL CLOSEG
  146.         GO TO 20
  147.       ELSEIF((ANSW(1).EQ.'S').OR.(ANSW(1).EQ.'s')) THEN
  148. C
  149. C     set upper and lower limits on X- and Y-axis
  150. C
  151.  1949   DO 1950 I=1,10
  152.           IF(IPTS(I).NE.0) WRITE(0,'(10X,I2,1X,A)') I,FNAME(I)
  153.  1950   CONTINUE
  154.         WRITE(0,'(10X,I2,1X,A)') 11,'To manually set limits'
  155.         WRITE(0,'(1X,/,1X,A\)') 'Spectrum number to get limits from '
  156.         READ(0,*,ERR=1949) ID
  157.         IF(ID.NE.11) THEN
  158.           JMAX=IPTS(ID)
  159.           XMAX=R(ID,1)
  160.           XMIN=R(ID,1)
  161.           RMAX=SCAT1(ID,1)
  162.           RMIN=SCAT1(ID,1)
  163.           DO 2000 I=1,JMAX
  164.             IF(SCAT1(ID,I).GT.RMAX) RMAX=SCAT1(ID,I)
  165.             IF(SCAT1(ID,I).LT.RMIN) RMIN=SCAT1(ID,I)
  166.             IF(R(ID,I).GT.XMAX) XMAX=R(ID,I)
  167.             IF(R(ID,I).LT.XMIN) XMIN=R(ID,I)
  168.  2000       CONTINUE
  169.           WRITE(0,*) ' Y-AXIS LIMITS ARE NOW ',RMAX,RMIN
  170.           WRITE(0,*) ' X-AXIS LIMITS ARE NOW', XMAX,XMIN
  171.         ELSE
  172.           WRITE(0,*) ' OLD Y-AXIS LIMITS ARE  ',RMAX,RMIN
  173.           WRITE(0,'(A\)') ' ENTER NEW LIMITS: '
  174.           READ(0,*,ERR=20) RMAX,RMIN
  175.           WRITE(0,*) ' OLD X-AXIS LIMITS ARE  ',XMAX,XMIN
  176.           WRITE(0,'(A\)') ' ENTER NEW LIMITS: '
  177.           READ(0,*,ERR=20) XMAX,XMIN
  178.         ENDIF
  179.         GO TO 20
  180.       ELSEIF((ANSW(1).EQ.'G').OR.(ANSW(1).EQ.'g')) THEN
  181.         GO TO 20
  182.       ELSEIF((ANSW(1).EQ.'Q').OR.(ANSW(1).EQ.'q')) THEN
  183. C
  184. C                       quit- stop the program
  185.         STOP
  186.       ELSEIF((ANSW(1).EQ.'L').OR.(ANSW(1).EQ.'l')) THEN
  187. C
  188. C                           re-examine last screen image
  189.         CALL INITGR(1)
  190.         CALL SETIEE(1)
  191.         CALL MOVETO(0,0,IMAGE(1),1)
  192. C
  193. C                          display image until a key is pressed
  194.         CALL GETCHR(CHR)
  195.         CALL CLOSEG
  196.         GO TO 20
  197.       ELSEIF((ANSW(1).EQ.'E').OR.(ANSW(1).EQ.'e')) THEN
  198.         WRITE(0,'(A\)') ' Read in new efficiency curve data (Y/N):'
  199.         CALL GETCHR(CHR)
  200.         WRITE(0,*) CHR
  201.         IF((CHR.EQ.'Y').OR.(CHR.EQ.'y').OR.(IFLGZ.EQ.0)) THEN
  202. C>>>>>>>>>>>>VVVVVVVVVV
  203.           WRITE(0,*) '                2'
  204.           WRITE(0,*) ' 1)    eff = A*E  + B*E + C'
  205.           WRITE(0,*)
  206.           WRITE(0,*) '                2'
  207.           WRITE(0,*) ' 2) ln(eff)= A*E  + B*E + C'
  208.           WRITE(0,*)
  209.           WRITE(0,*) ' 3) ln(eff)= A*ln(E) + C'
  210.           WRITE(0,*)
  211.  300      WRITE(0,'(A\)') ' Number of function to use: '
  212.           READ(0,*,ERR=300) IFUN
  213. C
  214.           IF(IFUN.EQ.1) THEN
  215.  310        WRITE(0,'(A\)') ' A,B,C  '
  216.             READ(0,*,ERR=310) AA,BB,CC
  217.           ELSEIF(IFUN.EQ.2) THEN
  218.  315        WRITE(0,'(A\)') ' A,B,C  '
  219.             READ(0,*,ERR=315) AA,BB,CC
  220.           ELSEIF(IFUN.EQ.3) THEN
  221.  320        WRITE(0,'(A\)') ' A,C  '
  222.             READ(0,*,ERR=320) AA,CC
  223.           ELSE
  224.             GO TO 300
  225.           ENDIF
  226. C>>>>>>>>>>>>>^^^^^^^^^^
  227.  325      WRITE(0,'(A\)') ' Valid energy range: Elow, Ehigh '
  228.           READ(0,*,ERR=325) ELOW,EHGH
  229.           IFLGZ=1
  230.         ENDIF
  231.  400    DO 450 I=1,10
  232.           IF(IPTS(I).NE.0) WRITE(0,'(10X,I2,1X,A)') I,FNAME(I)
  233.  450    CONTINUE
  234.         WRITE(0,'(1X,/,1X,A\)') 'Spectrum number to correct '
  235.         READ(0,*,ERR=400) ID
  236. C
  237.         DO 475 J=1,IPTS(ID)
  238.           EID=R(ID,J)
  239.           IF((EID.GE.ELOW).AND.(EID.LE.EHGH)) THEN
  240. C>>>>>>>>>>>VVVVVVV
  241.             IF(IFUN.EQ.1) THEN
  242.               SCAT1(ID,J)=SCAT1(ID,J)/((AA*R(ID,J)+BB)*R(ID,J)+CC)
  243.             ELSEIF(IFUN.EQ.2) THEN
  244.               SCAT1(ID,J)=SCAT1(ID,J)/EXP((AA*R(ID,J)+BB)*R(ID,J)+CC)
  245.             ELSEIF(IFUN.EQ.3) THEN
  246.               SCAT1(ID,J)=SCAT1(ID,J)/EXP(AA*ALOG(R(ID,J)) + CC)
  247.             ENDIF
  248. C>>>>>>>>>^^^^^^^^^
  249.           ENDIF
  250.  475    CONTINUE
  251.         GO TO 20
  252.       ELSEIF((ANSW(1).EQ.'K').OR.(ANSW(1).EQ.'k')) THEN
  253. C
  254. C                           saves a copy of the last screen image
  255. C                           used with overlaying two spectrums.
  256.         CALL INITGR(1)
  257.         CALL SETIEE(1)
  258.         CALL MOVETO(0,0,IMAGE(1),1)
  259.         CALL MOVEFR(0,0,639,199,KEEP(1))
  260.         CALL CLOSEG
  261.         GO TO 20
  262.       ELSEIF((ANSW(1).EQ.'O').OR.(ANSW(1).EQ.'o')) THEN
  263. C
  264. C                           overlay one spectrum on another
  265.  549    DO 550 I=1,10
  266.           IF(IPTS(I).NE.0) WRITE(0,'(10X,I2,1X,A)') I,FNAME(I)
  267.  550    CONTINUE
  268.         WRITE(0,'(1X,/,1X,A\)') 'Spectrum number to plot '
  269.         READ(0,*,ERR=549) ID
  270.         CALL INITGR(1)
  271.         CALL SETIEE(1)
  272.         CALL MOVETO(0,0,KEEP(1),1)
  273. C
  274. C  NOTE: the X and Y axis limits are set to those associated with
  275. C        the last 'Set limits' command which may not be the same
  276. C        as those used to draw the graph saved in the "KEEP" array
  277. C        or those of the spectrum being overlayed.
  278. C
  279.         CALL SETWOR(XMIN,RMIN,XMAX,RMAX)
  280.         CALL MOVABS(R(ID,1),SCAT1(ID,1))
  281.         JMAX=IPTS(ID)-1
  282.         DO 555 J=1,IPTS(ID)
  283.           DUMY(J)=SCAT1(ID,J)
  284.  555      DUMX(J)=R(ID,J)
  285.         CALL POLYLA(DUMX(2),DUMY(2),JMAX)
  286.         CALL SETGPR(2)
  287.         CALL WORLDO
  288.         CALL MOVEFR(0,0,639,199,IMAGE(1))
  289.         CALL GETCHR(CHR)
  290.         CALL CLOSEG
  291.         GO TO 20
  292.       ELSEIF((ANSW(1).EQ.'W').OR.(ANSW(1).EQ.'w')) THEN
  293.  1200    DO 1250 I=1,10
  294.           IF(IPTS(I).NE.0) WRITE(0,'(10X,I2,1X,A)') I,FNAME(I)
  295.  1250    CONTINUE
  296.         WRITE(0,'(1X,/,1X,A\)') 'Spectrum number to WRITE '
  297.         READ(0,*,ERR=1200) ID
  298. C
  299.  1385  WRITE(0,'(A\)')'  OUTPUT FILENAME: '
  300.        READ(0,'(A)') F2CHR
  301.        INQUIRE(FILE=F2CHR,EXIST=IEXIST)
  302.        IF(IEXIST) THEN
  303.          WRITE(0,'(A\)') ' File exists- overwrite it (Y/N): '
  304.          READ(0,'(A)')ANSW1
  305.          IF((ANSW1.EQ.'Y').OR.(ANSW1.EQ.'y')) THEN
  306.            OPEN(4,FILE=F2CHR,STATUS='OLD')
  307.          ELSE
  308.            GO TO 1385
  309.          ENDIF
  310.        ELSE
  311.          OPEN(4,FILE=F2CHR,STATUS='NEW')
  312.        ENDIF
  313. C
  314.  1386  WRITE(0,'(A\)') ' 1 OR 2 COLUMN FILETYPE (1/2): '
  315.        READ(0,*,ERR=1386) IFLTYP
  316.        IF(IFLTYP.EQ.1) THEN
  317.          WRITE(4,*,ERR=1435) IFLTYP
  318.          DO 1430 J=1,IPTS(ID)
  319.            WRITE(4,*,ERR=1435) SCAT1(ID,J)
  320.  1430   CONTINUE
  321.        ELSEIF(IFLTYP.EQ.2) THEN
  322.          WRITE(4,*,ERR=1435) IFLTYP
  323.          DO 1433 J=1,IPTS(ID)
  324.            WRITE(4,'(1X,F10.5,1X,F8.1)',ERR=1435) R(ID,J),SCAT1(ID,J)
  325.  1433    CONTINUE
  326. C
  327.        ELSE
  328.          GO TO 1386
  329.        ENDIF
  330.  1435  CLOSE(4,STATUS='KEEP')
  331.         GO TO 20
  332.       ELSE
  333.         CALL CLOSEG
  334.         GO TO 20
  335.       ENDIF
  336.       END
  337.