C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C VKIEL - Viewer for KIEL FTMW spectra C - ---- C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c This program allows viewing of multiple spectra contained in a given c directory and recorded in the KIEL FTMW standard : c c c c Interdependence of displays: c c SUMMAR-----LOOKSP c | c --------INTCOM------LOOKSP c c where: SUMMAR - summary screen of 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 programs VIEW, V32 c and VIEWM (V6) c C Ver 29b.XII.2003 ---- 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 29.12.03: creation from V6 of 28.10.03 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 vkiel.for C C Optimised compilation for any PENTIUM: C C df -nodebug -traceback -arch=pn1 -tune=pn1 C -fast -static -libs=qwin -fpscomp:filesfromcmd vkiel.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/vkiel.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/ Call the program from the command line set to the directory containing C the data, assuming the PATH leads to the directory containing VKIEL.EXE C 2/ Launch the program from an icon on the desktop C 3/ Launch the program from any file manager C C Only method 1/ assures that the program will operate directly on the C directory of choice. In methods 2/ and 3/ the starting directory depends C on the operating system and previous usage. It maight be necessary C to navigate to the directory with spectra using the SelectFile window. 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=1000,maxpts=4096,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 mxnrep=0 mnnrep=maxpts c call startg(iconf) dummy4=passdirkeysqq(.true.) c C...HEADER C numfonts = INITIALIZEFONTS ( ) 557 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('VKIEL -') dummy=setcolor(9) CALL MOVETO (INT2(nhor+1), INT2(nvert+1), ixy) CALL OUTGTEXT('VKIEL -') dummy=setcolor(1) CALL MOVETO (INT2(nhor+2), INT2(nvert+2), ixy) CALL OUTGTEXT('VKIEL -') c dummy=setcolor(11) fontnum = SETFONT ('t''Arial''h60w20ei') CALL MOVETO (INT2(nhor+220), INT2(nvert+11), ixy) CALL OUTGTEXT('Viewer for Kiel FTMW') dummy=setcolor(9) CALL MOVETO (INT2(nhor+220+1), INT2(nvert+11+1), ixy) CALL OUTGTEXT('Viewer for Kiel FTMW') dummy=setcolor(1) CALL MOVETO (INT2(nhor+220+2), INT2(nvert+11+2), ixy) CALL OUTGTEXT('Viewer for Kiel FTMW') 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 29b.XII.2003') 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 29b.XII.2003') 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\VKIEL.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 556 call inpout(iexit,dirnam,ntsys) if(iexit.eq.1)then dum2=setexitqq(qwin$exitnopersist) stop endif iarch=0 VKIEL filnam=' ' VKIEL c c- - - - - - IARCH=0 - read individual spectral files - - - - - - - - - - - - c c either as found in current directory or as listed in c a listing file (from FILMAN, SVIEW, FFTLIST) c c...read LIST.DAT until EOF, errors in input skip the line in question so that c comment lines are allowed, but best be initiated with some nonnumeric c symbol such as $ or ! c if(iarch.eq.0)then goto 555 VKIEL only 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 555 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''//8x, * ''Press ENTER to continue '',$)') read(*,'(i5)',err=557)n goto 557 endif c mxnrep=0 nscans=1 do 1006 n=1,nfil filnam=fnams(n) call readspk(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''//8x, * ''Press ENTER to continue '',$)') read(*,'(i5)',err=557)n goto 557 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 readspk(iarch,n,filnam,iread) ISEEN(N)=15 nreps(n)=nrep nskip(n)=nskips nskip1(n)=nskipe tsteps(n)=tstep vsteps(n)=vstep nave(n)=naver if(nrep.gt.mxnrep)mxnrep=nrep 5 continue nrep=mxnrep c c...SORT interferograms in frequency c 1105 if(nscans.gt.1)CALL SORTH c endif c c- - - - - - IARCH=1 - read files from spectral archive - - - - - - - - - - - c if(iarch.eq.1)then iarcht=1 open(3,file=filarc,form='binary',status='old') c 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 readspk(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,dirnam) c stop end c c--------------------------------------------------------------------------- c subroutine readspk(iarch,nspe,filnam,iread) c c*** NOTE: For KIEL spectra IARCH=0 is the only legal option 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=1000,maxpts=4096) PARAMETER (ntextc=0, ntextb=7) c character txblock*256 integer*2 kp(32) real*8 rp(24) c real*8 fcent,freq(maxspe) character timdat*20,coment*50,sample*20 cc character INTEXT*30 character filnam*30,cdummy*6,filarc*30 character comnt(maxspe)*50,sampl(maxspe)*20,timd(maxspe)*20 integer interf(maxspe,maxpts),idata(maxpts),idummy integer*2 ipoint(maxspe) common /scans/interf,freq,wmult,ipoint,filarc common /scans1/idata,vstep,tstep,nrep,nskips,nskipe,naver COMMON /SCTEXT/COMNT,SAMPL,TIMD c iread=1 if(iarch.eq.0)then write(*,'(4x,a12,$)')filnam(1:12) OPEN(3,FILE=FILNAM,FORM='BINARY',ERR=503,STATUS='OLD') else read(3,end=510)cdummy,filnam(1:12),cdummy write(*,'(4x,a12,$)')filnam(1:12) endif C cc READ(3,end=510)sample cc READ(3,end=510)intext(1:27) cc READ(intext,'(3i5,f12.5)',err=510)nrep,nskips,nskipe,fcent cc if(nrep.lt.50)goto 510 cc if(fcent.lt.500.or.fcent.gt.41000.)goto 510 cc READ(3)intext(1:27) cc READ(intext,'(1pe10.3,e10.3,i7)',err=510)tstep,vstep,naver cc READ(3,end=510)coment,timdat c read(3,err=510,end=510)txblock if(txblock(1:10).ne.' @ SYS 5 @')goto 510 read(3,err=510,end=510)kp read(3,err=510,end=510)rp c COMENT=txblock(1:30) SAMPLE=txblock(57:76) TIMDAT=txblock(31:40)//' '// * txblock(41:42)//':'//txblock(43:44)//':'//txblock(45:46) C nrep=kp(5) if(nrep.lt.50)goto 510 naver=kp(3) fcent=rp(1) if(fcent.lt.500.or.fcent.gt.41000.)goto 510 nskips=0 nskipe=5 if(txblock(11:16).eq.'FTMW2.')then vstep=1.d-9 else vstep=1.d-6 endif tstep=real(kp(1))*1.d-9 c IF(IARCH.EQ.1)NSPE=NSPE+1 freq(nspe)=fcent COMNT(NSPE)=COMENT timd(nspe)=TIMDAT sampl(nspe)=SAMPLE C c...Intensities of spectral data points c DO 20 N=1,Nrep if(n.le.maxpts)then READ(3,end=510)interf(nspe,n) else read(3,end=510)idummy endif 20 CONTINUE if(nrep.gt.maxpts)then iread=2 nskipe=nskipe-(nrep-maxpts) if(nskipe.lt.1)nskipe=1 nrep=maxpts if(nrep-nskips-nskipe.le.5)then nskipe=5 nskips=5 endif endif C if(iarch.eq.0)CLOSE(3) goto 501 c 503 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,dirnam) 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 ALL INTERFEROGRAMS SINGLE INTERFEROGRAM C c INTERF(1..NSCANS, ) -> idata(1..NREP) c NREPS() -> NREP c NSKIP() -> NSKIPS c NSKIP1() -> NSKIPE c TSTEPS() -> TSTEP (s) c VSTEPS() -> VSTEP (V) c FREQ() -> FCENT (MHz) c c Frequency domain points from FFT are contained in P(1..NPTS), c spaced FSTEP kHz in frequency. The first point is at FCENT-FIF 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,powamp,dirnam*50 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 real*8 FIF,FIFkhz parameter (maxspe=1000,maxpts=4096,nivols=7,nmaxpt=65536, * vrange=50.0,drange=400.,true=.true.) PARAMETER (ntextc=0, ntextb=7, nbordc=15, ncursc=14) PARAMETER ( FIF=30.d0,FIFkhz=FIF*1000.d0,maxsyn=1000000) c character fnams(maxspe)*12,filarc*30 real detvol(maxspe,2),volint(maxspe,nivols),p(nmaxpt) integer interf(maxspe,maxpts),idata(maxpts),nave(maxspe) integer*2 iseen(maxspe),ipoint(maxspe) real*8 freq(maxspe),fstep,df,bw,fs_st,fs_en,synspe(maxsyn),fstepm, * x0,x1,x2,cl0,cl1,cl2 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 common /specf/p,fstep,npts,NFFT,NCALL c if(powamp.ne.'P'.and.powamp.ne.'A')powamp='P' if(nsfft.ge.0)nsfft=-4 ncall=1 if(bw.eq.0.d0)bw=1.5d0 if(df.eq.0.d0)df=0.01d0 fs_st=freq(1)-0.5d0*BW fs_en=freq(nscans)+0.5d0*BW c if(natt.eq.0)then nn=0 do 510 n=1,nscans if(nreps(n).gt.nn)nn=nreps(n) 510 continue natt=-real(nn)/3.d0 endif c if(idispl.ne.-1)idispl=-1 c nmark=nscans/2+1 fmark=freq(nmark) c volt=0.0 n=nivols/2+1 DO 201 I=1,nscans if(volt.lt.volint(i,n))VOLT=VOLINT(I,N) 201 CONTINUE wmult=volt/(vrange*0.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(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 endif c c...plot fringe voltages c dummy=setcolor(ntextb) detscl=WRANGE/drange do 105 n=1,2 rint=-detvol(1,n)*detscl+0.1*detscl if(rint.gt.wrange)rint=wrange CALL moveto_w(freq(1),rint,wxy) DO 106 I=1,nscans rint=-detvol(i,n)*detscl+0.1*detscl if(rint.gt.wrange)RINT=WRANGE dummy=lineto_w(freq(I),rint) 106 CONTINUE 105 continue dummy=setcolor(15) C C...marker scale C yshift=wmin call marsca(fstart,fend,0.0d0,0.0d0) 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 U - generate spectrum from loaded interferograms c P - toggle display style c R - restore initial scaling c - quick exit from program c 77 IK=INKEY(N) KK=CHAR(IK) c c...terminate program, (with ESC) c if(iK.eq.27)then dummy=setexitqq(qwin$exitnopersist) stop endif c c...exit to individual interferogram and its FFT (with O) c if(KK.eq.'O'.or.kk.eq.'o')then nmark1=ipoint(nmark) 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) 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,' U - generate synthetic spectrum'/ * 9x,' P - toggle spectrum <-> histogram display style'/ * 9x,' R - restore initial settings'// * 9x,' I - go the INTERFEROGRAMS screen'/ * 9x,' O - go to the spectrum under the cursor'// * 9x,' - (followed by Y) exit from the program'/ * 9x,' - quick exit from the program'/// * 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 . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c...Generate synthetic spectrum from loaded interferograms c if(KK.eq.'U'.or.KK.eq.'u')then c c...menu c dummy4=setbkcolor(ntextb) DUMmy2=settextcolor(ntextc) dummy=displaycursor($gcursoron) 59 CALL clearscreen($GCLEARSCREEN) c nsypt=1.d0+(fs_en-fs_st)/df WRITE(*,233) 233 FORMAT(1x/'_____S y n t h e t i c S p e c t r u m',40(1H_)//) WRITE(*,57)df,nsypt,natt,iabs(nsfft),powamp,bw 57 FORMAT(1x/ * ' 1: Synthetic point spacing (MHz) = ',F11.4,T60, * '(',i7' pts)'/ * ' 2: Decay attenuation (-ve) = ',I6/ * ' 3: n for FFT = ',I6/ * ' 4: Power/Amplitude = ',5x,a/ * ' 5: Coaddition width (MHz) = ',f11.4/ * ' 6: SYNTHESISE'// * ' Select 1-6 (ENTER=Exit) ..... ',$) C C READ(*,'(I2)',err=59)I if(i.lt.0.or.i.gt.6)goto 59 c if(i.eq.1)then write(*,'(1x// * '' New point spacing for spectrum (MHz) = '',$)') read(*,'(F20.10)',err=59)freqv if(freqv.le.0.d0)goto 59 n=1.d0+(fs_en-fs_st)/freqv if(n.lt.10.or.n.gt.maxsyn)goto 59 df=freqv goto 59 endif c if(i.eq.2)then write(*,511) 511 format(1x//5x, * 'Interferograms can be multiplied by a decaying exponential ', * 'function to'/5x,'limit the effects of noise.'//5x, * 'The (-ve) decay constant for the exponential is to be ', * 'expressed as'/5x, * 'the number of interferogram points and the ', * 'default setting is a third'/5x, * 'of average interferogram length.'//5x, * 'New time-domain attenuation parameter = ',$) read(*,'(i10)',err=59)n if(n.ne.0.and.n.ge.-10)goto 59 natt=n goto 59 endif c if(i.eq.3)then write(*,'(1x// * '' New n for FFT (1...5) = '',$)') read(*,'(i10)',err=59)n if(n.lt.1.or.n.gt.5)goto 59 nsfft=-n goto 59 endif c if(i.eq.4)then if(powamp.eq.'P')then powamp='A' else powamp='P' endif goto 59 endif c if(i.eq.5)then write(*,'(1x// * '' New Coaddition (full) bandwidth (MHz) = '',$)') read(*,'(F20.10)',err=59)freqv if(freqv.le.0.01d0.or.freqv.gt.1000.d0)goto 59 bw=freqv fs_st=freq(1)-0.5d0*BW fs_en=freq(nscans)+0.5d0*BW goto 59 endif c c...spectrum c if(i.eq.6)then dummy=displaycursor($gcursoroff) do 500 n=1,nsypt synspe(n)=0.d0 500 continue c write(*,'(1x/)') do 501 n=1,nscans c write(*,'(i5,$)')n fcent=freq(n) jj=ipoint(n) nrep=nreps(jj) nskips=nskip(jj) nskipe=nskip1(jj) tstep=tsteps(jj) vstep=vsteps(jj) do 503 nn=1,nrep idata(nn)=interf(jj,nn) 503 continue c if(natt.lt.0)then do 506 j=1,nrep freqv=DBLE(J)/DBLE(Natt) if(dabs(freqv).gt.10)freqv=dsign(10.d0,freqv) idata(j)=iDATA(j)*DEXP(freqv) 506 continue endif c nfft=nsfft CALL FFTEXE fstepm=fstep*0.001d0 c if(powamp.eq.'A')then do 507 j=1,npts if(p(j).ne.0.d0)p(j)=sqrt(p(j)) 507 continue endif c c Number of synthetic point for frequency f: ns=1+(f-fs_st)/df c Frequency of synthetic point ns: f=fs_st+(ns-1)*df c Frequency of point in P: f=(fcent-FIF)+(n-1)*fstepm c Number of point in P for frequency f: np=1+(f-fcent+FIF)/fstepm c c NST,NEN are frequency limits in the synthetic spectrum to be updated c from the current spectrum in P. Intensity values from P are c derived by interpolation c c nst=(fcent-bw*0.5d0-fs_st)/df nen=(fcent+bw*0.5d0-fs_st)/df do 502 nn=nst,nen freqv=fs_st+(nn-1)*df ip=NINT(1.d0+(freqv-fcent+FIF)/fstepm) fp=(fcent-FIF)+(ip-1)*fstepm c c Linear interp. c if(ip.lt.npts)then c synspe(nn)=synspe(nn)+p(ip)+ c * (freqv-fp)*(p(ip+1)-p(ip))/fstepm c endif c c Quadratic interp. if(ip.lt.npts.and.ip.gt.1)then x0=fp-fstepm x1=fp x2=fp+fstepm CL0=(freqv-x1)*(freqv-x2)/((x0-x1)*(x0-x2)) CL1=(freqv-x0)*(freqv-x2)/((x1-x0)*(x1-x2)) CL2=(freqv-x0)*(freqv-x1)/((x2-x0)*(x2-x1)) synspe(nn)=synspe(nn)+CL0*P(ip-1)+CL1*P(ip)+CL2*P(ip+1) endif 502 continue c 501 continue c c...output c open(8,file='vkiel.out',status='unknown') write(8,509)df,natt,iabs(nsfft),powamp,bw 509 format('VKIEL SYNTHESIS: fstep=',F4.3,'MHz decay=',i4, * ' n=',i1,2x,A1,' FBW=',f4.2,'MHz') freqv=fs_st-df do 508 n=1,nsypt freqv=freqv+df write(8,512)freqv,synspe(n) 512 format(f10.4,1PE12.4) 508 continue close(8) c write(*,'(1x//5x,''Output has been written to:'' * /14x,'' '',$)') dummy=settextcolor(12) write(*,'(a)')dirnam(1:len_trim(dirnam))//'\vkiel.out' dummy=settextcolor(ntextc) WRITE(*,'(5x,''which can be further processed with SVIEW.''/// * 5x,''Press ENTER to continue '',$)') 200 ik=inkey(ik) if(ik.ne.13)goto 200 c dummy=displaycursor($gcursoron) goto 59 endif c C...return to main display c dummy=displaycursor($gcursoroff) CALL clearscreen($GCLEARSCREEN) CALL settextposition(8,int2(itxt+1),curpos) call outtext(emplin) GOTO 178 c endif c 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,FCENT,FIF) c subroutine marsca(f1,f2) c c Routine to plot and label the marker scale for frequency limits F1 - move to beginning/end of spectra c D,F - alternative keys to / c W,Z - change vertical scaling c 1-9 - goto displayed spectrum 1-9 c F1-F9 - display parameters of spectrum 1-9 c , - go back to previous screen c 77 IK=INKEY(N) KK=CHAR(IK) c c...terminate program (with Q) c if(KK.eq.'Q'.or.kk.eq.'q')then DUMMY= 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,' ENTER, - exit to the SUMMARY screen'/ * 9x,' Q - exit 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 IF(IK.NE.13.AND.IK.NE.27)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 VKIEL.CFG file c wc.numtextcols=80 wc.numtextrows=30 c open(3,file='c:\fft\vkiel.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 VKIEL.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 NOTE: actual frequency scale for these plots (and the data) are in C kHz going from 0 to 50000. All annotations are recalculated on C the basis of the assumed intermediate frequency 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 FIF = intermediate frequency (MHz) correponding to f-f_pump=0 c logical*2 true real*8 FIF,FIFkhz PARAMETER (Nmaxpt=65536,maxspe=1000,maxpts=4096,maxsmo=199, * nivols=7,nsect=20,true=.true., * FIF=30.d0,FIFkhz=FIF*1000.d0) 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,powamp character*80 emplin,lwork1,lwork2,lwork3 integer interf(maxspe,maxpts) real*8 freq(maxspe),YYSTEP,RRSMAL,YSHIFT,F1,F2 character fnams(maxspe)*12,filu*16 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 COMMON /plotda/bottom,top,RRSMAL,YYSTEP,YSHIFT c powamp='P' do 100 i=1,nrep idata(i)=interf(nmark1,i) 100 continue fcent=freq(nmark) c c c...preserve a copy of the interferogram in IOLDAT c do 1099 j=1,nrep ioldat(j)=idata(j) 1099 continue c c...apply the default decay correction c nhalf=-real(nrep)/3.d0 do 1507 j=1,nrep f=DBLE(J)/DBLE(NHALF) if(dabs(f).gt.10)f=dsign(10.d0,f) idata(j)=iDATA(j)*DEXP(f) 1507 continue c ncall=0 dummy4 = setbkcolor( ntextb ) call clearscreen($GCLEARSCREEN) call FFTEXE samfre=1./tstep fnyq=samfre/2. fmax=fnyq*1.E-3 c htcut=0.5 CURINC=1.0 WRITE(emplin,'(80(1H ))') 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-2*LINOFS+2) c c...Find Y-limits c 851 fmark= FIF*1000.d0 fstart=fmark-5000.d0 fend= fmark+5000.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) YYSTEP=1.d0/500.d0*(top-bottom) RRSMAL=bottom-13.d0*YYSTEP 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,RRSMAL,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 scale C 697 yshift=bottom f1=fcent+fstart*0.001d0-FIF f2=fcent+ fend *0.001D0-FIF c call marsca(f1,f2) call marsca(f1,f2,fcent,FIF) c c...f-f_pump=0 marker (if within display range) c if(FIFkhz.gt.fstart.and.FIFkhz.lt.FEND)then DUMMY2=SETCOLOR( 11 ) F1=bottom+(top-bottom)*0.1d0 CALL moveto_w(FIFkhz,F1,wxy) dummy2=lineto_w(FIFkhz,bottom) dummy2=lineto_w(FIFkhz+5.d0*fincr,RRSMAL) dummy2=lineto_w(FIFkhz-5.d0*fincr,RRSMAL) dummy2=lineto_w(FIFkhz,bottom) endif c c...cursor c 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-f.p='',F8.4,'', f='',F10.4, * '' MHz'',18X,''Y:'',F11.2)')fmark,fmark*0.001d0-FIF, * FPLUS-FIF,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,powamp, smax-smin, fend-fstart 822 format(' n=',i1,a1,F13.2,'<- Y_range X_range ->',f8.2,' kHz', * 20x,'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 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 T - convert between power and amplitude spectra 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 - quick exit to calling routine c 77 IK=INKEY(N) KK=CHAR(IK) c IF(KK.EQ.'K'.OR.KK.EQ.'k')GOTO 710 IF(KK.EQ.'L'.OR.KK.EQ.'l')GOTO 711 IF(KK.EQ.',')GOTO 750 IF(KK.EQ.'Q'.OR.KK.EQ.'q')GOTO 721 IF(KK.EQ.'E'.OR.KK.EQ.'e')GOTO 720 IF(KK.EQ.'R'.OR.KK.EQ.'r')GOTO 730 IF(KK.EQ.'A'.OR.KK.EQ.'a')GOTO 740 IF(KK.EQ.'S'.OR.KK.EQ.'s')GOTO 760 IF(KK.EQ.'Z'.OR.KK.EQ.'z')GOTO 810 IF(KK.EQ.'W'.OR.KK.EQ.'w')GOTO 820 IF(KK.EQ.'I'.OR.KK.EQ.'i')GOTO 830 IF(KK.EQ.'H'.OR.KK.EQ.'h')GOTO 840 IF(KK.EQ.'N'.OR.KK.EQ.'n')GOTO 850 IF(KK.EQ.'P'.OR.KK.EQ.'p')GOTO 1300 IF(KK.EQ.'O'.OR.KK.EQ.'o')GOTO 1400 IF(KK.EQ.'0'.OR.KK.EQ.')')GOTO 1450 IF(KK.EQ.'9'.OR.KK.EQ.'(')GOTO 1440 IF(KK.EQ.'='.OR.KK.EQ.'-')GOTO 1430 if(IK.eq.27)goto 915 c if(kk.eq.'T'.or.KK.eq.'t')then (with T) if(powamp.eq.'P')then powamp='A' do 854 j=1,npts if(p(j).ne.0.d0)p(j)=sqrt(p(j)) 854 continue else powamp='P' do 855 j=1,npts p(j)=p(j)*p(j) 855 continue endif goto 851 endif c if(kk.eq.'U'.or.kk.eq.'u'.or.kk.eq.'Y'.or.kk.eq.'y')then (with U) filu=fnams(nmark)(1:len_trim(fnams(nmark)))//'.fre' open(7,file=filu,status='unknown') (with Y) C if(powamp.eq.'P')then write(7,1805)'! Power',fnams(nmark) write(7,1801)fcent,smax,' Power' else write(7,1805)'! Amplitude',fnams(nmark) write(7,1801)fcent,smax,'Amplitude' endif 1805 format(a,' FFT of interferogram from: ',a/ * 1H!/1H!,50(1H-)/1H!) 1801 format('! Pump frequency =',f15.6/ * '! Display maximum =',f15.6/1H!/ * '! Frequency ',a/1H!) c 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 c DO 3 I=1,npts f=(i-1)*fstep if(f.lt.fstart)goto 3 if(f.gt.fend)goto 33 f=fcent+f*0.001D0-FIF write(7,'(f11.4,1pe12.4)')f,p(i)*pmult 3 CONTINUE 33 write(7,'(1H!,50(1H-))') close(7) c dummy4=setbkcolor(ntextb) DUMmy2=settextcolor(ntextc) CALL clearscreen($GCLEARSCREEN) WRITE(*,1806) 1806 FORMAT(1x/'_____A S C I I output',58(1H_)//// * ' Data has been written to file: ',$) DUMmy2=settextcolor(12) write(*,'(a)')filu DUMmy2=settextcolor(ntextc) write(*,1808)'FFT' 1808 format(1x//10x,'This file contains the current ',a,' as a ', * 'simple multi-'/10x,'column ASCII printout.'// * 10x,'You can use SVIEW to view and produce PostScript ', * 'diagrams '/10x, * 'from this file. Any suitable general graphics package may'/ * 10x,'also be used.'////10x,'Press ENTER to continue ',$) c 1807 IK=INKEY(J) IF(IK.NE.13)GOTO 1807 CALL clearscreen($GCLEARSCREEN) GOTO 699 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 fmark= FIF*1000.d0 fstart=fmark-5000.d0 fend= fmark+5000.d0 smax=smaxol 802 top= smax+0.10d0*(smax-smin) bottom=SMIN-0.10D0*(smax-smin) YYSTEP=1.d0/500.d0*(top-bottom) RRSMAL=bottom-13.d0*YYSTEP 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',xpeak*0.001d0-FIF,FNEWP-FIF 1441 format(F7.1,'kHz <-',a,'-> ',f10.4,' f=',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 sufficient curvature C is present in bisector points for some rectifying action to be taken. C (The preceding applies to supersonic jet FTMW for waveguide FTMW C the alarm level is considerably higher) C write(lwork3,1410)xpeak,'peak',xpeak*0.001d0-FIF,FNEWP-FIF, * errorx*1000.,ypeak 1410 format(F7.1,'kHz <-',a,'-> ',f10.4,' f=',f10.4, * ' (Er.fit=',f6.1,') Y:',f11.2) DUMMY=SETTEXTCOLOR(1) CALL settextposition(1,int2(itxt+1),curpos) CALL outtext(lwork3) WRITE(lwork3,'(64x,''FWHH:'',F11.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',foffs*0.001d0-FIF,fplus-FIF, * abs(flasto-fnewo)*0.001d0 1411 format(F7.1,'kHz <-',a,'-> ',f10.4,' f=',f10.4,' splitting', * f7.4,' MHz') 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), allow selection of discarded c points with scrollable cursors, baseline subtraction and decay c correction c 830 ICHANG=0 831 mini=1000000000 maxi=-1000000000 do 832 j=1,nrep if(j.lt.nskips)goto 832 if(j.gt.nrep-nskipe)goto 833 if(idata(j).lt.mini)mini=idata(j) if(idata(j).gt.maxi)maxi=idata(j) 832 continue c 833 if(maxi.le.mini)then c dummy=setvideomode($DEFAULTMODE) c write(*,'(1x/'' ---> ERROR: mini,maxi ='',2i12//)')mini,maxi c stop maxi= 1 mini=-1 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', * ' H = Help' CALL settextposition(1,int2(itxt+1),curpos) call outtext(lwork2) CALL settextposition(2,int2(itxt+1),curpos) call outtext(emplin(1:79)) CALL settextposition(int2(myrows-1),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 if(maxi.eq.1.and.mini.eq.-1)then CALL settextposition(myrows/4,int2(itxt+1)+10,curpos) call outtext( * 'WARNING: zero or overflowed dynamic range in this data set') endif c c...options: - scrolling of left and right cursor K,L A,S C - change increment for scrolling the cursor + - C - background subtraction B C - compensation for rotational relaxation N C - return to original interferogram R c - ASCII dump of current interferogram c (to file T.DAT) U c 834 IK=INKEY(N) KK=CHAR(IK) IF(KK.EQ.'K'.OR.KK.EQ.'k')GOTO 870 IF(KK.EQ.'L'.OR.KK.EQ.'l')GOTO 875 IF(KK.EQ.'A'.OR.KK.EQ.'a')GOTO 880 IF(KK.EQ.'S'.OR.KK.EQ.'s')GOTO 885 IF(KK.EQ.'B'.OR.KK.EQ.'b')GOTO 1100 IF(KK.EQ.'R'.OR.KK.EQ.'r')GOTO 1200 IF(KK.EQ.'N'.OR.KK.EQ.'n')GOTO 1500 IF(KK.EQ.'H'.OR.KK.EQ.'h')GOTO 1600 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 filu=fnams(nmark)(1:len_trim(fnams(nmark)))//'.int' open(7,file=filu,status='unknown') write(7,'(''! 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(f6.2,' * ',f11.5) 116 format(f6.2,2f11.5) 15 format(f6.2,f11.5,' * ') write(7,'(1H!,50(1H-))') close(7) c dummy4=setbkcolor(ntextb) DUMmy2=settextcolor(ntextc) CALL clearscreen($GCLEARSCREEN) WRITE(*,1806) DUMmy2=settextcolor(12) write(*,'(a)')filu DUMmy2=settextcolor(ntextc) write(*,1808)'interferogram' c 1809 IK=INKEY(J) IF(IK.NE.13)GOTO 1809 CALL clearscreen($GCLEARSCREEN) GOTO 831 endif c 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 if(powamp.eq.'A')then do 853 j=1,npts if(p(j).ne.0.d0)p(j)=sqrt(p(j)) 853 continue endif 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 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)=ioldat(j) 1201 continue nhalf=0 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'//) 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 . . . . . . . . . . . . . . . . . . . . . . . . c c...display the FFT 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 to the INTERFEROGRAMS 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 if(powamp.eq.'A')then do 852 j=1,npts if(p(j).ne.0.d0)p(j)=sqrt(p(j)) 852 continue endif GOTO 851 c return end c C------------------------------------------------------------------------ c subroutine inpout(iexit,dirnam,ntsys) c c This is a hacked version of the full routine from VIEWM and currently c it determines which directory is to be scanned for spectra c 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=45,maxspe=1000,maxpts=4096,nivols=7) PARAMETER (ntextc=0, ntextb=7) character fnams(maxspe)*12,filarc*30,filcon*50 character dirnam*50 integer*2 iwk(maxspe), * iseen(maxspe) integer interf(maxspe,maxpts) real detvol(maxspe,2),volint(maxspe,nivols) real*8 wk(maxspe) common /scans/interf,wk,wmult,iwk,filarc common /scans2/detvol,volint,iseen,nscans common /sfiles/fnams C ntsys=1 iexit=0 C c c...decide on the directory to use for input c dirnam=FILE$CURDRIVE fsys = GETDRIVEDIRQQ(dirnam) write(*,100) 100 format(1x// *' ----> The current directory is:') DUMmy2=settextcolor(12) write(*,'(8x,a)')dirnam(1:len_trim(dirnam)) DUMmy2=settextcolor(ntextc) write(*,'(1x/ *8x,''Press ENTER to read files from this directory, or''/ *8x, ''Press ESC to navigate to a different directory '', *''(select any file)'',$)') c 77 IK=INKEY(N) c if(ik.eq.27)then CALL SETMESSAGEQQ( * " All Files (*.*), *.*", * QWIN$MSG_FILEOPENDLG) filcon='' OPEN(4,file=FILCON,ERR=77,status='old') inquire(4,name=filcon) close(4) do 556 n=len(filcon),1,-1 if(filcon(n:n).eq.'\')goto 557 556 continue 557 dirnam=filcon(1:n-1) fsys=changedirqq(dirnam) return endif c if(ik.eq.13)then return endif c goto 77 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 USE DFLIB c logical*4 fsys parameter (maxspe=1000) 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 C Point spacing in the frequency domain is given by 1/(TSTEP*NPTS) where C NPTS is the number of time domain points C PARAMETER (Nmaxpt=65536,maxpts=4096) 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.65536)NMAX=65536 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,nowrit) 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,nowrit) 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 NOWRIT = block screen output if set to 1 c parameter (nmax=65536) 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) FOUR1 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 if(nowrit.ne.1)then write(*,25)nread 25 format(1x/i10,' points used in FFT') endif c return end c c---------------------------------------------------------------------------- c SUBROUTINE four1(nn,isign) parameter (nmax=65536) 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=65536,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=1000,maxpts=4096,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=65536,maxpts=4096,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 another 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_____________________________________________________________________________