C____________________________________________________________________________ C C LISTSPE - LISTING OF SPECTRAL PARAMETERS in frequency linearised files C_____________________________________________________________________________ C C The purpose: C C To produce a listing file LIST for use by ASCP_L to identify C the covered frequency regions (red markings on the frequency axis C and file name in the second information line) C C LISTSPE lists only binary spectral files compatible with C SVIEW_L C C C Operation: C C 1/ LISTSPE reads a listing of files created with the DIR command C 2/ opens all of these files in turn and checks for bona fide C SVIEW compatible binary files C 3/ for a bona fide spectral file the frequency limits are read C 4/ collected output is produced in the form of file LIST where C measurement file entries are arranged order of increasing start C frequency C C Notes: C C 1. LISTSPE works only on the current directory c c C Ver 2.02.2022 ----- 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 C Modification history: c c 19.03.07: last 16-bit version, which refused to work with W7 64bit c 8.10.12: mods for operation with current Windows, but limited c to NTFS directory listing c 4.04.17: eliminating overflow in listed >1THZ frequencies c 29.10.18: renamed and modified from SLIST c 2.02.22: autodetection and different output format for cm-1 spectra C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C NOTE: -ve NPTS2 = departure from the old standard of 32k 2-byte points after C which 4-byte NPTS is read, then C C +ve NPTS = 2-byte points C -ve points = 4-byte points C use DFLIB c PARAMETER (MAXPTS=2000,maxspe=1000) C INTEGER*4 npts,npoint(maxspe),dummy4 INTEGER*2 iwk(maxspe),i,nspec,dummy2 REAL*8 FSTART(maxspe),FEND(maxspe),FINCR(maxspe) REAL*4 volts(MAXPTS) CHARACTER bold*4,normal*4 character*12 name(maxspe) CHARACTER*200 line,filnam,fulnam(maxspe) c INTEGER*2 NPTS2,ISMALL,ILARGE, * IDAY,IMON,IYEAR,IHOUR,IMIN,ISEC REAL*4 VKMST,VKMEND,GRID,SAMPRE,GAIN,TIMEC,PHASE, 1 PPS,FRMOD,FRAMPL CHARACTER COMENT*72,LAMP*6,SCANSP*6,SAMPLE*20 c COMMON /FRBLK/fstart COMMON /LNUMS/Iwk c COMMON /SPECR/volts COMMON /SPEC/NPTS2,ISMALL,ILARGE COMMON /INFO/COMENT,IDAY,IMON,IYEAR,IHOUR,IMIN,ISEC, 1 LAMP,SAMPLE, 1 SCANSP,PPS,FRMOD,FRAMPL COMMON /FNAM/FILNAM c fremax=0.d0 c C C...WRITE THE HEADER INFORMATION C 155 FORMAT(1H+,A1,A) WRITE(*,156) 156 FORMAT(/1X,78(1H_)//' L I S T S P E - Lister for SVIEW_L ', * 'compatible binary spectra'/ * 1x,78(1H_)/ * ' version 2.II.2022',T64,'Zbigniew KISIEL '//) c write(*,157) 157 format(/' NOTE: this version is for the NTFS file system only'//) c C C...create and open directory listing C fsys=systemqq('dir>spec.lst') OPEN(3,FILE='spec.lst',err=503) nspec=0 c c c...Read a line from the directory file c 300 read(3,'(a)',err=503,end=500)line if(line(1:1).eq.' ')goto 300 npos=len_trim(line) if(npos.lt.15)goto 300 if(line(npos-1:npos).ne.'..')goto 300 npos=npos-1 c 501 read(3,'(a)',err=503,end=500)line C C C...Attempt to read file name determined from the directory file entry C 508 filnam=line(npos:) nbyte=2 c OPEN(2,FILE=FILNAM(1:len_trim(filnam)),FORM='BINARY', * status='old',ERR=501) READ(2,END=4565)COMENT,IDAY,IMON,IYEAR,IHOUR,IMIN,ISEC, 1 LAMP,VKMST,VKMEND,GRID,SAMPLE,SAMPRE,GAIN,TIMEC,PHASE, 1 SCANSP,PPS,FRMOD,FRAMPL READ(2,END=4565)NPTS2 if(npts2.eq.-1)then read(2)npts c write(*,'(i10,5x,a)')npts,FILNAM(1:len_trim(filnam)) ! debug if(npts.lt.0)then nbyte=4 npts=iabs(npts) endif else npts=npts2 read(2)ISMALL,ILARGE endif c write(*,'(i10,5x,a)')npts,FILNAM(1:len_trim(filnam)) ! debug if(npts.le.0)goto 4565 C nspec=nspec+1 C 505 DO 20 N=1,NPTS if(nbyte.eq.4)then READ(2,end=600)dummy4 else READ(2,end=600)dummy2 endif 20 CONTINUE goto 601 c 600 nspec=nspec-1 goto 4565 C C...PPS>500 marks linearised or PLL recorded spectra, other types of spectra C are currently ignored C 601 IF((PPS.GT.500.and.PPS.lt.600.).or.PPS.eq.51.)THEN READ(2,end=600)FSTART(nspec),FEND(nspec),FINCR(nspec) if(fstart(nspec).le.1.d0.or.fend(nspec).le.1.d0)goto 600 else if(npts2.ne.-1)goto 600 ENDIF c name(nspec)=filnam fulnam(nspec)=filnam iwk(nspec)=nspec npoint(nspec)=npts if(fstart(nspec).lt.1900.d0)then write(*,515)name(nspec)(1:12),fstart(nspec),fend(nspec), ! cm-1 echo * npts,fincr(nspec) else write(*,514)name(nspec)(1:12),fstart(nspec),fend(nspec), ! standard MHz echo * fincr(nspec) endif 515 format(1x,a,3x,f9.3,' -- ',f9.3,' cm-1,',i10,' pts @', * f9.6,' cm-1/pt') 514 format(1x,a,5x,f10.2,' -- ',f10.2,' MHz, @', * f6.3,' MHz/point') if(fend(nspec).gt.fremax)fremax=fend(nspec) C 4565 CLOSE(2) c goto 501 C 500 close(3) fsys=systemqq('del spec.lst') c write(*,'(1x/i5,'' spectra found in this directory''/)')nspec c c c...Sort the spectra in order of increasing frequency c i=1 if(nspec.gt.1)call sorth(i,nspec) c c c...Write the LIST file c open(4,file='LIST',STATUS='UNKNOWN') do 510 j=1,nspec i=iwk(j) filnam=fulnam(i) ! assuming cm-1 c if(fstart(j).lt.2000.d0)then write(4,534)fstart(j),fend(i),npoint(i), * fincr(i),filnam(1:len_trim(filnam)) goto 510 endif c if(fremax.lt.1000000.d0)then ! assuming MHz write(4,504)name(i)(1:12),fstart(j),fend(i),npoint(i), * fincr(i),filnam(1:len_trim(filnam)) else write(4,524)name(i)(1:12),fstart(j),fend(i),npoint(i), * fincr(i),filnam(1:len_trim(filnam)) endif c if((j/10)*10.eq.j)write(4,'(1x)') 510 continue write(4,'(1x/i5,'' spectra listed''/)')nspec c close(4) 504 format(1x,a,5x,f10.3,' -- ',f10.3,' MHz,',i8,' points @', * f5.2,' MHz/pt',5x,a) 524 format(1x,a,5x,f10.2,' -- ',f10.2,' MHz,',i8,' points @', * f5.2,' MHz/pt',5x,a) 534 format(1x,f9.3,' -- ',f9.3,' cm-1,',i10,' points @', * f9.6,' cm-1/pt',5x,a) C stop c 503 write(*,533) 533 format(1x//' ERROR: Cannot open file SPEC.LST'//) stop 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------------------------------------------------------------------------