c$debug C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C c VIEWer for Miscellaneous FTMW spectra c ---- - C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c This program allows viewing of multiple spectra, which can be: c c I. From a spectral archive .FAR as produced by FILMAN c II. An assortment of individual spectral files c as specified by the file LIST.DAT or similar produced with programs c FFTLIST or FILMAN or FFT8 in AUTO-SCAN c III. Any spectral files found in the local directory c c c Interdependence of displays: c c SUMMAR-----LOOKSP c | c --------INTCOM------LOOKSP c c where: SUMMAR - summary screen of fringe voltages and interferogram c amplitudes as a function of frequency c INTCOM - interferogram comparisons, nine interferograms per screen c LOOKSP - individual interferogram and its FFT c c NOTE: these routines, though they have the same names, are c different and incompatible with those in program VIEW for c viewing AUTOscanned spectra c C Ver 29.I.2001 ---- Zbigniew KISIEL ---- C __________________________________________________ C | Institute of Physics, Polish Academy of Sciences | C | Al.Lotnikow 32/46, Warszawa, POLAND | C | kisiel@ifpan.edu.pl | C_________________________/-------------------------------------------------- C C Modification history: C c 1.11.98: Creation c 8.11.98: Debugging to allow porting to MSF PS1.0 c 10.11.98: Reading of info associated with selected spectrum c 9.12.98: Modification to use LIST.DAT if found c 26.01.99: Modification to read .FAR spectral archives c 10.04.99: Modified bottom line in LOOKSP c 19.04.99: Input menu and option 9 in FFT c 30.04.99: Some allowance for 30 and 37 line graphics modes and MSPS4.0 c 7.05.99: Debugging c 11.05.99: More debugging of operation for MSF5.0, MSPS1.0 and MSPS4.0 c 12.05.99: Graphics mode set only on start and on exit - all other screen c changes made by clearing the same graphics screen c 25.05.99: maxarc=45 and debugging c 27.09.99: autoscaling in the summary screen c 29.09.99: debugging + various small mods. c 16.10.99: debugging c 22.10.99: interferograms in INTCOM plotted as a function of time c 9.01.00: $defaultmode exit from from the input options c 30.04.00: listing of frequency limits of archives c 23.08.00: modified ASCII output c 29.01.01: more of above + debugging + reading files from current dir. C_____________________________________________________________________________ c c MAXSPE - upper limit on the number of spectra that can be read in c MAXPTS - upper limit on the number of points in each interferogram c NIVOLS - number of diagnostic interferogram range voltages stored c in SCAN.DAT c INTERF - data points of all interferograms c FREQ - centre frequencies of all interferogram c VSTEP - voltage spacing per pixel (Volts) c TSTEP - time spacing per pixel (seconds) c NREP - number of recorded points in each intgerferogram (truncated c to MAXPTS if longer) c DETVOL - cavity fringe voltages on returning for each freq. step c VOLINT - interferogram amplitudes for various values of NSKIPS (the c central value is for NSKIPS as set during acquisition) c ISEEN - color for writing out name of interferogram to allow c discrimination between inspected and uninspected spectra c IPOINT - pointer to spectra in order of frequency sort C_____________________________________________________________________________ c c Compilation for MSF 5.0: c c - split this source into two parts before routine FFTEXE c - Comment out the INCLUDE FLIB.FI below c - Comment in the INTERFACE lines before routine INPOUT c - In INPOUT comment in lines with MSF5 and comment out lines with MSPS c - Comment out SUBROUTINE INKEY c - If FAR.LST is not created then there is not enough room for the c SYSTEM commands to execute: reduce MAXLIN or MAXSPE further (well c over 100 kbytes of headroom is required) c c Compilation for MS PowerStation 1.0 (this is the default for the code c below and should not be changed) c c - Use the INCLUDE FLIB.FI below c - Use SUBROUTINE INKEY at the end of listing c - Compile without the speed optimisation option (ie do not use -Ox) c c Compilation for MS Powerstation 4.0: c c - as above but replace all INCLUDE statements with USE MSFLIB c - use the -MWs option on compilation: this selects standard graphics c which works properly only in a window (not full screen). c QuickWin graphics as selected with -MW works even worse c c Select the required graphics mode in routine GRAPHICSMODE: uncomment only c one of MYMODE= and MYROWS= c c Colours: c C 0 - black 4 - red 8 - dark grey 12 - light red C 1 - blue 5 - magenta 9 - light blue 13 - light magenta C 2 - green 6 - brown 10 - light green 14 - yellow C 3 - cyan 7 - white 11 - light cyan 15 - bright white 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 The code in the graphics INCLUDE files clashes with IMPLICIT statements - C so when using MSF5.0 graphics the recomendation is to type everything C explicitly (check with -4Yg compilation switch) C c Uncomment the statements below (and in similar headers in routines c as necessary) MSF5 = MS Fortran 5.0 c PS1 and PS4 = MS Powerstation Fortrans 1.0 and 4.0 c c INCLUDE 'FGRAPH.FI' MSF5+PS1 INCLUDE 'FLIB.FI' PS1 INCLUDE 'FGRAPH.FD' MSF5+PS1 c USE MSFLIB PS4 C_____________________________________________________________________________ C RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy parameter (maxspe=500,maxpts=850,nivols=7,maxsmo=199) character fnams(maxspe)*12,filnam*30,filarc*30 real detvol(maxspe,2),volint(maxspe,nivols),spol(maxsmo) integer interf(maxspe,maxpts),idata(maxpts),nave(maxspe), * ioldat(maxpts),itemp(maxpts) integer*2 iseen(maxspe),ipoint(maxspe),dum2 INTEGER*2 maxx,maxy,LINOFS,mymode,myrows,mycols INTEGER*4 blue,red real*8 freq(maxspe) integer*2 nreps(maxspe),nskip(maxspe),nskip1(maxspe) real tsteps(maxspe),vsteps(maxspe) character comnt(maxspe)*50,sampl(maxspe)*20,timd(maxspe)*20 c common /scans/interf,freq,ipoint,filarc common /scans1/idata,vstep,tstep,nrep,nskips,nskipe,naver common /scans2/detvol,volint,iseen,nscans common /sfiles/fnams common /scan3/nreps,nskip,nskip1,tsteps,vsteps,nave COMMON /SCTEXT/COMNT,SAMPL,TIMD common /smooth/ioldat,itemp,spol COMMON /limits/maxx,maxy,LINOFS,curpos,ixy,wxy, * mymode,myrows,mycols,blue,red c mxnrep=0 mnnrep=maxpts c CALL graphicsmode() dum2=settextcolor( int2(15) ) call outtext( * '旼컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컫'// * '컴컴컴컴컴컴컴컴컴�') CALL settextposition(2,1,curpos) call outtext( * '� �'// * ' ver: 29.I.2001 �') CALL settextposition(3,1,curpos) call outtext( * '� V I E W M - VIEWer for Miscellaneous FTMW spectra �'// * ' �') CALL settextposition(4,1,curpos) call outtext( * '� �'// * ' Zbigniew Kisiel �') CALL settextposition(5,1,curpos) call outtext( * '읕컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컴컨'// * '컴컴컴컴컴컴컴컴컴�') dum2=settextcolor( int2(7) ) c write(*,3345)maxspe,maxpts 3345 format(1x/' up to',i5,' spectra'/ * ' up to',i5,' points in each spectrum') c if($BLUE.ne.#2a0000)then dum2=settextcolor(int2(11)) write(*,'(1x,a/)') * ' This program should be run in a maximised window' dum2=settextcolor(int2(15)) endif c c...Decide on type of input c call inpout(iarch,filarc,iexit) if(iexit.eq.1)then dum2=setvideomode($DEFAULTMODE) stop endif c c- - - - - - IARCH=0 - read individual spectral files - - - - - - - - - - - - c c either as found in current directory or as listed in c a listing file (from FILMAN, SVIEW, FFTLIST) c c...read LIST.DAT until EOF, errors in input skip the line in question so that c comment lines are allowed, but best be initiated with some nonnumeric c symbol such as $ or ! c if(iarch.eq.0)then c open(2,file='list.dat',status='old',err=1101) write(*,1102)'Using the standard listing file LIST.DAT' 1102 format(1x/' ----> ',a) write(filarc,'(a)')'Spectra listed in LIST.DAT' goto 102 1101 write(*,1102)'Usable LIST.DAT not found' c 101 write(*,100) 100 format(1x/' OPTIONS:'/ * ' ENTER = read spectral files in current directory'/ * ' file name = name of listing file for input of spectra'/ * ' minus sign = exit'//25x,'..... ',$) read(*,'(a)',err=101)filnam c c...exit c if(filnam(1:1).eq.'-')then dum2=setvideomode($DEFAULTMODE) stop endif c c - - - - - - read spectra as found in current directory c if(filnam(1:1).eq.' '.or.filnam(1:1).eq.char(0))then iarcht=-1 call inpspe(nfil) if(nfil.eq.0)then write(*,1115) 1115 format(1x//' ----> This directory', * ' appears to contain NO FTMW spectral files') goto 101 endif c mxnrep=0 nscans=1 do 1006 n=1,nfil filnam=fnams(n) call readsp(iarch,nscans,filnam,iread) c if(iread.gt.0)then ISEEN(nscans)=15 nreps(nscans)=nrep nskip(nscans)=nskips nskip1(nscans)=nskipe tsteps(nscans)=tstep vsteps(nscans)=vstep nave(nscans)=naver fnams(nscans)=fnams(n) if(nrep.gt.mxnrep)mxnrep=nrep ipoint(nscans)=NSCANS c do 1010 i=1,nrep idata(i)=interf(nscans,i) ioldat(i)=idata(i) 1010 continue c call baksub(51) c do 1011 i=1,nivols mindat= 1400000000 maxdat=-1400000000 j=nskips-(4-i)*20 do 1012 jj=j,nrep jjj=jj if(jjj.lt.1)jjj=1 if(idata(jjj).lt.mindat)mindat=idata(jjj) if(idata(jjj).gt.maxdat)maxdat=idata(jjj) 1012 continue volint(nscans,i)=1000.*vstep*(real(maxdat)-real(mindat)) 1011 continue c nscans=nscans+1 endif 1006 continue c nscans=nscans-1 nrep=mxnrep write(filarc,'(a)')'Spectra in local directory' c if(nscans.eq.0)then write(*,1115) goto 101 endif c c write(*,'(1x//i5,'' spectra have been identified''/)')nscans c write(*,*)(fnams(j),j=1,nscans) c pause c goto 1105 c endif c c - - - - - - use the specified listing file c open(2,file=filnam,status='old',err=101) filarc='Spectra listed in '//filnam iarcht=0 c 102 nscans=0 c 1 if(nscans.ge.maxspe)then read(2,3,end=2,err=1)filnam,vstep, * nrep,tstep,vstep,(vstep,j=1,nivols) if(vstep.eq.0.)goto 1 nscans=nscans+1 goto 1 else read(2,3,end=2,err=1)fnams(nscans+1),freq(nscans+1), * nrep,tstep,vstep,(volint(nscans+1,j),j=1,nivols) if(volint(nscans+1,nivols).eq.0.)goto 1 endif 3 format(a12,f12.3,i6,2f6.3,7f10.3) nscans=nscans+1 ipoint(nscans)=NSCANS if(nrep.gt.mxnrep)mxnrep=nrep if(nrep.lt.mnnrep)mnnrep=nrep goto 1 c 2 close(2) c write(*,4)NSCANS,mnnrep,mxnrep 4 FORMAT(1x//' The definition file has',i6,' interferograms'/ * ' minimum length = ',i5/ * ' maximum length = ',i5/) if(mxnrep.gt.maxpts)write(*,3470)char(7),maxpts if(nscans.eq.0.or.mnnrep.lt.50.or.mxnrep.lt.50)then write(*,1102)'List file rejected, try again' goto 101 endif if(nscans.gt.maxspe)then nscans=maxspe write(*,3471)char(7),nscans endif 3470 format(' ***** Interferograms will be chopped to ', * a,i5,' points') 3471 format(' ***** Only the first ',a,i5, * ' interferograms will be read') write(*,3473) 3473 format(1x/50x,'Press E N T E R ',$) read(*,'(i1)',err=3472)j 3472 write(*,'(1x/'' N O W R E A D I N G:''/)') c mxnrep=0 do 5 n=1,nscans filnam=fnams(n) call readsp(iarch,n,filnam,iread) ISEEN(N)=15 nreps(n)=nrep nskip(n)=nskips nskip1(n)=nskipe tsteps(n)=tstep vsteps(n)=vstep nave(n)=naver if(nrep.gt.mxnrep)mxnrep=nrep 5 continue nrep=mxnrep c c...SORT interferograms in frequency c 1105 if(nscans.gt.1)CALL SORTH c endif c c- - - - - - IARCH=1 - read files from spectral archive - - - - - - - - - - - c if(iarch.eq.1)then iarcht=1 open(3,file=filarc,form='binary',status='old') c write(*,'(1x/'' N O W R E A D I N G:''/)') n=0 c c...main loop for extraction of spectra from archive c ichop=0 411 call readsp(iarch,n,filnam,iread) if(iread.eq.-1)goto 410 if(iread.eq.2)ichop=1 ipoint(n)=n fnams(n)=filnam nreps(n)=nrep nskip(n)=nskips nskip1(n)=nskipe tsteps(n)=tstep vsteps(n)=vstep nave(n)=naver if(nrep.gt.mxnrep)mxnrep=nrep if(nrep.lt.mnnrep)mnnrep=nrep c c...subtract baseline using a 51 point smooth do 210 i=1,nrep idata(i)=interf(n,i) ioldat(i)=idata(i) 210 continue call baksub(51) c c...determine diagnostic voltages do 201 i=1,7 mindat= 1400000000 maxdat=-1400000000 j=nskips-(4-i)*20 do 200 jj=j,nrep jjj=jj if(jjj.lt.1)jjj=1 if(idata(jjj).lt.mindat)mindat=idata(jjj) if(idata(jjj).gt.maxdat)maxdat=idata(jjj) 200 continue volint(n,i)=1000.*vstep*(real(maxdat)-real(mindat)) 201 continue c if(n.eq.maxspe)then write(*,412)maxspe,char(7) 412 format(1x/' ***** The maximum of',i5,' intereferograms', * ' reached - no more will be read',a,$) else goto 411 endif 410 close(3) if(ichop.eq.1)write(*,454)maxpts,char(7) 454 format(1x/' ***** Interferograms have been chopped to',i5, * ' points',a,$) nscans=n nrep=mxnrep c write(*,540)NSCANS,filarc,mnnrep,mxnrep 540 FORMAT(1x//i6,' interferograms have been read from ',a/ * ' minimum length = ',i5/ * ' maximum length = ',i5/) write(*,3473) read(*,'(i1)',err=3475)j c 3475 if(nscans.gt.1)CALL SORTH c do 203 n=1,nscans ISEEN(N)=15 203 continue c endif c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...plot statistics c iarch=iabs(iarcht) call summar(iarch) c stop end c c--------------------------------------------------------------------------- c subroutine readsp(iarch,nspe,filnam,iread) c c IARCH=0 Read spectral file FILNAM and store it as spectrum number NSPE c - if there are more than MAXPTS data points they are truncated c to MAXSPE c IARCH=1 Read spectrum from the currently open spectral archive, c reading past the end of the archive results in IREAD=-1 c c IREAD=-1 end of file reached while attempting to read spectrum c IREAD= 0 spectrum could not be read properly c IREAD= 1 spectrum read in without problems c IREAD= 2 spectrum chopped to maxpts c PARAMETER (maxspe=500,maxpts=850) real*8 fcent,freq(maxspe) character timdat*20,coment*50,sample*20,INTEXT*30 character filnam*30,cdummy*6,filarc*30 character comnt(maxspe)*50,sampl(maxspe)*20,timd(maxspe)*20 integer interf(maxspe,maxpts),idata(maxpts),idummy integer*2 ipoint(maxspe) common /scans/interf,freq,ipoint,filarc common /scans1/idata,vstep,tstep,nrep,nskips,nskipe,naver COMMON /SCTEXT/COMNT,SAMPL,TIMD c iread=1 if(iarch.eq.0)then write(*,'(4x,a12,$)')filnam(1:12) OPEN(3,FILE=FILNAM,FORM='BINARY',ERR=503,STATUS='OLD') else read(3,end=510)cdummy,filnam(1:12),cdummy write(*,'(4x,a12,$)')filnam(1:12) endif C READ(3,end=510)sample READ(3,end=510)intext(1:27) READ(intext,'(3i5,f12.5)',err=510)nrep,nskips,nskipe,fcent if(nrep.lt.50)goto 510 if(fcent.lt.500.or.fcent.gt.26000.)goto 510 READ(3)intext(1:27) READ(intext,'(1pe10.3,e10.3,i7)',err=510)tstep,vstep,naver READ(3,end=510)coment,timdat c IF(IARCH.EQ.1)NSPE=NSPE+1 freq(nspe)=fcent COMNT(NSPE)=coment timd(nspe)=timdat sampl(nspe)=sample C c...Intensities of spectral data points c DO 20 N=1,Nrep if(n.le.maxpts)then READ(3,end=510)interf(nspe,n) else read(3,end=510)idummy endif 20 CONTINUE if(nrep.gt.maxpts)then iread=2 nskipe=nskipe-(nrep-maxpts) if(nskipe.lt.1)nskipe=1 nrep=maxpts if(nrep-nskips-nskipe.le.5)then nskipe=5 nskips=5 endif endif C if(iarch.eq.0)CLOSE(3) goto 501 c 503 write(*,504)filnam,char(7) 504 format(1x//' ***** Cannot open file: ',2a//) iread=0 return 510 iread=-1 c 501 return end c c--------------------------------------------------------------------------- c subroutine summar(iarch) c C Routine to display summary information on all acquired spectra and allow c cursor selection of spectrum/spectra for display c c VRANGE = voltage range (mV) for scaling of interferogram ranges c DRANGE = voltage range (mV) for scaling of fringe voltages c c...declarations necessary for graphics c INCLUDE 'FGRAPH.FD' MSF5+PS1 c USE MSFLIB PS4 c RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy INTEGER*1 MARK [ALLOCATABLE] (:) INTEGER*2 maxx,maxy,LINOFS,dummy,inkey,mymode,myrows,mycols INTEGER*4 dummy4,blue,red logical*2 true real*8 wmin,wmax,fstart,fend,fmark,rint,wrange,smin character kk,emplin*80,lwork1*80,lwork2*80,lwork3*80, * outstr*21 COMMON /limits/maxx,maxy,LINOFS,curpos,ixy,wxy, * mymode,myrows,mycols,blue,red c c...declarations for spectra c parameter (maxspe=500,maxpts=850,nivols=7, * vrange=50.0,drange=400.,true=.true.) character fnams(maxspe)*12,filarc*30 real detvol(maxspe,2),volint(maxspe,nivols) integer interf(maxspe,maxpts),idata(maxpts) integer*2 iseen(maxspe),ipoint(maxspe) real*8 freq(maxspe) common /scans/interf,freq,ipoint,filarc common /scans1/idata,vstep,tstep,nrep,nskips,nskipe,naver common /scans2/detvol,volint,iseen,nscans common /sfiles/fnams c idefm=0 smin=0.0d0 wmult=1.0 c volt=0.0 n=nivols/2+1 DO 201 I=1,nscans if(volt.lt.volint(i,n))VOLT=VOLINT(I,N) 201 CONTINUE wmult=volt/(vrange*0.5) c WRITE(emplin,'(80(1H ))') C c. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c G R A P H I C S C C...Start up the graphics C 179 pixcol=getcolor() dummy4 = setbkcolor( BLUE ) itxt=(mycols-80)/2 C C...definition of graphics viewport: first pixel coordinates of viewport c then real coordinates for scales c call setviewport(0,0,maxx,maxy) c fstart=freq(1) fend=freq(nscans) fstart=fstart-0.02*(fend-fstart) fend=fend+0.02*(fend-fstart) if(fend.eq.fstart)then fstart=fstart-2. fend=fend+2. endif c c...complete screen refresh from here c 178 wrange=wmult*vrange wmin=-0.1*WRANGE wmax= 1.1*WRANGE dummy=setwindow(TRUE,fstart,wmin,fend,wmax) call clearscreen($GCLEARSCREEN) CALL moveto_w(fstart,0.0d0,wxy) dummy=lineto_w(fend,0.0d0) dummy=lineto_w(fend,wrange) dummy=lineto_w(fstart,wrange) dummy=lineto_w(fstart,0.0d0) c c...define marker c if(idefm.eq.0)then nmark=nscans/2+1 fmark=freq(nmark) $NODEBUG CALL setlinestyle(#9999) $DEBUG CALL moveto_w(fmark,smin,wxy) dummy=lineto_w(fmark,dble(wrange)) imsize=imagesize_w(fmark,dble(wrange),fmark,0.d0) ALLOCATE (MARK(imsize)) CALL getimage_w(fmark,dble(wrange),fmark,0.d0,MARK) call putimage_w(fmark,dble(wrange),MARK,$GXOR) $NODEBUG CALL setlinestyle(#ffff) $DEBUG idefm=1 endif c c...Plot range voltages c DUMMY=SETCOLOR(12) do 100 n=1,nivols VOLT=VOLINT(1,N) IF(VOLT.GT.WRANGE)VOLT=WRANGE CALL moveto_w(freq(1),DBLE(volT),wxy) if(n.eq.nivols/2+1)dummy=setcolor(15) if(n.gt.nivols/2+1)dummy=setcolor(14) DO 101 I=1,nscans VOLT=VOLINT(I,N) IF(VOLT.GT.WRANGE)VOLT=WRANGE dummy=lineto_w(freq(I),dble(volT)) 101 CONTINUE 100 continue dummy=setcolor(15) CALL moveto_w(fstart,wrange,wxy) dummy=lineto_w(fend,wrange) c c...plot fringe voltages c dummy=setcolor(11) detscl=WRANGE/drange do 105 n=1,2 rint=-detvol(1,n)*detscl+0.1*detscl if(rint.gt.wrange)rint=wrange CALL moveto_w(freq(1),rint,wxy) DO 106 I=1,nscans rint=-detvol(i,n)*detscl+0.1*detscl if(rint.gt.wrange)RINT=WRANGE dummy=lineto_w(freq(I),rint) 106 CONTINUE 105 continue dummy=setcolor(15) c c...marker c call putimage_w(fmark,dble(WRANGE),MARK,$GXOR) c c...information lines c 771 write(lwork1,'(a12,f15.4,'' MHz'')')fnams(nmark),freq(nmark) CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(lwork1) dummy=settextcolor(14) call settextposition(myrows,int2(itxt+36),curpos) call outtext(filarc(1:30)) dummy=settextcolor(15) WRITE(OUTSTR,'(A,F8.2)')'Yrange /mV:',WRANGE CALL settextposition(myrows,int2(itxt+2),curpos) CALL outtext(OUTSTR(1:19)) CALL settextposition(myrows,int2(itxt+70),curpos) CALL outtext('H = help') c c...options loop: A,S - move marker left/right c - marker beginning/end c D,F - alternative keys to the above c W,Z - change vertical scaling C O - go to spectrum under the cursor c I - go to screen comparing interferograms c 77 IK=INKEY(N) KK=CHAR(IK) c c...terminate program, with 'Q' c if(KK.eq.'Q'.or.kk.eq.'q')then dummy=setvideomode($DEFAULTMODE) stop endif c c...exit to individual interferogram and its FFT, with 'O' c if(KK.eq.'O'.or.kk.eq.'o')then nmark1=ipoint(nmark) call looksp(nmark,nmark1) GOTO 179 endif c c...go to comparison of interferograms, with 'I' c if(KK.eq.'I'.or.kk.eq.'i')then call intcom(nmark,iarch) fmark=freq(nmark) GOTO 179 endif c c...cursor left, with 'A' c if(KK.eq.'A'.or.KK.eq.'a')then call putimage_w(fmark,dble(WRANGE),MARK,$GXOR) nmark=nmark-1 if(KK.eq.'A')nmark=nmark-4 if(nmark.lt.1)nmark=1 fmark=freq(nmark) call putimage_w(fmark,dble(WRANGE),MARK,$GXOR) goto 771 endif c c...cursor right, with 'S' c if(KK.eq.'S'.or.KK.eq.'s')then call putimage_w(fmark,dble(WRANGE),MARK,$GXOR) nmark=nmark+1 if(KK.eq.'S')nmark=nmark+4 if(nmark.gt.nscans)nmark=nscans fmark=freq(nmark) call putimage_w(fmark,dble(WRANGE),MARK,$GXOR) goto 771 endif c c...marker beginning,end or D/F c if(ik.eq.-71.or.kk.eq.'D'.or.kk.eq.'d')then call putimage_w(fmark,dble(WRANGE),MARK,$GXOR) nmark=1 fmark=freq(nmark) call putimage_w(fmark,dble(WRANGE),MARK,$GXOR) goto 771 endif c if(ik.eq.-79.or.kk.eq.'F'.or.kk.eq.'f')then call putimage_w(fmark,dble(WRANGE),MARK,$GXOR) nmark=nscans fmark=freq(nmark) call putimage_w(fmark,dble(WRANGE),MARK,$GXOR) goto 771 endif c c...change of vertical scaling - zoom out with 'Z' c if(KK.eq.'Z'.or.kk.eq.'z')then wmult=wmult*1.1 if(kk.eq.'Z')wmult=wmult*1.364 goto 178 endif c c...change of vertical scaling - zoom in with 'W' c if(KK.eq.'W'.or.kk.eq.'w')then wmult=wmult/1.1 if(kk.eq.'W')wmult=wmult/1.364 goto 178 endif c c...Help screen, with 'H' c if(KK.eq.'H'.or.KK.eq.'h')then 840 CALL clearscreen($GCLEARSCREEN) write(*,'(1x)') WRITE(*,232) 232 FORMAT(9x,'SUMMARY OF COMMANDS ACTIVE IN SUMMARY SCREEN:'/ * 9x, '---------------------------------------------'/// * 9x,' A/S - cursor left/right'/ * 9x,' - cursor to beginning/end'/ * 9x,' D/F - alternative keys to /'/ * 9x,' W/Z - Y-scale zoom-in/zoom-out'// * 9x,' caps on/off - fast/slow change in the above'/// * 9x,' I - go to comparison of interferograms'/ * 9x,' O - look at spectrum under the cursor'/ * 9x,' ENTER - (followed by Y) exit'/ * 9x,' Q - quit program altogether'//) 107 IK=INKEY(J) IF(IK.NE.13)GOTO 107 GOTO 178 endif c c IF(IK.NE.13)GOTO 77 C C...exit C CALL settextposition(2,int2(itxt+1),curpos) CALL outtext(emplin) CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(emplin) DUMMY=SETTEXTCOLOR(15) dummy4 = setbkcolor( RED ) WRITE(OUTSTR,'(A)')'ARE YOU SURE ?' CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(outstr(1:14)) CALL settextposition(1,int2(itxt+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,int2(itxt+1),curpos) call outtext(lwork1) CALL settextposition(2,int2(itxt+1),curpos) call outtext(lwork2) CALL settextposition(myrows,int2(itxt+20),curpos) CALL outtext(lwork3(1:40)) GOTO 77 c 915 DEALLOCATE(MARK) dummy=setvideomode($DEFAULTMODE) stop c RETURN END c c--------------------------------------------------------------------------- c subroutine intcom(nmark,iarch) c C Routine to compare interferograms nine at a time in frequency c order 1 2 3 c 4 5 6 c 7 8 9 c c VRANGE = a priori voltage range (mV) for scaling of interferogram ranges c WRANGE = voltage range (mV) for scaling actually used, equal to c wmult*vrange c INCLUDE 'FGRAPH.FD' MSF5+PS1 c USE MSFLIB PS4 c RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy INTEGER*2 maxx,maxy,LINOFS,dummy,inkey,mymode,myrows,mycols, * lsecnd,lthird,lcol2,lcol3 INTEGER*4 dummy4,blue,red real*8 wmin,wmax,fstart,fend,xpoint character kk,emplin*80,lwork1*80,lwork2*80,lwork3*80,OUTSTR*21, * filarc*30 logical*2 true COMMON /limits/maxx,maxy,LINOFS,curpos,ixy,wxy, * mymode,myrows,mycols,blue,red c c...declarations for spectra c parameter (maxspe=500,maxpts=850,vrange=10.0,nivols=7,true=.true.) character fnams(maxspe)*12,filnam*12 real detvol(maxspe,2),volint(maxspe,nivols) integer interf(maxspe,maxpts),idata(maxpts),nave(maxspe) integer*2 iseen(maxspe),ipoint(maxspe) real*8 freq(maxspe) integer*2 nreps(maxspe),nskip(maxspe),nskip1(maxspe) real tsteps(maxspe),vsteps(maxspe) character comnt(maxspe)*50,sampl(maxspe)*20,timd(maxspe)*20 common /scans/interf,freq,ipoint,filarc common /scans1/idata,vstep,tstep,nrep,nskips,nskipe,naver common /scans2/detvol,volint,iseen,nscans common /sfiles/fnams common /scan3/nreps,nskip,nskip1,tsteps,vsteps,nave COMMON /SCTEXT/COMNT,SAMPL,TIMD c lsecnd=9 lthird=17 lcol2=28 lcol3=55 itxt=(mycols-80)/2 lcol2=lcol2+itxt lcol3=lcol3+2*itxt if(myrows.eq.30)then lsecnd=11 lthird=21 endif if(myrows.eq.37)then lsecnd=13 lthird=25 endif c if(WMULT.EQ.0.0)then timmax=0. do 600 n=1,nscans if(tsteps(n)*nreps(n).gt.timmax)timmax=tsteps(n)*nreps(n) do 600 i=4,nivols wmult=wmult+volint(n,i) 600 continue wmult=wmult/(real(nscans)*real(nivols-3)*vrange) endif WRITE(emplin,'(80(1H ))') C c. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c G R A P H I C S C C...Start up the graphics C 179 pixcol=getcolor() dummy4 = setbkcolor( BLUE ) C C...definition of graphics viewport: first pixel coordinates of viewport c then real coordinates for scales c call setviewport(0,0,maxx,maxy) c fstart=0.d0 fend=3.1*timmax c c...complete screen refresh from here c 178 wrange=wmult*vrange hrange=0.5*wrange wmin=-0.1*WRANGE wmax= 3.3*WRANGE dummy=setwindow(TRUE,fstart,wmin,fend,wmax) call clearscreen($GCLEARSCREEN) c c c...Plot nine interferograms per screen c nstart=nmark-4 if(nstart.lt.1)nstart=1 nfin=nstart+8 if(nfin.gt.nscans)then nfin=nscans nstart=nfin-8 if(nstart.lt.1)nstart=1 endif c do 100 jj=nstart,nfin j=jj if(iarch.eq.1)j=ipoint(jj) vmult=vsteps(j)*1000. tstep=tsteps(j) nrep=nreps(j) nskips=nskip(j) nskipe=nskip1(j) ncolch=nrep-nskipe c k=jj-nstart+1 if(mod(K,3).eq.0)then xshift=2.1*timmax else xshift=(mod(k,3)-1)*1.05*timmax endif vshift=(2-((k-1)/3))*1.1*wrange VOLT=interf(j,1)*vmult if(volt.lt.-hrange)volt=-hrange if(volt.gt.hrange)volt=hrange volt=volt+hrange+vshift xpoint=tstep+xshift CALL moveto_w(xpoint,DBLE(volT),wxy) dummy=setcolor(12) DO 101 I=1,nrep VOLT=interf(j,i)*vmult if(volt.lt.-hrange)volt=-hrange if(volt.gt.hrange)volt=hrange volt=volt+hrange+vshift xpoint=i*tstep+xshift if(i.eq.nskips)dummy=setcolor(15) if(i.eq.ncolch)dummy=setcolor(12) dummy=lineto_w(xpoint,dble(volT)) 101 CONTINUE 100 continue dummy=setcolor(15) c c...information lines c 771 write(lwork1,772)(fnams(I),freq(i),I=nstart,nstart+2) write(lwork2,773)(fnams(I),freq(i),I=nstart+3,nstart+5) write(lwork3,774)(fnams(I),freq(i),I=nstart+6,nstart+8) 772 format('1=',a12,f10.3,3x,'2=',a12,f10.3,3x,'3=',a12,f10.3) 773 format('4=',a12,f10.3,3x,'5=',a12,f10.3,3x,'6=',a12,f10.3) 774 format('7=',a12,f10.3,3x,'8=',a12,f10.3,3x,'9=',a12,f10.3) c c dummy=settextcolor(iseen(nstart)) CALL settextposition(1,1,curpos) CALL outtext(lwork1(1:24)) dummy=settextcolor(iseen(nstart+1)) CALL settextposition(1,lcol2,curpos) CALL outtext(lwork1(28:51)) dummy=settextcolor(iseen(nstart+2)) CALL settextposition(1,lcol3,curpos) CALL outtext(lwork1(55:78)) c dummy=settextcolor(iseen(nstart+3)) CALL settextposition(lsecnd,1,curpos) CALL outtext(lwork2(1:24)) dummy=settextcolor(iseen(nstart+4)) CALL settextposition(lsecnd,lcol2,curpos) CALL outtext(lwork2(28:51)) dummy=settextcolor(iseen(nstart+5)) CALL settextposition(lsecnd,lcol3,curpos) CALL outtext(lwork2(55:78)) c dummy=settextcolor(iseen(nstart+6)) CALL settextposition(lthird,1,curpos) CALL outtext(lwork3(1:24)) dummy=settextcolor(iseen(nstart+7)) CALL settextposition(lthird,lcol2,curpos) CALL outtext(lwork3(28:51)) dummy=settextcolor(iseen(nstart+8)) CALL settextposition(lthird,lcol3,curpos) CALL outtext(lwork3(55:78)) c dummy=settextcolor(14) call settextposition(myrows,int2(itxt+36),curpos) call outtext(filarc(1:30)) dummy=settextcolor(15) WRITE(OUTSTR,'(A,F8.2)')'Yrange /mV:',WRANGE CALL settextposition(myrows,int2(itxt+2),curpos) CALL outtext(OUTSTR(1:19)) CALL settextposition(myrows,int2(itxt+70),curpos) CALL outtext('H = help') c c...options loop: A,S - move back/forwards in spectra c - move to beginning/end of spectra c D,F - alternative keys to / c W,Z - change vertical scaling c 1-9 - goto displayed spectrum 1-9 c F1-F9 - display parameters of spectrum 1-9 c , - go back to previous screen c 77 IK=INKEY(N) KK=CHAR(IK) c c...terminate program, with 'Q' c if(KK.eq.'Q'.or.kk.eq.'q')then dummy=setvideomode($DEFAULTMODE) stop endif c c...go to the left in spectra, with 'A' c if(KK.eq.'A'.or.kk.eq.'a')then nmark=nmark-1 if(nmark.gt.nscans-5)nmark=nscans-5 if(KK.eq.'A')nmark=nmark-4 if(nmark.lt.5)nmark=5 goto 179 endif c c...go to the right in spectra, with 'S' c if(KK.eq.'S'.or.kk.eq.'s')then nmark=nmark+1 if(nmark.lt.6)nmark=6 if(KK.eq.'S')nmark=nmark+4 if(nmark.gt.nscans-4)nmark=nscans-4 goto 179 endif c c...first,last spectrum or D,F c if(ik.eq.-71.or.kk.eq.'D'.or.kk.eq.'d')then nmark=5 goto 179 endif c if(ik.eq.-79.or.kk.eq.'F'.or.kk.eq.'f')then nmark=nscans-4 goto 179 endif c c...go to FFT of selected interferogram c if(KK.eq.'1'.or.KK.eq.'!')then ncall=nstart goto 800 endif if(KK.eq.'2'.or.KK.eq.'@')then ncall=nstart+1 goto 800 endif if(KK.eq.'3'.or.KK.eq.'#')then ncall=nstart+2 goto 800 endif if(KK.eq.'4'.or.KK.eq.'$')then ncall=nstart+3 goto 800 endif if(KK.eq.'5'.or.KK.eq.'%')then ncall=nstart+4 goto 800 endif if(KK.eq.'6'.or.KK.eq.'^')then ncall=nstart+5 goto 800 endif if(KK.eq.'7'.or.KK.eq.'&')then ncall=nstart+6 goto 800 endif if(KK.eq.'8'.or.KK.eq.'*')then ncall=nstart+7 goto 800 endif if(KK.eq.'9'.or.KK.eq.'(')then ncall=nstart+8 goto 800 endif c goto 801 800 if(iarch.eq.0)then ncall1=ncall else ncall1=ipoint(ncall) endif nrep=nreps(ncall1) nskips=nskip(ncall1) nskipe=nskip1(ncall1) ncolch=nrep-nskipe vstep=vsteps(ncall1) tstep=tsteps(ncall1) iseen(ncall)=7 call looksp(ncall,ncall1) GOTO 179 801 continue c c...change of vertical scaling - zoom out with 'Z' c if(KK.eq.'Z'.or.kk.eq.'z')then wmult=wmult*1.1 if(kk.eq.'Z')wmult=wmult*1.364 goto 178 endif c c...change of vertical scaling - zoom in with 'W' c if(KK.eq.'W'.or.kk.eq.'w')then wmult=wmult/1.1 if(kk.eq.'W')wmult=wmult/1.364 goto 178 endif c c...Display recording parameters, with function key c if(ik.ge.-67.and.ik.le.-59)then ncall=iabs(ik)-59 ncall=nstart+ncall filnam=fnams(ncall) if(iarch.eq.0)then ncall1=ncall else ncall1=ipoint(ncall) endif CALL clearscreen($GCLEARSCREEN) write(*,'(1x)') c write(*,'(1x//17x,''Spectral file: '',a///1x,a/)')filnam, * comnt(ncall1) WRITE(*,10)' Sample: ',SAMPL(ncall1) WRITE(*,10)' Time/Date: ',TIMD(ncall1) write(*,11)' No of points: ',nreps(ncall1) write(*,11)' Points skipped at beginning: ',nskip(ncall1) write(*,11)' Points skipped at end: ',nskip1(ncall1) write(*,12)' Microwave frequency (MHz): ',freq(ncall) write(*,12)' X-spacing (microseconds): ',tsteps(ncall1)/1.E-6 write(*,12)' Y-spacing (Volts) : ',vsteps(ncall1) write(*,11)' Number of averages: ',nave(ncall1) write(*,'(1x//30x,''Press E N T E R to continue'')') c 10 format(1x,2a) 11 format(1x,a,i7) 12 format(1x,a,f20.12) c 108 IK=INKEY(J) IF(IK.NE.13)GOTO 108 GOTO 178 endif c c...Help screen, with 'H' c if(KK.eq.'H'.or.KK.eq.'h')then 840 CALL clearscreen($GCLEARSCREEN) write(*,'(1x)') WRITE(*,232) 232 FORMAT( * 9X,'SUMMARY OF COMMANDS ACTIVE IN INTERFEROGRAMS SCREEN:'/ * 9x,'----------------------------------------------------'/// * 9x,' A/S - spectra left/right'/ * 9x,' - first/last spectrum'/ * 9x,' D/F - alternative keys to /'/ * 9x,' W/Z - Y-scale zoom-in/zoom-out'// * 9x,' caps on/off - fast/slow change in the above'/// * 9x,' 1 to 9 - look at spectrum 1 to 9'/ * 9x,' to - display parameters of spectrum 1 to 9'/ * 9x,' ENTER, - exit to summary display'/ * 9x,' Q - quit program altogether'//) 107 IK=INKEY(J) IF(IK.NE.13)GOTO 107 GOTO 178 endif c IF(IK.NE.13.AND.IK.NE.27)GOTO 77 C C...exit back to SUMMAR C RETURN 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' MSF5+PS1 c USE MSFLIB PS4 C RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy INTEGER*2 dummy,maxx,maxy,LINOFS,mymode,myrows,mycols integer*4 dummy4,blue,red RECORD /videoconfig/myscreen COMMON /limits/maxx,maxy,LINOFS,curpos,ixy,wxy, * 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 c 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 looksp(nmark,nmark1) c INCLUDE 'FGRAPH.FD' MSF5+PS1 c USE MSFLIB PS4 C RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy c c fcent = excitation frequency (MHz) c fstep = point spacing in frequency (kHz) c p = spectral points from the FFT c npts = number of spectral points out of the FFT c fmax = frequency of the last spectral point (kHz) c fmark = current marker frequency (kHz) c fincr = frequency increment per horizontal pixel (kHz) c nmark = position of spectrum defined by FMARK in order of frequency c nmark1 = the original position (in order of input) of spectrum defined by c FMARK c logical*2 true PARAMETER (Nmaxpt=8192,maxspe=500,maxpts=850,maxsmo=199, * nivols=7,nsect=20,true=.true.) c INTEGER*1 MARK [ALLOCATABLE] (:) integer*4 dummy4,idata(maxpts),ioldat(maxpts),itemp(maxpts) real*8 fcent,fstep,fstart,fend,top,bottom,f,fmark,fincr, * flast,fmean,fmax,fchang,frange,FMIN,FPLUS, * fnewp,fnewo,fnewm,flastp,flasto,flastm,smin,smax, * hbotsp,htopsp,cursle,cursri,rinter real p(nmaxpt),spol(maxsmo) INTEGER*2 dummy,maxx,maxy,LINOFS,inkey,ipoint(maxspe), * mymode,myrows,mycols character kk,outstr*27,filarc*30 character*80 emplin,lwork1,lwork2,lwork3 integer interf(maxspe,maxpts),blue,red real*8 freq(maxspe) character fnams(maxspe)*12 real detvol(maxspe,2),volint(maxspe,nivols) integer*2 iseen(maxspe) c common /scans/interf,freq,ipoint,filarc COMMON /limits/maxx,maxy,LINOFS,curpos,ixy,wxy, * mymode,myrows,mycols,blue,red common /specf/p,fstep,npts,NFFT,NCALL common /scans1/idata,vstep,tstep,nrep,nskips,nskipe,naver common /scans2/detvol,volint,iseen,nscans common /sfiles/fnams common /peak/x(nsect),y(nsect) common /smooth/ioldat,itemp,spol c do 100 i=1,nrep idata(i)=interf(nmark1,i) 100 continue fcent=freq(nmark) c ncall=0 call clearscreen($GCLEARSCREEN) call FFTEXE samfre=1./tstep fnyq=samfre/2. fmax=fnyq*1.E-3 c idefm=0 htcut=0.5 CURINC=1.0 WRITE(emplin,'(80(1H ))') c c...preserve a copy of the interferogram in IOLDAT c do 1099 j=1,nrep ioldat(j)=idata(j) 1099 continue c c. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C C...Start up the graphics C pixcol=getcolor() dummy4 = setbkcolor( BLUE ) IPIXLN=nint(real(maxy)/real(myrows)) C C...definition of graphics viewport in pixel coordinates C call setviewport(0,0,maxx,maxy) c c...Find Y-limits c 851 fstart=0.d0 fend=500.d0 smin=1.d+20 smax=1.d-20 f=-fstep do 111 i=1,npts f=f+fstep if(f.lt.fstart)goto 111 if(f.gt.fend)goto 112 if(p(i).lt.smin)smin=p(i) if(p(i).gt.smax)smax=p(i) 111 continue 112 smax=1.05*smax smaxol=smax SMIN=0 c top=smax+0.10d0*(smax-smin) bottom=smin-0.1D0*(smax-smin) CDUMP OPEN(7,FILE='DUMP',STATUS='UNKNOWN') CDUMP WRITE(7,'(4F20.8)')SMIN,SMAX,TOP,BOTTOM htopsp=top-(2.*real(ipixln)+2.)/real(maxy)*(top-bottom) itxt=(mycols-80)/2 if(myrows.eq.37)then hbotsp=bottom+(2.*real(ipixln)+1.)/real(maxy)*(top-bottom) else hbotsp=bottom+(1.2*real(ipixln)+1.)/real(maxy)*(top-bottom) endif c c...definition of graphics viewport in floating point coordinates to be used c for plotting C NOTE: for simplicity the whole screen is assigned in this program to the c floating point graphics window. Space corresponding to two top and c one bottom textmode lines is erased by lines carrying descriptive c information. Rectangular boundary frame is drawn by calculating c appropriate floating point coordinates so that vertical pixels just c below and just above descriptive lines are used. c dummy=setwindow(TRUE,fstart,bottom, * fend,top) call clearscreen($GCLEARSCREEN) DUMMY=SETTEXTCOLOR(7) c c...define marker c fmark=(fend-fstart)/2.d0 fincr=(fend-fstart)/maxx if(idefm.eq.0)then $NODEBUG CALL setlinestyle(#9999) $DEBUG CALL moveto_w(fmark,hbotsp,wxy) dummy=lineto_w(fmark,smax) imsize=imagesize_w(fmark,smax,fmark,hbotsp) ALLOCATE (MARK(imsize)) CALL getimage_w(fmark,smax,fmark,hbotsp,MARK) call putimage_w(fmark,smax,MARK,$GXOR) $NODEBUG CALL setlinestyle(#ffff) $DEBUG idefm=1 endif c c...Plot c 699 nfirst=0 c dummy=setcolor(9) c dummy=rectangle_w($GFILLINTERIOR,fstart,htopsp,fend,hbotsp) c dummy=setcolor(15) CALL moveto_w(fstart,hbotsp,wxy) dummy=lineto_w(fend,hbotsp) dummy=lineto_w(fend,htopsp) dummy=lineto_w(fstart,htopsp) dummy=lineto_w(fstart,hbotsp) DO 6 I=1,npts f=(i-1)*fstep if(f.lt.fstart)goto 6 if(f.gt.fend)goto 697 if(nfirst.eq.0)then nfirst=1 RSPEC=p(i) IF(RSPEC.gt.htopsp)rspec=htopsp if(rspec.lt.hbotsp)rspec=hbotsp CALL moveto_w(fstart,dble(rspec),wxy) endif RSPEC=p(i) IF(RSPEC.gt.htopsp)rspec=htopsp if(rspec.lt.hbotsp)rspec=hbotsp dummy=lineto_w(f,RSPEC) 6 CONTINUE c c...marker c 697 call putimage_w(fmark,smax,MARK,$GXOR) c c...information lines c 771 FMIN=FCENT-FMARK/1000.D0 FPLUS=FCENT+FMARK/1000.D0 YVAL=P( NINT(FMARK/FSTEP)+1 ) write(lwork1,'(F7.1,''kHz --> f-'',F11.4,'', f+'',F11.4, * '' MHz'',21X,''Y:'',F8.2)')fmark,FMIN,FPLUS,yval CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(lwork1) CALL settextposition(2,int2(itxt+1),curpos) CALL outtext(EMPLIN) CALL settextposition(myrows,int2(itxt+2),curpos) CALL outtext('n='//CHAR(48+NFFT)) write(lwork3,822) smax-smin, fend-fstart 822 format(F12.2,'<- Y_range X_range ->',f8.2,' kHz') CALL settextposition(myrows,int2(itxt+5),curpos) call outtext(lwork3(1:45)) DUMMY=SETTEXTCOLOR(14) CALL settextposition(myrows,int2(itxt+56),curpos) CALL outtext(fnams(nmark)) DUMMY=SETTEXTCOLOR(7) CALL settextposition(myrows,int2(itxt+72),curpos) CALL outtext('H = help') c c...options loop c C K,L - scroll cursor c , - move cursor by quarter screen c A,S - scroll spectrum horizontally c Q,E - change horizontal scaling c W,Z - change vertical scaling c R - return to initial settings C I - display interferogram c H - help screen c U - ASCII dump of current FFT to file F.DAT C (end is the higher of 0.5MHz and end of display window) c O - determine frequency of peak nearest the cursor c 0 - change bisection range for peak measurement c 9 - take cursor frequency as line frequency c = - central frequency of Doppler doublet (from last two lines c measured with 'O') c P - show the FFT points c - quick exit to calling routine c 77 IK=INKEY(N) KK=CHAR(IK) 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 IF(KK.EQ.'Q'.OR.KK.EQ.'q')GOTO 721 IF(KK.EQ.'E'.OR.KK.EQ.'e')GOTO 720 IF(KK.EQ.'R'.OR.KK.EQ.'r')GOTO 730 IF(KK.EQ.'A'.OR.KK.EQ.'a')GOTO 740 IF(KK.EQ.'S'.OR.KK.EQ.'s')GOTO 760 IF(KK.EQ.'Z'.OR.KK.EQ.'z')GOTO 810 IF(KK.EQ.'W'.OR.KK.EQ.'w')GOTO 820 IF(KK.EQ.'I'.OR.KK.EQ.'i')GOTO 830 IF(KK.EQ.'H'.OR.KK.EQ.'h')GOTO 840 IF(KK.EQ.'N'.OR.KK.EQ.'n')GOTO 850 IF(KK.EQ.'P'.OR.KK.EQ.'p')GOTO 1300 IF(KK.EQ.'O'.OR.KK.EQ.'o')GOTO 1400 IF(KK.EQ.'0'.OR.KK.EQ.')')GOTO 1450 IF(KK.EQ.'9'.OR.KK.EQ.'(')GOTO 1440 IF(KK.EQ.'='.OR.KK.EQ.'_')GOTO 1430 if(IK.eq.27)goto 915 if(kk.eq.'U'.or.kk.eq.'u'.or.kk.eq.'Y'.or.kk.eq.'y')then open(7,file='f.dat',status='unknown') fcut=max(500.,fend) write(7,'(1H!,50(1H-)/1H!/''! FFT of interferogram from: '',a/ * 1H!/1H!,50(1H-)/1H!)')fnams(nmark) write(7,'(''! Pump frequency ='',f15.6/ * ''! Maximum offset ='',f15.6/1H!/ * ''! Maximum intensity ='',f15.6/1H!/ * ''! DeltaF power f- f+'')') * fcent,fcut/1000.,smax pmult=1.d0 if(kk.eq.'Y'.or.kk.eq.'y')then pmax=0.d0 do 1800 i=1,npts if(p(i).gt.pmax)pmax=p(i) 1800 continue pmult=1000.d0*vstep*(maxi-mini)/pmax endif f=0.d0 do 3 i=1,npts fmin=fcent-f/1000. fplus=fcent+f/1000. write(7,'(f8.5,1pe12.4,0P,2f12.4)')f/1000.,p(i)*pmult, * fmin,fplus f=f+fstep if(f.gt.fcut)goto 33 3 continue 33 close(7) endif c IF(IK.NE.13)GOTO 77 C C...exit C 915 continue DEALLOCATE(MARK) do 2201 j=1,nrep idata(j)=ioldat(j) 2201 continue return C C...Shift cursor to the left (with K) C 710 call putimage_w(fmark,smax,MARK,$GXOR) fmark=fmark-8.d0*fincr IF(KK.EQ.'k')fmark=fmark+7.d0*fincr IF(fmark.LT.fstart)fmark=fstart C 719 call putimage_w(fmark,smax,MARK,$GXOR) GOTO 771 C C...Shift cursor to the right (with L) C 711 call putimage_w(fmark,smax,MARK,$GXOR) fmark=fmark+8.d0*fincr IF(KK.EQ.'l')fmark=fmark-7.d0*fincr IF(fmark.gT.fend)fmark=fend GOTO 719 C C...Center cursor, on second keypress move the cursor into the center of the C opposite screenhalf (with ,) C 750 call putimage_w(fmark,smax,MARK,$GXOR) 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 720 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.0.d0)fstart=0.d0 if(fend.gt.fmax)fend=fmax IF(FMARK.LT.fstart)FMARK=Fstart IF(FMARK.GT.fend)FMARK=Fend c 801 fincr=(fend-fstart)/maxx dummy=setwindow(TRUE,fstart,bottom, * fend,top) call clearscreen($GCLEARSCREEN) GOTO 699 C C...zoom-out in frequency (with Q) C 721 FRange=Fend-Fstart Fchang=1.D0*FRange IF(KK.EQ.'q')Fchang=0.25d0*FRange Fstart=Fstart-Fchang Fend=Fend+fchang GOTO 698 c c...restore original settings (with R) c 730 fstart=0.d0 fend=500.d0 fmark=(fend-fstart)/2.d0 smax=smaxol 802 top= smax+0.10d0*(smax-smin) bottom=SMIN-0.10D0*(smax-smin) CDUMP WRITE(7,'(4F20.8)')SMIN,SMAX,TOP,BOTTOM htopsp=top-(2.*real(ipixln)+2.)/real(maxy)*(top-bottom) if(myrows.eq.37)then hbotsp=bottom+(2.*real(ipixln)+1.)/real(maxy)*(top-bottom) else hbotsp=bottom+(1.2*real(ipixln)+1.)/real(maxy)*(top-bottom) endif goto 801 c c...shift window to the left (with A) c 740 FRange=fend-fstart Fchang=FRange*0.5D0 IF(KK.EQ.'a')Fchang=FRange*0.1D0 fstart=fstart-Fchang IF(fstart.LT.0.D0)THEN fstart=0.D0 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 801 C C...shift of viewing window to the right (with S) C 760 FRange=fend-fstart Fchang=FRange*0.5D0 IF(KK.EQ.'s')Fchang=FRange*0.1D0 fstart=fstart+Fchang fend=fend+Fchang IF(fend.gt.fmax)THEN fend=fmax CALL settextposition(1,int2(itxt+1),curpos) WRITE(*,101)CHAR(7) fstart=fend-frange ENDIF FMARK=FMARK+Fchang GOTO 801 C C...zoom-out in height (with Z) C 810 sMULT=2.D0 IF(KK.EQ.'z')sMULT=1.1D0 smax=SMIN+sMULT*(smax-SMIN) GOTO 802 C C...zoom-in in height (with W) C 820 sMULT=0.5D0 IF(KK.EQ.'w')sMULT=0.95D0 smax=SMIN+sMULT*(smax-SMIN) GOTO 802 c c...Show the FFT points (with P) C 1300 dely=smax/150. delx=(fend-fstart)/150. DO 1301 i=1,Npts if(p(i).gt.htopsp)goto 1301 f=(i-1)*fstep if(f.lt.fstart)goto 1301 if(f.gt.fend)goto 1302 X1=f-DELX Y1=p(i)+DELY X2=f+DELX Y2=p(i)-DELY dummy=ellipse_w($GFILLINTERIOR,X1,Y1,X2,Y2) 1301 CONTINUE 1302 GOTO 77 c c...Take current marker frequency as measurement of line frequency (with 9) c 1440 xpeak=fmark FLASTM=FNEWM FLASTP=FNEWP flasto=fnewo fNEWM=fcent-dble(xpeak)*0.001d0 FNEWP=FCENT+dble(XPEAK)*0.001d0 fnewo=xpeak write(lwork3,1441)xpeak,'peak',FNEWM,FNEWP 1441 format(F7.1,'kHz <-',a,'-> ',f10.4,' - + ',f10.4) DUMMY=SETTEXTCOLOR(15) CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(lwork3) CALL settextposition(2,int2(itxt+1),curpos) CALL outtext(emplin) DUMMY=SETTEXTCOLOR(7) c DUMMY=SETCOLOR(14) y1=htopsp y2=0.d0 call moveto_w(DBLE(xpeak),DBLE(y1),wxy) dummy=lineto_w(DBLE(xpeak),DBLE(y2)) dummy=setcolor(15) c goto 77 c c...Frequency of peak nearest the cursor (with O) C 1400 FLASTM=FNEWM FLASTP=FNEWP flasto=fnewo call pf(fmark,ypeak,xpeak,errorx,htcut,xbot,fhalm,fhalp) fNEWM=fcent-dble(xpeak)*0.001d0 FNEWP=FCENT+dble(XPEAK)*0.001d0 fnewo=xpeak C C...the quantity Er.fit is error in frequency determined from straight line C fit in Hz - in practice if it exceeds 10 then appreciable curvature C is present in bisector points for some rectifying action to be taken C write(lwork3,1410)xpeak,'peak',FNEWM,FNEWP,errorx*1000.,ypeak 1410 format(F7.1,'kHz <-',a,'-> ',f10.4,' - + ',f10.4, * ' (Er.fit=',f6.1,') Y:',f8.2) DUMMY=SETTEXTCOLOR(15) CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(lwork3) WRITE(lwork3,'(67x,''FWHH:'',F8.2)')fhalp-fhalm CALL settextposition(2,int2(itxt+1),curpos) CALL outtext(lwork3) DUMMY=SETTEXTCOLOR(7) c c...bisection points dely=smax/150. delx=(fend-fstart)/150. DUMMY=SETCOLOR(9) DO 1401 i=1,Nsect X1=x(i)-DELX Y1=y(i)+DELY X2=x(i)+DELX Y2=y(i)-DELY if(y1.lt.top.and.y2.lt.top)then * dummy=ellipse_w($GFILLINTERIOR,X1,Y1,X2,Y2) 1401 CONTINUE c c...fitted line DUMMY=SETCOLOR(12) y2=0.4*ypeak if(y2.lt.top)then call moveto_w(DBLE(xpeak),DBLE(ypeak),wxy) dummy=lineto_w(DBLE(xbot),DBLE(y2)) endif c c...vertical bar DUMMY=SETCOLOR(14) y1=ypeak y2=0.d0 if(y1.lt.top)then call moveto_w(DBLE(xpeak),DBLE(y1),wxy) dummy=lineto_w(DBLE(xpeak),DBLE(y2)) endif c c...horizontal bars at 0, 0.5 and 1.0 Ymax x1=xpeak-5.*delx x2=xpeak+5.*delx y1=ypeak if(y1.lt.top)then call moveto_w(DBLE(x1),DBLE(y1),wxy) dummy=lineto_w(DBLE(x2),DBLE(y1)) endif Y1=0. call moveto_w(DBLE(x1),DBLE(y1),wxy) dummy=lineto_w(DBLE(x2),DBLE(y1)) c c...FWHH bar y1=ypeak*0.5 if(y1.lt.top)then call moveto_w(DBLE(fhalm),DBLE(y1),wxy) dummy=lineto_w(DBLE(fhalp),DBLE(y1)) endif DUMMY=SETCOLOR(15) c goto 77 c c...Mean frequency of last two measured peaks (for Doppler doublets), with = C 1430 fmin=(flastm+fnewm)*0.5d0 fplus=(flastp+fnewp)*0.5d0 foffs=(flasto+fnewo)*0.5d0 write(lwork3,1411)foffs,'mean',fmin,fplus,abs(flasto-fnewo) 1411 format(F7.1,'kHz <-',a,'-> ',f10.4,' - + ',f10.4,' splitting', * f7.2,' kHz') DUMMY=SETTEXTCOLOR(11) CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(lwork3) DUMMY=SETTEXTCOLOR(7) CALL settextposition(2,int2(itxt+1),curpos) CALL outtext(emplin) goto 77 c c...Change bisection range for peak frequency determination (with 0) c 1450 CALL clearscreen($GCLEARSCREEN) 1451 write(*,1452)htcut 1452 format(3x/' Current height range for bisection:',f6.2/ * 25x,' New range: ',$) read(*,'(F7.4)',ERR=1451)ypeak if(ypeak.le.0.0.or.ypeak.ge.1.0)goto 1451 htcut=ypeak dummy=setwindow(TRUE,fstart,bottom, * fend,top) call clearscreen($GCLEARSCREEN) GOTO 699 c c . . . . . . . . . . . . . . . . . . . . . . . . c c...display the interferogram (with I) and allow selection of discarded c points with scrollable cursors c 830 ICHANG=0 831 mini=1000000000 maxi=-1000000000 do 832 j=1,nrep if(j.lt.nskips)goto 832 if(j.gt.nrep-nskipe)goto 833 if(idata(j).lt.mini)mini=idata(j) if(idata(j).gt.maxi)maxi=idata(j) 832 continue c 833 if(maxi.le.mini)then dummy=setvideomode($DEFAULTMODE) write(*,'(1x/'' ---> ERROR: mini,maxi ='',2i12//)')mini,maxi stop endif toplim=1.05d0*(real(maxi)-real(mini))+dble(mini) botlim=dble(maxi)-1.05d0*(real(maxi)-real(mini)) dummy=setwindow(TRUE,1.0d0,dble(botlim), * DBLE(nrep),dble(toplim)) call clearscreen($GCLEARSCREEN) c rinter=idata(1) if(idata(1).gt.maxi)rinter=maxi if(idata(1).lt.mini)rinter=mini CALL moveto_w(DBLE(1),rinter,wxy) dummy=setcolor(12) if(nskips.gt.0)then DO 61 I=1,nskips RINTER=DBLE(Idata(I)) if(idata(i).gt.maxi)rinter=maxi if(idata(i).lt.mini)rinter=mini dummy=lineto_w(DBLE(I),RINTER) 61 CONTINUE endif dummy=setcolor(15) DO 86 I=nskips+1,nrep-nskipe Rinter=DBLE(Idata(I)) dummy=lineto_w(DBLE(I),Rinter) 86 CONTINUE dummy=setcolor(12) DO 62 I=nrep-nskipe+1,nrep Rinter=DBLE(Idata(I)) if(idata(i).gt.maxi)rinter=maxi if(idata(i).lt.mini)rinter=mini dummy=lineto_w(DBLE(I),Rinter) 62 CONTINUE dummy=setcolor(15) c CURSLE=DBLE(NSKIPS) CURSRI=DBLE(NREP-NSKIPE) call putimage_w(CURSLE,dble(maxi),MARK,$GXOR) call putimage_w(CURSRI,dble(maxi),MARK,$GXOR) C WRITE(LWORK2,'(2A)') * 'A,S <-cursors-> K,L |+| |-| |N| |B|ackgr. o|', * 'R|iginal d|U|mp ENTER to exit' CALL settextposition(1,int2(itxt+1),curpos) call outtext(lwork2) write(lwork3,82) (maxi-mini)*vstep*1000,tstep*1.d6 82 format(' Yrange ',f9.2,'mV ',F5.2,'us/pt') CALL settextposition(myrows,int2(itxt+1),curpos) call outtext(lwork3(1:38)) CALL settextposition(myrows,int2(itxt+52),curpos) WRITE(OUTSTR,1550)nint(cursle),nint(cursri), * (nint(cursri)-nint(cursle))*tstep*1.e6 1550 format('in use:',i5,',',i4,' ->',F5.1,'us') call outtext(outstr) c c...options: - scrolling of left and right cursor K,L A,S C - change increment for scrolling the cursor + - C - background subtraction B C - compensation for rotational relaxation N C - return to original interferogram R c - ASCII dump of current interferogram c (to file T.DAT) U c 834 IK=INKEY(N) KK=CHAR(IK) IF(KK.EQ.'K'.OR.KK.EQ.'k')GOTO 870 IF(KK.EQ.'L'.OR.KK.EQ.'l')GOTO 875 IF(KK.EQ.'A'.OR.KK.EQ.'a')GOTO 880 IF(KK.EQ.'S'.OR.KK.EQ.'s')GOTO 885 IF(KK.EQ.'B'.OR.KK.EQ.'b')GOTO 1100 IF(KK.EQ.'R'.OR.KK.EQ.'r')GOTO 1200 IF(KK.EQ.'N'.OR.KK.EQ.'n')GOTO 1500 IF(KK.EQ.'+'.OR.KK.EQ.'=')CURINC=CURINC*5.0 IF(KK.EQ.'-'.OR.KK.EQ.'_')CURINC=CURINC*0.2 if(kk.eq.'U'.or.kk.eq.'u')then open(7,file='t.dat',status='unknown') write(7,'(1H!,50(1H-)/1H!/''! Interferogram from file: '',a/ * 1H!/1H!,50(1H-)/1H!)')fnams(nmark) write(7,'(''! Pump frequency/MHz ='',f15.6)')fcent write(7,'(''! Point spacing/microsec ='',f15.6)')tstep/1.e-6 write(7,'(''! Cutoff points/microsec ='',F15.6,'','',F15.6/ * ''! Last point/microsec ='',F15.6)') * nskips*tstep*1.e+6,(nrep-nskipe)*tstep*1.e+6, * nrep*tstep*1.e+6 write(7,'(1H!,7x,''Intensity limits = '',F15.6,'','',F15.6)') * mini*1000.d0*vstep,maxi*1000.d0*vstep write(7,'(''!''/''! time voltage/mV)'')') do 14 j=1,nrep if(j.lt.nskips.or.j.gt.nrep-nskipe) * write(7,115)real(j)*tstep/1.E-6,real(idata(j))*1000.d0*vstep if(j.gt.nskips.and.j.lt.nrep-nskipe) * write(7,15)real(j)*tstep/1.E-6,real(idata(j))*1000.d0*vstep if(j.eq.nskips.or.j.eq.nrep-nskipe) * write(7,116)real(j)*tstep/1.E-6, * real(idata(j))*1000.d0*vstep,real(idata(j))*1000.d0*vstep 14 continue 115 format(f5.1,' * ',f10.3) 116 format(f5.1,2f10.3) 15 format(f5.1,f10.3,' * ') close(7) endif IF(IK.NE.13)GOTO 834 c c...recalculate FFT if any changes in discarded points c 890 if(ichang.eq.1)THEN NFFT=-NFFT nskips=cursle nskipe=nrep-cursri CALL settextposition(myrows,int2(itxt+2),curpos) CALL outtext(' --- R e c a l c u l a t i n g F F T --- ') CALL FFTEXE goto 851 ELSE goto 835 ENDIF c C...Shift RIGHT cursor to the left (with K) C 870 call putimage_w(CURSRI,dble(maxi),MARK,$GXOR) CURSRI=CURSRI-8.d0*CURINC IF(KK.EQ.'k')CURSRI=CURSRI+7.d0*CURINC IF(CURSRI.LE.CURSLE)CURSRI=CURSLE+CURINC C 872 call putimage_w(CURSRI,dble(maxi),MARK,$GXOR) ICHANG=1 CALL settextposition(myrows,int2(itxt+52),curpos) WRITE(OUTSTR,1550)nint(cursle),nint(cursri), * (nint(cursri)-nint(cursle))*tstep*1.e6 call outtext(outstr) GOTO 834 C C...Shift RIGHT cursor to the right (with L) C 875 call putimage_w(CURSRI,dble(maxi),MARK,$GXOR) CURSRI=CURSRI+8.d0*CURINC IF(KK.EQ.'l')CURSRI=CURSRI-7.d0*CURINC IF(CURSRI.GT.dble(NREP))CURSRI=dble(NREP) GOTO 872 c C...Shift LEFT cursor to the left (with A) C 880 call putimage_w(CURSLE,dble(maxi),MARK,$GXOR) CURSLE=CURSLE-8.d0*CURINC IF(KK.EQ.'a')CURSLE=CURSLE+7.d0*CURINC IF(CURSLE.LT.0.d0)CURSLE=0.d0 C 882 call putimage_w(CURSLE,dble(maxi),MARK,$GXOR) ICHANG=1 CALL settextposition(myrows,int2(itxt+52),curpos) WRITE(OUTSTR,1550)nint(cursle),nint(cursri), * (nint(cursri)-nint(cursle))*tstep*1.e6 call outtext(outstr) GOTO 834 c C...Shift LEFT cursor to the right (with S) C 885 call putimage_w(cursle,dble(maxi),MARK,$GXOR) cursle=cursle+8.d0*CURINC IF(KK.EQ.'s')cursle=cursle-7.d0*CURINC IF(cursle.ge.cursri)cursle=cursri-1.d0*CURINC GOTO 882 C C...Subtraction of background by triple smoothing of interferogram with c least squares smoothing interval (with B) c 1100 CALL clearscreen($GCLEARSCREEN) 1101 WRITE(*,1102)nrep 1102 FORMAT(1X//12x,'Number of points in the interferogram: ',i5/12x, * 'Number of points (>3 and odd) in smoothing interval .... ',$) READ(*,'(i5)',ERR=1101)NSPT IF(NSPT.LE.3.OR.NSPT.GT.maxsmo)GOTO 1101 IF((NSPT/2)*2.EQ.NSPT)GOTO 1101 WRITE(*,'(1X//'' S U B T R A C T I N G''//)') C call baksub(nspt) c ICHANG=1 GOTO 831 C C...Compensate for rotational relaxation (with N) C 1500 CALL clearscreen($GCLEARSCREEN) 1501 WRITE(*,1502)nrep 1502 FORMAT(1X//12x,'Number of points in the interferogram: ',i5/ * 12x,'Number of points for halfdecay .... ',$) READ(*,'(i5)',ERR=1501)NHALF IF(NHALF.LE.10.AND.NHALF.GE.-10)GOTO 1501 C do 1506 j=1,nrep f=DBLE(J)/DBLE(NHALF) if(dabs(f).gt.10)f=dsign(10.d0,f) idata(j)=iDATA(j)*DEXP(f) 1506 continue C ICHANG=1 GOTO 831 c c...Restore original interferogram c 1200 do 1201 j=1,nrep idata(j)=ioldat(j) 1201 continue ichang=1 goto 831 C c . . . . . . . . . . . . . . . . . . . . . . . . c c...display the help screen (with H) c 840 CONTINUE CALL clearscreen($GCLEARSCREEN) write(*,'(1x)') WRITE(*,232) 232 FORMAT( ' SUMMARY OF COMMANDS ACTIVE IN FFT MODE:'/ * ' ---------------------------------------'// * ' W/Z - change vertical scaling'/ * ' Q/E - change horizontal scaling'/ * ' A/S - shift spectrum left/right'/ * ' K/L/, - move marker left/right/centre'/ * ' caps on/off - fast/slow change in the above'// * ' I - show the interferogram'/ * ' N - change FFT zero filling parameter n'/ * ' P - show the FFT points'/ * ' R - rescale spectrum to initial conditions'/ * 8x,'U,Y - ASCII dump of current FFT: U is for standard FFT,'/ * 15x,'Y produces output scaled to mV range of interferogram'/ * 15x,'(use option Y only after having used option I)'/ * ' O - frequency of peak nearest the cursor'/ * ' 9 - use marker frequency as line frequency'/ * ' 0 - change height cutoff for peak measurement'/ * ' = - mean frequency of last two measured peaks'// * ' Exit back to previous routine is by pressing '/) WRITE(*,106) 106 FORMAT(40X, * 'ENTER returns to the spectral display ',$) 107 IK=INKEY(J) IF(IK.NE.13)GOTO 107 835 dummy=setwindow(TRUE,fstart,bottom, * fend,top) call clearscreen($GCLEARSCREEN) GOTO 699 c c...change FFT zero filling parameter n c 850 CALL clearscreen($GCLEARSCREEN) call FFTEXE GOTO 851 c return end c C------------------------------------------------------------------------ c interface to integer*2 function system [C] (string[reference]) msf5 c character*1 string msf5 c end msf5 C------------------------------------------------------------------------ c subroutine inpout(ioper,filnam,iexit) c c Routine to determine whether there are any spectral archives (extension c .FAR) in the directory and what is to be done with the spectra that are c found c c IOPER - operation code of what to do on return c = 0 read spectra according to LIST.DAT c = 1 read the archive with name in FILNAM c INCLUDE 'FLIB.FD' PS1 c USE MSFLIB PS4 c c integer*2 system msf5 logical*4 fsys parameter (maxarc=45,maxspe=500,maxpts=850,nivols=7) character line*20,filnam*30,fnams(maxspe)*12,filarc*30 character cdummy*18,cdum*2,outa*12,outb*12 integer*2 minfs(maxarc),maxfs(maxarc),intfre,iwk(maxspe), * iseen(maxspe) integer interf(maxspe,maxpts) real detvol(maxspe,2),volint(maxspe,nivols) real*8 wk(maxspe) equivalence (cdum,intfre) common /scans/interf,wk,iwk,filarc common /scans2/detvol,volint,iseen,nscans common /sfiles/fnams c c c...determine the presence of FFT archives (with extension .FAR) c iexit=0 write(*,'(1x/)') fsys=systemqq('dir *.far/On>far.lst') msps c ifsys= system('dir *.far/On>far.lst'c) msf5 c fsys=.true. msf5 if(fsys.neqv..TRUE.)then write(*,'(1x/a//)')' ***** ERROR: Cannot do dir *.far>far.lst' stop endif open(2,file='far.lst',status='old') c narch=0 7 read(2,'(a)',end=9)line if(line(10:12).ne.'FAR')goto 7 do 8 i=9,1,-1 if(line(i:i).ne.' ')goto 10 8 continue 10 narch=narch+1 if(narch.eq.maxarc)then write(*,'(1x//'' ***** Too many archives - the program is '', * ''only dimensioned up to'',i5,a//)')maxarc,char(7) stop endif fnams(narch)=line(1:i)//'.'//line(10:12) goto 7 9 close(2) fsys=systemqq('del far.lst') msps c ifsys= system('del far.lst'C) msf5 c c...options c 19 if(narch.eq.0)then write(*,100) 100 format(1x// * ' ----> This directory contains NO FFT archive files:'/ * ' attempting to use the LIST.DAT file') 101 ioper=0 return else write(*,15)narch 15 format(1x//' This directory contains',i3, * ' FFT archive file(s):'/) c c...read frequency limits of archives c do 200 i=1,narch iwk(i)=i open(2,file=fnams(i),form='binary',status='old',err=200) read(2)cdummy read(2)cdum if(cdum.ne.'--')then minfs(i)=intfre wk(i)=intfre else wk(i)=0.0d0 endif read(2)cdum if(cdum.ne.'--')maxfs(i)=intfre close(2) 200 continue c c...sort according to frequency (-ve NSCANS is used to avoid c further reordering built into this version of SORTH) c nscans=-narch if(narch.gt.1)call sorth nscans=0 c c...write list of archives c if(narch.lt.10)then do 12 j=1,narch i=iwk(j) if(minfs(i).eq.0.and.maxfs(i).eq.0)then write(outa,'(a12)')' ' else write(outa,'(i6,''-'',i5)')minfs(i),maxfs(i) endif write(*,17)j,fnams(i),outa 12 continue 17 format(12x,i2,' = ',a,a) endif c if(narch.le.36.and.narch.ge.10)then j=narch/2 do 112 k=1,j i=iwk(k) ipj=iwk(k+j) if(minfs(i).eq.0.and.maxfs(i).eq.0)then write(outa,'(a12)')' ' else write(outa,'(i6,''-'',i5)')minfs(i),maxfs(i) endif if(minfs(ipj).eq.0.and.maxfs(ipj).eq.0)then write(outb,'(a12)')' ' else write(outb,'(i6,''-'',i5)')minfs(ipj),maxfs(ipj) endif write(*,117)k,fnams(i),outa,k+j,fnams(ipj),outb 112 continue if(2*(narch/2).ne.narch)then i=iwk(narch) if(minfs(i).eq.0.and.maxfs(i).eq.0)then write(outa,'(a12)')' ' else write(outa,'(i6,''-'',i5)')minfs(i),maxfs(i) endif write(*,118)narch,fnams(i),outa endif 117 format(4x,i2,' = ',a,a, 12x,i2,' = ',a,a) 118 format(45x, i2,' = ',a,a) endif c if(narch.gt.36.and.narch.le.maxarc)then j=narch/3 do 120 i=1,j jj=(i-1)*3+1 write(*,121)jj,fnams(jj),jj+1,fnams(jj+1),jj+2,fnams(jj+2) 120 continue 121 format(5x,i2,' = ',a,2(10x,i2,' = ',a)) if(j*3.ne.narch)then jj=j*3+1 write(*,121)(i,fnams(i),i=jj,narch) endif endif c write(*,18) 18 format(1x/ * ' OPTIONS: 0 = read spectra according to summary data file'/ * ' n = read archive n (any -ve value for exit)'// * 25x,'..... '$) read(*,'(i2)',err=20)ioper if(ioper.lt.0)then iexit=1 return endif if(ioper.lt.0.or.ioper.gt.narch)goto 20 if(ioper.gt.0)then filnam=fnams(iwk(ioper)) ioper=1 else ioper=0 endif return endif c 20 write(*,'(1x,a)')char(7) goto 19 c return end c C_____________________________________________________________________________ c subroutine inpspe(nfil) c c Routine to set up a list of files available for input as spectra c c INCLUDE 'FLIB.FD' PS1 c USE MSFLIB PS4 c c integer*2 system msf5 logical*4 fsys parameter (maxspe=500) character line*20,fnams(maxspe)*12 common /sfiles/fnams c c c...save the current directory to file c write(*,'(1x/)') fsys=systemqq('dir /Od>spec.lst') msps c ifsys= system('dir /Od>spec.lst'c) msf5 c fsys=.true. msf5 if(fsys.neqv..TRUE.)then write(*,'(1x/a//)')' ***** ERROR: Cannot do dir >spec.lst' stop endif c c...go through the directory file and identify potential spectral files c open(2,file='spec.lst',status='old') c nfil=0 7 read(2,'(a)',end=9)line if(line(1:1).eq.' '.or.line(1:1).eq.'.')goto 7 if(line(10:10).eq.'~')goto 7 if(line(10:12).eq.'FAR')goto 7 if(line(10:12).eq.'FOR'.or.line(10:12).eq.'for')goto 7 if(line(10:12).eq.'EXE'.or.line(10:12).eq.'exe')goto 7 if(line(10:12).eq.'OBJ'.or.line(10:12).eq.'obj')goto 7 if(line(10:12).eq.'DAT'.or.line(10:12).eq.'dat')goto 7 if(line(10:12).eq.'LST'.or.line(10:12).eq.'lst')goto 7 if(line(14:14).eq.'<'.or.line(16:16).eq.'<')goto 7 if(line(10:12).eq.'OUT'.or.line(10:12).eq.'out')goto 7 if(line(10:12).eq.'OUT'.or.line(10:12).eq.'out')goto 7 if(line(10:12).eq.'ARJ'.or.line(10:12).eq.'arj')goto 7 if(line(10:12).eq.'ASR'.or.line(10:12).eq.'asr')goto 7 if(line(10:12).eq.'INP'.or.line(10:12).eq.'inp')goto 7 if(line(10:12).eq.'ASF'.or.line(10:12).eq.'asf')goto 7 if(line(10:12).eq.'PAR'.or.line(10:12).eq.'par')goto 7 if(line(10:12).eq.'LIN'.or.line(10:12).eq.'lin')goto 7 if(line(10:12).eq.'VAR'.or.line(10:12).eq.'var')goto 7 if(line(10:12).eq.'BIN'.or.line(10:12).eq.'bin')goto 7 if(line(10:12).eq.'INT'.or.line(10:12).eq.'int')goto 7 if(line(10:12).eq.'FIT'.or.line(10:12).eq.'fit')goto 7 if(line(10:12).eq.'CAT'.or.line(10:12).eq.'cat')goto 7 if(line(10:12).eq.'PMI'.or.line(10:12).eq.'pmi')goto 7 if(line(10:12).eq.'COR'.or.line(10:12).eq.'cor')goto 7 if(line(10:12).eq.'STF'.or.line(10:12).eq.'stf')goto 7 if(line(10:12).eq.'GLE'.or.line(10:12).eq.'gle')goto 7 if(line(10:12).eq.'DOC'.or.line(10:12).eq.'doc')goto 7 if(line(10:12).eq.'BAK'.or.line(10:12).eq.'bak')goto 7 if(line(1:6).eq.'STATUS'.and.line(10:11).eq.'ME')goto 7 c do 8 i=9,1,-1 if(line(i:i).ne.' ')goto 10 8 continue 10 nfil=nfil+1 fnams(nfil)=line(1:i)//'.'//line(10:12) if(nfil.eq.maxspe)then write(*,'(1x//'' ***** The current limit of'',i3,a * '' on the number of files has been reached''/ * '' ***** NO MORE WILL BE READ IN''/)') * maxspe,char(7) goto 9 endif goto 7 9 close(2) fsys=systemqq('del spec.lst') msps c ifsys= system('del spec.lst'C) msf5 c return end c C_____________________________________________________________________________ c subroutine FFTEXE c C Intermediate routine which prepares input for the FFT calculation c on the recorded interferogram. C C The amount of zero-filling is determined by the variable MULZER - this c can be set externally to this routine (but given a negative sign), in which c case no screen output is made by this routine. C PARAMETER (Nmaxpt=8192,maxpts=850) c real data(nmaxpt),w1(2*nmaxpt),w2(nmaxpt) real p(nmaxpt) integer idata(maxpts) real*8 fstep logical ovrlap common /points/data,npts common /work/w1 common /work1/w2 common /scans1/idata,vstep,tstep,nrep,nskips,nskipe,naver common /specf/p,fstep,ncut,MULZER,NCALL C c c...Transfer points to array DATA passed to FFT routines: c minimum number of points is 256 or higher powers of 2 so fill-up c appropriately c NCALL=NCALL+1 NOWRIT=0 i=0 do 170 j=nskips+1,nrep-nskipe i=i+1 data(i)=idata(j) 170 continue npts=i IF(NPTS.LE.8192)NMAX=8192 if(npts.le.4096)nmax=4096 if(npts.le.2048)nmax=2048 if(npts.le.1024)nmax=1024 if(npts.le.512)nmax=512 if(npts.le.256)nmax=256 if(npts.ne.nmax)then do 52 i=npts+1,nmax data(i)=data(npts) 52 continue npts=nmax endif c c...FFT options: amount of zero-filling: note that -ve MULZER can be C generated by routine LOOKIN for recalculation of FFT with previous c value of MULZER, ie. when cutoffs for rejected points have been modified C C -on first time into this routine (NCALL=1) default value of MULZER is c assigned c IF(MULZER.GE.0)THEN write(*,56)npts 56 format(1x/i7,' points readied for FFT') 31 if(NCALL.ne.1)then 33 write(*,30) 30 format(1x/' Specify zero filling parameter n defined as ' * ' Total_Npts = 2**n * Npts'/ * ' (n=0,1,2,3.... )'// * 45x,' n = ',$) read(*,*,err=31)mulzer if(npts*2**mulzer.lt.npts)goto 33 else mulzer=4 555 if(npts*2**mulzer.gt.nmaxpt)then MULZER=MULZER-1 GOTO 555 ENDIF ENDIF C if(npts*2**mulzer.gt.nmaxpt)then mulzer=npts*2**mulzer write(*,775)mulzer,nmaxpt,char(7) 775 format(1x/' ERROR:',i8,' points needed for FFT but only ', * i6,' dimensioned',a// * ' -----> Specify smaller n'/) goto 31 endif ELSE mulzer=-mulzer 556 if(npts*2**mulzer.gt.nmaxpt)then MULZER=MULZER-1 GOTO 556 ENDIF NOWRIT=1 ENDIF C SHIFT=DATA(NPTS) do 32 i=1,npts*2**mulzer IF(I.LE.NPTS)THEN DATA(I)=DATA(I)-SHIFT ELSE DATA(I)=0.0 ENDIF 32 continue npts=npts*2**mulzer C k=1 m=npts/(k+1) IF(NOWRIT.NE.1)write(*,57)npts 57 format(1x/i7,' point record will be used for FFT') c c...FFT c samfre=1./tstep fnyq=samfre/2. fstep=samfre/npts ncut=fnyq/fstep fstep=fstep/1000. IF(NOWRIT.NE.1) * write(*,25)tstep*1.E+6,samfre*1.E-6,fnyq*1.E-6,fstep,ncut 25 format(1x/' time step = ',f15.10,' microsec.'/ * ' sampling frequency = ',f15.10,' MHz'/ * ' Nyquist frequency = ',f15.10,' MHz'/ * ' frequency step = ',f15.10,' kHz'/ * ' points in Nyq. interval = ',i15/) c ovrlap=.true. call spctrm(m,k,ovrlap) C C...Postscale points in power spectrum so that their intensities for c various amounts of zero filling are unified and equivalent to those c for n=4 c ymult=mulzer-4 ymult=16.d0**nint(ymult) if(nint(ymult).ne.1)then do 570 i=1,ncut p(i)=p(i)*ymult 570 continue endif c return end C C------------------------------------------------------------------------ c SUBROUTINE spctrm(m,k,ovrlap) c c Power spectrum estimation using routine 'four1' c c p = on output contains the input data's power (mean square amplitude) at c frequency (j-1)/(2*m) cycles per gridpoint, for j=1,2....,m c m = number of data points in segment c k = number of segments (each with 2m data points) c ovrlap=.false. segments do not overlap, 4*m*k data points c ovrlap=.true. segments overlap, (2k+1)*m data points c data = time domain data points c parameter (nmax=8192) INTEGER k,m c REAL p(m),w1(2*nmax),w2(nmax) REAL p(nmax),w1(2*nmax),w2(nmax) LOGICAL ovrlap real data(nmax) real*8 fstep common /points/data,npts common /work/w1 common /work1/w2 common /specf/p,fstep,ncut,NFFT,NCALL c INTEGER j,j2,joff,joffn,kk,m4,m43,m44,mm REAL den,facm,facp,sumw,w,window window(j)=(1.-abs(((j-1)-facm)*facp)) Bartlett c window(j)=1. Square c window(j)=(1.-(((j-1)-facm)*facp)**2 Welch nread=0 mm=m+m m4=mm+mm m44=m4+4 m43=m4+3 den=0. facm=m facp=1./m c c...accumulate the squared sum of the weights c sumw=0. do 11 j=1,mm sumw=sumw+window(j)**2 11 continue c c...initialize the spectrum to zero c do 12 j=1,m p(j)=0. 12 continue c c...initialize the 'save' half-buffer - this is a modifcation to use c the data from common block /points/. The values are read in c successively and NREAD is the total number of data points used. c If more points are required then are in the data then the last point c is repeated c if(ovrlap)then do 21 j=1,m nread=nread+1 if(nread.gt.npts)then w2(j)=data(npts) else w2(j)=data(nread) endif 21 continue endif c c...Loop over data set segments in groups of two. Get two complete c segments into workspace. c do 18 kk=1,k do 15 joff=-1,0,1 if(ovrlap)then do 13 j=1,m w1(joff+j+j)=w2(j) 13 continue do 22 j=1,m nread=nread+1 if(nread.gt.npts)then w2(j)=0. else w2(j)=data(nread) endif 22 continue joffn=joff+mm do 14 j=1,m w1(joffn+j+j)=w2(j) 14 continue else do 23 j=joff+2,m4,2 nread=nread+1 if(nread.gt.npts)then w1(j)=0. else w1(j)=data(nread) endif 23 continue endif 15 continue c c...Apply the window to the data c do 16 j=1,mm j2=j+j w=window(j) w1(j2)=w1(j2)*w w1(j2-1)=w1(j2-1)*w 16 continue c c...Fourier transform the windowed data c call four1(mm,1) c c...Sum results into previous segments c p(1)=p(1)+w1(1)**2+w1(2)**2 do 17 j=2,m j2=j+j p(j)=p(j)+w1(j2)**2+w1(j2-1)**2 * +w1(m44-j2)**2+w1(m43-j2)**2 17 continue den=den+sumw 18 continue c c...Correct normalization and normalize the output c den=m4*den do 19 j=1,m p(j)=p(j)/den 19 continue c write(*,25)nread 25 format(1x/i10,' points used in FFT') c return end c c---------------------------------------------------------------------------- c SUBROUTINE four1(nn,isign) parameter (nmax=8192) INTEGER isign,nn c REAL data(2*nn) real data(2*nmax) common /work/data c c Routine replaces data(1:2*nn) by its discrete Fourier transform, if isign c is input as -1; or replaces data(1:2*nn) by nn times its inverse discrete c Fourier transform, if isign is input as -1. c data is a complex array of length nn, or equivalently, a real array of c length 2*nn. c nn MUST be an integer power of 2 (this is not checked for!) c INTEGER i,istep,j,m,mmax,n REAL tempi,tempr DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp n=2*nn j=1 do 11 i=1,n,2 if(j.gt.i)then tempr=data(j) tempi=data(j+1) data(j)=data(i) data(j+1)=data(i+1) data(i)=tempr data(i+1)=tempi endif m=n/2 1 if((m.ge.2).and.(j.gt.m))then j=j-m m=m/2 goto 1 endif j=j+m 11 continue c mmax=2 2 if(n.gt.mmax)then istep=2*mmax theta=6.28318530717959d0/(isign*mmax) wpr=-2.d0*sin(0.5d0*theta)**2 wpi=sin(theta) wr=1.d0 wi=0.d0 do 13 m=1,mmax,2 do 12 i=m,n,istep j=i+mmax tempr=sngl(wr)*data(j)-sngl(wi)*data(j+1) tempi=sngl(wr)*data(j+1)+sngl(wi)*data(j) data(j)=data(i)-tempr data(j+1)=data(i+1)-tempi data(i)=data(i)+tempr data(i+1)=data(i+1)+tempi 12 continue wtemp=wr wr=wr*wpr-wi*wpi+wr wi=wi*wpr+wtemp*wpi+wi 13 continue mmax=istep goto 2 endif c return end c C------------------------------------------------------------------------ c SUBROUTINE PF(fmark,smax,XPEAK,ERRORX,htcut,xbot,fhalm,fhalp) C C Position of line maximum is established using the bisection method: C midpoints of line contour are determined at preselected number of sections c NSECT from peak maximum down to a selected fraction of peak height, HTCUT. c C Straight line fit to such midpoints gives, for y equal to line maximum, c the line frequency, with some account for possible line asymmetry. C C FMARK - frequency of the marker, which is assumed to have been set near C peak maximum c SMAX - on exit the intensity at the maximum C XPEAK - on exit the required central fitted peak position (requires C addition of FCENT) C ERRORX - on exit error on the fitted peak position c HTCUT - proportion of line height to which profile division is taken c XBOT - value of X for Y=0.4Ymax for drawing fitted line c FHALM - offset for negative FWHH point c FHALP - offset for positive FWHH point C PARAMETER (Nmaxpt=8192,nsect=20) c real p(nmaxpt),fr(nsect,2) real*8 fstep,fmark REAL*8 SUMX,SUMY,SUMXY,SUMX2,SUMY2,CXX,CXY,CYY,RN,A0,A1, * xoffs,yoffs c common /specf/p,fstep,npts,NFFT,NCALL common /peak/x(nsect),y(nsect) C c...determine initial value of peak maximum and its position c n=(fmark/fstep)+1. SMAX=P(N) 1 IF(N.LE.1.OR.N.GE.NPTS-1)THEN XPEAK=(N-1)*FSTEP ERRORX=(NPTS-1)*FSTEP RETURN ENDIF IF(P(N+1).GT.SMAX)THEN SMAX=P(N+1) N=N+1 GOTO 1 ENDIF IF(P(N-1).GT.SMAX)THEN SMAX=P(N-1) N=N-1 GOTO 1 ENDIF NMAX=N C C...Determine frequencies of points on sections through line contour: c linear interpolation used C do 2 ns=1,nsect ysect=smax-ns*smax*htcut/real(nsect) y(ns)=ysect do 3 n=nmax,npts if(p(n).le.ysect)then rn=real(n-1)+(ysect-p(n-1))/(p(n)-p(n-1)) fr(ns,2)=(rn-1.0)*fstep goto 2 endif 3 continue 2 continue c do 5 ns=1,nsect ysect=y(ns) do 4 n=nmax,2,-1 if(p(n).le.ysect)then rn=real(n-1)+(ysect-p(n-1))/(p(n)-p(n-1)) fr(ns,1)=(rn-1.0)*fstep goto 5 endif 4 continue 5 continue C do 6 n=1,nsect x(n)=0.5*(fr(n,1)+fr(n,2)) 6 continue c C...Straight line fit: since the line is almost vertical (gradient very c large) this was found to lead to numerical instabilities and for c this reason axes are reversed for least squares. For further increased c numerical stability SMAX is subtracted from Y and X(1) from X ie. the c equation of fit is: c c (x-x1) = a0 + a1 (y-smax) C SUMX=0.D0 SUMY=0.D0 SUMXY=0.D0 SUMX2=0.D0 SUMY2=0.D0 XOFFS=X(1) YOFFS=SMAX DO 7 I=1,NSECT SUMy=SUMy+(X(I)-xoffs) SUMx=SUMx+(Y(I)-yoffs) SUMXY=SUMXY+(X(I)-xoffs)*(Y(I)-yoffs) SUMy2=SUMy2+(X(I)-xoffs)**2 SUMx2=SUMx2+(Y(I)-yoffs)**2 7 CONTINUE C C...coefficients RN=NSECT 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 c c...peak frequency xpeak=a0+x(1) c C...coordinates of 0.4Ymax point xbot=a0-0.6*smax*a1+x(1) C C...error CYY=SUMY2-SUMY*SUMY/RN ERA1S=((CYY/CXX)-(CXY/CXX)**2)/(RN-2.D0) ERA0S=SUMX2*ERA1S/RN ERRORX=dsqrt(dble(era0s)) C C...Find X values at FWHH C ysect=0.5*smax do 13 n=nmax,npts if(p(n).le.ysect)then rn=real(n-1)+(ysect-p(n-1))/(p(n)-p(n-1)) fhalp=(rn-1.0)*fstep goto 12 endif 13 continue fhalp=(npts-1)*fstep c 12 do 14 n=nmax,2,-1 if(p(n).le.ysect)then rn=real(n-1)+(ysect-p(n-1))/(p(n)-p(n-1)) fhalm=(rn-1.0)*fstep goto 15 endif 14 continue fhalm=fstep 15 continue c RETURN END C C------------------------------------------------------------------------ C SUBROUTINE SORTH c c This routine is based on the SORT2 'heapsort' routine from Numerical c Recipes and sorts the quantities in vector WK from WK(NSTART) to WK(N) C in ascending order of magnitude and also accordingly rearranges vector C IPT of pointers to original positions of sorted quantities. c parameter (maxspe=500,maxpts=850,nivols=7) character fnams(maxspe)*12,ftemp(maxspe)*12,filarc*30 real detvol(maxspe,2),volint(maxspe,nivols) integer interf(maxspe,maxpts) integer*2 ipt(maxspe),iseen(maxspe) real*8 wk(maxspe) common /scans/interf,wk,ipt,filarc common /scans2/detvol,volint,iseen,nscans common /sfiles/fnams c INTEGER*2 IIPT,L,N,NSTART,I,J,IR REAL*8 WWK real rtemp(maxspe) equivalence (rtemp(1),ftemp(1)) C nstart=1 n=iabs(nscans) c L=N/2+1 IR=N 10 CONTINUE IF(L.GT.NSTART)THEN L=L-1 WWK=WK(L) IIPT=IPT(L) ELSE WWK=WK(IR) IIPT=IPT(IR) WK(IR)=WK(1) IPT(IR)=IPT(1) IR=IR-1 IF(IR.EQ.NSTART)THEN WK(1)=WWK IPT(1)=IIPT GOTO 100 ENDIF ENDIF I=L J=L+L 20 IF(J.LE.IR)THEN IF(J.LT.IR)THEN IF(WK(J).LT.WK(J+1))J=J+1 ENDIF IF(WWK.LT.WK(J))THEN WK(I)=WK(J) IPT(I)=IPT(J) I=J J=J+J ELSE J=IR+1 ENDIF GO TO 20 ENDIF WK(I)=WWK IPT(I)=IIPT GO TO 10 c c...reorder FNAMS, DETVOL and VOLINT according to the order in IPT c (this is not done if NSCANS has previously been made negative) c 100 if(nscans.lt.0)return do 101 l=1,2 do 102 i=1,nscans rtemp(i)=detvol(i,l) 102 continue do 101 i=1,nscans j=ipt(i) detvol(i,l)=rtemp(j) 101 continue c do 201 l=1,nivols do 202 i=1,nscans rtemp(i)=volint(i,l) 202 continue do 201 i=1,nscans j=ipt(i) volint(i,l)=rtemp(j) 201 continue c do 302 i=1,nscans ftemp(i)=fnams(i) 302 continue do 301 i=1,nscans j=ipt(i) fnams(i)=ftemp(j) 301 continue c c RETURN END C C_____________________________________________________________________________ c subroutine baksub(nspt) c PARAMETER (Nmaxpt=8192,maxpts=850,maxsmo=199) c integer idata(maxpts),ioldat(maxpts),itemp(maxpts) real spol(maxsmo) common /scans1/idata,vstep,tstep,nrep,nskips,nskipe,naver common /smooth/ioldat,itemp,spol c C...Subtraction of background by triple smoothing of interferogram with c least squares smoothing interval 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...Smooth three times ISTRT=M+1 IFIN=nrep-M DO 1104 k=1,3 do 1105 j=1,nrep itemp(j)=idata(j) 1105 continue DO 543 I=1,nrep SUM=0. DO 544 J=1,NSPT IS=J-M-1 II=I+IS IF(II.LT.1)II=-II+1 IF(II.GT.nrep)II=nrep-(II-nrep-1) SUM=SUM+itemp(II)*SPOL(J) 544 CONTINUE Idata(I)=sum 543 CONTINUE DO 545 I=1,nrep ITEMP(I)=IDATA(I) 545 CONTINUE 1104 continue C do 1106 j=1,nrep idata(j)=ioldat(j)-idata(j) 1106 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 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_____________________________________________________________________________