C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C VIEWer for Miscellaneous FTMW spectra C ---- - C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c This program allows viewing of multiple spectra: c c I. From a .FAR spectral archive 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 mode 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 9a.X.2007 ---- Zbigniew KISIEL ---- 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 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 4.06.01: conversion to CVF6.5 graphics + overhaul c 7.01.02: intensity weighted mean frequency C 12.02.02: debugging of operation for both W2000 and W95/98 C 3.01.03: switch to QWIN graphics, rewritten summary screen + other mods. C 28.10.03; config file C 29.12.03: some of the modifications introduced in VKIEL C 28.03.04: plotting also of fringe voltages for scans C 11.05.04: refresh option for data input C 16.11.04: subtraction of a background interferogram C 9.10.07: debugging of FAR listing C 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 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 O M P I L A T I O N: C----------------------------------------------------------------------------- C C This version will only compile satisfactorily with C Compaq Visual Fortran 6.50 (and possibly with not too distant earlier C versions of Microsoft Powerstation Fortran) C Note that there is compatibility with older versions in that C C Compilation is now to be for QWIN graphics - this necessitates explicit C programming out of several unnecessary frills, but results in smoother C launch of the program than is possible with the STANDARD graphics as used C previously. C C-------------------------------- C Command line compilation: C-------------------------------- C C Simplest compilation for the local machine: C C df -static -libs=qwin -fpscomp:filesfromcmd viewm.for C C Optimised compilation for any PENTIUM: C C df -nodebug -traceback -arch=pn1 -tune=pn1 C -fast -static -libs=qwin -fpscomp:filesfromcmd viewm.for C C Other processor options are pn2,pn3,pn4,k6_2,k7 C C-------------------------------- C Visual Studio compilation: C-------------------------------- C C FORTRAN: /compile_only /fpscomp:filesfromcmd C /libs:qwin /nologo /nopdbfile /optimize:3 /traceback /tune:pn1 C /architecture:pn1 /static C C LINK: kernel32.lib /nologo /subsystem:windows /pdb:none C /machine:IX86 /out:"Debug/v6.exe" C C The use of /check:all FORTRAN option is also recommended, but only for C debugging. C C----------------------------------------------------------------------------- C S T A R T U P: C----------------------------------------------------------------------------- C C Program startup: C C 1/ in Win95,Win98 just call the program from the command line set to C the directory containing the data C 2/ in Win2000 use the command: C START /d . c:\fft\viewm.exe C from the command line set to the directory containing the data, C assuming the PATH leads to the directory containing VIEWM.EXE 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 USE DFLIB C RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy C_____________________________________________________________________________ c parameter (maxspe=500,maxpts=850,nivols=7,maxsmo=199) PARAMETER (ntextc=0, ntextb=7) c character fnams(maxspe)*12,filnam*30,filarc*30,dirnam*50 real detvol(maxspe,2),volint(maxspe,nivols),spol(maxsmo) integer interf(maxspe,maxpts),idata(maxpts),nave(maxspe), * ioldat(maxpts),itemp(maxpts),dummy4 integer*2 iseen(maxspe),ipoint(maxspe),dum2 INTEGER*2 maxx,maxy,LINOFS,mymode,myrows,mycols real*8 freq(maxspe) integer*2 nreps(maxspe),nskip(maxspe),nskip1(maxspe),dummy2 real tsteps(maxspe),vsteps(maxspe) character comnt(maxspe)*50,sampl(maxspe)*20,timd(maxspe)*20 c common /scans/interf,freq,wmult,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/wxy,maxx,maxy,LINOFS,curpos,ixy, * mymode,myrows,mycols c irefr=0 mxnrep=0 mnnrep=maxpts c call startg(iconf) dummy4=passdirkeysqq(.true.) c C...HEADER C numfonts = INITIALIZEFONTS ( ) fontnum = SETFONT ('t''Arial''h75w25ei') dummy4=setbkcolor(ntextb) call clearscreen($gclearscreen) c NBOTL=120 dummy=setcolor(15) CALL MOVETO (INT2( 0), INT2(NBOTL), ixy) dummy=lineto(INT2( maxx), INT2(NBOTL)) CALL MOVETO (INT2( 0), INT2(0), ixy) dummy=lineto(INT2( maxx), INT2(0)) dummy=setcolor(8) dummy=floodfill(1,1,15) c nvert=(NBOTL-75)/2 nhor=28 c dummy=setcolor(11) CALL MOVETO (INT2(nhor), INT2(nvert), ixy) CALL OUTGTEXT('VIEWM -') dummy=setcolor(9) CALL MOVETO (INT2(nhor+1), INT2(nvert+1), ixy) CALL OUTGTEXT('VIEWM -') dummy=setcolor(1) CALL MOVETO (INT2(nhor+2), INT2(nvert+2), ixy) CALL OUTGTEXT('VIEWM -') c dummy=setcolor(11) fontnum = SETFONT ('t''Arial''h60w20ei') CALL MOVETO (INT2(nhor+220), INT2(nvert+11), ixy) CALL OUTGTEXT('Viewer for FTMW Spectra') dummy=setcolor(9) CALL MOVETO (INT2(nhor+220+1), INT2(nvert+11+1), ixy) CALL OUTGTEXT('Viewer for FTMW Spectra') dummy=setcolor(1) CALL MOVETO (INT2(nhor+220+2), INT2(nvert+11+2), ixy) CALL OUTGTEXT('Viewer for FTMW Spectra') c dummy=setcolor(15) CALL MOVETO (INT2( 0), INT2(NBOTL+ 32), ixy) dummy=lineto(INT2( maxx), INT2(NBOTL+ 32)) dummy=setcolor(8) dummy=floodfill(1,INT2(NBOTL+30),15) c dummy=setcolor(0) CALL MOVETO (INT2( 0), INT2(NBOTL+ 32), ixy) dummy=lineto(INT2( maxx), INT2(NBOTL+ 32)) dummy=setcolor(7) CALL MOVETO (INT2( 0), INT2(NBOTL+ 1), ixy) dummy=lineto(INT2( maxx), INT2(NBOTL+ 1)) c fontnum = SETFONT ('t''Arial''h20w10') dummy=setcolor( 0) CALL MOVETO (INT2( 11), INT2(NBOTL+ 7), ixy) CALL OUTGTEXT('version 9a.X.2007') CALL MOVETO (INT2( maxx-169), INT2(NBOTL+ 7), ixy) CALL OUTGTEXT('Zbigniew KISIEL') dummy=setcolor(15) CALL MOVETO (INT2( 10), INT2(NBOTL+ 6), ixy) CALL OUTGTEXT('version 9a.X.2007') CALL MOVETO (INT2( maxx-170), INT2(NBOTL+ 6), ixy) CALL OUTGTEXT('Zbigniew KISIEL') c nrlin=nint(real(NBOTL+32)/(real(maxy)/real(myrows)))+2 call settextposition(nrlin,45,curpos) dummy=settextcolor(ntextc) write(*,'(''up to'',i5,'' spectra'',$)')maxspe call settextposition(nrlin+1,45,curpos) write(*,'(''up to'',i5,'' points in each spectrum'')')maxpts c C...Warn of missing config file C 70 call settextposition(11,1,curpos) if(iconf.eq.0)then dummy=setcolor(12) fontnum = SETFONT ('t''Arial''h18w9e') CALL MOVETO (INT2(100), INT2(220), ixy) CALL OUTGTEXT( * 'Configuration file C:\FFT\V6.CFG was not found:') CALL MOVETO (INT2(250), INT2(240), ixy) fontnum = SETFONT ('t''Arial''h18w9i') CALL OUTGTEXT( * 'default sized window of 800x540 pixels will be used') call settextposition(15,1,curpos) endif c c c...Decide on type of input c 555 call inpout(iarch,filarc,iexit,dirnam,ntsys) <---- if(iexit.eq.1)then dum2=setexitqq(qwin$exitnopersist) 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 557 if(iarch.eq.0)then c if(irefr.eq.1)goto 558 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 dummy=setexitqq(qwin$exitnopersist) stop endif c c - - - - - - read spectra as found in the current directory c 558 if(filnam(1:1).eq.' '.or.filnam(1:1).eq.char(0))then iarcht=-1 call inpspe(nfil,ntsys) if(nfil.eq.0)then write(*,1115) 1115 format(1x//' ----> The directory ',$) DUMmy2=settextcolor(12) n=len_trim(dirnam) write(*,'(1x,a)')dirnam(1:n) DUMmy2=settextcolor(ntextc) write(*,'(8x, * ''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) DUMmy2=settextcolor(12) n=len_trim(dirnam) write(*,'(1x,a)')dirnam(1:n) DUMmy2=settextcolor(ntextc) write(*,'(8x, * ''appears to contain NO FTMW spectral files'')') 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)then dummy4=setbkcolor(12) DUMmy2=settextcolor(15) write(*,3470)maxpts dummy4=setbkcolor(ntextb) DUMmy2=settextcolor(ntextc) endif 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 dummy4=setbkcolor(12) DUMmy2=settextcolor(15) nscans=maxspe write(*,3471)nscans dummy4=setbkcolor(ntextb) DUMmy2=settextcolor(ntextc) endif 3470 format(' ***** Interferograms will be chopped to ', * i5,' points') 3471 format(' ***** Only the first ',i5, * ' interferograms will be read') write(*,3473) 3473 format(1x/50x,'Press E N T E R ',$) read(*,'(i1)',err=3472)j 3472 call clearscreen($gclearscreen) 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 556 if(iarch.eq.1)then iarcht=1 open(3,file=filarc,form='binary',status='old') c call clearscreen($gclearscreen) 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 dummy4=setbkcolor(12) DUMmy2=settextcolor(15) write(*,412)maxspe dummy4=setbkcolor(ntextb) DUMmy2=settextcolor(ntextc) 412 format(1x/' ***** The maximum of',i5,' intereferograms', * ' reached - no more will be read',$) else goto 411 endif 410 close(3) if(ichop.eq.1)then dummy4=setbkcolor(12) DUMmy2=settextcolor(15) write(*,454)maxpts dummy4=setbkcolor(ntextb) DUMmy2=settextcolor(ntextc) endif 454 format(1x/' ***** Interferograms have been chopped to',i5, * ' points',$) 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,irefr) if(irefr.eq.1)then if(filarc(1:16).eq.'Spectra in local')then iarch=0 filarc=' ' endif if(iarch.eq.1)then goto 556 else filnam=' ' goto 557 endif endif 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 USE DFLIB PARAMETER (maxspe=500,maxpts=850,nivols=7) PARAMETER (ntextc=0, ntextb=7) c 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) real detvol(maxspe,2),volint(maxspe,nivols) common /scans/interf,freq,wmult,ipoint,filarc common /scans1/idata,vstep,tstep,nrep,nskips,nskipe,naver common /scans2/detvol,volint,iseen,nscans 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(naver.lt.0)then read(3,end=510)detvol(nspe,1) read(3,end=510)detvol(nspe,2) else detvol(nspe,1)=0.0 detvol(nspe,2)=0.0 endif C if(iarch.eq.0)CLOSE(3) goto 501 c 503 dummy4=setbkcolor(12) DUMmy2=settextcolor(15) write(*,504)filnam 504 format(1x/' ***** Cannot open file: ',a,$) dummy4=setbkcolor(ntextb) DUMmy2=settextcolor(ntextc) write(*,'(1x)') iread=0 return 510 iread=-1 c 501 return end c c--------------------------------------------------------------------------- c subroutine summar(iarch,irefr) 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 USE DFLIB c RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy INTEGER*2 maxx,maxy,LINOFS,dummy,inkey,mymode,myrows,mycols INTEGER*4 dummy4 logical*2 true real*8 wmin,wmax,fstart,fend,fmark,rint,wrange,fincr,freqv REAL*8 YYSTEP,YSHIFT,RRSMAL,fchang character kk,emplin*80,lwork1*80,outstr*21 COMMON /limits/wxy,maxx,maxy,LINOFS,curpos,ixy, * mymode,myrows,mycols COMMON /plotda/wmin,wmax,RRSMAL,YYSTEP,YSHIFT COMMON /lines/emplin c c...declarations for spectra c parameter (maxspe=500,maxpts=850,nivols=7, * vrange=50.0,true=.true.) PARAMETER (ntextc=0, ntextb=7, nbordc=15, ncursc=14) c character fnams(maxspe)*12,filarc*30 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) common /scans/interf,freq,wmult,ipoint,filarc common /scans1/idata,vstep,tstep,nrep,nskips,nskipe,naver common /scans2/detvol,volint,iseen,nscans common /scan3/nreps,nskip,nskip1,tsteps,vsteps,nave common /sfiles/fnams c if(idispl.ne.-1)idispl=-1 c nmark=nscans/2+1 fmark=freq(nmark) c ifring=0 volt=0.0 n=nivols/2+1 drange=0.0 DO 201 I=1,nscans if(volt.lt.volint(i,n))VOLT=VOLINT(I,N) if(-detvol(i,1).gt.drange)drange=-detvol(i,1) if(-detvol(i,2).gt.drange)drange=-detvol(i,2) 201 CONTINUE if(drange.ne.0.0)ifring=1 wmult=volt/(vrange*0.9) wmulti=wmult c WRITE(emplin,'(80(1H ))') C c. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c G R A P H I C S C C...Start up the graphics C itxt=(mycols-80)/2 C C...definition of graphics viewport: first pixel coordinates of viewport c then real coordinates for scales c 179 dummy4=setbkcolor(ntextb) DUMmy2=settextcolor(ntextc) call clearscreen($GCLEARSCREEN) call setviewport(2,2*LINOFS-2,maxx-2,maxy-2*LINOFS+2) c if(irefr.eq.1)then irefr=0 fstart=0.d0 fend=0.d0 endif if(fstart.eq.0.d0.and.fend.eq.0.d0)then 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 fincr=1.04*(fend-fstart)/(maxx-4) endif c c...complete screen refresh takes place from here c 178 wrange=wmult*vrange wmin= 0.0d0 wmax= 1.05*WRANGE YYSTEP=1.d0/500.d0*(wmax-wmin) RRSMAL=wmin-13.d0*YYSTEP dummy=setwindow(TRUE,fstart,RRSMAL,fend,wmax) dummy4=setbkcolor(1) DUMMY2=SETCOLOR( nbordc ) call clearscreen($GVIEWPORT) DUMMY2=SETCOLOR( 0 ) CALL moveto_w(fstart,wmin,wxy) dummy=lineto_w(fstart,wmax) dummy=lineto_w(fend,wmax) DUMMY2=SETCOLOR( nbordc ) dummy=lineto_w(fend,wmin) dummy=lineto_w(fstart,wmin) c c...Plot range voltages using one of the two possible display schemes c c 1/ spectral scheme (join dots as function of frequency) C 2/ histogram scheme - i.e. a stick diagram c if(idispl.eq.1)then DUMMY=SETCOLOR(12) red do 102 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) white if(n.gt.nivols/2+1)dummy=setcolor(14) yellow DO 103 I=1,nscans freqv=freq(I) if(freqv.lt.fstart.or.freqv.gt.fend)goto 103 VOLT=VOLINT(I,N) IF(VOLT.GT.wmax)VOLT=wmax dummy=lineto_w(freqv,dble(volT)) 103 CONTINUE 102 continue else do 100 I=1,nscans freqv=freq(I) if(freqv.lt.fstart.or.freqv.gt.fend)goto 100 c VOLT=VOLINT(I,1) IF(VOLT.GT.wmax)VOLT=wmax DUMMY=SETCOLOR(12) red CALL moveto_w(freqv,0.d0,wxy) dummy=lineto_w(freqv,dble(volT)) c VOLT=VOLINT(I,4) IF(VOLT.GT.wmax)VOLT=wmax DUMMY=SETCOLOR(15) white CALL moveto_w(freqv,0.d0,wxy) dummy=lineto_w(freqv,dble(volT)) c DUMMY=SETCOLOR(14) yellow VOLT=VOLINT(I,5) IF(VOLT.GT.wmax)VOLT=wmax CALL moveto_w(freqv,0.d0,wxy) dummy=lineto_w(freqv,dble(volT)) c VOLT=VOLINT(I,6) IF(VOLT.GT.wmax)VOLT=wmax CALL moveto_w(freqv-fincr,0.d0,wxy) dummy=lineto_w(freqv-fincr,dble(volT)) CALL moveto_w(freqv+fincr,0.d0,wxy) dummy=lineto_w(freqv+fincr,dble(volT)) c VOLT=VOLINT(I,7) IF(VOLT.GT.wmax)VOLT=wmax CALL moveto_w(freqv-2.d0*fincr,0.d0,wxy) dummy=lineto_w(freqv-2.d0*fincr,dble(volT)) CALL moveto_w(freqv+2.d0*fincr,0.d0,wxy) dummy=lineto_w(freqv+2.d0*fincr,dble(volT)) c 100 continue c endif c c...plot fringe voltages, if available c if(ifring.eq.1)then detscl=WRANGE/drange DUMMY=SETCOLOR(3) cyan do 105 n=1,2 j=0 DO 106 I=1,nscans freqv=freq(I) if(freqv.lt.fstart.or.freqv.gt.fend)goto 106 j=j+1 rint=-detvol(i,n)*detscl+0.1*detscl if(rint.gt.wrange)RINT=WRANGE if(j.eq.1)then CALL moveto_w (freqv,rint,wxy) else dummy=lineto_w(freqv,rint) endif 106 CONTINUE 105 continue endif dummy=setcolor(15) C C...marker scale C yshift=wmin call marsca(fstart,fend) c c...cursor c dummy=setwritemode($GXOR) DUMMY2=SETCOLOR( ncursc ) CALL setlinestyle(#3333) CALL moveto_w(FMARK,wmax,wxy) dummy2=lineto_w(FMARK,wmin) dummy=setwritemode($GPSET) CALL setlinestyle(#FFFF) c c...information lines c dummy4=setbkcolor(ntextb) dummy=settextcolor(12) call settextposition(myrows,int2(itxt+36),curpos) call outtext(filarc(1:30)) dummy=settextcolor(ntextc) 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 771 write(lwork1,'('' file: '',12x,'' frequency:'', * f12.4,'' MHz'')'),freq(nmark) CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(lwork1) dummy=settextcolor(12) CALL settextposition(1,int2(itxt+8),curpos) CALL outtext(fnams(nmark)) dummy=settextcolor(ntextc) c c...options loop: c A,S - shift screen window left/right c Q,E - zoom in/out in frequency c W,Z - increase/decrease vertical scale c K,L - move cursor left/right c - cursor beginning/end C C O - go to spectrum under the cursor c I - go to screen comparing interferograms c c P - toggle display style c R - restore initial scaling c - exit to M/P to reread data c - exit from program c 77 IK=INKEY(N) KK=CHAR(IK) c c...terminate program, (with ESC) c if(iK.eq.27)then irefr=1 return 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) nrep=nreps(nmark1) nskips=nskip(nmark1) nskipe=nskip1(nmark1) vstep=vsteps(nmark1) tstep=tsteps(nmark1) iseen(nmark)=11 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,irefr) if(irefr.eq.1)return fmark=freq(nmark) if(fmark.lt.fstart.or.fmark.gt.fend)then frange=fend-fstart fstart=fmark-0.5d0*frange fend=fmark+0.5d0*frange endif GOTO 179 endif c c...zoom-in in frequency (with E) c if(KK.eq.'E'.or.KK.eq.'e')then FRange=Fend-Fstart Fchang=0.25D0*FRange IF(KK.EQ.'e')Fchang=0.45d0*FRange Fstart=Fmark-Fchang Fend=Fmark+Fchang if(fend-fstart.lt.0.1D0)then fstart=fmark-0.05d0 fend=fmark+0.05d0 endif c if(fstart.lt.freq(1))fstart=freq(1)-0.1d0 if(fend.gt.freq(nscans))fend=freq(nscans)+0.1d0 c fincr=1.04*(fend-fstart)/maxx goto 178 endif c c...zoom-out in frequency (with Q) c if(KK.eq.'Q'.or.KK.eq.'q')then FRange=Fend-Fstart Fchang=0.5D0*FRange IF(KK.EQ.'q')Fchang=0.1d0*FRange Fstart=Fstart-Fchang Fend=Fend+fchang c if(fstart.lt.freq(1))fstart=freq(1)-0.1d0 if(fend.gt.freq(nscans))fend=freq(nscans)+0.1d0 c fincr=1.04*(fend-fstart)/maxx goto 178 endif C C...Shift screen window to left (with A) C if(KK.eq.'A'.or.KK.eq.'a')then FRange=fend-fstart Fchang=FRange*0.5D0 IF(KK.EQ.'a')Fchang=FRange*0.1D0 fstart=fstart-Fchang fend= fend -Fchang IF(fstart.LT.freq(1))THEN fstart=freq(1)-0.1d0*frange fend=fstart+frange ENDIF 150 if(fmark.gt.fend)then nmark=nmark-1 fmark=freq(nmark) goto 150 endif if(fmark.lt.fstart)then fstart=fmark-frange*0.5d0 fend= fmark+frange*0.5d0 endif fincr=1.04*(fend-fstart)/maxx goto 178 endif C C...Shift screen window to right (with S) C if(KK.eq.'S'.or.KK.eq.'s')then FRange=fend-fstart Fchang=FRange*0.5D0 IF(KK.EQ.'s')Fchang=FRange*0.1D0 fstart=fstart+Fchang fend= fend +Fchang IF(fend.gt.freq(nscans))THEN fend=freq(nscans)+0.1d0*frange fstart=fend-frange ENDIF 151 if(fmark.lt.fstart)then nmark=nmark+1 fmark=freq(nmark) goto 151 endif if(fmark.gt.fend)then fstart=fmark-frange*0.5d0 fend= fmark+frange*0.5d0 endif fincr=1.04*(fend-fstart)/maxx goto 178 endif c c...cursor left, (with K) c if(KK.eq.'K'.or.KK.eq.'k')then dummy=setwritemode($GXOR) DUMMY2=SETCOLOR( ncursc ) CALL setlinestyle(#3333) CALL moveto_w(FMARK,wmax,wxy) dummy2=lineto_w(FMARK,wmin) nmark=nmark-1 if(KK.eq.'K')nmark=nmark-9 if(nmark.lt.1)nmark=1 130 fmark=freq(nmark) if(fmark.lt.fstart)then nmark=nmark+1 goto 130 endif CALL moveto_w(FMARK,wmax,wxy) dummy2=lineto_w(FMARK,wmin) CALL setlinestyle(#FFFF) dummy=setwritemode($GPSET) goto 771 endif c c...cursor right, (with L) c if(KK.eq.'L'.or.KK.eq.'l')then dummy=setwritemode($GXOR) DUMMY2=SETCOLOR( ncursc ) CALL setlinestyle(#3333) CALL moveto_w(FMARK,wmax,wxy) dummy2=lineto_w(FMARK,wmin) nmark=nmark+1 if(KK.eq.'L')nmark=nmark+9 if(nmark.gt.nscans)nmark=nscans 131 fmark=freq(nmark) if(fmark.gt.fend)then nmark=nmark-1 goto 131 endif CALL moveto_w(FMARK,wmax,wxy) dummy2=lineto_w(FMARK,wmin) CALL setlinestyle(#FFFF) dummy=setwritemode($GPSET) goto 771 endif c c...marker beginning,end c if(ik.eq.-71)then dummy=setwritemode($GXOR) DUMMY2=SETCOLOR( ncursc ) CALL setlinestyle(#3333) CALL moveto_w(FMARK,wmax,wxy) dummy2=lineto_w(FMARK,wmin) nmark=1 140 fmark=freq(nmark) if(fmark.lt.fstart)then nmark=nmark+1 goto 140 endif CALL moveto_w(FMARK,wmax,wxy) dummy2=lineto_w(FMARK,wmin) CALL setlinestyle(#FFFF) dummy=setwritemode($GPSET) goto 771 endif c if(ik.eq.-79)then dummy=setwritemode($GXOR) DUMMY2=SETCOLOR( ncursc ) CALL setlinestyle(#3333) CALL moveto_w(FMARK,wmax,wxy) dummy2=lineto_w(FMARK,wmin) nmark=nscans 141 fmark=freq(nmark) if(fmark.gt.fend)then nmark=nmark-1 goto 141 endif CALL moveto_w(FMARK,wmax,wxy) dummy2=lineto_w(FMARK,wmin) CALL setlinestyle(#FFFF) dummy=setwritemode($GPSET) goto 771 endif C C...restore original spectrum and scaling (with R) C IF(KK.EQ.'R'.OR.KK.EQ.'r')THEN wmult=wmulti nmark=nscans/2+1 fmark=freq(nmark) 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 fincr=1.04*(fend-fstart)/(maxx-4) goto 178 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...toggle display style - between spectrum and histogram C if(KK.eq.'P'.or.kk.eq.'p')then idispl=-idispl goto 178 endif c c...Help screen (with H) c if(KK.eq.'H'.or.KK.eq.'h')then dummy4=setbkcolor(ntextb) DUMmy2=settextcolor(ntextc) CALL clearscreen($GCLEARSCREEN) WRITE(*,232) 232 FORMAT(1x/'_____S U M M A R Y screen commands', * 45(1H_)/// * 9x,' W/Z - zoom-in/zoom-out in intensity'/ * 9x,' E/Q - zoom-in/zoom-out in frequency'/ * 9x,' K/L - cursor left/right'/ * 9x,' A/S - window left/right'/ * 9x,' - cursor to beginning/end'// * 9x,' caps on/off - fast/slow change in the above'// * 9x,' P - toggle spectrum <-> histogram display style'/ * 9x,' R - restore initial settings'// * 9x,' I - go to comparison of interferograms'/ * 9x,' O - go to spectrum under the cursor'// * 9x,' - (followed by Y) exit from the program'/ * 9x,' - reread input data'/// * 9x,' Press ENTER to exit this HELP screen'/) 107 IK=INKEY(J) IF(IK.NE.13)GOTO 107 CALL clearscreen($GCLEARSCREEN) CALL settextposition(2,int2(itxt+1),curpos) call outtext(emplin) GOTO 178 endif c c IF(IK.NE.13)GOTO 77 C C...exit control C DUMMY= SETTEXTCOLOR(ntextc) dummy4 = setbkcolor(ntextb) 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 (12) WRITE(outstr,'(A)')' ARE YOU SURE (Y/N) ?' CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(outstr(1:21)) 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(ntextc) dummy4 = setbkcolor(ntextb) CALL settextposition(1,int2(itxt+1),curpos) call outtext(lwork1) GOTO 77 c 915 dummy=setexitqq(qwin$exitnopersist) stop c RETURN END c C_____________________________________________________________________________ C subroutine marsca(f1,f2) c c Plot and label the marker scale for frequency limits F1,F2 c USE DFLIB c RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy c LOGICAL*2 true PARAMETER (TRUE=.TRUE.) PARAMETER (ntextc=0, ntextb=7, nplotc=15, nplotb=1) c INTEGER*2 maxx,maxy,linofs,mymode,myrows,mycols,dummy,nbufer,nm INTEGER*4 dummy4 CHARACTER*80 emplin,marlin CHARACTER 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 COMMON /lines/emplin 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 c 1114 YY=RSMALL-5.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(nplotc) 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( 1 ) dummy4=setbkcolor (ntextb) CALL settextposition(int2(myrows-1),1,curpos) CALL outtext(marlin) c return end C c--------------------------------------------------------------------------- c subroutine intcom(nmark,iarch,irefr) 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 USE DFLIB 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 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/wxy,maxx,maxy,LINOFS,curpos,ixy, * mymode,myrows,mycols c c...declarations for spectra c parameter (maxspe=500,maxpts=850,vrange=50.0,nivols=7,true=.true.) PARAMETER (ntextc=0, ntextb=7) c 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),volt,hrange,vshift,xshift,vmult,dtstep 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,wmult,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 timmax=0. do 600 n=1,nscans if(tsteps(n)*nreps(n).gt.timmax)timmax=tsteps(n)*nreps(n) 600 continue WRITE(emplin,'(80(1H ))') C c. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c G R A P H I C S C C...Start up the graphics C 179 dummy4 = setbkcolor( 1 ) 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 c For P120 and P166 computers plot every second point for a sensible c reresh rate (loop: DO 101 ...) C - note that PS4 and CVF6.5 graphics is appreciably slower than c PS1 graphics 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. dtstep=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=dtstep+xshift CALL moveto_w(xpoint,volT,wxy) dummy=setcolor(12) c DO 101 I=2,nrep DO 101 I=3,nrep,2 VOLT=interf(j,i)*vmult if(volt.lt.-hrange)volt=-hrange if(volt.gt.hrange)volt=hrange volt=volt+hrange+vshift c xpoint=xpoint+dtstep xpoint=xpoint+2.d0*dtstep if(i.eq.nskips.or.i.eq.nskips+1)dummy=setcolor(15) if(i.eq.ncolch.or.i.eq.ncolch+1)dummy=setcolor(12) dummy=lineto_w(xpoint,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(1) if(nstart+1.le.nscans)dummy=settextcolor(iseen(nstart+1)) CALL settextposition(1,lcol2,curpos) CALL outtext(lwork1(28:51)) dummy=settextcolor(1) if(nstart+2.le.nscans)dummy=settextcolor(iseen(nstart+2)) CALL settextposition(1,lcol3,curpos) CALL outtext(lwork1(55:78)) c dummy=settextcolor(1) if(nstart+3.le.nscans)dummy=settextcolor(iseen(nstart+3)) CALL settextposition(lsecnd,1,curpos) CALL outtext(lwork2(1:24)) dummy=settextcolor(1) if(nstart+4.le.nscans)dummy=settextcolor(iseen(nstart+4)) CALL settextposition(lsecnd,lcol2,curpos) CALL outtext(lwork2(28:51)) dummy=settextcolor(1) if(nstart+5.le.nscans)dummy=settextcolor(iseen(nstart+5)) CALL settextposition(lsecnd,lcol3,curpos) CALL outtext(lwork2(55:78)) c dummy=settextcolor(1) if(nstart+6.le.nscans)dummy=settextcolor(iseen(nstart+6)) CALL settextposition(lthird,1,curpos) CALL outtext(lwork3(1:24)) dummy=settextcolor(1) if(nstart+7.le.nscans)dummy=settextcolor(iseen(nstart+7)) CALL settextposition(lthird,lcol2,curpos) CALL outtext(lwork3(28:51)) dummy=settextcolor(1) if(nstart+8.le.nscans)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 - reread input data 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= SETTEXTCOLOR(ntextc) dummy4 = setbkcolor(ntextb) 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 (12) CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(' ARE YOU SURE YOU WANT TO EXIT (Y/N) ?') 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'.and.kk.ne.'Q'.and.kk.ne.'q')GOTO 916 C DUMMY=SETTEXTCOLOR(ntextc) dummy4 = setbkcolor(ntextb) CALL settextposition(1,int2(itxt+1),curpos) call outtext(lwork1) GOTO 179 c 915 dum2=setexitqq(qwin$exitnopersist) 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(ncall.gt.nscans)goto 801 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)=11 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 dummy4=setbkcolor(ntextb) DUMmy2=settextcolor(ntextc) CALL clearscreen($GCLEARSCREEN) write(*,'(1x)') c write(*,'(1x//17x,''Spectral file: '',$)') DUMmy2=settextcolor(12) write(*,'(a)')filnam DUMmy2=settextcolor(ntextc) write(*,'(1x//1x,a/)')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 dummy4=setbkcolor(1) DUMmy2=settextcolor(7) GOTO 178 endif c c...Help screen (with H) c if(KK.eq.'H'.or.KK.eq.'h')then dummy4=setbkcolor(ntextb) DUMmy2=settextcolor(ntextc) CALL clearscreen($GCLEARSCREEN) WRITE(*,232) 232 FORMAT(1x/'_____', * 'I N T E R F E R O G R A M S screen commands', * 31(1H_)/// * 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 - go to spectrum 1 to 9'/ * 9x,' to - display parameters of spectrum 1 to 9'/ * 9x,' - reread input data'/ * 9x,' ENTER - exit to the SUMMARY screen'/ * 9x,' Q - quit the program'/// * 9x,' Press ENTER to exit this HELP screen'/) 107 IK=INKEY(J) IF(IK.NE.13)GOTO 107 dummy4=setbkcolor(1) DUMmy2=settextcolor(7) GOTO 178 endif c c...Go back to the M/P to reread input data (with ESC) c IF(IK.eq.27)then irefr=1 dummy4=setbkcolor(ntextb) dummy=settextcolor(ntextc) call clearscreen($GCLEARSCREEN) return ENDIF c IF(IK.NE.13)GOTO 77 C C...exit back to SUMMAR C RETURN END C C_____________________________________________________________________________ C subroutine startg(iconf) c C This routine uses QWIN graphics and techniques from the CLEANWIN programming C example for CVF6 to avoid the full-screen startup of standard graphics, C while preserving a simple frame. C Note the use of the WIN32 routines MoveWindow, UpdateWindow, GetWindowLong, C SetWindowLong, GetHWndQQ - their operation and parameter values are not C really understood! c USE DFLIB USE DFWIN c RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy INTEGER*2 maxx,maxy,linofs,mymode,myrows,mycols,ifc,ifm,ifhb,ifb, * idelta integer*4 dummy4,i character fntnam*30,line*80 COMMON /limits/wxy,maxx,maxy,linofs,curpos,ixy, * mymode,myrows,mycols COMMON /gsets/wc,win,ifc,ifm,ifhb,ifb,idelta type (windowconfig)wc type (qwinfo)win logical status C c...set the principal window parameters, as hardcoded below and c specified in the ASCP.CFG file c wc.numtextcols=80 wc.numtextrows=30 c open(3,file='c:\fft\v6.cfg',status='old',err=12) 7 read(3,'(a)')line if(line(1:1).eq.'!')goto 7 read(line,5)wc.numxpixels read(3,'(a)')line read(line,5)wc.numypixels read(3,'(a)')line fntnam=line(36:65) 5 format(35x,i4) c wc.fontsize=QWIN$EXTENDFONT wc.numcolors=-1 wc.extendfontname=trim(fntnam)//char(0) wc.extendfontsize=-1 c wc.extendfontattributes=0 8 read(3,'(a)')line if(line(1:1).eq.'!')goto 9 read(line,5)iattr if(iattr.lt.1.or.iattr.gt.15)then write(*,10)iattr 10 format(1x//' Extended font attribute from V6.CFG is',i5, * ', which is illegal (1-15 allowed)'// * ' **** TRY AGAIN! *****'//) pause stop endif if(iattr.eq. 1)wc.extendfontattributes=wc.extendfontattributes * +QWIN$EXTENDFONT_NORMAL if(iattr.eq. 2)wc.extendfontattributes=wc.extendfontattributes * +QWIN$EXTENDFONT_UNDERLINE if(iattr.eq. 3)wc.extendfontattributes=wc.extendfontattributes * +QWIN$EXTENDFONT_BOLD if(iattr.eq. 4)wc.extendfontattributes=wc.extendfontattributes * +QWIN$EXTENDFONT_ITALIC c if(iattr.eq. 5)wc.extendfontattributes=wc.extendfontattributes * +QWIN$EXTENDFONT_FIXED_PITCH if(iattr.eq. 6)wc.extendfontattributes=wc.extendfontattributes * +QWIN$EXTENDFONT_VARIABLE_PITCH c if(iattr.eq. 7)wc.extendfontattributes=wc.extendfontattributes * +QWIN$EXTENDFONT_FF_ROMAN if(iattr.eq. 8)wc.extendfontattributes=wc.extendfontattributes * +QWIN$EXTENDFONT_FF_SWISS if(iattr.eq. 9)wc.extendfontattributes=wc.extendfontattributes * +QWIN$EXTENDFONT_FF_MODERN if(iattr.eq.10)wc.extendfontattributes=wc.extendfontattributes * +QWIN$EXTENDFONT_FF_SCRIPT if(iattr.eq.11)wc.extendfontattributes=wc.extendfontattributes * +QWIN$EXTENDFONT_FF_DECORATIVE c if(iattr.eq.12)wc.extendfontattributes=wc.extendfontattributes * +QWIN$EXTENDFONT_ANSI_CHARSET if(iattr.eq.13)wc.extendfontattributes=wc.extendfontattributes * +QWIN$EXTENDFONT_DEFAULT_CHARSET if(iattr.eq.14)wc.extendfontattributes=wc.extendfontattributes * +QWIN$EXTENDFONT_SYMBOL_CHARSET if(iattr.eq.15)wc.extendfontattributes=wc.extendfontattributes * +QWIN$EXTENDFONT_OEM_CHARSET goto 8 c 9 close(3) iconf=1 goto 11 C C...open default sized window for a 800x600 screen if the configuration file C cannot be opened C 12 wc.numxpixels=800 wc.numypixels=540 wc.extendfontname='Courier New' iconf=0 C C...Kill menu C 11 DO I = 7,1,-1 STATUS= DELETEMENUQQ(I, 0) END DO C C...Kill status bar C i = clickqq( QWIN$STATUS ) C C...Kill scroll bars and unwanted features (note that the title seems possible C only on the (killed) daughter window and not on the framewindow C i = GetWindowLong( GetHWndQQ(QWIN$FRAMEWINDOW), GWL_STYLE ) i = ior( iand( i, not(WS_THICKFRAME) ), WS_BORDER ) i = iand( i, not(WS_MAXIMIZEBOX) ) k = SetWindowLong( GetHWndQQ(QWIN$FRAMEWINDOW), GWL_STYLE, i ) C i = GetWindowLong( GetHWndQQ(0), GWL_STYLE ) i = ior(iand( i, not(WS_CAPTION.or.WS_SYSMENU.or.WS_THICKFRAME)), & & WS_BORDER) k = SetWindowLong( GetHWndQQ(0), GWL_STYLE, i ) c c...Position window - for compatibility with small pixel size screens make the c top and left edge of the bounding frame disappear c ifxed= GetSystemMetrics(sm_cxfixedframe) ifyed= GetSystemMetrics(sm_cyfixedframe) win.x = -ifxed win.y = -ifyed c c...Correct sizing parameters to take account of removal of the menu bar and of c the caption area for the child window - these vary with system font size and c are augmented with emprirically established IDELTA fudge parameter C C C W98,ME small fonts: ifc=19 ifm=19 idelta=5 -> sum=43 C W2000, small=100% fonts: ifc=19 ifm=19 idelta=5 -> sum=43 C W2000, large=125% fonts: ifc=24 ifm=24 idelta=4 -> sum=52 C W2000, custom=132% fonts: ifc=25 ifm=25 idelta=3 -> sum=53 C WindowsXP,small fonts: ifc=26 ifm=20 idelta=2 -> sum=48 C C ifc = GetSystemMetrics(sm_cycaption) ifm = GetSystemMetrics(sm_cymenu) ifhb = GetSystemMetrics(sm_cxborder) ifb = GetSystemMetrics(sm_cyborder) c write(*,*)ifc,ifm,ifb,ifhb,ifxed,ifyed c pause c idelta=4 if(ifc.eq.19.and.ifc.eq.19)idelta=5 if(ifc.eq.25.and.ifc.eq.25)idelta=3 if(ifc.ge.26)idelta=2 c win.w = wc.numxpixels-2*ifhb win.h = wc.numypixels-(ifc+ifm+idelta) win.type=qwin$set dummy4 = setwsizeqq(qwin$framewindow,win) status = getwsizeqq(QWIN$FRAMEWINDOW,QWIN$SIZECURR, win) c wc.numtextcols=80 wc.numtextrows=30 wc.title=' 'C c status=setwindowconfig(wc) if(.not.status)status=setwindowconfig(wc) C C...Magical Windows incantations to make style set above real (without C these commands the active window does not expand to the size of the C program framewindow) C i = MoveWindow( GetHWndQQ(0), -1, -1, 0, 0, .TRUE.) call clearscreen($GCLEARSCREEN) status = UpdateWindow(GETHANDLEFRAMEQQ()) c C pixel limits on x and y axes (0,maxx), (0,maxy) c maxx=wc.numxpixels-1 maxy=wc.numypixels-1 myrows=wc.numtextrows mycols=wc.numtextcols linofs=nint(real(maxy)/real(myrows))+1 c return end C c--------------------------------------------------------------------------- c subroutine looksp(nmark,nmark1) c USE DFLIB 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=32768,maxspe=500,maxpts=850,maxsmo=199, * nivols=7,nsect=20,true=.true.) PARAMETER (ntextc=0, ntextb=7, nbordc=15, ncursc=14) c 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, * cursle,cursri,rinter,ssum 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) real*8 freq(maxspe) character fnams(maxspe)*12 real detvol(maxspe,2),volint(maxspe,nivols) integer*2 iseen(maxspe) c common /scans/interf,freq,wmult,ipoint,filarc COMMON /limits/wxy,maxx,maxy,LINOFS,curpos,ixy, * mymode,myrows,mycols 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 dummy4 = setbkcolor( ntextb ) call clearscreen($GCLEARSCREEN) call FFTEXE samfre=1./tstep fnyq=samfre/2. fmax=fnyq*1.E-3 nhalf=0 c 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 C C...definition of graphics viewport in pixel coordinates C call setviewport(2,2*LINOFS-2,maxx-2,maxy-1*LINOFS+1) c c...Find Y-limits c 851 fstart=0.d0 fend=500.d0 fmark=250.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 smaxol=smax SMIN=0 c top=smax+0.10d0*(smax-smin) bottom=smin-0.1D0*(smax-smin) itxt=(mycols-80)/2 c c...definition of graphics window in floating point coordinates to be used c for plotting c c The graphics viewport is assigned to be two pixels narrower on each c side than the screen, and without the number of pixels corresponding c to two lines at the top and one line at the bottom c c...Plot c 699 dummy=setwindow(TRUE,fstart,bottom,fend,top) fincr=(fend-fstart)/maxx c dummy=setcolor(nbordc) dummy4 = setbkcolor( 1 ) call clearscreen($GVIEWPORT) DUMMY2=SETCOLOR( 0 ) CALL moveto_w(fstart,bottom,wxy) dummy=lineto_w(fstart,top) dummy=lineto_w(fend,top) DUMMY2=SETCOLOR( nbordc ) dummy=lineto_w(fend,bottom) dummy=lineto_w(fstart,bottom) nfirst=0 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.top)rspec=top if(rspec.lt.0.d0)rspec=0.d0 CALL moveto_w(fstart,dble(rspec),wxy) endif RSPEC=p(i) IF(RSPEC.gt.top)rspec=top if(rspec.lt.0.d0)rspec=0.d0 dummy=lineto_w(f,RSPEC) 6 CONTINUE c c...marker c 697 dummy=setwritemode($GXOR) DUMMY2=SETCOLOR( ncursc ) CALL setlinestyle(#3333) CALL moveto_w(FMARK,top,wxy) dummy2=lineto_w(FMARK,bottom) dummy=setwritemode($GPSET) CALL setlinestyle(#FFFF) c c...information lines c 771 dummy4=setbkcolor(ntextb) dummy=settextcolor(ntextc) 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'',20X,''Y:'',F9.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) c write(lwork3,822)nfft, smax-smin, fend-fstart 822 format(' n=',i1,F12.2,'<- Y_range X_range ->',f8.2,' kHz', * 22x,'H = help') CALL settextposition(myrows,int2(itxt+1),curpos) call outtext(lwork3(1:79)) DUMMY=SETTEXTCOLOR(12) CALL settextposition(myrows,int2(itxt+56),curpos) CALL outtext(fnams(nmark)) DUMMY=SETTEXTCOLOR(ntextc) 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 C I - display interferogram C N - change the FFT zero-filling parameter c P - show the FFT points c R - return to initial settings 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 Y - ASCII dump of FFT in mV units (only after those have been C defined by a previous peek at the interferogram with I) C 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 - exit back to the 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 C if(kk.eq.'U'.or.kk.eq.'u'.or.kk.eq.'Y'.or.kk.eq.'y')then with U open(7,file='f.dat',status='unknown') with Y 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+''/1H!)') * 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 write(7,'(1H!,50(1H-))') close(7) CALL settextposition(myrows/4,int2(itxt+1)+15,curpos) call outtext( * 'Spectrum from current FFT has been written to F.DAT') endif c IF(IK.NE.13)GOTO 77 C C...exit C 915 continue do 2201 j=1,nrep idata(j)=ioldat(j) 2201 continue return C C...Shift cursor to the left (with K) C 710 dummy=setwritemode($GXOR) DUMMY2=SETCOLOR( ncursc ) CALL setlinestyle(#3333) CALL moveto_w(FMARK,top,wxy) dummy2=lineto_w(FMARK,bottom) fmark=fmark-8.d0*fincr IF(KK.EQ.'k')fmark=fmark+7.d0*fincr IF(fmark.LT.fstart)fmark=fstart C 719 CALL moveto_w(FMARK,top,wxy) dummy2=lineto_w(FMARK,bottom) dummy=setwritemode($GPSET) CALL setlinestyle(#FFFF) GOTO 771 C C...Shift cursor to the right (with L) C 711 dummy=setwritemode($GXOR) DUMMY2=SETCOLOR( ncursc ) CALL setlinestyle(#3333) CALL moveto_w(FMARK,top,wxy) dummy2=lineto_w(FMARK,bottom) 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 dummy=setwritemode($GXOR) DUMMY2=SETCOLOR( ncursc ) CALL setlinestyle(#3333) CALL moveto_w(FMARK,top,wxy) dummy2=lineto_w(FMARK,bottom) 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 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) goto 699 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) 101 FORMAT(1X,A1,$) ENDIF fend=fend-Fchang FMARK=FMARK-Fchang GOTO 699 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) fstart=fend-frange ENDIF FMARK=FMARK+Fchang GOTO 699 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 dummy=setcolor(nbordc) dely= (5.0/maxy)*smax delx=0.75*(5.0/maxx)*(fend-fstart) DO 1301 i=1,Npts if(p(i).gt.top)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(1) CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(lwork3) write(lwork3,'(''pump='',f10.4)')fcent DUMMY=SETTEXTCOLOR(12) CALL settextposition(1,int2(itxt+51),curpos) CALL outtext(lwork3(1:15)) c CALL settextposition(2,int2(itxt+1),curpos) CALL outtext(emplin) DUMMY=SETTEXTCOLOR(ntextc) c DUMMY=SETCOLOR(14) y1=top 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 ypeakl=ypeak 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:',f9.2) DUMMY=SETTEXTCOLOR(1) 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(ntextc) c c...bisection points dely= (5.0/maxy)*smax delx=0.75*(5.0/maxx)*(fend-fstart) 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 C e.g. for Doppler doublets (with =) C Intensity weighted mean of last two measured peaks C e.g. for averaging over unassigned splittings (with -) C 1430 if(kk.eq.'=')then fmin= (flastm+fnewm)*0.5d0 fplus=(flastp+fnewp)*0.5d0 foffs=(flasto+fnewo)*0.5d0 else fmin= (flastm*sqrt(ypeakl)+fnewm*sqrt(ypeak))/ * (sqrt(ypeakl)+sqrt(ypeak)) fplus=(flastp*sqrt(ypeakl)+fnewp*sqrt(ypeak))/ * (sqrt(ypeakl)+sqrt(ypeak)) foffs=(flasto*sqrt(ypeakl)+fnewo*sqrt(ypeak))/ * (sqrt(ypeakl)+sqrt(ypeak)) endif 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(9) CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(lwork3) DUMMY=SETTEXTCOLOR(ntextc) CALL settextposition(2,int2(itxt+1),curpos) CALL outtext(emplin) if(kk.eq.'-')then CALL settextposition(2,int2(itxt+1),curpos) CALL outtext(' intensity weighted') endif 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 rmult=0.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=setcolor(nbordc) dummy4 = setbkcolor( 1 ) dummy=setwindow(TRUE,1.0d0,dble(botlim), * DBLE(nrep),dble(toplim)) call clearscreen($GVIEWPORT) DUMMY2=SETCOLOR( 0 ) CALL moveto_w(1.d0,dble(botlim),wxy) dummy=lineto_w(1.d0,dble(toplim)) dummy=lineto_w(dble(nrep),dble(toplim)) DUMMY2=SETCOLOR( nbordc ) dummy=lineto_w(dble(nrep),dble(botlim)) dummy=lineto_w(1.d0,dble(botlim)) 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) ssum=0.d0 DO 86 I=nskips+1,nrep-nskipe Rinter=DBLE(Idata(I)) dummy=lineto_w(DBLE(I),Rinter) ssum=ssum+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 issum=(nrep-nskipe-nskips-1) if(issum.eq.0)issum=1 ssum=ssum/issum dummy=setcolor(9) CALL moveto_w(dble(nskips+1),ssum,wxy) dummy=lineto_w(dble(nrep-nskipe),ssum) dummy=setcolor(15) c CURSLE=DBLE(NSKIPS) CURSRI=DBLE(NREP-NSKIPE) dummy=setwritemode($GXOR) DUMMY2=SETCOLOR( ncursc ) CALL setlinestyle(#3333) CALL moveto_w(cursle,dble(maxi),wxy) dummy2=lineto_w(cursle,dble(mini)) CALL moveto_w(cursri,dble(maxi),wxy) dummy2=lineto_w(cursri,dble(mini)) dummy=setwritemode($GPSET) CALL setlinestyle(#FFFF) C dummy4=setbkcolor(ntextb) dummy=settextcolor(ntextc) WRITE(LWORK2,'(2A)') * ' A,S <-cursors-> K,L + - B N R U', * ' O H = Help' CALL settextposition(1,int2(itxt+1),curpos) call outtext(lwork2) CALL settextposition(2,int2(itxt+1),curpos) call outtext(emplin(1:79)) write(lwork3,82) (maxi-mini)*vstep*1000,tstep*1.d6, * nint(cursle),nint(cursri), * (nint(cursri)-nint(cursle))*tstep*1.e6 82 format(' Yrange ',f9.2,'mV ',F5.2,'us/pt',14x, * 'in use:',i5,',',i4,' ->',F5.1,'us') CALL settextposition(myrows,int2(itxt+1),curpos) call outtext(lwork3(1:79)) 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 - subtraction of background interferogr. O c - changing subtraction coefficient up/down arrow 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.'H'.OR.KK.EQ.'h')GOTO 1600 IF(KK.EQ.'O'.OR.KK.EQ.'o')GOTO 1700 if(ik.eq.-72.or.ik.eq.-80)goto 1750 IF(KK.EQ.'+'.OR.KK.EQ.'=')CURINC=CURINC*5.0 IF(KK.EQ.'-'.OR.KK.EQ.'_')CURINC=CURINC*0.2 c if(kk.eq.'U'.or.kk.eq.'u')then with U 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,1802) 1802 format('!'/'! used for FFT'/ * '! | excluded'/'! | |'/ * '! Time/us Voltage/mV'/1H!) 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,' * ') write(7,'(1H!,50(1H-))') close(7) CALL settextposition(myrows/4,int2(itxt+1)+15,curpos) call outtext( * 'Current interferogram has been written to T.DAT') 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(1,int2(itxt+1),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 699 ENDIF c C...Shift RIGHT cursor to the left (with K) C 870 dummy=setwritemode($GXOR) DUMMY2=SETCOLOR( ncursc ) CALL setlinestyle(#3333) CALL moveto_w(cursri,dble(maxi),wxy) dummy2=lineto_w(cursri,dble(mini)) CURSRI=CURSRI-8.d0*CURINC IF(KK.EQ.'k')CURSRI=CURSRI+7.d0*CURINC IF(CURSRI.LE.CURSLE)CURSRI=CURSLE+CURINC C 872 CALL moveto_w(cursri,dble(maxi),wxy) dummy2=lineto_w(cursri,dble(mini)) dummy=setwritemode($GPSET) CALL setlinestyle(#FFFF) ICHANG=1 CALL settextposition(myrows,int2(itxt+53),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) GOTO 834 C C...Shift RIGHT cursor to the right (with L) C 875 dummy=setwritemode($GXOR) DUMMY2=SETCOLOR( ncursc ) CALL setlinestyle(#3333) CALL moveto_w(cursri,dble(maxi),wxy) dummy2=lineto_w(cursri,dble(mini)) 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 dummy=setwritemode($GXOR) DUMMY2=SETCOLOR( ncursc ) CALL setlinestyle(#3333) CALL moveto_w(cursle,dble(maxi),wxy) dummy2=lineto_w(cursle,dble(mini)) 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 moveto_w(cursle,dble(maxi),wxy) dummy2=lineto_w(cursle,dble(mini)) dummy=setwritemode($GPSET) CALL setlinestyle(#FFFF) ICHANG=1 CALL settextposition(myrows,int2(itxt+53),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 dummy=setwritemode($GXOR) DUMMY2=SETCOLOR( ncursc ) CALL setlinestyle(#3333) CALL moveto_w(cursle,dble(maxi),wxy) dummy2=lineto_w(cursle,dble(mini)) 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/'_____B A C K G R O U N D S U B T R A C T I O N', * 32(1H_)/// * 5x,'This option is equivalent to a high-pass filter and allows ' * 'removal'/ * 5x'of unwanted low-frequency fluctuations. The baseline is ', * 'defined '/ * 5x,'by triple least-squares smoothing.'// * 5x,'If the decay rate is also to be modified this should be ', * 'done only'/5x, * 'after background subtraction on the original interferogram.'/// * 5x,'Number of points in the interferogram ',18(1h.),i5/5x, * 'Number of points (>3 and odd) in smoothing interval .... ',$) READ(*,'(i5)',ERR=1100)NSPT IF(NSPT.LE.3.OR.NSPT.GT.maxsmo)GOTO 1100 IF((NSPT/2)*2.EQ.NSPT)GOTO 1100 WRITE(*,'(1X//'' S U B T R A C T I N G''//)') C do 1103 j=1,nrep ioldat(j)=idata(j) 1103 continue 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,nhalf 1502 FORMAT(1x/'_____MODIFY APPARENT RELAXATION TIME',44(1H_)/// * 5x,'This option multiplies the interferogram by an additional', * ' exponential'/ * 5x,'decay factor. Its decay half-time is to be specified as', * ' the number'/5x,'of interferogram points:'// * 5x,'- positive values amplify the interferogram tail, improving', * ' resolution,'/ * 5x,'- negative values attenuate the interferogram tail, ' * 'improving S/N.'/ * 5x,'- zero uses the original intrerferogram'/// * 12x,'Number of points in the interferogram ...',i5/ * 12x,'Number of points for halfdecay ..........',i5// * 12x,'New halfdecay points .................... ',$) READ(*,'(i5)',ERR=1500)N IF(N.eq.0)then nhalf=0 GOTO 1200 ENDIF IF(N.LE.10.AND.N.GE.-10)GOTO 1500 NHALF=N 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 (with R) c 1200 do 1201 j=1,nrep idata(j)=interf(nmark1,j) c idata(j)=ioldat(j) 1201 continue ichang=1 goto 831 C C...display the interferogram help screen (with H) C 1600 dummy4=setbkcolor(ntextb) DUMmy2=settextcolor(ntextc) CALL clearscreen($GCLEARSCREEN) WRITE(*,1601) 1601 FORMAT(1x/'_____S I N G L E ', * ' I N T E R F E R O G R A M screen commands',20(1H_)/// * ' A/S - move lefthand cutoff cursor'/ * ' K/L - move righthand cutoff cursor'/ * ' caps on/off - fast/slow change in the above'/ * ' +/- - increase/decrease cursor step'// * ' B - background subtraction'/ * ' N - decay rate modification'/ * ' R - restore original interferogram'/ * ' U - ASCII dump of current interferogram'/ * ' O - subtraction of background interferogram'/ * ' up/dwn arrow - change coefficient for interferogram', * ' subtraction' //) WRITE(*,1602) 1602 FORMAT(17X, * 'Press ENTER to exit this HELP screen ',$) 1603 IK=INKEY(J) IF(IK.NE.13)GOTO 1603 CALL clearscreen($GCLEARSCREEN) GOTO 831 C C...subtraction of background interferogram (with O) C 1700 CALL clearscreen($GCLEARSCREEN) 1701 WRITE(*,1702) 1702 FORMAT(1x/'_____B A C K G R O U N D ', * 'I N T E R F E R O G R A M subtraction',14(1H_)/// * 5x,'The background interferogram is to be specified by a number', * ' defining '/ * 5x,'its position relative to the current interferogram'// * 5x,'..... ',$) read(*,'(i5)',err=1700)nbint if(nbint.eq.0)goto 1700 if(nmark+nbint.lt.0)goto 1700 if(nmark+nbint.gt.nscans)goto 1700 c nbint=ipoint(nmark+nbint) rmult=1.0 1704 do 1703 j=1,nrep idata(j)=interf(nmark1,j)-rmult*interf(nbint,j) 1703 continue c ichang=1 goto 831 C C...change scaling for background interferogram subtraction c (with up/down arrows) C 1750 if(ik.eq.-72)rmult=rmult*1.02 if(ik.eq.-80)rmult=rmult*0.980392 goto 1704 C c . . . . . . . . . . . . . . . . . . . . . . . . c c...display the help screen (with H) c 840 dummy4=setbkcolor(ntextb) DUMmy2=settextcolor(ntextc) CALL clearscreen($GCLEARSCREEN) WRITE(*,232) 232 FORMAT(1x/'_____F F T screen commands',53(1H_)/// * ' 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/modify the interferogram'/ * ' T - toggle between Power and Amplitude spectra'/ * ' N - change FFT zero filling parameter n'/ * ' P - show the FFT points'/ * ' R - rescale spectrum to initial conditions'/ * 10x,'U,Y - ASCII dump of current FFT: U is for standard FFT,'/ * 17x,'Y produces output scaled to mV range of interferogram'/ * 17x,'(use option Y only after having used option I)'/ * ' - exit back to previous screen'// * ' 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'/ * ' - - intensity weighted mean frequency of last ', * 'two measured peaks'//) WRITE(*,106) 106 FORMAT(17X, * 'Press ENTER to exit this HELP screen ',$) 107 IK=INKEY(J) IF(IK.NE.13)GOTO 107 CALL clearscreen($GCLEARSCREEN) GOTO 699 c c...change FFT zero filling parameter n (with N) c 850 CALL clearscreen($GCLEARSCREEN) call FFTEXE GOTO 851 c return end c C------------------------------------------------------------------------ c subroutine inpout(ioper,filnam,iexit,dirnam,ntsys) 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 IEXIT = setting this to 1 on output requests termination by the M/P c DIRNAM = returns the name of the current directory on exit c USE DFLIB c logical*4 fsys parameter (maxarc=54,maxspe=500,maxpts=850,nivols=7) PARAMETER (ntextc=0, ntextb=7) character line*80,filnam*30,fnams(maxspe)*12,filarc*30 character cdummy*18,cdum*2,outa*12,outb*12,dirnam*50 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,wmult,iwk,filarc common /scans2/detvol,volint,iseen,nscans common /sfiles/fnams C C C...determine the presence of FFT archives (with extension .FAR) C C this is done by means of a directory listing - note that default listing C format differs between W95/98 and NT/2000, and there are also small C differences between language versions. C C The DIR keyword -N enforces in W2000 the old 8.3 form of listing, but C it is an illegal option in W95/98 C ntsys=0 fsys=systemqq('ver>far.lst') open (2,file='far.lst',status='old') read(2,'(a)',end=9)line read(2,'(a)',end=9)line if(line(1:1).eq.'M')ntsys=1 close(2) c iexit=0 write(*,'(1x/)') if(ntsys.eq.1)then fsys=systemqq('dir *.far/On/-N>far.lst') else fsys=systemqq('dir *.far/On>far.lst') endif 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 c...skip top four lines and determine directory name from the fifth line c do 150 i=1,4 read(2,'(a)',end=9)line 150 continue i=len_trim(line) if(line(2:9).eq.'Katalog ')then dirnam=line(10:i) endif if(line(2:9).eq.'Katalog:')then dirnam=line(11:i) endif if(line(2:14).eq.'Directory of ')dirnam=line(15:i) read(2,'(a)',end=9)line c narch=0 7 read(2,'(a)',end=9)line if(line(10:12).ne.'FAR'.and.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 c if(narch.eq.maxarc)then dummy4=setbkcolor(12) DUMmy2=settextcolor(15) write(*,'(1x//'' ***** Too many archives - the program is '', * ''only dimensioned up to'',i5//)')maxarc dummy4=setbkcolor(ntextb) DUMmy2=settextcolor(ntextc) stop endif fnams(narch)=line(1:i)//'.'//line(10:12) goto 7 c 9 close(2) fsys=systemqq('del far.lst') c c...options c 19 if(narch.eq.0)then write(*,100) 100 format(1x// * ' ----> The directory '$) DUMmy2=settextcolor(12) write(*,'(a)')dirnam(1:len_trim(dirnam)) DUMmy2=settextcolor(ntextc) write(*,'('' contains NO FFT archive files - '', * ''attempting to use the LIST.DAT file'')') 101 ioper=0 return else i=len_trim(dirnam) DUMmy2=settextcolor(12) write(*,'(1x,a,$)')dirnam(1:i) DUMmy2=settextcolor(ntextc) write(*,15)narch 15 format(' contains',i3,' FFT archive(s):'/40(1H )) 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 c...single column 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 c...two column c if(narch.le.36.and.narch.ge.10)then j=narch/2 c do 112 k=1,j line by line 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 c if(2*(narch/2).ne.narch)then last odd file 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 c 117 format(4x,i2,' = ',a,a, 12x,i2,' = ',a,a) 118 format(45x, i2,' = ',a,a) endif c c...three column c if(narch.gt.36.and.narch.le.maxarc)then j=narch/3 c do 120 k=1,j i=iwk(k) ipj=iwk(k+j) iipj=iwk(k+2*j) write(*,121)k,fnams(i),k+j,fnams(ipj),k+2*j,fnams(iipj) 120 continue c if(narch-j*3.eq.1)then i=iwk(narch) write(*,122)narch,fnams(i) endif c if(narch-j*3.eq.2)then i=iwk(narch-1) write(*,122)narch-1,fnams(i) i=iwk(narch) write(*,122)narch,fnams(i) endif c 121 format(5x, i2,' = ',a,2(10x,i2,' = ',a)) 122 format(59x,i2,' = ',a) endif c 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 goto 19 c return end c C_____________________________________________________________________________ c subroutine inpspe(nfil,ntsys) c c Routine to set up a list of files available for input as spectra c c USE DFLIB c logical*4 fsys parameter (maxspe=500) PARAMETER (ntextc=0, ntextb=7) character line*80,fnams(maxspe)*12 common /sfiles/fnams c c c...save the current directory to file c write(*,'(1x/)') if(ntsys.eq.1)then fsys=systemqq('dir /Od/-N>spec.lst') else fsys=systemqq('dir /Od>spec.lst') endif 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 do 150 i=1,5 read(2,'(a)',end=9)line 150 continue c nfil=0 c 7 read(2,'(a)',end=9)line c 21 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'.or.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 dummy4=setbkcolor(12) DUMmy2=settextcolor(15) write(*,'(1x//'' ***** The current limit of'',i3, * '' on the number of files has been reached''/ * '' ***** NO MORE WILL BE READ IN''/)') * maxspe dummy4=setbkcolor(ntextb) DUMmy2=settextcolor(ntextc) goto 9 endif goto 7 9 close(2) fsys=systemqq('del spec.lst') 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=32768,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 ifromi=i IF(NPTS.LE.32768)NMAX=32768 IF(NPTS.LE.16384)NMAX=16384 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)mulzer,ifromi,npts,npts*2**mulzer 56 FORMAT(1x/'_____C H A N G E F F T Z E R O F I L L I N G', * 30(1H_)/// * 5x,'The last FFT was performed using filling parameter n=',i1, * ' and:'// * i7,' data points from the interferogram, first filled-up to'/ * i7,' points (= Npts), and then to a total of'/ * i7,' points by replicating the last data point.'/) 31 if(NCALL.ne.1)then 33 write(*,30) 30 format(1x/5x,'Specify new value of the filling parameter n ', * 'defined by'/ * 5x,'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 775 format(1x/' ERROR:',i8,' points needed for FFT but only ', * i6,' dimensioned'// * ' -----> 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=32768) 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=32768) 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=32768,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,wmult,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=32768,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=iabs(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) 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 USE DFLIB c INTEGER*2 IK CHARACTER*1 KK c KK=GETCHARQQ() IK=ICHAR(KK) IF(IK.EQ.0 .OR. IK.EQ.224 ) THEN KK=GETCHARQQ() IK=-ICHAR(KK) ENDIF n2=ik INKEY=IK END C_____________________________________________________________________________ C_____________________________________________________________________________ c c readsp To read a spectral file c summar To display summary information on acquired spectra c marsca To plot and label the frequency marker scale c intcom To compare nine interferograms per screen c startgr To initialise graphics c looksp Main graphics screen c inpout To determine whether .FAR archives are available and c how to input spectra c inpspe To set up a list of files available for input as spectra c FFTEXE To set up the FFT calculation c spectrm Power spectrum estimation c four1 FFT routine c PF Peak meaurement c SORTH For sorting input spectra in frequency c baksub Background subtraction C_____________________________________________________________________________