C____________________________________________________________________________ C C FILMAN - FILE MANAGEMENT PROGRAM FOR FTMW spectral files C c Main functions: c c 1. Collect all spectral files in the directory into a spectral c archive, while also producing a summary file LIST.DAT c c 2. Add spectral files in the directory to an already existing archive c c 3. Expand a spectral archive into individual spectral files c c 4. List the contents of a spectral archive and also stamp the archive c with frequency range of its spectra, if this has not yet been done c c C Ver 9.X.2007 ----- Zbigniew Kisiel ----- C __________________________________________________ C | Institute of Physics, Polish Academy of Sciences | C | Al.Lotnikow 32/46, Warszawa, POLAND | C | kisiel@ifpan.edu.pl | C | http://info.ifpan.edu.pl/~kisiel/prospe.htm | C_________________________/-------------------------------------------------- C c Modification history: c c 24.01.99: Creation from FFTLIST c 3.02.99: Checks against duplication on append c 4.02.99: Enhanced archive extraction c 25.02.99: Allowance for larger no of archives than 9 c 20.04.99: Archive listing option c 25.05.99: MAXARC=45 c 6.10.99: debugging and alpabetic listing c 29.04.00: introduction of MINF,MAXF limits for an archive c 2.10.01: modification for NT/2000 operation and CVF6 compilation c 1.02.02: sorting out further W2000/W98/W95 compatibility issues c 12.05.04: extended file standard for autoscanned spectra C 9.10.07: debugging of FAR listing c C---------------------------------------------------------------------------- c c I/O units used: c 2 = input spectral file or spectral archive c 3 = output spectral file or spectral archive c 4 = resulting LIST.DAT file c 5 = DIR file c c To be compiled with MS-PSF 1.0 or higher (without optimisation if PS1). c The program uses several nonstandard commands available only from this c version onwards: c SYSTEMQQ, PACKTIMEQQ, SETFILETIMEQQ c C---------------------------------------------------------------------------- c c STRUCTURE OF FFT DATA ARCHIVE: c c This simply consists of back to back spectral files each preceded by c c ------fname.ext ------ c c ie. a 12 character local DOS filename surrounded on both sides by c six '-' characters. c c The first spectral file is an exception since the first four c bytes in the second field of six '-' characters may be replaced by c two binary coded integer*2 values of the frequency limits for the files c in the archive. These are bytes 19 to 22. c c---------------------------------------------------------------------------- c c STRUCTURE OF FFT DATA FILE: c c Data file is binary but all header information is ASCII so that it can c be inspected with an editor, and modified with hex editor (NUMBER OF C CHARACTERS IN BRACKETS) c c SAMPLE (20) = sample name c NREP (5) = number of points in the interferogram c NSKIPS (5) = number of points from beginning of interf. to be skipped c for FFT c NSKIPE (5) = number of points from end of interf. to be skipped c for FFT c FCENT (12) = excitation frequency (MHz) c TSTEP (10) = horizontal spacing between points (seconds) c VSTEP (10) = vertical spacing between points (volts) c NAVER (7) = number of averages c COMENT (50) = comment c TIMDAT (20) = time and date c IDATA (4*NREP) = point intensities as integer*4 values c DETVA(4) = optional fringe detector voltage if NAVER<0 (Autoscan) c DETVB(4) = optional fringe detector voltage if NAVER<0 (Autoscan) c c MINF = frequency of smallest frequency file in an archive c MAXF = frequency of highest frequency file in an archive c C_____________________________________________________________________________ C USE MSFLIB PS4 logical*4 fsys c PARAMETER (MAXPTS=10000,maxspe=1000,maxsmo=199) C C CHARACTER line*80 character*12 name(maxspe),filnam,FILARC c COMMON /FRBLK/freqs COMMON /LNUMS/Iwk integer*2 iwk(maxspe),i,nspec,nreps(maxspe),nskip(maxspe), * nskip1(maxspe),minf,maxf integer*2 year,month,day,hour,minute,second integer*4 idata(maxpts),iread,mindat(maxspe,7),maxdat(maxspe,7), * ioldat(maxpts),itemp(maxpts),navers(maxspe),pactim real*8 freqs(maxspe),freq,fbuff(maxspe) real*4 vsteps(maxspe),vstep,tsteps(maxspe),spol(maxsmo), * deta(maxspe),detb(maxspe) character sample*20,text1*27,text2*27,timdat*20,coment*50 character fnams(maxspe)*12,timdl(maxspe)*20,dirnam*80 common /scan/idata,nskips,nskipe,nrep,tstep,vstep,detva,detvb common /sptext/sample,text1,text2,timdat,coment common /smooth/ioldat,itemp,spol common /list/fnams,timdl,vsteps,tsteps,deta,detb,nreps,navers c skipal=0 c C C...HEADING C WRITE(*,3344) 3344 FORMAT(1X//' ',76(1H_)/' |',T79,'|'/ * ' | F I L M A N - File Manager for FTMW spectral files ', * T79,'|'/ * ' |',76(1H_),'|'/' version 9.X.2007',T64,'Zbigniew KISIEL') c 1 format(i5) c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...determine what is to be done c call inpout(ioper,filnam,ntsys) FILARC=FILNAM minf= 20000 maxf=-20000 c c IOPER - operation code to deal with spectra c = 1 create new archive c = 2 append to specified archive c = 3 expand an archive c = 4 list an archive c FILNAM - name of archive to be processed c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...go through an existing archive for APPEND, or LIST options c if(ioper.eq.2.or.ioper.eq.4)then write(*,'(1x/'' I N S P E C T I N G archive '',a)')filnam call listsp(nolspe,filnam,istamp,minf,maxf) write(*,556)nolspe 556 format(35x,i6,' spectra found'/) c c...listing file c if(ioper.eq.4)then do 806 n=1,nolspe iwk(n)=n 806 continue c c...sorting of files according to time or frequency c 815 write(*,816) 816 format(15x,' 0 = sort files according to creation time'/ * 15x,' 1 = sort files according to frequency'// * 15x,'.... ',$) read(*,'(i1)',err=815)isort if(isort.lt.0.or.isort.gt.1)goto 815 c c...an archive without previous frequency limits will now c have those stamped on c if(istamp.eq.0)then OPEN(2,FILE=FILNAM,FORM='BINARY',ACCESS='DIRECT', * RECL=2,ERR=11,STATUS='OLD') write(2,REC=10)minf,maxf 15 close(2) goto 10 11 write(*, * '(//'' PROBLEMS opening archive for stamping''/)') 10 continue endif c c...sorting c if(isort.eq.1)then call sorth(int2(1),int2(nolspe)) else do 811 nn=1,nolspe fbuff(nn)=freqs(nn) 811 continue do 810 nn=1,nolspe read(timdl(nn),'(1x,i2,1x,i2,1x,i2,1x,i2,1x,i2,1x,i4)') * hour,minute,second,day,month,year call packtimeqq(pactim, * year,month,day,hour,minute,second) freqs(nn)=pactim 810 continue call sorth(int2(1),int2(nolspe)) do 812 nn=1,nolspe i=iwk(nn) freqs(nn)=fbuff(i) 812 continue endif c do 800 n=1,12 if(filnam(n:n).eq.'.')goto 801 800 continue write(*,'(1x//'' ***** File name problem on LIST''//)') stop 801 filnam=filnam(1:n)//'lst' open(5,file=filnam,status='unknown') c if(isort.eq.0)then write(5,803)'Time',filnam(1:n)//'far' else write(5,803)'Frequency',filnam(1:n)//'far' endif 803 format(79(1h-)/a,' sorted contents of archive ',a/79(1h-)// * 'filename freq/MHz points DeltaT DeltaV', * ' Naver time/date'/ * ' /10-6s /10-6V'/) do 802 nn=1,nolspe i=iwk(nn) write(5,804)fnams(i),freqs(nn),nreps(i), * tsteps(i)*1000000., * vsteps(i)*1000000.,navers(i),timdl(i) 802 continue 804 format(a,f14.4,i6,f9.3,f9.3,i6,3x,a) write(5,805)nolspe,filnam(1:n)//'far' 805 format(1x/i6,' spectra in archive ',a//79(1h-)) c close(5) write(*,'(1x/'' L I S T I N G file written to '',a//)') * filnam stop endif endif c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...create a DIR file to identify spectral files to put/append to an archive c if(ioper.lt.3)then if(ntsys.eq.1)then fsys=systemqq('dir/-N>list.spe') else fsys=systemqq('dir>list.spe') endif if(fsys.neqv..TRUE.)then write(*,702)'Cannot do dir>list.spe' stop endif endif 702 format(1x/' ***** ERROR: ',a//) C C...open the input/output archive C call opfile(ioper,filnam) C C...Open the DIR file C if(ioper.lt.3)then OPEN(5,FILE='list.spe',status='old',err=700) goto 701 700 write(*,702)'Cannot open LIST.SPE' stop c 701 write(*,'(1x)') nspec=0 c c...skip top five lines of the DIR file and determine system type on the basis c of sixth line c do 150 i=1,4 read(5,'(a)',err=500,end=500)line 150 continue i=len_trim(line) if(line(2:9).eq.'Katalog ')dirnam=line(10:i) if(line(2:9).eq.'Katalog:')dirnam=line(11:i) if(line(2:14).eq.'Directory of ')dirnam=line(15:i) read(5,'(a)',err=500,end=500)line endif c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...Go through the DIR file line by line or through the input archive c spectrum by spectrum c 501 if(ioper.lt.3)then 601 read(5,'(a)',err=500,end=500)line if(line(1:1).eq.' ')goto 601 if(line(10:12).eq.'FAR'.or.line(10:12).eq.'far')goto 601 if(line(1:4).eq.'LIST'.and.line(10:12).eq.'SPE')goto 601 if(line(1:4).eq.'LIST'.and.line(10:12).eq.'DAT')goto 601 line(9:9)='.' do 507 i=8,1,-1 if(line(i:i).ne.' ')goto 508 507 continue 508 filnam=line(1:i)//line(9:12) call readsp(ioper,filnam,freq,iread) if(iread.eq.0)goto 501 else call readsp(ioper,filnam,freq,iread) if(iread.eq.0)goto 501 if(iread.eq.-1)then close(2) if(ioper.eq.3)then write(*,555)nspec 555 format(1x/i5,' spectra have been extracted'//) endif stop endif endif c c...FFT spectrum has been read: if it is to be appended then check if it c is not already in the archive c if(ioper.eq.2)then do 630 n=1,nolspe if(filnam.eq.fnams(n))goto 631 630 continue goto 632 c 631 if(timdat.eq.timdl(n))then write(*,634)filnam 634 format(1x,a12,' <----- skipping, spectrum already in archive') goto 501 else write(*,635)filnam,timdat,fnams(n),timdl(n),char(7) 635 format(1x/' Same file name but different creation dates:'/ * 10x,' SPECTRUM: ',a12,' --- ',a/ * 10x,'in ARCHIVE: ',a12,' --- ',a,a// * ' File will be skipped, but some corrective action is', * ' suggested'//40x,'Press E N T E R to continue '$) read(*,'(i1)',err=501)n goto 501 endif endif c c...FFT spectrum has been read: write copy to archive or as new file c depending on ioper c 632 call wrispa(ioper,filnam,iskip) if(int(freq).lt.minf)minf=int(freq) if(int(freq).gt.maxf)maxf=int(freq) c if(iskip.lt.0)then iskip=-iskip if(iskip.eq.2)iskip=0 write(*,641)filnam 641 format(1x,a12,' <----- skipping, spectrum already exists') goto 501 endif c nspec=nspec+1 name(nspec)=filnam iwk(nspec)=nspec freqs(nspec)=freq vsteps(nspec)=vstep tsteps(nspec)=tstep nreps(nspec)=nrep nskip(nspec)=nskips nskip1(nspec)=nskipe read(text2(21:27),'(i7)')naver if(naver.lt.0)then deta(nspec)=detva detb(nspec)=detvb endif c write(*,514)name(nspec)(1:12),freq 514 format(1x,a,5x,f12.5,' MHz') C c c...work out details for writing in a line of SCAN.DAT type c do 250 i=1,nrep ioldat(i)=idata(i) 250 continue c call baksub(51) c do 200 i=1,7 mindat(nspec,i)= 1400000000 maxdat(nspec,i)=-1400000000 j=nskips-(4-i)*20 do 200 jj=j,nrep jjj=jj if(jjj.lt.1)jjj=1 if(idata(jjj).lt.mindat(nspec,i)) * mindat(nspec,i)=idata(jjj) if(idata(jjj).gt.maxdat(nspec,i)) * maxdat(nspec,i)=idata(jjj) 200 continue c goto 501 C 500 close(5) fsys=systemqq('del list.spe') c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c...sort the spectra in order of frequency c if(nspec.eq.0)goto 530 write(*,'(1x/'' S O R T I N G'')') i=1 if(nspec.eq.1)then iwk(1)=1 else call sorth(i,nspec) endif c c...write out a summary file in the standard of SCAN.DAT for use by VIEW c write(*,'(1x/'' W R I T I N G to LIST.DAT'')') open(4,file='LIST.DAT',STATUS='UNKNOWN') write(4,540) 540 format('!',113(1h-)/'! name Pump Points ', * ' dt dV Data ranges (mV) for [(nskips-60+i*20),i=0,6]'/ * '! /MHz /10-6s /10-6V'/ * '!',113(1h-)) do 510 j=1,nspec i=iwk(j) write(4,704)name(i)(1:12),freqs(j), * nreps(i),tsteps(i)*1000000.,vsteps(i)*1000000., * (1000.*vsteps(i)*(real(maxdat(i,k))-real(mindat(i,k))),k=1,7) 510 continue 704 format(a12,f12.3,i6,f6.3,f6.2,7f10.3) close(4) c 530 write(*,531)nspec 531 format(1x/i5,' data files processed'//) c c...stamp frequency limits on created/modified archives c if(ioper.le.2)then CLOSE(3) OPEN(3,FILE=filarc,FORM='BINARY',ACCESS='DIRECT', * RECL=2,ERR=18,STATUS='OLD') write(3,REC=10)minf,maxf close(3) endif goto 17 18 WRITE(*,*)'**** Cannot open archive for stamping f.limits' c 17 stop end C C------------------------------------------------------------------------ c subroutine opfile(ioper,filarc) c c Open archive file for output as UNIT 3, for input as UNIT 2. c character filarc*12,stat*7 c c...new archive c if(ioper.eq.1)then stat='new' 2 open(3,file=filarc,FORM='BINARY',ERR=1,STATUS=stat) return c 1 WRITE(*,4)char(7),filarc 4 format(1X,a/' The file ',a, * ' already exists, OVERWRITE (Y/N)? ',$) READ(*,'(a)',ERR=1)CHARFL IF(CHARFL.EQ.'Y'.OR.CHARFL.EQ.'y')THEN STAT='UNKNOWN' GOTO 2 ENDIF IF(CHARFL.EQ.'N'.OR.CHARFL.EQ.'n')THEN 3 WRITE(*,'('' New file name: '',$)') READ(*,'(a)',ERR=3)FILarc STAT='NEW' GOTO 2 ENDIF C endif c c...append to old archive c if(ioper.eq.2)then open(3,file=filarc,ACCESS='APPEND',FORM='BINARY', * ERR=10,STATUS='OLD') return endif c c...expand or list an archive c if(ioper.gt.2)then open(2,file=filarc,FORM='BINARY',ERR=10,STATUS='OLD') return endif 10 write(*,'(1x//'' Cannot open '',a,a//)')filarc,char(7) stop c return end C C------------------------------------------------------------------------ c SUBROUTINE SORTH(NSTART,N) 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) c COMMON /FRBLK/WK COMMON /LNUMS/IPT INTEGER*2 IPT(maxspe),IIPT,L,N,NSTART,I,J,IR REAL*8 WK(maxspe),WWK 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 RETURN 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 RETURN END C C------------------------------------------------------------------------ c subroutine listsp(nolspe,filnam,istamp,minf,maxf) c c Go through an existing spectral archive FILNAM and determine the contents. c This is used for: c ioper=2 append files to archive c ioper=4 general listing of archive c c NOLSPE = the number of spectra in archive returned on output c ISTAMP = on output flags whether the archive has already been c stamped with frequency limits (=1) or not (=0) c MINF, MAXF = on output frequency limits for files in archive c parameter (maxspe=1000) character fnams(maxspe)*12,timdl(maxspe)*20,filnam*12, * cdummy*6,filtmp*12,txttmp*27,tmdtmp*20,comtmp*50, * samtmp*20 integer*2 nreps(maxspe),minf,maxf integer*4 navers(maxspe) real*4 vsteps(maxspe),tsteps(maxspe),deta(maxspe),detb(maxspe) real*8 freqs(maxspe) COMMON /FRBLK/freqs common /list/fnams,timdl,vsteps,tsteps,deta,detb,nreps,navers minf= 20000 maxf=-20000 c c...open archive c OPEN(2,FILE=FILNAM,FORM='BINARY',ERR=10,STATUS='OLD') c nolspe=0 1 read(2,err=20,end=40)cdummy,filtmp(1:12),cdummy if(cdummy.ne.'------')then istamp=1 else istamp=0 endif READ(2,err=20,end=30)samtmp READ(2,err=20,end=30)txttmp(1:27) READ(txttmp,'(3i5,f12.5)',end=30,err=20) * nrep,nskips,nskipe,fcent READ(2,err=20,end=30)txttmp(1:27) READ(txttmp,'(1pe10.3,e10.3,i7)',end=30,err=20) * tstep,vstep,naver READ(2,err=20,end=30)comtmp,tmdtmp DO 22 N=1,Nrep READ(2,err=20,end=30)idummy 22 CONTINUE if(naver.lt.0)then read(2)detva read(2)detvb endif c nolspe=nolspe+1 nreps(nolspe)=nrep tsteps(nolspe)=tstep vsteps(nolspe)=vstep navers(nolspe)=naver freqs(nolspe)=fcent fnams(nolspe)=filtmp timdl(nolspe)=tmdtmp if(int(fcent).lt.minf)minf=int(fcent) if(int(fcent).gt.maxf)maxf=int(fcent) if(naver.lt.0)then deta(nolspe)=detva detb(nolspe)=detvb endif goto 1 c c...error messages c 10 write(*,21)'problem on opening archive ', * filnam,char(7) stop 20 write(*,21)'problem on reading data on scanning ', * filnam,char(7) 21 format(1x//' ***** ERROR: ',a,a,a//) stop 30 write(*,21)'unexpected end of file on scanning ', * filnam,char(7) stop 50 write(*,23)'problem extracting data from: ',txttmp,char(7), * filtmp,filnam 23 format(1x//' ***** ERROR: ',a,a,a//30x,' spectrum: ',a/ * 30x,' archive: ',a//) stop c 40 close(2) c return end C c--------------------------------------------------------------------------- c subroutine readsp(ioper,filnam,fcent,iread) c c IOPER=1,2: c Read file FILNAM as a spectral file: if it is read successfully c then IREAD=1, if it is not a valid spectral file then IREAD=0 c IOPER=3,4: c Read spectrum in archive in unit 2, name of spectral file will c be returned in FILNAM c If end of archive encountered then IREAD=-1 on output c PARAMETER (maxpts=10000) real*8 fcent character timdat*20,coment*50,sample*20, * text1*27,text2*27 character filnam*12,cdummy*6 integer idata(maxpts),iread common /scan/idata,nskips,nskipe,nrep,tstep,vstep,detva,detvb common /sptext/sample,text1,text2,timdat,coment c if(ioper.eq.1.or.ioper.eq.2)then OPEN(2,FILE=FILNAM,FORM='BINARY',ERR=503,STATUS='OLD') endif if(ioper.eq.3.or.ioper.eq.4)then read(2,err=503,end=505)cdummy,filnam(1:12),cdummy endif C READ(2,err=503,end=503)sample READ(2,err=503,end=503)text1(1:27) READ(text1,'(3i5,f12.5)',end=503,err=503) * nrep,nskips,nskipe,fcent READ(2,err=503,end=503)text2(1:27) READ(text2,'(1pe10.3,e10.3,i7)',end=503,err=503) * tstep,vstep,naver READ(2,err=503,end=503)coment,timdat if( timdat(4:4).ne.':'.or. * timdat(7:7).ne.':'.or. * timdat(10:10).ne.','.or. * timdat(13:13).ne.'/'.or. * timdat(16:16).ne.'/')goto 503 C c...Intensities of spectral data points c if(nrep.gt.maxpts)nrep=maxpts DO 20 N=1,Nrep READ(2,end=503)idata(n) 20 CONTINUE C if(naver.lt.0)then read(2)detva read(2)detvb endif C if(ioper.eq.1.or.ioper.eq.2)CLOSE(2) iread=1 goto 501 c 503 write(*,504)filnam 504 format(' ***** Cannot open or not spectral file: ',a) iread=0 RETURN 505 IREAD=-1 c 501 return end c C------------------------------------------------------------------------ c subroutine wrispa(ioper,filnam,iskip) c c Write current spectral data: c IOPER=1,2 to an already open archive in unit 3 c IOPER=3 as an individual spectral file c c FILNAM = file name associated with the spectrum c FCENT = pump frequency for the spectrum c ISKIP = determines operation on encounering a file with the same file c name as the file being extracted c ISKIP is normally zero but set to 1 for skipAll, and is returned c as -1 or -2 on each encountered duplication (and reset in M/P) c c USE MSFLIB PS4 c include 'flib.fd' PARAMETER (maxpts=10000) character timdat*20,coment*50,sample*20,text1*27,text2*27 character filnam*12,charfl,stat*7 integer*4 idata(maxpts),pactim integer*2 year,month,day,hour,minute,second logical*4 opfile common /scan/idata,nskips,nskipe,nrep,tstep,vstep,detva,detvb common /sptext/sample,text1,text2,timdat,coment c c...open new file for output of extracted spectrum c if(ioper.eq.3)then stat='new' 2 open(3,file=filnam,FORM='BINARY',ERR=1,STATUS=stat) goto 5 c 1 if(iskip.eq.1)then iskip=-1 return endif WRITE(*,4)char(7),filnam 4 format(1X,a/' The file ',a, * ' already exists, OVERWRITE (Y/N/Skip/skipAll ? ',$) READ(*,'(a)',ERR=1)CHARFL IF(CHARFL.EQ.'S'.OR.CHARFL.EQ.'s')THEN iskip=-2 return endif IF(CHARFL.EQ.'A'.OR.CHARFL.EQ.'a')THEN iskip=-1 return endif IF(CHARFL.EQ.'Y'.OR.CHARFL.EQ.'y')THEN STAT='UNKNOWN' GOTO 2 ENDIF IF(CHARFL.EQ.'N'.OR.CHARFL.EQ.'n')THEN 3 WRITE(*,'('' New file name: '',$)') READ(*,'(a)',ERR=3)FILnam STAT='NEW' GOTO 2 ENDIF endif c C...header c write(3)'------',filnam,'------' 5 WRITE(3)sample c c...nrep,nskips,nskipe,fcent in format (3i5,f12.5) write(3)text1 c c...tstep,vstep,naver in format (1pe10.3,e10.3,i7) write(3)text2 c write(3)coment,timdat C c...Intensities of INTEGER*4 spectral data points c DO 20 N=1,Nrep WRITE(3)idata(n) 20 CONTINUE read(text2(21:27),'(i7)')naver if(naver.lt.0)then write(3)detva write(3)detvb endif c c...recover the original creation time for the extracted spectral file c if(ioper.eq.3)then close(3) read(timdat,'(1x,i2,1x,i2,1x,i2,1x,i2,1x,i2,1x,i4)') * hour,minute,second,day,month,year call packtimeqq(pactim,year,month,day,hour,minute,second) C C...NOTE: the packed time value seems to be 8 hours=28800 seconds too short, c hence the correction below: ie. this is suspiciously like c California time pactim=pactim+28800 opfile=setfiletimeqq(filnam,pactim) endif C RETURN END c C------------------------------------------------------------------------ c subroutine inpout(ioper,filnam,ntsys) c c Routine to determine whether there are any spectral archives (extension c .FAR) in the directory and what is to be done with the spectra that are c found c c IOPER - operation code to deal with spectra c = 1 create new archive c = 2 append to specified archive c = 3 expand an archive c = 4 list an archive c FILNAM - name of archive to be processed (on output) c USE MSFLIB PS4 logical*4 fsys parameter (maxarc=54,maxspe=1000) character line*80,filnam*12,fnams(maxarc)*12,opcode*3 character cdummy*18,cdum*2,outa*12,outb*12,dirnam*50 integer*2 minfs(maxarc),maxfs(maxarc),intfre,iwk(maxspe) real*8 freqs(maxspe) equivalence (cdum,intfre) COMMON /FRBLK/freqs COMMON /LNUMS/Iwk c c c...determine the presence of FFT archives (with extension .FAR) c ntsys=0 fsys=systemqq('ver>far.lst') open (2,file='far.lst',status='old') read(2,'(a)',end=9)line read(2,'(a)',end=9)line if(line(1:1).eq.'M')ntsys=1 close(2) c write(*,'(1x/)') if(ntsys.eq.1)then fsys=systemqq('dir *.far/On/-N>far.lst') else fsys=systemqq('dir *.far/On>far.lst') endif if(fsys.neqv..TRUE.)then write(*,'(1x/a//)')' ***** ERROR: Cannot do dir *.far>far.lst' stop endif open(2,file='far.lst',status='old') c C...skip top lines, determine current directory on the basis of fourth line c do 150 i=1,4 read(2,'(a)',end=9)line 150 continue i=len_trim(line) if(line(2:9).eq.'Katalog ')dirnam=line(10:i) if(line(2:9).eq.'Katalog:')dirnam=line(11:i) if(line(2:14).eq.'Directory of ')dirnam=line(15:i) read(2,'(a)',end=9)line c narch=0 7 read(2,'(a)',end=9)line if(line(10:12).ne.'FAR'.and.line(10:12).ne.'far')goto 7 do 8 i=9,1,-1 if(line(i:i).ne.' ')goto 10 8 continue 10 narch=narch+1 c if(narch.eq.maxarc)then write(*,'(1x//'' ***** Too many archives - the program is '', * ''only dimensioned up to'',i5,a//)')maxarc,char(7) stop endif fnams(narch)=line(1:i)//'.'//line(10:12) goto 7 c 9 close(2) fsys=systemqq('del far.lst') c c...options c 19 ndash=len_trim(dirnam)+4 write(*,'(1x/23x,100a)')'+',('-',i=1,ndash),'+' write(*,15)dirnam(1:len_trim(dirnam)) 15 format(' Current directory is | ',a,' |') write(*,'(23x,100a)')'+',('-',i=1,ndash),'+' if(narch.eq.0)then write(*,100) 100 format(1x/' There are NO FFT archive files'/ * /' ----> Press ENTER to combine all FFT spectra in', * ' this directory'/ * ' into an archive ',$) read(*,'(a)')opcode opcode(1:1)='n' else write(*,'(1x/'' There are'',i3,'' FFT archive file(s):''/)') * narch c c...read frequency limits of archives c do 200 i=1,narch iwk(i)=i open(2,file=fnams(i),form='binary',status='old',err=200) read(2)cdummy read(2)cdum if(cdum.ne.'--')then minfs(i)=intfre freqs(i)=intfre else freqs(i)=0.0d0 endif read(2)cdum if(cdum.ne.'--')maxfs(i)=intfre close(2) 200 continue c c...sort according to frequency c if(narch.gt.1)call sorth(int2(1),int2(narch)) <---- c c...write list of archives c c...single column c if(narch.lt.10)then do 12 j=1,narch i=iwk(j) if(minfs(i).eq.0.and.maxfs(i).eq.0)then write(outa,'(a12)')' ' else write(outa,'(i6,''-'',i5)')minfs(i),maxfs(i) endif write(*,17)j,fnams(i),outa 12 continue 17 format(12x,i2,' = ',a,a) endif c c...two column c if(narch.le.36.and.narch.ge.10)then j=narch/2 do 112 k=1,j i=iwk(k) ipj=iwk(k+j) if(minfs(i).eq.0.and.maxfs(i).eq.0)then write(outa,'(a12)')' ' else write(outa,'(i6,''-'',i5)')minfs(i),maxfs(i) endif if(minfs(ipj).eq.0.and.maxfs(ipj).eq.0)then write(outb,'(a12)')' ' else write(outb,'(i6,''-'',i5)')minfs(ipj),maxfs(ipj) endif write(*,117)k,fnams(i),outa,k+j,fnams(ipj),outb 112 continue c if(2*(narch/2).ne.narch)then i=iwk(narch) if(minfs(i).eq.0.and.maxfs(i).eq.0)then write(outa,'(a12)')' ' else write(outa,'(i6,''-'',i5)')minfs(i),maxfs(i) endif write(*,118)narch,fnams(i),outa endif 117 format(4x,i2,' = ',a,a, 12x,i2,' = ',a,a) 118 format(45x, i2,' = ',a,a) endif c c...three column c if(narch.gt.36.and.narch.le.maxarc)then j=narch/3 c do 120 k=1,j i=iwk(k) ipj=iwk(k+j) iipj=iwk(k+2*j) write(*,121)k,fnams(i),k+j,fnams(ipj),k+2*j,fnams(iipj) 120 continue c if(narch-j*3.eq.1)then i=iwk(narch) write(*,122)narch,fnams(i) endif c if(narch-j*3.eq.2)then i=iwk(narch-1) write(*,122)narch-1,fnams(i) i=iwk(narch) write(*,122)narch,fnams(i) endif c 121 format(5x, i2,' = ',a,2(10x,i2,' = ',a)) 122 format(59x,i2,' = ',a) endif c write(*,18) 18 format(1x/ * ' OPTIONS: N = combine all spectra in this directory', * ' into new archive'/ * 12x,'nA = append spectra to archive n'/ * 12x,'nE = expand archive n into individual spectra'/ * 12x,'nL = list archive n'// * 25x,'..... '$) read(*,'(a)',err=20)opcode endif c c...new archive c if(opcode(1:1).eq.'n'.or.opcode(1:1).eq.'N')then ioper=1 31 write(*,30) 30 format(1x/' File name (extension .FAR implicit) for new', * ' archive: ',$) read(*,'(a)',err=32)filnam do 33 i=1,9 if(filnam(i:i).eq.'/')goto 32 if(ichar(filnam(i:i)).gt.ichar('~'))goto 32 if(filnam(i:i).eq.' '.or.filnam(i:i).eq.'.')then j=i-1 goto 34 endif 33 continue j=8 34 filnam=filnam(1:j)//'.'//'FAR' return 32 write(*,'(1x,a)')char(7) goto 31 endif c c...operation on existing archive c n=len_trim(opcode) if(n.eq.2)then read(opcode(1:1),'(i1)',err=19)numarc else read(opcode(1:2),'(i2)',err=19)numarc endif c if(numarc.ge.1.and.numarc.le.narch)then numarc=iwk(numarc) filnam=fnams(numarc) if(opcode(n:n).eq.'E'.or.opcode(n:n).eq.'e')then ioper=3 return endif if(opcode(n:n).eq.'A'.or.opcode(n:n).eq.'a')then ioper=2 return endif if(opcode(n:n).eq.'L'.or.opcode(n:n).eq.'l')then ioper=4 return endif endif c 20 write(*,'(1x,a)')char(7) goto 19 c return end c c---------------------------------------------------------------------------- c subroutine baksub(nspt) c PARAMETER (maxpts=10000,maxsmo=199) c integer idata(maxpts),ioldat(maxpts),itemp(maxpts) real spol(maxsmo) common /scan/idata,nskips,nskipe,nrep,tstep,vstep common /smooth/ioldat,itemp,spol c C...Subtraction of background by triple smoothing of interferogram with c least squares smoothing interval c C For smoothing interval of length 2m+1 the elements of the smoothing c (cubic) polynomial are given by: C C 3(3m**2 + 3m -1 - 5s**2) C c(s) = ------------------------ C (2m+1) (2m-1) (2m+3) C C where s runs from -m to +m (T.H.Edwards and P.D.Wilson, Applied C Spectroscopy 28,541-545(1974)) C C c...set up coefficients in smoothing polynomial M=NSPT/2 T1=3.D0/((2*M+1)*(2.D0*M-1.D0)*(2*M+3)) T2=3*M*M+3.D0*M-1.D0 DO 1103 j=1,NSPT IS=j-M-1 SPOL(j)=T1*(T2-5*IS*IS) 1103 CONTINUE C c...Smooth three times ISTRT=M+1 IFIN=nrep-M DO 1104 k=1,3 do 1105 j=1,nrep itemp(j)=idata(j) 1105 continue DO 543 I=1,nrep SUM=0. DO 544 J=1,NSPT IS=J-M-1 II=I+IS IF(II.LT.1)II=-II+1 IF(II.GT.nrep)II=nrep-(II-nrep-1) SUM=SUM+itemp(II)*SPOL(J) 544 CONTINUE Idata(I)=sum 543 CONTINUE DO 545 I=1,nrep ITEMP(I)=IDATA(I) 545 CONTINUE 1104 continue C do 1106 j=1,nrep idata(j)=ioldat(j)-idata(j) 1106 continue c return end C c---------------------------------------------------------------------------- c----------------------------------------------------------------------------