C____________________________________________________________________________ C C SLIST - LISTING OF SPECTRAL PARAMETERS in frequency linearised files C C The program reads a listing of files created with the DIR C command, opens all of these files in turn and reads C frequency limits. It then outputs to file LIST a listing C of these files in order of increasing start frequency. C C Notes: C C 1. SLIST works only on the current directory C 2. there is still some use of ANSI.SYS c c C Ver 19c.III.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 PARAMETER (MAXPTS=27000) C INTEGER*4 npts,npoint(1000) INTEGER*2 iwk(1000),i,nspec,dummy2 REAL*8 FSTART(1000),FEND(1000),FINCR(1000) REAL*4 volts(MAXPTS) CHARACTER bold*4,normal*4 character*12 name(1000) CHARACTER*200 line,emplin,filnam c INTEGER*2 ISPEC(MAXPTS),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/ISPEC,NPTS2,ISMALL,ILARGE COMMON /lines/toplin,botlin,emplin,paslin COMMON /INFO/COMENT,IDAY,IMON,IYEAR,IHOUR,IMIN,ISEC, 1 LAMP,SAMPLE, 1 SCANSP,PPS,FRMOD,FRAMPL COMMON /FNAM/FILNAM c C C...WRITE THE HEADER INFORMATION C 155 FORMAT(1H+,A1,A) WRITE(*,156) 156 FORMAT(/1X,78(1H_)//' S L I S T - Lister for frequency ', * 'linearised spectra '/ * 1X,78(1H )/1x,78(1H_)/ * ' version 19c.III.2003',T64,'Zbigniew KISIEL ') c LINOFS=14 WRITE(emplin,'(79(1H ))') 1 format(i5) C write(*,'(1x///'' REMEMBER to first list the directory using:''// * 18x,'' DIR >A''/ * 18x,''or: DIR specnam.*>A for win95/98''// * 18x,'' DIR/-N>A''/ * 18x,''or: DIR specnam.*/-N>a for NT/2000'')') C C C...Open directory listing C 503 WRITE(*, * '(1X//'' NAME OF FILE containing directory listing: ''\)') READ(*,'(A)',err=503,end=503)FILNAM OPEN(3,FILE=FILNAM) write(*,'(2x)') c c c...Read a line from the directory file c nspec=0 501 read(3,'(a)',err=503,end=500)line if(line(1:1).eq.' ')goto 501 if(line(1:1).eq.'.')goto 501 if(line(15:15).eq.'<'.or.line(22:22).eq.'<')goto 501 C C C...Atempt to read file name determined from the directory file entry C line(9:9)='.' do 507 i=8,1,-1 if(line(i:i).ne.' ')goto 508 507 continue 508 filnam=line(37:) 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 else npts=npts2 read(2)ISMALL,ILARGE endif if(npts.le.0)goto 4565 C nspec=nspec+1 C 505 DO 20 N=1,NPTS READ(2,end=600)dummy2 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 goto 600 ENDIF c name(nspec)=filnam iwk(nspec)=nspec npoint(nspec)=npts write(*,514)name(nspec)(1:12),fstart(nspec),fend(nspec), * fincr(nspec) 514 format(1x,a,5x,f10.3,' -- ',f10.3,' MHz, @', * f5.2,' MHz/point') C 4565 CLOSE(2) c goto 501 C 500 close(3) 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) write(4,504)name(i)(1:12),fstart(j),fend(i),npoint(i), * fincr(i) 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') C 530 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 (MAXfil=1000) c COMMON /FRBLK/WK COMMON /LNUMS/IPT INTEGER*2 IPT(maxfil),IIPT,L,N,NSTART,I,J,IR REAL*8 WK(maxfil),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------------------------------------------------------------------------