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 in order of increasing start C frequency C 5/ option to correct the dud year number in MWFTSBI files (but only C offered if this is the only difference between system time/date C and the time/date internal to the file) C 6/ option to correct '1 Jan 80' error due to forgotten setting of C date on the measuring computer C C Notes: C C 1. LISTWG works only on the current directory C C 2. Ensure that date in the DIR command is in the form: dd.MM.yyyy C and that time is in the 24h form: HH:mm C C this is done using control panel->Region-> C C version 1: Format=Polish, check "Short date" C version 2: Match Windows Display Language: this usually sets English (United States) c Additional Settings->Date->dd-MM-yy C (if not initially available three MMMs can be edited to MM) C two yy can be edited to yyyy C Additional Settings->Time-> Short time format=HH:mm C Long time format=HH:mm:ss C (24h format in DIR appears only if both short and long are changed) C c C Ver 16.III.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 28.10.18: Modified from 4.4.17 version of SLIST c 22.10.21: Added frequency for conversion via .DAT loaded to FFTS c 16.03.22: Option for updating bad year numbers in MWFTSBI C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C use DFLIB use IFPORT c PARAMETER (MAXSPE=1000,MAXPTS=27000) C character txblock*256 integer*2 kp(32) real*8 rp(24),freq C character y1,y2 type (file$info)fspecs integer dummy4 c INTEGER*4 npts,npoint(maxspe),navgs(maxspe) INTEGER*2 iwk(maxspe),i,nspec INTEGER diffyer,difftim,diffday,diffmon,diff80 REAL*8 FSTART(maxspe),FEND(maxspe),FINCR(maxspe),delay(maxspe), * forFFTS(maxspe) character*12 name(maxspe) CHARACTER line*200,filnam*200 CHARACTER sysdat(maxspe)*10,systim(maxspe)*5, * mwfdat(maxspe)*9, mwftim(maxspe)*5, monnam(12)*3, * mwfold*9 c COMMON /FRBLK/fstart COMMON /LNUMS/Iwk c DATA monnam/'Jan','Feb','Mar','Apr','Mai','Jun', * 'Jul','Aug','Sep','Okt','Nov','Dez' / 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 15.III.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>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 ! skip descriptive lines npos=len_trim(line) if(npos.lt.15)goto 300 ! skip spacing lines if(line(npos-1:npos).ne.'..')goto 300 ! skip . line c c...NPOS is the column of first characetr of file name c 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 sysdat(nspec)=line(1:10) systim(nspec)=line(13:17) mwfdat(nspec)=txblock(32:40) if(mwfdat(nspec)(1:1).eq.' ')mwfdat(nspec)(1:1)='0' c mwftim(nspec)(1:2)=txblock(41:42) mwftim(nspec)(3:3)=':' mwftim(nspec)(4:5)=txblock(43:44) if(mwftim(nspec)(1:1).eq.' ')mwftim(nspec)(1:1)='0' if(mwftim(nspec)(4:4).eq.' ')mwftim(nspec)(4:4)='0' c 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) forFFTS(nspec)=freq-5.0d0 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 c...Sort the found spectra in order of increasing frequency c i=1 if(nspec.gt.1)call sorth(i,nspec) <----- c c------------------------------------------------------------------------ c c...Write the LIST file: typical output line usable by ASCP_L: c cBN.069 8215.500 -- 8219.500 MHz, 1024 121 2.1 c open(4,file='LIST',STATUS='UNKNOWN') write(4,540)'file name fstart fend'// * ' pts avgs delay/us forFFTS'// * ' Date Time' write(4,542)'System MWFTSBI Sys MWFT' 540 format(a) 542 format(90x,a/) c diff80=0 diffday=0 difftim=0 diffmon=0 diffyer=0 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),forFFTS(i), * sysdat(i),mwfdat(i),systim(i),mwftim(i) else write(4,524)name(i)(1:12),fstart(j),fend(i),npoint(i), * navgs(i),delay(i),forFFTS(i), * sysdat(i),mwfdat(i),systim(i),mwftim(i) endif c if((j/10)*10.eq.j)write(4,'(1x)') c c...check for differences in time/date c if(systim(i).ne.mwftim(i))difftim=difftim+1 if(sysdat(i)(1: 2).ne.mwfdat(i)(1:2))diffday=diffday+1 read(sysdat(i)(4:5),'(i2)')mon if(mwfdat(i)(4:6).ne.monnam(mon))diffmon=diffmon+1 if(sysdat(i)(9:10).ne.mwfdat(i)(8:9))diffyer=diffyer+1 if(mwfdat(i).eq.'01 Jan 80')diff80=diff80+1 c 510 continue 504 format(1x,a,5x,f10.3,' -- ',f10.3,' MHz,',i8,i7,f8.1,f14.3, * 4x,a,2x,a,3x,a,2x,a) 524 format(1x,a,5x,f10.2,' -- ',f10.2,' MHz,',i8,i7,f8.1,f14.3, * 4x,a,2x,a,3x,a,2x,a) write(4,'(1x/i5,'' spectra listed''/)')nspec close(4) c write(*,'(1x/i5,'' spectra listed''/)')nspec write(*,'(1x,i5,'' differences in system/MWFTSBI time'')')difftim write(*,'(1x,i5,'' differences in system/MWFTSBI day '')')diffday write(*,'(1x,i5,'' differences in system/MWFTSBI month'')')diffmon write(*,'(1x,i5,'' differences in system/MWFTSBI year'')')diffyer write(*,'(1x,i5,'' MWFTSBI date = 01 Jan 80'')')diff80 c c------------------------------------------------------------------------ c c...Solicit to correct the unset date in the measuring computer, c equal to "01 Jan 80" in the recorded file c c This will be changed to the system date, which was to be assigned c externally c if(diff80.gt.0)then 561 write(*,560) 560 format(1x// * ' Do you want to correct ''01 Jan 80'' date (Y/N = 1/0) ? '/ * ' (first assign proper system date to such files)'// *, 2x,'.... ',$) read(*,'(i5)',err=561)i80corr if(i80corr.ne.1)goto 563 c write(*,'(1x)') do 564 j=1,nspec i=iwk(j) if(mwfdat(i).ne.'01 Jan 80')goto 564 c mwfold=mwfdat(i) mwfdat(i)(1:2)=sysdat(i)(1:2) ! day read(sysdat(i)(4:5),'(i2)')mon mwfdat(i)(4:6)=monnam(mon) ! month mwfdat(i)(8:9)=sysdat(i)(9:10) ! year c c...save system date of MWFTSBI file prior to any operations: LASTM contains c the packed time/date c ihandl=file$first dummy4=getfileinfoqq(name(i),fspecs,ihandl) lastm=fspecs%lastwrite c c...change year numbers in MWFTSBI file (but this operation changes c system date to current date) c open(2,file=name(i),access='DIRECT', * form='binary',recl=1,status='OLD') c kk=0 do 565 k=32,40 kk=kk+1 write(2'k)mwfdat(i)(kk:kk) 565 continue write(*,'(5x,a,5x,a,'' -> '',a)')name(i),mwfold, * mwfdat(i) close(2) c c...restore the original MWFTSBI system date c dummy4=setfiletimeqq(name(i),lastm) c 564 continue c endif c c------------------------------------------------------------------------ c c...Solicit to update the year digits in MWFTSBI files only if c no differences in day and month (difference in time allowed) c 563 if(nspec .ge.diffyer.and. * diffday.eq.0 .and. * diffmon.eq.0 .and. * nspec.gt.0 .and. diffyer.gt.0)then 531 write(*,530) 530 format(1x// * ' Do you want to correct MWFTSBI year (Y/N = 1/0) ? ',$) read(*,'(i5)',err=531)icorrect if(icorrect.ne.1)goto 541 c write(*,'(1x)') do 550 j=1,nspec i=iwk(j) if(sysdat(i)(9:10).eq.mwfdat(i)(8:9))goto 550 c c...save system date of MWFTSBI file prior to any operations: LASTM contains c the packed time/date c ihandl=file$first dummy4=getfileinfoqq(name(i),fspecs,ihandl) lastm=fspecs%lastwrite c c...change year numbers in MWFTSBI file (but this operation changes c system date to current date) c open(2,file=name(i),access='DIRECT', * form='binary',recl=1,status='OLD') c read(2'39)y1 read(2'40)y2 write(2'39)sysdat(i)(9:9) write(2'40)sysdat(i)(10:10) write(*,'(5x,a,5x,2a,'' -> '',a)')name(i), * y1,y2,sysdat(i)(9:10) close(2) c c...restore the original MWFTSBI system date c dummy4=setfiletimeqq(name(i),lastm) c 550 continue c endif c c------------------------------------------------------------------------ c c...Solicit to update the month+day+year in MWFTSBI files c (difference in time allowed) c 541 if(diffday.ne.0 .or. * diffmon.ne.0)then 571 write(*,570) 570 format(1x//' Do you want to correct the complete MWFTSBI ', * ' date (Y/N = 1/0) ?'/ * ' (first assign proper system date to such files)'// *, 2x,'.... ',$) read(*,'(i5)',err=571)icorrect if(icorrect.ne.1)goto 572 c write(*,'(1x)') do 573 j=1,nspec i=iwk(j) read(sysdat(i)(4:5),'(i2)')mon if(sysdat(i)(1:2).eq.mwfdat(i)(1:2).and. * mwfdat(i)(4:6).eq.monnam(mon) )goto 573 c mwfold=mwfdat(i) mwfdat(i)(1:2)=sysdat(i)(1:2) ! day read(sysdat(i)(4:5),'(i2)')mon mwfdat(i)(4:6)=monnam(mon) ! month mwfdat(i)(8:9)=sysdat(i)(9:10) ! year c c...save system date of MWFTSBI file prior to any operations: LASTM contains c the packed time/date c ihandl=file$first dummy4=getfileinfoqq(name(i),fspecs,ihandl) lastm=fspecs%lastwrite c c...change year numbers in MWFTSBI file (but this operation changes c system date to current date) c open(2,file=name(i),access='DIRECT', * form='binary',recl=1,status='OLD') c kk=0 do 575 k=32,40 kk=kk+1 write(2'k)mwfdat(i)(kk:kk) 575 continue write(*,'(5x,a,5x,a,'' -> '',a)')name(i),mwfold, * mwfdat(i) close(2) c c...restore the original MWFTSBI system date c dummy4=setfiletimeqq(name(i),lastm) c 573 continue c endif c c------------------------------------------------------------------------ C 572 stop c c...Error conditions c 503 write(*,533) 533 format(1x//' ERROR: Cannot open file SPECWG.LST'//) c 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------------------------------------------------------------------------