C____________________________________________________________________________ C C LISTCP - Listing of all IFPAN chirped pulse results C____________________________________________________________________________ C C Algorithm: C C 1. Generate a listing of .TRC.INF files created with the DIR C command C 2. Go through the listing and open every bona fide .INF file, C read its information and output a summary line to the ouput C LIST_FIDs.TXT file. C 2a. After reading the .INF file also open the .FID file and change C its sample entry (if undefined) from #00 to easily spotted C UNDEFINED string (for optional binary reediting). C Similarly deal with undefined COMENT, but note that this is C overwritted by FFTS C 3. Deal with the .FID file date+time: C a) if COMENT or SAMPLE entry has been modified then change c file date to that before editing c b) if file date is more than 5 minutes off the date internal c to the file (as for externally edited .FID) then change c to the internal date c c C Ver 20.10.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 21.12.13: Hacked out of FFTADD c 6.04.15: Listing of comments c 29.10.18: Renamed from FFTLST + mods c 14.08.22: correction of .FID header for spotting the sample field c 28.08.22: keep original .FID file date if header has been corrected c 2.09.22: recover and list internal time+date c 20.10.22: list also the SAMPLE string in LIST_FIDs.txt C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C use DFLIB use IFPORT c type (file$info)fspecs integer*4 dummy4,lastm c CHARACTER*200 line,filnam,filefid CHARACTER FDATEF*10,FTIMEF*8,outstr*20,coment*72,linout*120(1000), * kchar,strund*72,sample*20 BYTE kk integer*2 iyr,imon,iday,ihr,imin,isec integer*4 lecroydate,filedate real*8 totfid,taudel,taupin,taupout,fcent,arbswp c strund='undefined '// * ' ' c C C...WRITE THE HEADER INFORMATION C 155 FORMAT(1H+,A1,A) WRITE(*,156) 156 FORMAT(///1X,78(1H-)/' L I S T C P - Lister of chirped', * ' pulse FIDs'/ * 1x,78(1H-)/ * ' version 20.X.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 *.TRC.INF>spec.lst') OPEN(3,FILE='spec.lst',err=503) OPEN(4,FILE='LIST_FIDs.txt',status='UNKNOWN') nspec=0 nsample=0 ncoment=0 newdate=0 nlout=0 c cVolume in drive C has no label. cVolume Serial Number is 2049-076F c cDirectory of C:\rotprog\fftadd c c013/10/08 10:50 AM 10,000,190 F4_cb_00011.fid c013/10/08 10:50 AM 10,000,190 F4_cb_00012.fid c013/10/08 10:50 AM 10,000,190 F4_cb_00013.fid c013/10/08 10:50 AM 10,000,190 F4_cb_00014.fid c013/10/08 10:50 AM 10,000,190 F4_cb_00015.fid c013/10/08 10:50 AM 10,000,190 F4_cb_00016.fid c013/10/08 10:50 AM 10,000,190 F4_cb_00017.fid c013/10/08 10:56 AM 10,000,190 F4_cb_00018.fid c013/10/08 10:50 AM 10,000,190 F4_cb_00019.fid c013/10/08 10:50 AM 10,000,190 F4_cb_00020.fid c013/10/08 10:50 AM 10,000,190 F4_cb_00021.fid c013/10/08 10:48 AM 10,000,190 F4_cb_00022.fid c c cWolumin w stacji C to dysk_C cNumer seryjny woluminu: 18B3-BDCE c cKatalog: c:\FFT_chirped\H2Odimer\20131206 c c013-12-06 14:27 4ÿ501 F4_h2o2_00000.trc.inf c013-12-06 14:36 4ÿ501 F4_h2o2_00005.trc.inf c013-12-06 14:59 4ÿ501 F4_h2o2_00014.trc.inf c013-12-06 15:55 4ÿ501 F4_h2o2_00027.trc.inf c013-12-06 16:02 4ÿ501 F4_h2o2_00028.trc.inf c013-12-06 16:04 4ÿ501 F4_h2o2_00029.trc.inf c013-12-06 16:21 4ÿ501 F4_h2o2_00030.trc.inf c013-12-06 16:38 4ÿ501 F4_h2o2_00032.trc.inf c 8 plik(¢w) 36ÿ008 bajt¢w c 0 katalog(¢w) 606ÿ757ÿ421ÿ056 bajt¢w wolnych c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c Main file processing loop c c...Read a line from the directory file c read(3,'(a)',err=503)line read(3,'(a)',err=503)line read(3,'(a)',err=503)line read(3,'(a)',err=503)line c write(4,600)line(1:len_trim(line)) 600 format(1x,a//15x,'File F_cent +-Arb Naver IW', * ' Nmw tot_FID t_del t_Pin t_Pout time date'/) c write(*,'(1x/1x,a,a/)')' File fcent +-Arb', * ' Naver IW N_mw time date' c c _____beginning of loop reading the directory listing c | 501 read(3,'(a)',err=503,end=500)line if(line(1:1).eq.' ')goto 501 npos=len_trim(line) if(npos.lt.15)goto 501 if(line(npos-7:npos).ne.'.trc.inf')goto 501 C C...Attempt to read file name determined from the directory file entry C do 508 n=npos,1,-1 if(line(n:n).eq.' ')goto 509 508 continue 509 filnam=line(n+1:npos) if(len_trim(filnam).le.0)goto 501 c c write(*,'(1x,a)')FILNAM(1:len_trim(filnam)) n=len_trim(filnam) OPEN(2,FILE=FILNAM(1:len_trim(filnam)),status='old',ERR=501) c c _____beginning of loop through the .TRC.INF file c | c nspec=nspec+1 do 601 n=1,5 read(2,'(a)',err=503)line 601 continue outstr='TOTFID' read(line(42:54),*,err=1000)totfid totfid c read(2,'(a)',err=503)line outstr='MWPULS' read(line(42:54),*,err=1000)mwpuls mwpuls c read(2,'(a)',err=503)line outstr='TAUDEL' read(line(42:54),*,err=1000)taudel taudel c read(2,'(a)',err=503)line outstr='TAUPIN' read(line(42:54),*,err=1000)taupin taupin c read(2,'(a)',err=503)line outstr='TAUPOUT' read(line(42:54),*,err=1000)taupout taupout c read(2,'(a)',err=503)line iwait outstr='IWAIT' read(line(42:54),*,err=1000)iwait c read(2,'(a)',err=503)line read(2,'(a)',err=503)line outstr='FCENT' read(line(42:54),*,err=1000)fcent fcent c read(2,'(a)',err=503)line outstr='ARBSWP' read(line(42:54),*,err=1000)arbswp arbswp c 602 read(2,'(a)',err=503)line if(line(2:15).ne.'SWEEPS_PER_ACQ')goto 602 read(line(40:51),*,err=1000)naver naver c 603 read(2,'(a)',err=503)line if(line(2:25).ne.'TRIGGER_TIME: timestamp:')goto 603 fdatef=line(40:49) if(fdatef(6:6).eq.' ')fdatef(6:6)='0' if(fdatef(9:9).eq.' ')fdatef(9:9)='0' ftimef=line(52:59) if(ftimef(4:4).eq.' ')ftimef(4:4)='0' if(ftimef(7:7).eq.' ')ftimef(7:7)='0' c c...look for optional comment between two bottom lines of = characters c c By default an empty line is generated in TRC.INF file by WF735. c This can be filled in manually, and will then be used by FFTS c 1681 read(2,'(a)',err=503)line if(line(2:15).ne.'Point spacing ')goto 1681 read(2,'(a)',err=503)line coment='' read(2,'(a)',err=4565,end=4565)line if(len_trim(line).gt.0)read(line,'(a)')coment C 4565 CLOSE(2) ! TRC.INF file c c c...Also peek at the .FID file (note that byte number used on ACCESS='DIRECT' starts from 1 not 0) c C Binary file format byte by byte: I*2 words: byte number: C C COMENT character*72 36 0 C IDAY,IMON,IYEAR 3 * integer*2 3 72 C IHOUR,IMIN,ISEC 3 * integer*2 3 78 C LAMP character*6 3 84 = 735ZiA for .FID C VOLMIN,VOLMAX 2 * real*4 used to be VKMST,VKMEND 4 90,94 C GRID real*4 2 98 C SAMPLE character*20 10 102 C SAMPRE real*4 2 122 C GAIN,TIMEC,PHASE 3 * real*4 6 126 C SCANSP character*6 used by WF735 for NAVER 3 138 C PPS real*4 =PPS+500 in FREQLIN standard 2 144 C FRMOD,FRAMPL 2 * real*4 4 total=78 148,152 C C then either: C NPTS integer*2 always +ve 1 156 C ISMALL,ILARGE 2 * integer*2 these are I*4 internally 2 C or C -1 integer*2 1 156 C NPTS integer*4 +ve=2byte -ve=4byte spectral points 2 C C then either for +ve NPTS C ISPEC NPTS * integer*2 this is I*4 internally C or for -ve NPTS C ISPEC -NPTS * integer*4 C C FSTART,FEND,FINCR 3 * real*8 point f's determined by FSTART and FINCR C NCALPT integer*2 =0 ensuring backwards compatibility C c c c...save system date of the .FID file prior to any operations: LASTM contains c the packed time/date c c NOTE: if the .TRC .INF .FID files are generated by automatic conversion with WF735 c on kisiel2 and transferred to kisiel7 then their date/time are for the moment c of transfer. c This may differ from that internal in the .TRC file and as transferred c to the time/date field in the .FID file (differences will arise from c unsynchronised system times in kisil8/kisiel2/kisiel7. c lenfid=len_trim(filnam)-8 FILEFID=filnam(1:lenfid)//'.fid' c ihandl=file$first dummy4=getfileinfoqq(FILEFID(1:len_trim(filefid)),fspecs,ihandl) filedate=fspecs%lastwrite c c OPEN(7,FILE=FILEFID(1:len_trim(filefid)),access='DIRECT', * form='binary',recl=1,status='OLD') read(7'73)iday read(7'75)imon read(7'77)iyr read(7'79)ihr read(7'81)imin read(7'83)isec call packtimeqq(lecroydate,iyr,imon,iday,ihr,imin,isec) c write(*,'(6i6)')iyr,imon,iday,ihr,imin,isec debug c c...if file date differs by more than 5 minutes from the LeCroy date c internal to the .FID file then request the file date to be c updated to the LeCroy date c c iupdate=0 if(iabs(lecroydate-filedate).gt.300)then iupdate=1 filedate=lecroydate newdate=newdate+1 endif c c...if COMENT only has zero characters then replace it with a stub string c read(7'1)kk if(kk.eq.0)then ncoment=ncoment+1 ii=0 do 511 l=1,72 ii=ii+1 kchar=strund(ii:ii) write(7'l)kchar 511 continue iupdate=1 endif c c...if SAMPLE only has zero characters then replace it with a stub string c read(7'103)kk if(kk.eq.0)then nsample=nsample+1 ii=0 do 510 l=103,122 ii=ii+1 kchar=strund(ii:ii) write(7'l)kchar 510 continue iupdate=1 endif c read(7'103)sample c CLOSE(7) c c...if necessary restore either the original .FID system date or its c internal date c if(iupdate.ne.0)dummy4= * setfiletimeqq(FILEFID(1:len_trim(filefid)),filedate) c c c...output to LIST_FIDs.txt c write(4,605)filnam(1:len_trim(filnam)-8),fcent,arbswp,naver, * iwait,mwpuls,totfid,taudel,taupin,taupout, * ftimef,fdatef(9:10)//'.'//fdatef(6:7)//'.'//fdatef(1:4), * sample(1:len_trim(sample)) 605 format(a20,f10.2,f8.1,i8,2i5,f10.1,f8.1,2f6.1,2x,a,2x,a,3x,a) c if(len_trim(coment).ge.1)then nlout=nlout+1 write(linout(nlout),1683)filnam(1:len_trim(filnam)-8),fcent, * arbswp,naver,sample(1:len_trim(sample)), * coment(1:len_trim(coment)) 1683 format(a20,f10.2,f8.1,i8,':',2x,a,2x,a) endif c write(*,606)filnam(1:len_trim(filnam)-8), * fcent,arbswp,naver,iwait,mwpuls, * ftimef,fdatef(9:10)//'.'//fdatef(6:7)//'.'//fdatef(1:4) 606 format(1x,a,t22,f10.2,f8.1,i8,2i5,2x,a,2x,a) c goto 501 ! read next listing line c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C 500 close(3) c if(nlout.gt.0)then write(4,'(1x/)') do 1684 n=1,nlout write(4,'(a)')linout(n)(1:len_trim(linout(n))) 1684 continue endif close(4) fsys=systemqq('del spec.lst') c write(*,5000)nspec,ncoment,nsample,newdate 5000 format(1x/i12,' FIDs found in this directory'/ * i12,' FIDs given stub COMMENT descriptor'/ * i12,' FIDs given stub SAMPLE descriptor'/ * i12,' FIDs assigned internally saved date'// * 12x,' Press ENTER to continue ',$) c read(*,'(i5)',err=1002)i c 1002 stop c c...error conditions c 503 write(*,533) 533 format(1x//' ERROR: Cannot open file SPEC.LST'//) stop c 1000 write(*,1001)outstr(1:len_trim(outstr)),filnam(1:len_trim(filnam)) write(4,1001)outstr(1:len_trim(outstr)),filnam(1:len_trim(filnam)) 1001 format(' ERROR on reading ',a,' from: ',a) close(2) goto 501 c 1501 continue c end C C_____________________________________________________________________________ C_____________________________________________________________________________