c$DEBUG C_____________________________________________________________________________ C C SVIEW - DISPLAY AND MEASUREMENT PROGRAM FOR LINEARIZED SPECTRA C_____________________________________________________________________________ c C C Version 16.04.2001 ----- Zbigniew Kisiel ----- C C __________________________________________________ C | Institute of Physics, Polish Academy of Sciences | C | Al.Lotnikow 32/46, Warszawa, POLAND | C | kisiel@ifpan.edu.pl | C | http://info.ifpan.edu.pl/~kisiel/prospe.htm | C_________________________/-------------------------------------------------- C C Modification history: C c 31.3.95: Elimination of crash on option XL for narrow spectra and of c crash on evaluation of peak frequency for level signal c 6.6.95: Change of peakfinder width with 0 not O C 31.8.95: Addition of safety features on input and .FRE compatibility c 26.11.95: Tweaking of screen refresh in LOOK c 11.02.97: As above C 9.06.97: Test for frequencies increasing from left to right C 27.03.01: gle output C 16.04.01: major reconstruction C C---------------------------------------------------------------------------- c C - This version will only compile with FORTRANS from PowerStation 1.0 C upwards (will no longer work with MS-FORTRAN 5.0) c C - Remember to compile without optimisation (at least with PS1) c C - ANSI.SYS still has to be loaded C C=========================================================================== C C...Initialization commands for graphics. The three structured C variables contain coordinates: C curpos.row and curpos.col - cursor coordinates (INTEGER*2) C ixy.xcoord and ixy.ycoord - pixel coordinates (INTEGER*2) C wxy.wx and wxy.wy - window coordinates (REAL*8) c c Uncomment the statements below (and in similar headers in routines c as necessary) c PS1 and PS4 = MS Powerstation Fortrans 1.0 and 4.0 C INCLUDE 'FGRAPH.FI' PS1 INCLUDE 'FLIB.FI' PS1 INCLUDE 'FGRAPH.FD' PS1 c USE MSFLIB PS4 C_____________________________________________________________________________ c PARAMETER (MAXPTS=32000) RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy C C...The code in the two INCLUDE files clashes with IMPLICIT statements - so C when using MSF5.0 graphics the recomendation is to type everything C explicitly (check with -4Yg compilation switch) C REAL*8 FREQs(MAXPTS) INTEGER*2 maxx,maxy,linofs,mymode,myrows,mycols,iflag INTEGER*4 blue,red REAL*8 FSTART,FEND,FINCR REAL*4 volts(MAXPTS) CHARACTER bold*4,normal*4,errmes*40 CHARACTER*80 toplin,emplin,paslin character*79 botlin c INTEGER*4 ISPEC(MAXPTS),NPTS,ISMALL,ILARGE INTEGER*2 ita,itb,itc INTEGER*2 IDAY,IMON,IYEAR,IHOUR,IMIN,ISEC REAL*4 VKMST,VKMEND,GRID,SAMPRE,GAIN,TIMEC,PHASE, 1 PPS,FRMOD,FRAMPL CHARACTER FILNAM*25,COMENT*72,LAMP*6,SCANSP*6,SAMPLE*20 c COMMON /SPECR/volts COMMON /SPEC/ISPEC,NPTS,ISMALL,ILARGE COMMON /FRE/FREQS COMMON /limits/wxy,maxx,maxy,linofs,curpos,ixy, * mymode,myrows,mycols,blue,red COMMON /INFO/COMENT,IDAY,IMON,IYEAR,IHOUR,IMIN,ISEC, 1 LAMP,VKMST,VKMEND,GRID,SAMPLE,SAMPRE,GAIN,TIMEC,PHASE, 1 SCANSP,PPS,FRMOD,FRAMPL COMMON /lines/toplin,emplin,paslin,botlin COMMON /FNAM/FILNAM COMMON /FLIMIT/FSTART,FEND,FINCR c C C...HEADING C WRITE(BOLD,'(A1,''[1m'')')CHAR(27) WRITE(NORMAL,'(A1,''[0m'')')CHAR(27) WRITE(*,155)CHAR(27),'[2J' WRITE(*,155)CHAR(27),'[7m' 155 FORMAT(1H+,A1,A) WRITE(*,156) 156 FORMAT(1X,78(1H )/' S V I E W - Viewer for frequency ', * 'linearised spectra '/ * 1X,78(1H )/1x,78(1H_)/ * ' version 16.04.2001',T64,'Zbigniew KISIEL ') WRITE(*,155)CHAR(27),'[0m' c WRITE(emplin,'(80(1H ))') 1 format(i5) C C...Input of a stored spectrum C 1503 WRITE(*,'(1X//'' NAME OF DATA FILE ? ''\)') READ(*,'(A)',ERR=1503)FILNAM c_______________________________________________________ c c...standard binary format c OPEN(2,FILE=FILNAM,FORM='BINARY',STATUS='OLD',ERR=1503) READ(2,ERR=503,END=503)COMENT,IDAY,IMON,IYEAR,IHOUR,IMIN,ISEC, 1 LAMP,VKMST,VKMEND,GRID,SAMPLE,SAMPRE,GAIN,TIMEC,PHASE, 1 SCANSP,PPS,FRMOD,FRAMPL READ(2)ita,itb,itc NPTS=ita ISMALL=itb ILARGE=itc if(iday.lt.1.or.iday.gt.31)goto 503 if(imon.lt.1.or.imon.gt.12)goto 503 if(iyear.lt.1980.or.iyear.gt.2050)goto 503 C WRITE(*,155)CHAR(27),'[2J' WRITE(*,'(1H+,A1,''[7m'',2X,A72,2X,A1,''[0m''/)')CHAR(27), 1 COMENT,CHAR(27) WRITE(*,'('' Time and Date: '',A4,I2,'':'',I2,'':'', 1 I2,'', '',I2,''/'',I2,''/'',I4,A4)')BOLD,IHOUR,IMIN,ISEC, 1 IDAY,IMON,IYEAR,NORMAL WRITE(*,'(1X/'' Lamp: '',A4,A,A4)') 1 BOLD,LAMP,NORMAL WRITE(*,'('' Vkm limits /mV: '',A4,F8.2,''-'', 1 F8.2,A4)')BOLD,VKMST,VKMEND,NORMAL WRITE(*,'('' Grid /V: '',A4,F6.1,A4)') 1 BOLD,GRID,NORMAL WRITE(*,'(1X/'' Sample: '',A4,A,A4)') 1 BOLD,SAMPLE,NORMAL WRITE(*,'('' Sample pressure /mTorr: '',A4,F6.1,A4)') 1 BOLD,SAMPRE,NORMAL WRITE(*,'(1X/'' Gain /mV: '',A4,F6.1,A4)') 1 BOLD,GAIN,NORMAL WRITE(*,'('' Time constant /s: '',A4,F6.3,A4)') 1 BOLD,TIMEC,NORMAL WRITE(*,'('' Phase /deg: '',A4,F6.1,A4)') 1 BOLD,PHASE,NORMAL WRITE(*,'('' SIPƒOW scan speed: '',A4,A,A4)') 1 BOLD,SCANSP,NORMAL WRITE(*,'('' Points per second: '',A4,F7.2,A4)') 1 BOLD,PPS,NORMAL WRITE(*,'(1X/'' Modulation freq. /KHz: '',A4,F8.3,A4)') 1 BOLD,FRMOD,NORMAL WRITE(*,'('' Modulation ampl. /mV: '',A4,F6.1,A4)') 1 BOLD,FRAMPL,NORMAL WRITE(*,'(1X/1X,A4,I5,A4,'' points, ranging from'' 1 ,A4,I6,A4,'' to'',A4,I6,A4)')BOLD,NPTS,NORMAL,BOLD, 1 ISMALL,NORMAL,BOLD,ILARGE,NORMAL C if(npts.gt.maxpts)then write(*,'(1x//1x,i5,'' points in spectrum which exceeds'', * '' present maximum of '',i5//)')npts,maxpts stop endif DO 20 N=1,NPTS READ(2,ERR=494)ita ISPEC(N)=ita 20 CONTINUE c goto 495 494 write(*,'(1x//'' PROBLEMS WITH INPUT OF INTENSITIES at pt. '', * i5//)')n stop 495 continue C READ(2)FSTART,FEND,FINCR WRITE(*,'('' Frequency from'',A4,F10.2,A4,'' to'',A4,F10.2, 1A4,'' MHz'')')BOLD,FSTART,NORMAL,BOLD,FEND,NORMAL C IF(FEND.LE.FSTART.or.fincr.lt.0.d0)THEN WRITE(*,'(1x//'' PROBLEMS WITH FREQUENCY LIMITS - correct'', * '' with MODSPE''//)') STOP ENDIF goto 1000 c_______________________________________________________ C C...Input from an ASCII file which is executed once binary read fails C (data is treated as linearized file and only the frequency values C of the first and last points matter) C 503 WRITE(*,492)char(7) 492 FORMAT(1X/'---- This is not a file in the IFPAN binary format:', * ' will now try reading it'/ * ' as two column ASCII, assuming that first line ' * ' contains the'/ * ' descriptive comment',A///) CLOSE(2) OPEN(2,FILE=FILNAM,ERR=489) errmes='Problem with the comment' READ(2,1300,ERR=489)COMENT 1300 FORMAT(A) c c...first pass to determine scaling c NPTS=maxpts ASCMIN= 1.E20 ASCMAX=-1.E20 errmes='Problem with the X,Y pairs' DO 488 N=1,NPTS READ(2,*,ERR=489,end=1505)XASC,YASC IF(YASC.GT.ASCMAX)ASCMAX=YASC IF(YASC.LT.ASCMIN)ASCMIN=YASC 488 CONTINUE goto 1506 c c...second pass to fill the data tables c 1505 NPTS=n-1 1506 REWIND(2) READ(2,1300)CHARFL SCASC=20000.D0/(ASCMAX-ASCMIN) DO 487 N=1,NPTS READ(2,*)freqs(n),YASC ISPEC(N)=(YASC-ASCMIN)*SCASC-10000.D0 487 CONTINUE fstart=freqs(1) fend=freqs(npts) fincr=(fend-fstart)/(npts-1) c ISMALL=-10000 ILARGE=10000 PPS=51. IDAY=1 IMON=1 IYEAR=2000 WRITE(SAMPLE,'(1P(2E10.3))')ASCMIN,ASCMAX SCANSP=' ' LAMP=' ' c WRITE(*,155)CHAR(27),'[2J' WRITE(*,'(1H+,A1,''[7m'',2X,A72,2X,A1,''[0m''/)')CHAR(27), 1 COMENT,CHAR(27) WRITE(*,'(1X/1X,A4,I5,A4,'' points: intensity from'' 1 ,A4,1PE12.4,A4,'' to'',A4,E12.4,A4)')BOLD,NPTS,NORMAL,BOLD, 1 ASCMIN,NORMAL,BOLD,ASCMAX,NORMAL WRITE(*,'('' frequency from '',A4,F10.2,A4, * '' to '',A4,F10.2, 1 A4,'' '')')BOLD,FSTART,NORMAL,BOLD,FEND,NORMAL goto 1001 489 write(*,1502)errmes 1502 format(1x/' ***** ASCII input unsuccessful: ',a//) goto 1503 c c_______________________________________________________ C C C...fill out the frequency table c 1000 DO 4566 N=1,NPTS FREQS(N)=FSTART+(N-1)*FINCR 4566 CONTINUE c c...if short spectrum then continue the frequency table at least until the c end of screen c 1001 IF(MAXX.EQ.0)MAXX=640 IF(NPTS.LT.MAXX)THEN DO 4596 N=NPTS+1,MAXX+1 FREQS(N)=FSTART+(N-1)*FINCR ISPEC(N)=ISPEC(NPTS) 4596 CONTINUE NPTS=MAXX ENDIF FEND=FREQs(MAXX) GOTO 4565 pause C 4565 CLOSE(2) C C C...Scaling and plot C 500 IF(ISMALL.EQ.ILARGE)THEN WRITE(*,'(1X/'' ****ERROR, zero dynamic range in data'', * A/)')CHAR(7) GOTO 1410 ENDIF CALL LOOKFM C 1410 WRITE(*,'(1X/10X,''0 = EXIT''/ * 10X,''1 = another spectrum''/ 1 10X,''2 = another look at the spectrum from '',a// 2 10x,''..... '',$)')filnam READ(*,1,ERR=1410)IFLAG IF(IFLAG.EQ.1)GOTO 1503 IF(IFLAG.EQ.2)GOTO 500 C 530 stop end C C------------------------------------------------------------------------ C SUBROUTINE graphicsmode() C C This sets the required graphics mode card. It also C determines the pixel limits on x and y axes (0,maxx), (0,maxy) C INCLUDE 'FGRAPH.FD' PS1 c USE MSFLIB PS4 C RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy INTEGER*2 dummy,maxx,maxy,mymode,myrows,mycols,linofs integer*4 dummy4,blue,red RECORD /videoconfig/myscreen COMMON /limits/wxy,maxx,maxy,linofs,curpos,ixy, * mymode,myrows,mycols,blue,red C C...Determine current graphics mode. C CALL getvideoconfig(myscreen) C C...Set graphics mode C C...this setting was preferred until graphics cards started showing c it as a ribbon narrower than screen height (640*350 and 25*80 chars. EGA) c mymode=$ERESCOLOR c myrows=25 C C...this setting should have widest compatibility (640*480, 30*80 chars. VGA) c (the 16 color mode usually delivers faster scrolling) c mymode=$VRES256COLOR mymode=$VRES16COLOR myrows=30 C C...this is for 800*600, 37*100 chars. SVGA which is available only for MFPS c (the 256 color mode experiences problems with some cards) c mymode=$SRES256COLOR c mymode=$SRES16COLOR c myrows=37 c dummy = setvideomoderows ( mymode, myrows ) myrows=dummy if(myrows.ne.25.and.myrows.ne.30.and.myrows.ne.37)then write(*,'(1x//i5,a,a//)')myrows, * ' <--- this is the number of text lines in this mode', * ' and it is not yet supported' pause endif C IF( dummy .EQ. 0 ) STOP 'Error: cannot set graphics mode' C C...Determine parameters of the graphics mode that is being used C CALL getvideoconfig( myscreen ) maxx = myscreen.numxpixels - 1 maxy = myscreen.numypixels - 1 linofs=nint(real(maxy)/real(myrows)) mycols = myscreen.numtextcols if(mycols.lt.80)then write(*,'(1x//i5,a,a//)')myrows, * ' <--- this is the number of text columns in this mode', * ' and it is too small' pause endif c c...patch for different use of SETBKCOLOR by MSPS4.0 from MSPS1.0 (and MSF5) c blue=$BLUE red=$RED if($BLUE.ne.#2a0000)then blue=1 red=4 endif c dummy4 = setbkcolor( BLUE ) call clearscreen($GCLEARSCREEN) C RETURN END C C------------------------------------------------------------------------ C SUBROUTINE LOOKFM C C Plot of spectrum with scrolling along the X-axis and zooming along C both the X and Y axes C C Plot is normally made from FREQS,ISPEC but when points become too far c apart they are interpolated as necessary at each screen refresh c (since time delay is minimal) C C - ISPEC() contains the current spectrum C - ITEMP() work buffer for operations on the spectrum C - IOSPEC() contains original spectrum C - FREQS() contains the point frequencies C - ISPINT() contains interpolated points C - FREINT() contains interpolated frequencies C INCLUDE 'FGRAPH.FD' PS1 c USE MSFLIB PS4 C LOGICAL*2 true PARAMETER (MAXPTS=32000,TRUE=.TRUE.,intpt=640,maxpk=500) RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy INTEGER*2 II,IK,IX,N,I,NFIT,IYCUT,IBASE INTEGER*2 maxx,maxy,linofs,mymode,myrows,mycols INTEGER*4 blue,red INTEGER*4 ISPEC(MAXPTS),NPTS,ISMALL,ILARGE,ISPINT(intpt) INTEGER*4 IOSPEC(maxpts),itemp(maxpts) INTEGER*2 dummy,inkey,NSPLIN REAL*8 FREQS(MAXPTS),ymeano,FREINT(intpt),a0,a1 INTEGER*4 dummy4 REAL*8 RSMALL,RLARGE,RANGE,ymean REAL*8 X(1000),Y(1000),A(1000),B(1000),C(1000),D(1000), * GRA,CA,GRB,CB REAL*8 XFIT(maxpk),YFIT(maxpk),XPEAK,ERRORX REAL*8 YSHIFT,YYSTEP,RRSMAL,RSPEC,ycord,ycent,xcent REAL*8 fmark,fstart,fend,fmean,flast,fchang,frange CHARACTER OUTSTR*21,FILNAM*25 CHARACTER*80 toplin,emplin,paslin,FREQLIN character*79 botlin C COMMON /FRE/FREQS COMMON /limits/wxy,maxx,maxy,linofs,curpos,ixy, * mymode,myrows,mycols,blue,red COMMON /SPEC/ISPEC,NPTS,ISMALL,ILARGE COMMON /lines/toplin,emplin,paslin,botlin COMMON /SPL/NSPLIN,X,Y,A,B,C,D,GRA,CA,GRB,CB COMMON /FRFIT/XFIT,YFIT COMMON /FNAM/FILNAM COMMON /plotda/RSMALL,RLARGE,RRSMAL,YYSTEP,YSHIFT common /bufers/iospec,itemp common /intpol/freint,ispint C itxt=1 NFIT=7 RSMALL=real(ISMALL)-0.05*(ilarge-ismall) RLARGE=real(ILARGE)+0.05*(ilarge-ismall) ymean=0.25*(rlarge-rsmall)+rsmall do 53 i=1,npts iospec(i)=ispec(i) 53 continue ymeano=ymean c WRITE(botlin,601) 601 FORMAT('A-S Q-E Z-W 2-3 K-L ', * ' H=help ') C 155 WRITE(*,'(/1x,A1,''Ready to plot - press ENTER ''\)')CHAR(7) 900 READ(*,'(I5)',ERR=900)I C C C...Preparations of graphics for plotting C CALL graphicsmode() dummy4 = setbkcolor( BLUE ) fstart=freqs(1) fend=freqs(maxx+1) fmark=(fstart+fend)*0.5d0 C C...definition of pixel limits for the graphics viewport C (note that pixel origin is now at absolute {0,2*LINOFS+1}) C call setviewport(0,2*LINOFS+1,maxx,maxy-LINOFS-1) C C---------------------------------------------------- C C...A COMPLETE refresh of plot takes place from here C (the bottom of the graphics is set lower to RRSMAL than the range of c the data RSMALL to make space for the marker plot and label line) C C...bottom information line 333 dummy=SETTEXTCOLOR(7) CALL settextposition(myrows,1,curpos) CALL outtext(botlin) DUMMY=SETTEXTCOLOR(14) CALL settextposition(myrows,45,curpos) CALL outtext(filnam) DUMMY=SETTEXTCOLOR(7) C C...declare new floating point bounds for graphics and clear the viewport c (top and bottom information lines will not be cleared) C 33 YYSTEP=1.d0/DBLE(maxy-(3*linofs+2)-28)*(RLARGE-RSMALL) RRSMAL=RSMALL-28.D0*YYSTEP NSTART=1+nint( (fstart-freqs(1))/(freqs(npts)-freqs(1))*(npts-1)) NEND =1+nint( (fend -freqs(1))/(freqs(npts)-freqs(1))*(npts-1)) if(nstart.lt.1)nstart=1 if(nend.gt.npts)nend=npts fstart=freqs(nstart) fend=freqs(nend) fincr=(FEND-FSTART)/DBLE(maxx) dummy=setwindow(TRUE,FSTART,RRSMAL,FEND,RLARGE) $NODEBUG CALL setlinestyle(#FFFF) $DEBUG CALL clearscreen($GVIEWPORT) c c...box c YSHIFT=RSMALL-5.d0*YYSTEP CALL moveto_w(FSTART,RLARGE,wxy) dummy=lineto_w(FSTART,YSHIFT) dummy=lineto_w(FEND,YSHIFT) dummy=lineto_w(FEND,RLARGE) dummy=lineto_w(FSTART,RLARGE) c c...spectrum c nmult=1 if(nend-nstart.lt.intpt/2)then call interp(fstart,fend,nstart,nend,nplot,nmult) DO 16 I=1,nplot RSPEC=DBLE(ISPINT(i)) IF(RSPEC.gt.rlarge)rspec=rlarge if(rspec.lt.yshift)rspec=yshift if(i.eq.1)then CALL moveto_w(fstart,rspec,wxy) else dummy=lineto_w(FREINT(i),RSPEC) endif 16 CONTINUE else DO 6 I=NSTART,NEND RSPEC=DBLE(ISPEC(i)) IF(RSPEC.gt.rlarge)rspec=rlarge if(rspec.lt.yshift)rspec=yshift if(i.eq.nstart)then CALL moveto_w(fstart,rspec,wxy) else dummy=lineto_w(FREQS(i),RSPEC) endif 6 CONTINUE endif C c...draw the cursor C 697 dummy=setwritemode($GXOR) dummy=setcolor(14) CALL moveto_w(fmark,RLARGE,wxy) dummy=lineto_w(fmark,YSHIFT) dummy=setcolor(15) dummy=setwritemode($GPSET) c open(4,file='dump',status='unknown') c do 5555 i=nstart,nend c write(4,'(i7,f15.4,i10)')i,freqs(i),ispec(i) c5555 continue c write(4,'(1x)') c if(nplot.gt.1)then c do 5556 i=1,nplot c write(4,'(i7,f15.4,i10)')i,freint(i),ispint(i) c5556 continue c endif c close(4) C C...Frequency marker scale and labels C 777 call marsca(fstart,fend) C C c.....O P T I O N S L O O P c c...update the top two screen information lines c 77 DUMMY=SETTEXTCOLOR(7) NSTART=nint(1.0+(fstart-freqs(1))/(freqs(npts)-freqs(1))*npts) NEND =nint(1.0+(fend -freqs(1))/(freqs(npts)-freqs(1))*npts) if(nstart.lt.1)nstart=1 if(nend.gt.npts)nend=npts marker=1+nint( (fmark-freqs(1))/(freqs(npts)-freqs(1))*(npts-1) ) WRITE(toplin,600)NSTART,NEND,INT(RSMALL),INT(RLARGE), * MARKER,fmark 600 FORMAT('X:',2I6,3X,'Y:',2I7,13X,'Cursor at: ',I5,3X, * F10.3,' MHz ') CALL settextposition(1,1,curpos) CALL outtext(toplin) CALL settextposition(2,1,curpos) CALL outtext(emplin) DUMMY=SETTEXTCOLOR(15) C C Options: A,S - shift screen window over the spectrum c Q,E - X-axis zoom C W,Z - Y-axis zoom C 2,3 - shift spectrum down/up C K,L - move cursor over the spectrum C , - center/quarter cursor C - move to beginning/end of spectrum C B - subtract the background C N - smooth the spectrum C M - write current spectrum to file C H - display HELP screen C R - restore initial screen C O,0 - frequency of the line peak selected by cursor C C - toggle display of information lines C 7 IK=INKEY(N) KK=CHAR(IK) IF(KK.EQ.'A'.OR.KK.EQ.'a')GOTO 36 IF(KK.EQ.'S'.OR.KK.EQ.'s')GOTO 35 IF(KK.EQ.'E'.OR.KK.EQ.'e')GOTO 50 IF(KK.EQ.'Q'.OR.KK.EQ.'q')GOTO 100 IF(KK.EQ.'W'.OR.KK.EQ.'w')GOTO 800 IF(KK.EQ.'Z'.OR.KK.EQ.'z')GOTO 820 IF(KK.EQ.'3'.OR.KK.EQ.'#')GOTO 60 IF(KK.EQ.'2'.OR.KK.EQ.'@')GOTO 61 c IF(KK.EQ.'K'.OR.KK.EQ.'k')GOTO 710 IF(KK.EQ.'L'.OR.KK.EQ.'l')GOTO 711 IF(KK.EQ.',')GOTO 750 c IF(KK.EQ.'B'.OR.KK.EQ.'b')GOTO 830 IF(KK.EQ.'N'.OR.KK.EQ.'n')GOTO 850 IF(KK.EQ.'M'.OR.KK.EQ.'m')GOTO 870 c IF(KK.EQ.'H'.OR.KK.EQ.'h')GOTO 630 IF(KK.EQ.'O'.OR.KK.EQ.'o'.OR.KK.EQ.'0')GOTO 901 IF(KK.EQ.'G'.or.KK.eq.'g')then call clearscreen($GCLEARSCREEN) call gleout(YSHIFT,RLARGE) GOTO 333 ENDIF C C...restore original spectrum and scaling (with R) C IF(KK.EQ.'R'.OR.KK.EQ.'r')THEN do 1100 i=1,npts ispec(i)=iospec(i) 1100 continue ymean=ymeano RSMALL=real(ISMALL)-0.05*(ilarge-ismall) RLARGE=real(ILARGE)+0.05*(ilarge-ismall) GOTO 33 ENDIF C c...go to beginning of spectrum (with ) c IF(IK.EQ.-71)THEN fstart=freqs(1) fend=fstart+maxx*fincr fmark=(fstart+fend)/2.d0 GOTO 33 ENDIF C c...go to end of spectrum (with ) c IF(IK.EQ.-79)THEN fend=freqs(npts) fstart=fend-maxx*fincr if(fstart.lt.freqs(1))then fstart=freqs(1) fend=fstart+maxx*fincr endif fmark=(fstart+fend)/2.d0 GOTO 33 ENDIF c IF(IK.NE.13)GOTO 7 C C...exit C CALL settextposition(2,1,curpos) CALL outtext(emplin) CALL settextposition(1,1,curpos) CALL outtext(emplin) DUMMY=SETTEXTCOLOR(15) dummy4 = setbkcolor( RED ) WRITE(OUTSTR,'(A)')'ARE YOU SURE ?' CALL settextposition(1,1,curpos) CALL outtext(outstr(1:14)) CALL settextposition(1,20,curpos) WRITE(*,'(1X,A1,$)')CHAR(7) 916 IK=INKEY(N) KK=CHAR(IK) IF(KK.EQ.'Y'.OR.KK.EQ.'y')GOTO 915 IF(KK.NE.'N'.AND.KK.NE.'n')GOTO 916 C DUMMY=SETTEXTCOLOR(7) dummy4 = setbkcolor( BLUE ) CALL settextposition(1,1,curpos) CALL outtext(toplin) GOTO 7 C 915 dummy=setvideomode($DEFAULTMODE) GOTO 37 C C...Shift screen window to right of spectrum (with S) C 35 rspec=fstart FRange=fend-fstart Fchang=FRange*0.5D0 IF(KK.EQ.'s')Fchang=FRange*0.1D0 fstart=fstart+Fchang fend=fend+Fchang IF(fend.gt.freqs(npts))THEN fend=freqs(npts) CALL settextposition(1,int2(itxt+1),curpos) WRITE(*,101)CHAR(7) fstart=fend-frange ENDIF FMARK=FMARK+(fstart-rspec) goto 33 C C...Shift screen window to left of spectrum (with A) C 36 FRange=fend-fstart Fchang=FRange*0.5D0 IF(KK.EQ.'a')Fchang=FRange*0.1D0 fstart=fstart-Fchang IF(fstart.LT.freqs(1))THEN fstart=freqs(1) Fchang=fend-(fstart+FRange) CALL settextposition(1,int2(itxt+1),curpos) WRITE(*,101)CHAR(7) 101 FORMAT(1X,A1,$) ENDIF fend=fend-Fchang FMARK=FMARK-Fchang GOTO 33 C C...Shift cursor to the left (with K) C 710 dummy=setwritemode($GXOR) dummy=setcolor(14) CALL moveto_w(fmark,RLARGE,wxy) dummy=lineto_w(fmark,YSHIFT) fmark=fmark-8.d0*fincr IF(KK.EQ.'k')fmark=fmark+7.d0*fincr IF(fmark.LT.fstart+fincr)fmark=fstart+fincr C 719 CALL moveto_w(fmark,RLARGE,wxy) dummy=lineto_w(fmark,YSHIFT) dummy=setcolor(15) dummy=setwritemode($GPSET) GOTO 77 C C...Shift cursor to the right (with L) C 711 dummy=setwritemode($GXOR) dummy=setcolor(14) CALL moveto_w(fmark,RLARGE,wxy) dummy=lineto_w(fmark,YSHIFT) fmark=fmark+8.d0*fincr IF(KK.EQ.'l')fmark=fmark-7.d0*fincr IF(fmark.gT.fend-fincr)fmark=fend-fincr GOTO 719 C C...Center cursor, on second keypress move the cursor into the center of the C opposite screenhalf C 750 dummy=setwritemode($GXOR) dummy=setcolor(14) CALL moveto_w(fmark,RLARGE,wxy) dummy=lineto_w(fmark,YSHIFT) fmean=(fend+fstart)/2.d0 IF(fmark.EQ.Fmean)THEN IF(fLAST.LT.fmean)FMARK=FSTART+0.75*(fend-fstart) IF(fLAST.GE.fmean)FMARK=FSTART+0.25*(fend-fstart) fLAST=FMEAN GOTO 719 ENDIF fLAST=fMARK fmark=fmean GOTO 719 c c...zoom-in in frequency (with E) c 50 FRange=Fend-Fstart Fchang=0.10D0*FRange IF(KK.EQ.'e')Fchang=0.33d0*FRange Fstart=Fmark-Fchang Fend=Fmark+Fchang c 698 if(fstart.lt.freqs(1))fstart=freqs(1) if(fend.gt.freqs(npts))fend=freqs(npts) IF(FMARK.LT.fstart)FMARK=Fstart IF(FMARK.GT.fend)FMARK=Fend c 801 fincr=(fend-fstart)/maxx GOTO 33 C C...zoom-out in frequency (with Q) C 100 FRange=Fend-Fstart Fchang=0.5D0*FRange IF(KK.EQ.'q')Fchang=0.1d0*FRange Fstart=Fstart-Fchang Fend=Fend+fchang GOTO 698 C C...Y axis compression C 800 IF(kk.eq.'W')THEN smult=-0.25 ELSE smult=-0.05 ENDIF goto 810 C C...Y axis expansion C 820 IF(kk.eq.'Z')THEN smult=0.25 ELSE smult=0.05 ENDIF 810 RANGE=RLARGE-RSMALL RSMALL=YMEAN-0.25*RANGE*(1.+smult) RLARGE=YMEAN+0.75*RANGE*(1.+SMULT) GOTO 33 C C...Y-axis shift upwards (with 3) C 60 range=rlarge-rsmall if(kk.eq.'3')then range=-0.02*range else range=-0.10*range endif 63 ymean=ymean+range rsmall=rsmall+range rlarge=rlarge+range goto 33 C C...Y-axis shift downwards (with 2) C 61 range=rlarge-rsmall if(kk.eq.'2')then range= 0.02*range else range= 0.10*range endif goto 63 C C...Background subtraction C 830 CALL clearscreen($GCLEARSCREEN) call smooth(2) CALL clearscreen($GCLEARSCREEN) DO 1101 I=NSTART,NEND RSPEC=DBLE(Iospec(i)) IF(RSPEC.gt.rlarge)rspec=rlarge if(rspec.lt.yshift)rspec=yshift if(i.eq.nstart)then CALL moveto_w(fstart,rspec,wxy) else dummy=lineto_w(FREQS(i),RSPEC) endif 1101 CONTINUE dummy=setcolor(4) dummy=setwritemode($GPSET) DO 1102 I=NSTART,NEND RSPEC=DBLE(Itemp(i)) IF(RSPEC.gt.rlarge)rspec=rlarge if(rspec.lt.yshift)rspec=yshift if(i.eq.nstart)then CALL moveto_w(fstart,rspec,wxy) else dummy=lineto_w(FREQS(i),RSPEC) endif 1102 CONTINUE dummy=setcolor(15) CALL settextposition(1,1,curpos) write(*,'('' Press ENTER to continue '',$)') read(*,'(i3)',err=1103)i 1103 dummy=setwritemode($GPSET) ymean=0.0 rsmall=1.E+10 rlarge=-1.E+10 do 1106 i=1,npts rspec=ispec(i) if(rspec.lt.rsmall)rsmall=rspec if(rspec.gt.rlarge)rlarge=rspec ymean=ymean+rspec 1106 continue YMEAN=RLARGE-RSMALL RSMALL=RSMALL-0.05*YMEAN RLARGE=RLARGE+0.05*YMEAN ymean=0.25*(rlarge-rsmall)+rsmall goto 333 C C...Smoothing C 850 CALL clearscreen($GCLEARSCREEN) CALL settextposition(1,1,curpos) call smooth(1) goto 333 C C...Output to file C 870 CALL clearscreen($GCLEARSCREEN) CALL settextposition(1,1,curpos) call savesp goto 333 C C...Peak frequencies: O,o - frequency of transition underneath the cursor C 0 - set number of points for fitting, on -ve number C execute PEAKFINDER C 901 IF(KK.EQ.'0')THEN 902 CALL settextposition(1,1,curpos) call outtext(emplin) call settextposition(2,1,curpos) call outtext(emplin) call settextposition(1,1,curpos) WRITE(*,905)NFIT 905 FORMAT(' Current no. of points for fitting lineshape: ',I3/ * ' New number (odd, -ve for PEAKFINDER): ',$) READ(*,'(I5)',ERR=902)I IF(ABS(I).LT.5.OR.ABS(I).GT.maxpk)GOTO 902 IF(ABS(I).EQ.2*(ABS(I)/2))GOTO 902 NFIT=ABS(I) IF(I.LT.0)GOTO 930 GOTO 632 ENDIF C C C...P.E.A.K.F.I.N.D.E.R.............................. C 930 IF(I.LT.0.AND.NFIT.GE.5)THEN c c...determine background level c DUMMY=SETTEXTCOLOR(11) call settextposition(1,1,curpos) call outtext(emplin) call settextposition(2,1,curpos) call outtext(emplin) call settextposition(1,1,curpos) write(freqlin,'(a)') * ' Set the baseline level with W,Z keys, terminate with ENTER' call outtext(freqlin) IBASE=YMEAN dummy=setwritemode($GXOR) dummy=setcolor(12) goto 5499 5500 CALL moveto_w(fstart,dble(iyold),wxy) dummy=lineto_w(fend,dble(iyold)) 5499 iyold=ibase CALL moveto_w(fstart,dble(ibase),wxy) dummy=lineto_w(fend,dble(iBASE)) 5501 IK=INKEY(N) KK=CHAR(IK) if(KK.eq.'z'.or.kk.eq.'Z')then ibase=ibase-(rlarge-rsmall)/maxy if(kk.eq.'Z')ibase=ibase-9.*(rlarge-rsmall)/maxy if(ibase.lt.rsmall)ibase=rsmall goto 5500 endif if(KK.eq.'W'.or.kk.eq.'w')then ibase=ibase+(rlarge-rsmall)/maxy if(kk.eq.'W')ibase=ibase+9.*(rlarge-rsmall)/maxy if(ibase.gt.rlarge)ibase=rlarge goto 5500 endif if(ik.ne.13)goto 5501 c c...determine cutoff level c call settextposition(1,1,curpos) call outtext(emplin) call settextposition(1,1,curpos) write(freqlin,'(a)') * ' Set the Y-axis cutoff with W,Z keys, terminate with ENTER' call outtext(freqlin) IYCUT=Ibase+10*(rlarge-rsmall)/maxy goto 5505 5502 CALL moveto_w(fstart,dble(iyold),wxy) dummy=lineto_w(fend,dble(iyold)) 5505 iyold=iycut CALL moveto_w(fstart,dble(iycut),wxy) dummy=lineto_w(fend,dble(iycut)) 5503 IK=INKEY(N) KK=CHAR(IK) if(KK.eq.'z'.or.kk.eq.'Z')then iycut=iycut-(rlarge-rsmall)/maxy if(kk.eq.'Z')iycut=iycut-9.*(rlarge-rsmall)/maxy if(iycut.le.ibase)iycut=ibase+(rlarge-rsmall)/maxy goto 5502 endif if(KK.eq.'W'.or.kk.eq.'w')then iycut=iycut+(rlarge-rsmall)/maxy if(kk.eq.'W')iycut=iycut+9.*(rlarge-rsmall)/maxy if(iycut.gt.rlarge)iycut=rlarge goto 5502 endif if(ik.ne.13)goto 5503 c CALL clearscreen($GCLEARSCREEN) CALL AUTOPK(IYCUT,IBASE,NFIT) dummy=setwritemode($GPSET) dummy=setcolor(15) DUMMY=SETTEXTCOLOR(15) GOTO 632 ENDIF C.................................................... C C...Frequency of line under the cursor (with O) C c If the spectrum is interpolated then fitting width becomes NFIT*nmult and c points from FREINT,ISPINT are used c IF(KK.EQ.'O'.or.KK.EQ.'o')THEN DUMMY=SETTEXTCOLOR(11) if(nmult.eq.1)then mark=marker else mark=1+nint( (fmark-fstart)/(fend-fstart)*(nplot-1) ) endif I=0 DO 904 II=-(nmult*NFIT)/2,(nmult*NFIT)/2,1 I=I+1 IX=MARK+II IF(IX.LT.1.OR.IX.GT.NPTS)THEN WRITE(FREQLIN,906) 906 FORMAT(' ERROR: fitting interval exceeding data bounds') CALL settextposition(2,1,curpos) CALL outtext(FREQlin(1:80)) GOTO 7 ENDIF if(nmult.eq.1)then XFIT(I)=FREQS(IX) YFIT(I)=ISPEC(IX) else XFIT(I)=FREINT(IX) YFIT(I)=ISPINT(IX) endif 904 CONTINUE C if(nmult*nfit.gt.maxpk)then write(freqlin,'(2a)')' ERROR: Too many points for peak ', * 'measurement: reduce X-expansion' GOTO 965 endif CALL PEAKF(int2(nmult*NFIT),XPEAK,ERRORX,A0,A1) flast2=flast1 flast1=xpeak c c...refresh spectrum and cursor c CALL clearscreen($GVIEWPORT) DO 1105 I=NSTART,NEND RSPEC=DBLE(Ispec(i)) IF(RSPEC.gt.rlarge)rspec=rlarge if(rspec.lt.yshift)rspec=yshift if(i.eq.nstart)then CALL moveto_w(fstart,rspec,wxy) else dummy=lineto_w(FREQS(i),RSPEC) endif 1105 CONTINUE dummy=setwritemode($GXOR) dummy=setcolor(14) CALL moveto_w(fmark,RLARGE,wxy) dummy=lineto_w(fmark,YSHIFT) dummy=setwritemode($GPSET) c c...plot results - the whole screen is redrawn here to plot only the c results for the current peak c CALL moveto_w(FSTART,RLARGE,wxy) dummy=lineto_w(FSTART,YSHIFT) dummy=lineto_w(FEND,YSHIFT) dummy=lineto_w(FEND,RLARGE) dummy=lineto_w(FSTART,RLARGE) c C...fitted parabola c dummy=setwritemode($GPSET) dummy=setcolor(12) ycent=yfit((nmult*nfit)/2+1) xcent=xfit((nmult*nfit)/2+1) do 909 n=1,nmult*nfit rspec=xfit(n)+xcent if(n.eq.(nmult*nfit)/2+1)then ycord=ycent rspec=xcent else ycord=(a0+a1*xfit(n))*xfit(n)+ycent endif if(n.eq.1)then CALL moveto_w(rspec,dble(ycord),wxy) else dummy=lineto_w(rspec,ycord) endif 909 continue c c...various vertical lines c dummy=setcolor(11) rspec=(rlarge+rrsmal)/2.d0 CALL moveto_w(XPEAK,rspec,wxy) dummy=lineto_w(XPEAK,rrsmal) c $NODEBUG CALL setlinestyle(#9999) $DEBUG dummy=setcolor(14) if(nmult.eq.1)then rspec=freqs(mark+nfit/2) else rspec=freint(mark+(nmult*nfit)/2) endif CALL moveto_w(rspec,RLARGE,wxy) dummy=lineto_w(rspec,YSHIFT) c if(nmult.eq.1)then rspec=freqs(mark-nfit/2) else rspec=freint(mark-(nmult*nfit)/2) endif CALL moveto_w(rspec,RLARGE,wxy) dummy=lineto_w(rspec,YSHIFT) $NODEBUG CALL setlinestyle(#FFFF) $DEBUG c call marsca(fstart,fend) c C...text results c if(nmult.eq.1)then WRITE(FREQlin,903)XPEAK,ERRORX,NFIT else WRITE(FREQlin,908)XPEAK,ERRORX,NFIT,nmult endif 903 FORMAT('Fitted peak frequency: ',F14.4,' +-',F7.4, * ' MHz, using',I4,' points') 908 FORMAT('Fitted peak frequency: ',F14.4,' +-',F7.4, * ' MHz, using',I4,' *',i3,' points') C 965 DUMMY=SETTEXTCOLOR( 11 ) c dummy4= setbkcolor( ntextb ) CALL settextposition(2,1,curpos) call outtext(emplin) CALL settextposition(1,1,curpos) CALL outtext(FREQlin(1:80)) C GOTO 7 ENDIF GOTO 7 C C...Help screen C 630 CALL clearscreen($GCLEARSCREEN) CALL HELP C 631 IK=INKEY(I) IF(IK.NE.13)GOTO 631 632 DUMMY=SETTEXTCOLOR(7) GOTO 333 C C...Error in options C 76 WRITE(*,'(2A1,$)')CHAR(7),CHAR(7) GOTO 33 C 37 RETURN END C C------------------------------------------------------------------------ C SUBROUTINE GLEOUT(YMIN,YMAX) c implicit real*8 (a-h,o-z) PARAMETER (MAXPTS=32000, plotl=273.) c INTEGER*4 ISPEC(maxpts),ISMALL,ILARGE,NPTS REAL*8 FREQS(maxpts) CHARACTER filnam*25,filgen*10,filout*12 c COMMON /SPEC/ISPEC,NPTS,ISMALL,ILARGE COMMON /FRE/FREQS COMMON /FNAM/FILNAM c if(nstr.eq.0)nstr=1 miny=YMIN maxy=YMAX c c...determine generic file name - fnam.ext type filename in the current c directory c filgen=filnam do 14 nc=1,10 if(filgen(nc:nc).eq.' '.or.filgen(nc:nc).eq.'.')goto 15 14 continue 15 nc=nc-1 if(nc.gt.6)nc=6 c c...OPTIONS c if(RM.eq.0.d0)RM=1.d0 FSP1=freqs(1) FSP2=freqs(NPTS) if(FSTART.eq.0.d0)FSTART=FSP1 if(FSCAL.eq.0.0d0)FSCAL=(FSP2-FSP1)/PLOTL c 59 WRITE(*,56) 56 FORMAT(1x,61(1H-)/22x,'min',9x,'max',9x,'range',4x,'10*mark') WRITE(*,55)' SPECTRUM:',FSP1,FSP2,FSP2-FSP1, * int((FSP2-FSP1)/(10.d0*rm)) 55 FORMAT(a,5x,3f12.2,i7/1x,61(1H-)) c RANGE=FSCAL*plotl F1=FSTART n=1 60 F2=f1+range WRITE(*,61)' PLOT:',n,F1,F2,range,int(range/(10.d0*rm)) 61 Format(a,i2,3x,3f12.2,i7) if(f2.lt.fsp2)then n=n+1 f1=f1+range goto 60 endif c 58 WRITE(*,57)nstr,rm,fscal,miny,maxy,fstart 57 FORMAT(1x/ * ' 1: Strips per page =',i7/ * ' 2: Marker spacing =',f11.3,' MHz'/ * ' 3: Plot scaling =',f11.3,' MHz/mm'/ * ' 4: Y-limits =',2I7/ * ' 5: Start frequency =',F11.3// * ' Select 1-5 (ENTER=OK) ..... ',$) C READ(*,'(I2)',err=59)I if(i.lt.0.or.i.gt.5)goto 59 c if(i.eq.1)then write(*,'(1x/'' Number of strips per page (1,2,or 3) = '',$)') read(*,'(i2)',err=59)n if(n.lt.1.or.n.gt.3)goto 59 nstr=n goto 59 endif c if(i.eq.2)then write(*,'(1x/'' New marker spacing: '',$)') read(*,'(F20.10)',err=59)temp if(temp.lt.0.001.or.temp.gt.1000.d0)goto 59 rm=temp goto 59 endif c if(i.eq.3)then write(*,'(1x/'' New plot scaling: '',$)') read(*,'(F20.10)',err=59)temp if(temp.le.0.001d0)goto 59 if(temp.gt.1000.d0)goto 59 fscal=temp goto 59 endif c if(i.eq.4)then write(*,70)ismall,ilarge 70 format(1x/' Y-axis limits of data: ',2i7// 1 ' Specify new MINY,MAXY: ',$) read(*,'(2i15)',err=59)ia,ib if(ib.le.ia)goto 59 if(ib.le.ismall.and.ia.le.ismall)goto 59 if(ib.ge.ilarge.and.ia.ge.ilarge)goto 59 miny=ia maxy=ib goto 59 endif c if(i.eq.5)then write(*,'(1x/'' New start frequency = '',$)') read(*,'(F20.10)',err=59)temp if(temp.gt.fsp2)goto 59 if(temp.lt.fsp1-plotl*fscal)goto 59 fstart=temp goto 59 endif c c...write a single .DAT file for the whole spectrum c filout=filgen(1:nc)//'.dat' write(*,'(1x/a)')' Data written to '//filout OPEN(3,file=filout,status='unknown') write(3,1)'! Spectrum from file: '//filnam write(3,1)'!' 1 format(a) scale=maxy-miny do 100 n=1,npts write(3,101)freqs(n),(ispec(n)-miny)/scale 100 continue 101 format(f12.4,f9.4) close(3) c c...generate the necessary .GLE files c RANGE=FSCAL*plotl F1=FSTART n=1 65 F2=f1+range call wrigle(f1,f2,rm,n,nstr,filgen,nc) if(f2.lt.fsp2)then n=n+1 f1=f1+range goto 65 endif c WRITE(*,'(1x/'' ---- DONE, Press ENTER'')') READ(*,'(I2)',err=52)I 52 RETURN END C c C------------------------------------------------------------------------ C subroutine wrigle(f1,f2,rm,n,nstr,fnam,nc) c C Write/append a spectral strip to a .GLE file C c F1,F2 - frequency limits C RM - marker spacing C n - number of spectral strip c nstr - number of spectral strips per page c fnam - generic file name c nc - number of characters to be used from FNAM c implicit real*8 (a-h,o-z) PARAMETER (MAXPTS=32000, plotl=273.) c INTEGER*4 ISPEC(maxpts),ISMALL,ILARGE,NPTS REAL*8 FREQS(maxpts) CHARACTER fnam*10,filout*12,filnam*25,outstr*30 c COMMON /SPEC/ISPEC,NPTS,ISMALL,ILARGE COMMON /FRE/FREQS COMMON /FNAM/FILNAM c maxlab=5 topstr=0 nn=(n-1)/nstr+1 if(n-((n-1)/nstr)*nstr.eq.1)topstr=1 xs=-5.45 xtxt=0.3 c C...single strip c if(nstr.eq.1)then ys= 2.0 sizey=20. ytxt=19.5 endif c c...two strips c if(nstr.eq.2)then sizey=11. if(topstr.eq.1)then ys=11.0 else ys= 1.8 endif ytxt=20.9 endif c c...three strips c if(nstr.eq.3)then sizey=7.4 ytxt=21.2 if(topstr.eq.1)then ys=14.6 else nnn=n-(n/nstr)*nstr if(nnn.ne.0)then ys=8.2 else ys=1.8 endif endif endif c c...write .GLE file(s) c write(outstr,'(I2)')nn if(nn.lt.10)then filout=fnam(1:nc)//outstr(2:2)//'.gle' else filout=fnam(1:nc)//outstr(1:2)//'.gle' endif if(nstr.eq.1.or.topstr.eq.1)then write(*,'(a)')' Control file written to '//filout OPEN(4,file=filout,status='unknown') else OPEN(4,file=filout,status='old',access='append') endif c if(topstr.eq.1)then write(4,2) write(4,1)'! Plot of spectrum from file: '//filnam write(4,2) 2 format('!',75(1h-)) write(4,1)'!' write(4,1)'size 29.5 21' 1 FORMAT(a) write(4,1)' ' write(4,1)'set lwidth 0.025' write(4,1)'set join round' endif c write(4,1)' ' write(outstr,'(a,2f6.2)')'amove',xs,ys write(4,1)outstr write(4,1)'begin graph' write(4,1)' nobox' write(outstr,'(a,f6.2)')' size 38.57',sizey write(4,1)outstr filout=fnam(1:nc)//'.dat' write(4,1)' d1 bigfile '//filout write(4,'(a,f10.2,a,F10.2,a,F9.2,a,F9.3)') * ' xaxis min ',F1,' max ',F2,' dticks ',10.d0*RM, * ' dsubticks ',RM write(4,1)' x2ticks off' write(4,1)' xticks length 0.3' write(4,1)' xsubticks length 0.12' write(4,1)' xlabels hei 0.5 font texcmr' c write(4,1)' yaxis min 0.0 max 1.0' write(4,1)' ylabels off' write(4,1)' yticks off' write(4,1)' d1 lstyle 1 smooth' c c...deal with more than MAXLAB marker labels c tenm=rm*10.d0 ftenm=dint(f1/tenm)*tenm if(ftenm.le.f1)ftenm=ftenm+tenm firstm=ftenm c if(dint((f2-f1)/tenm).gt.real(maxlab))then mult=1 30 mult=mult+1 if((f2-f1)/(mult*tenm).gt.maxlab)goto 30 c 31 flastm=ftenm+6.d0*tenm call xlab(firstm,f2,ftenm,flastm,tenm,mult) if(flastm.lt.f2-tenm)then ftenm=flastm+tenm goto 31 endif endif c goto 26 c 26 write(4,1)'end graph' c c...legend line c if(n.eq.(n/nstr)*nstr)then write(4,1)' ' write(4,1)'set font texcmr' write(4,1)'set hei 0.7' write(outstr,'(2f6.1)')xtxt,ytxt write(4,1)'amove'//outstr write(4,1)'text '//filnam write(4,1)'!' write(4,2) endif c close(4) c return end C C------------------------------------------------------------------------ C subroutine marsca(f1,f2) c c Plot and label the marker scale for frequency limits F1,F2 c INCLUDE 'FGRAPH.FD' PS1 c USE MSFLIB PS4 c RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy c LOGICAL*2 true PARAMETER (TRUE=.TRUE.) c INTEGER*2 maxx,maxy,linofs,mymode,myrows,mycols,dummy,nbufer,nm INTEGER*4 blue,red CHARACTER*80 toplin,emplin,paslin,marlin CHARACTER botlin*79,BUFREQ*8 REAL*8 FSTEP,F1,F2,RM,FRMARK,FLONG,H,YY REAL*8 RSMALL,RLARGE,RRSMAL,YYSTEP,YSHIFT COMMON /limits/wxy,maxx,maxy,linofs,curpos,ixy, * mymode,myrows,mycols,blue,red COMMON /lines/toplin,emplin,paslin,botlin COMMON /plotda/RSMALL,RLARGE,RRSMAL,YYSTEP,YSHIFT c C...determine markers: RM=marker spacing, C FRMARK=frequency of first marker FSTEP=F2-F1 RM=100000.D0 1111 NM=FSTEP/RM IF(NM.LT.15)THEN RM=RM*0.1D0 GOTO 1111 ENDIF FRMARK=DINT(F1/RM)*RM IF(FRMARK.LT.F1)FRMARK=FRMARK+RM C C...plot the marker scale; NOTE that the X-axis of the floating point window C is set to frequencies C marlin=emplin FSTEP=(F2-F1)/maxx flong=0.0d0 dummy=setwindow(TRUE,F1,RRSMAL,F2,RLARGE) c 1114 YY=RSMALL-8.D0*YYSTEP H=DNINT(FRMARK/RM) IF(DNINT(10.D0*DINT(H*0.1D0)).EQ.H)THEN YY=RSMALL-13.D0*YYSTEP IF(FLONG.EQ.0.D0)FLONG=FRMARK NBUFER=(FRMARK-F1)/(F2-F1) * 80.D0 IF(NBUFER-3.GE.1.AND.NBUFER+4.LE.79)THEN WRITE(BUFREQ,'(F8.1)')FRMARK IF(NBUFER-3.LE.4)THEN marlin(NBUFER-3:NBUFER+4)=BUFREQ GOTO 1000 ENDIF IF(marlin(NBUFER-6:NBUFER-6).EQ.' ')THEN marlin(NBUFER-3:NBUFER+4)=BUFREQ ENDIF ENDIF ENDIF C 1000 DUMMY=SETCOLOR(15) CALL moveto_w(FRMARK,YSHIFT,wxy) dummy=lineto_w(FRMARK,YY) FRMARK=FRMARK+RM IF(FRMARK.LE.F2)GOTO 1114 c c...write the marker labels c DUMMY=SETTEXTCOLOR(15) CALL settextposition(int2(myrows-1),1,curpos) CALL outtext(marlin) c return end C C------------------------------------------------------------------------ C subroutine xlab(firstm,f2,frtenm,flastm,tenm,mult) c c firstm - frequency of first annotated marker c f2 - upper frequency limit of plot c frtenm,flastm - frequency of first and last big markers for annotation c tenm - big marker spacing c mult - label spacing which is MULT*TENM c implicit real*8 (a-h,o-z) character*127 marlin c c...the xplaces line c ftenm=frtenm write(4,'(a)')'!' write(marlin(1:9),'(a)')' xplaces ' marind=10 22 if(tenm.lt.0.01d0) * write(marlin(marind:marind+8),'(f9.3)',err=25)ftenm if(tenm.lt.0.1d0.and.tenm.ge.0.01d0) * write(marlin(marind:marind+8),'(f9.2)',err=25)ftenm if(tenm.lt.1.d0 .and.tenm.ge.0.1d0) * write(marlin(marind:marind+8),'(f9.1)',err=25)ftenm if(tenm.ge.1.d0) * write(marlin(marind:marind+8),'(i9)',err=25)nint(ftenm) marind=marind+9 if(marlin(marind-9:marind-9).ne.' ')then if(marind.le.127)marlin(marind:marind)=' ' marind=marind+1 endif ftenm=ftenm+tenm if(ftenm.le.flastm.and.ftenm.lt.f2)then goto 22 else write(4,'(a)')marlin(1:marind-1) endif c c...the xnames line c write(marlin(1:8),'(a)')' xnames ' marind=9 ftenm=frtenm c 30 if(dint((ftenm-firstm)/(mult*tenm))*mult*tenm.ne. * (ftenm-firstm))then write(marlin(marind:marind+8),'(a)')' " " ' marind=marind+9 else 23 if(tenm.lt.0.01d0) * write(marlin(marind:marind+10),'(a,f9.3,a)',err=25) * '"',ftenm,'"' if(tenm.lt.0.1d0.and.tenm.ge.0.01d0) * write(marlin(marind:marind+10),'(a,f9.2,a)',err=25) * '"',ftenm,'"' if(tenm.lt.1.d0 .and.tenm.ge.0.1d0) * write(marlin(marind:marind+10),'(a,f9.1,a)',err=25) * '"',ftenm,'"' if(tenm.ge.1.d0) * write(marlin(marind:marind+10),'(a,i9,a)',err=25) * '"',nint(ftenm),'"' marind=marind+11 endif c ftenm=ftenm+tenm if(ftenm.le.flastm.and.ftenm.lt.f2)then goto 30 else write(4,'(a)')marlin(1:marind-1) write(4,'(a)')'!' endif c return c 25 write(4,27) 27 format('!'/'! SORRY - Could not generate xnames/xplaces lines'/ * '!') return end C C------------------------------------------------------------------------ C SUBROUTINE HELP C WRITE(*,632) 632 FORMAT(1x/' ____A V A I L A B L E O P T I O N S',42(1h_)// * 9X,'A,S - shift screen window over the spectrum'/ * 9X,'Q,E - zoom out/in in frequency'/ * 9X,'W,Z - increase, decrease vertical scale'/ * 9X,'2,3 - shift spectrum up/down'/ * 9X,'K,L - move cursor over the spectrum'// * 9X,' All of the above are fast/slow for ', * 'upper/lower case'// * 9X,' , - center/quarter cursor'/ * ' - move to beginning/end of spectrum'/) WRITE(*,633) 633 FORMAT( * 9X,' B - baseline subtraction'/ * 9X,' N - smoothing'/ * 9X,' M - output of current spectrum'/ * 9X,'O/0 - peak frequency/fitting width and PEAKFINDER'/ * 9X,' R - restore original spectrum'/ * 9X,' G - gle output'// * 9X,' H - display this HELP screen (exit with ENTER)',$) C RETURN END C C------------------------------------------------------------------------ C SUBROUTINE AUTOPK(IYCUT,IBASE,NFIT) C IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-N) PARAMETER (MAXPTS=32000,maxlin=1000,maxpk=500) C INTEGER*4 ISPEC(MAXPTS),ISMALL,ILARGE,NPTS REAL*8 FREQS(MAXPTS) CHARACTER FILNAM*25,outstr*21,stat*7 REAL*8 X(maxlin),Y(maxlin),A(maxlin),B(maxlin),C(maxlin),D(maxlin) REAL*8 FPLU(maxlin) INTEGER*4 INTPLU(maxlin) REAL*4 ERPLU(maxlin) EQUIVALENCE (A(1),FPLU(1)),(B(1),ERPLU(1)),(C(1),INTPLU(1)) C COMMON /FRE/FREQS COMMON /SPEC/ISPEC,NPTS,ISMALL,ILARGE COMMON /SPL/NSPLIN,X,Y,A,B,C,D,GRA,CA,GRB,CB COMMON /FRFIT/XFIT(maxpk),YFIT(maxpk) COMMON /FNAM/FILNAM C c...preliminaries c WRITE(*,910) 910 FORMAT(1X/' ____P E A K F I N D E R',56(1h_)//) WRITE(*,912)IYCUT,IBASE 912 FORMAT(5x,'Peaks will be identified for lines with intensity ', * 'above'/5x,'the cutoff value and peak intensities will be ' * 'relative'/5x,'to the specified baseline'// * 5x,'Y-axis cutoff: ',I6/ * 5x,'Y-axis baseline: ',I6/) C STAT='NEW' 927 WRITE(*,'(1X/5x,''OUTPUT FILE NAME : '',$)') READ(*,'(a)',ERR=927)OUTSTR STAT='NEW' 918 OPEN(3,FILE=OUTSTR,STATUS=STAT,ERR=917) GOTO 920 C 917 WRITE(*,'(1X,a1/5x, * ''THIS FILE ALREADY EXISTS, OVERWRITE (Y/N)? '',$)')CHAR(7) READ(*,'(a)',ERR=917)CHARFL IF(CHARFL.EQ.'Y'.OR.CHARFL.EQ.'y')THEN STAT='UNKNOWN' GOTO 918 ENDIF IF(CHARFL.EQ.'N'.OR.CHARFL.EQ.'n')THEN 919 WRITE(*,'(5x,''New file name: '',$)') READ(*,'(a)',ERR=919)FILNAM GOTO 918 ENDIF c c C...establish maxima greater than IYCUT on the basis of five peaked points c and fit their position, two iterations of the fit are carried out to c compensate for the inaccuracy in the initial central point c 920 IX=NFIT/4 I=2*IX I2X=I nplu=0 WRITE(*,938) 938 FORMAT(1x//5x,'The number of identified lines: '/' ',$) c c...loop over the spectrum 1514 I=I+1 IF(I.GT.(NPTS-I2X))GOTO 1515 IF(ISPEC(I).LT.IYCUT)GOTO 1514 IF(ISPEC(I).GT.ISPEC(I-I2X).AND.ISPEC(I).GT.ISPEC(I-IX).AND. * ISPEC(I).GT.ISPEC(I+I2X).AND.ISPEC(I).GT.ISPEC(I+IX))THEN c NTIMES=0 922 J=0 DO 921 II=-NFIT/2,NFIT/2,1 J=J+1 K=I+II XFIT(J)=FREQS(K) YFIT(J)=ISPEC(K) 921 CONTINUE C CALL PEAKF(NFIT,XPEAK,ERRORX,A0,A1) NTIMES=NTIMES+1 delta=xpeak-freqs(i) deltaf=freqs(i+1)-freqs(i) C nplu=nplu+1 fplu(nplu)=xpeak erplu(nplu)=errorx INTPLU(NPLU)=ISPEC(I) intplu(nplu)=INTPLU(NPLU)-ibase c IF(NPLU.EQ.10*(NPLU/10))WRITE(*,'(I5,$)')NPLU I=I+I2X endif GOTO 1514 c C...output frequencies C 1515 WRITE(*, * '(1X//5x,''PEAKFINDER found'',i5,'' transitions''//)')nplu write(3,926)filnam,IYCUT,IBASE,NFIT,NPLU 926 format(78(1H-)/' PEAK FREQUENCIES MEASURED IN SPECTRUM: ', * a//' cutoff, baseline: ',2I7,7X,'fitting width:',I5/ * ' number of lines: ',i7/78(1H-)/) C C...Synthetic table of results C WRITE(3,950) 950 FORMAT(2(' F',14X,'Int ',3x),' F',14X,'Int'/) C if(nplu.lt.12)then do 800 i=1,11 write(3,947)FPLU(i),ERPLU(i),INTPLU(i) 800 continue goto 946 endif j=nplu/3 jj=j do 944 i=1,j write(3,948)FPLU(i),ERPLU(i),INTPLU(i), * FPLU(i+j),ERPLU(i+j),INTPLU(i+j), * FPLU(i+2*j),ERPLU(i+2*j),INTPLU(i+2*j) 944 continue jj=3*j 945 if(jj.lt.nplu)then jj=jj+1 write(3,949)FPLU(JJ),ERPLU(jj),INTPLU(jj) goto 945 endif c 948 FORMAT(2(F10.3,' +-',F5.3,I6,3x),F10.3,' +-',F5.3,I6) 949 FORMAT(54x,F10.3,' +-',F5.3,I6) 947 FORMAT(27x,F10.3,' +-',F5.3,I6) C 946 WRITE(3,'(78(1H-))') close(3) c WRITE(*,'(40x,''Press ENTER to continue '',$)') READ(*,'(I1)',ERR=941)I C 941 RETURN END C C------------------------------------------------------------------------ C SUBROUTINE PEAKF(N,XPEAK,ERRORX,A0,A1) C C Position of line maximum is established using a linear transformation C of the parabola C 2 Y-Yo C from Y = a + b X + c X to ---- = b + c ( X - Xo) C X-Xo C C The central XY point is used for Xo,Yo and a straight line fit gives C b and c. Peak of the parabola is at -b/2c. This routine will locate both C upward and downward peaks (c -ve and +ve), with reliability increasing C with the proximity of the central point in the data to the peak C C N - number of XY data pairs (odd) C X,Y - arrays containg XY coordinates of spectral points C XPEAK - on exit the required central fitted peak position C ERRORX - on exit the error on the fitted peak position C A0 - parameter b of the reduced parabola C A1 - parameter c of the reduced parabola C IMPLICIT REAL*8 (A-H,O-Z) INTEGER*2 N parameter (maxpk=500) c COMMON /FRFIT/X(maxpk),Y(maxpk) C C...value of X is given a small fractional shift so that no two points C have the same frequency NCENT=N/2+1 DO 1 I=1,N IF(I.EQ.NCENT)GOTO 1 X(I)=X(I)-X(NCENT)+I*1.D-7 Y(I)=(Y(I)-Y(NCENT))/X(I) 1 CONTINUE C C...The number of points in the fit is N-1 since the central point is C used for biasing C SUMX=0.D0 SUMY=0.D0 SUMXY=0.D0 SUMX2=0.D0 SUMY2=0.D0 DO 2 I=1,N IF(I.EQ.NCENT)GOTO 2 SUMX=SUMX+X(I) SUMY=SUMY+Y(I) SUMXY=SUMXY+X(I)*Y(I) SUMX2=SUMX2+X(I)*X(I) SUMY2=SUMY2+Y(I)*Y(I) 2 CONTINUE C C...coefficients RN=N-1 CXX=SUMX2-SUMX*SUMX/RN CXY=SUMXY-SUMX*SUMY/RN A1=CXY/CXX IF(A1.EQ.0.D0)THEN ERRORX=0.D0 XPEAK=0.D0 RETURN ENDIF A0=(SUMY-A1*SUMX)/RN XPEAK=X(NCENT)-0.5D0*A0/A1 C C...error CYY=SUMY2-SUMY*SUMY/RN ERA1S=((CYY/CXX)-(CXY/CXX)**2)/(RN-2.D0) ERA0S=SUMX2*ERA1S/RN ERRORX=ABS(0.5D0*(A0/A1))*DSQRT(ERA1S/A1**2+ERA0S/A0**2) C WRITE(*,*)X(NCENT) C WRITE(*,*)'A1 ',A1,DSQRT(ERA1S) C WRITE(*,*)'A0 ',A0,DSQRT(ERA0S) C RETURN END C C_____________________________________________________________________________ c subroutine smooth(icontr) c c Least squares smoothing routine: c c ICONTR=1 - just smooth the data in ISPEC c ICONTR=2 - subtract the baseline from the spectrum in ISPEC c PARAMETER (maxpts=32000,maxsmo=500) c integer*4 idata(maxpts),ioldat(maxpts),itemp(maxpts) integer*4 ismall,ilarge,npts real spol(maxsmo) COMMON /SPEC/Idata,NPTS,ISMALL,ILARGE common /bufers/ioldat,itemp c if(icontr.eq.2)then WRITE(*,2) 2 format(1X/' ____B A S E L I N E S U B T R A C T I O N', * 36(1h_)/// * 5x,'The baseline is defined by smoothing the spectrum with'/ * 5x,'an interval which is much longer than the linewidth'//5x, * '- Kisiel and Pszczolkowski, J.Mol.Spectrosc. 158,318(1993)'/) else WRITE(*,1) 1 format(1x,/ * ' ____L E A S T S Q U A R E S S M O O T H I N G',30(1h_)/// * 5x,'This is standard cubic polynomial smoothing of', * ' Savitsky and Golay and'/5x, * 'it has been recommended not to use smoothing intervals longer'/ * 5x,'than 0.7*FWHH'//5x, * '- Savitsky and Golay, Analyt.Chem. 36,1627(1964)'/5x, * '- Edwards and Wilson, Appl.Spectrosc. 28.541(1974)'/) endif c 1101 WRITE(*,1102) 1102 FORMAT(1X//5x,'Specify the number of points for ', * 'the smoothing interval ' * /5x,'( >3 and odd )'/30x,' .... ',$) READ(*,'(i5)',ERR=1101)NSPT IF(NSPT.LE.3.OR.NSPT.GT.maxsmo)GOTO 1101 IF((NSPT/2)*2.EQ.NSPT)GOTO 1101 c if(icontr.eq.2)then WRITE(*,'(1X//5x,''S U B T R A C T I N G''//)') else WRITE(*,'(1X//5x,''S M O O T H I N G''//)') endif c C For smoothing interval of length 2m+1 the elements of the smoothing c (cubic) polynomial are given by: C C 3(3m**2 + 3m -1 - 5s**2) C c(s) = ------------------------ C (2m+1) (2m-1) (2m+3) C C where s runs from -m to +m (T.H.Edwards and P.D.Wilson, Applied C Spectroscopy 28,541-545(1974)) C C c...set up coefficients in smoothing polynomial M=NSPT/2 T1=3.D0/((2*M+1)*(2.D0*M-1.D0)*(2*M+3)) T2=3*M*M+3.D0*M-1.D0 DO 1103 j=1,NSPT IS=j-M-1 SPOL(j)=T1*(T2-5*IS*IS) 1103 CONTINUE c c...straightforward smoothing c if(icontr.eq.1)then do 2105 j=1,npts itemp(j)=idata(j) 2105 continue DO 2543 I=1,npts SUM=0. DO 2544 J=1,NSPT IS=J-M-1 II=I+IS IF(II.LT.1)II=-II+1 IF(II.GT.npts)II=npts-(II-npts-1) SUM=SUM+itemp(II)*SPOL(J) 2544 CONTINUE Idata(I)=sum 2543 CONTINUE return endif c C...Subtraction of background by triple smoothing of interferogram with c least squares smoothing interval C c...Smooth three times DO 1104 k=1,3 write(*,'(20x,'' Smooth '',i1)')k do 1105 j=1,npts itemp(j)=idata(j) 1105 continue DO 543 I=1,npts SUM=0. DO 544 J=1,NSPT IS=J-M-1 II=I+IS IF(II.LT.1)II=-II+1 IF(II.GT.npts)II=npts-(II-npts-1) SUM=SUM+itemp(II)*SPOL(J) 544 CONTINUE Idata(I)=sum 543 CONTINUE DO 545 I=1,npts ITEMP(I)=IDATA(I) 545 CONTINUE 1104 continue C do 1106 j=1,npts itemp(j)=idata(j) idata(j)=ioldat(j)-idata(j) 1106 continue c return end C C------------------------------------------------------------------------ c SUBROUTINE SAVESP C C This routine saves the recorded data into a file FREQLIN type binary c format which consists of header, INTEGER*2 intensisites, and frequency c limits and increment. C IMPLICIT INTEGER*2 (I-N) IMPLICIT REAL*4 (A-H,O-Z) PARAMETER (MAXPTS=32000) COMMON /FLIMIT/FSTART,FEND,FINCR COMMON /FNAM/FILOLD COMMON /SPEC/ISPEC(MAXPTS),NPTS,ISMALL,ILARGE, 1 /INFO/COMENT,IDAY,IMON,IYEAR,IHOUR,IMIN,ISEC, 1 LAMP,VKMST,VKMEND,GRID,SAMPLE,SAMPRE,GAIN,TIMEC,PHASE, 1 SCANSP,PPS,FRMOD,FRAMPL REAL*8 FSTART,FEND,FINCR INTEGER*4 ISPEC,NPTS,ISMALL,ILARGE,imean CHARACTER FILOLD*25,CHARFL,STAT*7,filnam*25 CHARACTER*72 COMENT CHARACTER*6 LAMP,SCANSP CHARACTER*20 SAMPLE C C 51 write(*,50)filold 50 format(1x/' This spectrum is from file: ',a// * ' Specify file name for output: ',$) read(*,'(a)',err=51)filnam C 22 stat='NEW' 26 OPEN(3,FILE=FILNAM,STATUS=STAT,FORM='BINARY',ERR=21) WRITE(3)COMENT,IDAY,IMON,IYEAR,IHOUR,IMIN,ISEC, 1 LAMP,VKMST,VKMEND,GRID,SAMPLE,SAMPRE,GAIN,TIMEC,PHASE, 1 SCANSP,PPS,FRMOD,FRAMPL C c...Intensities of spectral data points - centre intensity on zero c ISMALL= 1000000000 ILARGE=-1000000000 do 100 n=1,npts if(ispec(n).lt.ismall)ismall=ispec(n) if(ispec(n).gt.ilarge)ilarge=ispec(n) 100 continue imean=(ilarge+ismall)/2 c WRITE(3)int2(NPTS),int2(ISMALL-imean),int2(ILARGE-imean) DO 20 N=1,NPTS WRITE(3)int2(ispec(n)-imean) 20 CONTINUE ncalpt=0 c C...Frequency limits and increment (MHz) c WRITE(3)FSTART,FEND,FINCR,ncalpt C CLOSE(3) GOTO 23 21 WRITE(*,'(1X,a1/'' THIS FILE ALREADY EXISTS, OVERWRITE (Y/N)? '' * ,$)')CHAR(7) READ(*,1300,ERR=21)CHARFL IF(CHARFL.EQ.'Y'.OR.CHARFL.EQ.'y')THEN STAT='UNKNOWN' GOTO 26 ENDIF IF(CHARFL.EQ.'N'.OR.CHARFL.EQ.'n')THEN 27 WRITE(*,'('' New file name: '',$)') READ(*,1300,ERR=27)FILNAM 1300 FORMAT(A) GOTO 22 ENDIF C 23 RETURN END C C------------------------------------------------------------------------ c SUBROUTINE INTERP(FSTART,FEND,nstart,nend,nplot,nmult) PARAMETER (MAXPTS=32000,intpt=640) C C Interpolation by successive doubling of the number of data points C (using Lagrange's formula for quadratic interpolation) c C FSTART,FEND - bounding frequencies C NSTART,NEND - indices for points with FTSART,FEND in ISPEC c nplot - number of points to be plotted from the interpolation c buffers ISPINT,FREINT c nmult - the multiplier by which the density of points has been c increased c implicit real*8 (a-h,o-z) INTEGER*4 ISPEC(maxpts),ISPINT(intpt) REAL*8 FREINT(intpt),work(intpt) COMMON /SPEC/ISPEC,NPTS,ISMALL,ILARGE common /intpol/freint,ispint c i=0 do 1 n=nstart,nend i=i+1 work(i)=dble(ispec(n)) 1 continue nplot=i c 2 I=0 DO 103 N=2,2*nplot-4,2 i=i+1 ispint(n-1)=work(i) ispint(n)=0.375d0*work(i)+0.75d0*work(i+1)-0.125d0*work(i+2) 103 CONTINUE ispint(2*nplot-3)=work(i+1) ispint(2*nplot-2)= * -0.125d0*work(i)+0.75d0*work(i+1)+0.375d0*work(i+2) ispint(2*nplot-1)=work(i+2) nplot=2*nplot-1 nmult=nmult*2 c if(2*nplot.le.intpt)then do 3 n=1,nplot work(n)=dble(ispint(n)) 3 continue goto 2 endif c fincr=(fend-fstart)/(nplot-1) do 4 n=1,nplot freint(n)=fstart+(n-1)*fincr 4 continue c RETURN END C C------------------------------------------------------------------------ c integer*2 function INKEY(N2) msps c c By L Pszczolkowski: c c...This emulates for MSF PS1.0 the INKEY function of Z.Czumaj which c in turn emulated for MSF5.0 the INKEY function from IIUWGRAF graphics c library for the Hercules card c c The function GETCHARQQ returns the ASCII character if the corresponding c key was pressed. If function or direction key was pressed then 0 c or hex E0 is returned and aniother call to GETCHARQQ is required to c get the extended code of the character c INCLUDE 'FLIB.FD' PS1 c USE MSFLIB PS4 c INTEGER*2 IK,n2 msps CHARACTER*1 KK msps c KK=GETCHARQQ() msps IK=ICHAR(KK) msps IF(IK.EQ.0 .OR. IK.EQ.224 ) THEN msps KK=GETCHARQQ() msps IK=-ICHAR(KK) msps ENDIF msps n2=ik msps INKEY=IK msps END msps C_____________________________________________________________________________ C_____________________________________________________________________________