C____________________________________________________________________________ C C L I S T W G - LISTING OF SPECTRAL PARAMETERS in Kiel standard C waveguide FTMW 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 If the VKIEL program is also used to produce a synthetic spectrum of C these measurements then a full broadband-type analysis with C the AABS package is possible C C C Operation: C C 1/ LISTWG 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 Kiel WG-FT measurement files C 3/ for an actual measurement file the pump frequency is 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. LISTWG works only on the current directory c c C Ver 28.X.2018 ----- 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 28.10.18: Modified from 4.4.17 version of SLIST C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C use DFLIB c PARAMETER (MAXSPE=1000,MAXPTS=27000) C character txblock*256 integer*2 kp(32) real*8 rp(24),freq C INTEGER*4 npts,npoint(maxspe),navgs(maxspe) INTEGER*2 iwk(maxspe),i,nspec REAL*8 FSTART(maxspe),FEND(maxspe),FINCR(maxspe),delay(maxspe) character*12 name(maxspe) CHARACTER line*200,filnam*200 c COMMON /FRBLK/fstart COMMON /LNUMS/Iwk 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 W G - Lister for Kiel 1995 standard ', * 'WG-FTMW spectra'/ * ' producing a listing for use by ASCP_L'/ * 1X,78(1H )/1x,78(1H_)/ * ' version 28.X.2018',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>specwg.lst') OPEN(3,FILE='specwg.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 as a KIEL WG file using the name determined from C the directory file entry C C read files begin with: C @ SYS 5 @MWFTSBI 1.0 01.02.95 C @ SYS 5 @FTMW2.x J.-U.Grabow C C 508 filnam=line(npos:) c OPEN(2,FILE=FILNAM(1:len_trim(filnam)),FORM='BINARY', * status='old',ERR=501) READ(2,END=4565,err=4565)txblock,kp,rp if(txblock(1:10).ne.' @ SYS 5 @')goto 4565 c nspec=nspec+1 npts=kp(4) freq=rp(1) FSTART(nspec)=freq-2.d0 FEND(nspec)=freq+2.d0 FINCR(nspec)=real(kp(1))/1000.d0 navgs(nspec)=kp(3) delay(nspec)=rp(4) goto 4566 c c...not an acceptable file c 600 nspec=nspec-1 goto 4565 C C...fill out bona fide file entries for later sorting C 4566 name(nspec)=filnam iwk(nspec)=nspec npoint(nspec)=npts write(*,514)name(nspec)(1:12),fstart(nspec),fend(nspec), * npoint(nspec),navgs(nspec) 514 format(1x,a,5x,f10.2,' -- ',f10.2,' MHz,',i9,' points,',i8, * ' avgs') if(fend(nspec).gt.fremax)fremax=fend(nspec) C 4565 CLOSE(2) c c...go back for next spectral file c goto 501 C c...finish processing the directory listing c 500 close(3) fsys=systemqq('del specwg.lst') c write(*,'(1x/i5,'' spectra found in this directory''/)')nspec c c c...Sort the found 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') write(4,540)'file name fstart fend'// * ' pts avgs delay/us' 540 format(a/) c do 510 j=1,nspec i=iwk(j) c if(fremax.lt.1000000.d0)then write(4,504)name(i)(1:12),fstart(j),fend(i),npoint(i), * navgs(i),delay(i) else write(4,524)name(i)(1:12),fstart(j),fend(i),npoint(i), * navgs(i),delay(i) endif c if((j/10)*10.eq.j)write(4,'(1x)') 510 continue write(4,'(1x/i5,'' spectra listed''/)')nspec c close(4) c cBN.069 8215.500 -- 8219.500 MHz, 1024 121 2.1 c 504 format(1x,a,5x,f10.3,' -- ',f10.3,' MHz,',i8,i7,f8.1) 524 format(1x,a,5x,f10.2,' -- ',f10.2,' MHz,',i8,i7,f8.1) C stop c 503 write(*,533) 533 format(1x//' ERROR: Cannot open file SPECWG.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------------------------------------------------------------------------