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------------------------------------------------------------------------