c$DEBUG C_____________________________________________________________________________ C C SVIEW - DISPLAY AND MEASUREMENT PROGRAM FOR LINEARIZED SPECTRA C C Version 9.04.2001 ----- Zbigniew Kisiel ----- C 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 Modification history: C c 31.3.95: Elimination of crash on option XL for narrow spectra and of c crash on evaluation of peak frequency for level signal c 6.6.95: Change of peakfinder width with 0 not O C 31.8.95: Addition of safety features on input and .FRE compatibility c 26.11.95: Tweaking of screen refresh in LOOK c 11.02.97: As above C 9.06.97: Test for frequencies increasing from left to right C 27.03.01: gle output C 9.04.01: more general graphics and compilation C C---------------------------------------------------------------------------- C The program uses many nonstandard features of MS-FORTRAN 5.0, especially C the graphics which allows it to adapt to most common graphics cards. C On compilation source code FGRAPH.FI and FGRAPH.FD provided by Microsoft C has to be included. The object code resulting from this listing C has to be linked with following libraries: C GRAPHICS.LIB - MS graphics C ROT5 - routine INKEY C ANSI.SYS also has to be loaded. C C=========================================================================== C C...Initialization commands for graphics. The three structured C variables contain coordinates: C curpos.row and curpos.col - cursor coordinates (INTEGER*2) C ixy.xcoord and ixy.ycoord - pixel coordinates (INTEGER*2) C wxy.wx and wxy.wy - window coordinates (REAL*8) c c Uncomment the statements below (and in similar headers in routines c as necessary) MSF5 = MS Fortran 5.0 c PS1 and PS4 = MS Powerstation Fortrans 1.0 and 4.0 C INCLUDE 'FGRAPH.FI' MSF5+PS1 c INCLUDE 'FLIB.FI' PS1 INCLUDE 'FGRAPH.FD' MSF5+PS1 c USE MSFLIB PS4 C_____________________________________________________________________________ c PARAMETER (MAXPTS=32000) RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy C C...The code in the two INCLUDE files clashes with IMPLICIT statements - so C when using MSF5.0 graphics the recomendation is to type everything C explicitly (check with -4Yg compilation switch) C INTEGER*4 FREQs(MAXPTS) INTEGER*2 maxx,maxy,linofs,mymode,myrows,mycols,iflag INTEGER*4 blue,red REAL*8 FSTART,FEND,FINCR REAL*4 volts(MAXPTS) CHARACTER bold*4,normal*4 CHARACTER*80 toplin,emplin,paslin character*79 botlin c INTEGER*2 ISPEC(MAXPTS),NPTS,ISMALL,ILARGE, * IDAY,IMON,IYEAR,IHOUR,IMIN,ISEC REAL*4 VKMST,VKMEND,GRID,SAMPRE,GAIN,TIMEC,PHASE, 1 PPS,FRMOD,FRAMPL CHARACTER FILNAM*25,COMENT*72,LAMP*6,SCANSP*6,SAMPLE*20, * COM1*72 c COMMON /SPECR/volts COMMON /SPEC/ISPEC,NPTS,ISMALL,ILARGE COMMON /FRE/FREQS COMMON /limits/maxx,maxy,linofs,curpos,ixy,wxy, * mymode,myrows,mycols,blue,red COMMON /INFO/COMENT,IDAY,IMON,IYEAR,IHOUR,IMIN,ISEC, 1 LAMP,VKMST,VKMEND,GRID,SAMPLE,SAMPRE,GAIN,TIMEC,PHASE, 1 SCANSP,PPS,FRMOD,FRAMPL COMMON /lines/toplin,emplin,paslin,botlin COMMON /FNAM/FILNAM COM1=' ----- FREQUENCY LINEARIZED SPECTRUM -----' c C C...HEADING C WRITE(BOLD,'(A1,''[1m'')')CHAR(27) WRITE(NORMAL,'(A1,''[0m'')')CHAR(27) WRITE(*,155)CHAR(27),'[2J' WRITE(*,155)CHAR(27),'[7m' 155 FORMAT(1H+,A1,A) WRITE(*,156) 156 FORMAT(1X,78(1H )/' S V I E W - Viewer for frequency ', * 'linearised spectra '/ * 1X,78(1H )/1x,78(1H_)/ * ' version 5.04.2001',T64,'Zbigniew KISIEL ') WRITE(*,155)CHAR(27),'[0m' c WRITE(emplin,'(80(1H ))') 1 format(i5) C C...Input of a stored spectrum C 503 WRITE(*,'(1X//'' NAME OF DATA FILE ? ''\)') READ(*,'(A)',ERR=503)FILNAM OPEN(2,FILE=FILNAM,FORM='BINARY',STATUS='OLD',ERR=503) READ(2,ERR=503,END=503)COMENT,IDAY,IMON,IYEAR,IHOUR,IMIN,ISEC, 1 LAMP,VKMST,VKMEND,GRID,SAMPLE,SAMPRE,GAIN,TIMEC,PHASE, 1 SCANSP,PPS,FRMOD,FRAMPL READ(2)NPTS,ISMALL,ILARGE C WRITE(*,155)CHAR(27),'[2J' WRITE(*,'(1H+,A1,''[7m'',2X,A72,2X,A1,''[0m''/)')CHAR(27), 1 COMENT,CHAR(27) WRITE(*,'('' Time and Date: '',A4,I2,'':'',I2,'':'', 1 I2,'', '',I2,''/'',I2,''/'',I4,A4)')BOLD,IHOUR,IMIN,ISEC, 1 IDAY,IMON,IYEAR,NORMAL WRITE(*,'(1X/'' Lamp: '',A4,A,A4)') 1 BOLD,LAMP,NORMAL WRITE(*,'('' Vkm limits /mV: '',A4,F8.2,''-'', 1 F8.2,A4)')BOLD,VKMST,VKMEND,NORMAL WRITE(*,'('' Grid /V: '',A4,F6.1,A4)') 1 BOLD,GRID,NORMAL WRITE(*,'(1X/'' Sample: '',A4,A,A4)') 1 BOLD,SAMPLE,NORMAL WRITE(*,'('' Sample pressure /mTorr: '',A4,F6.1,A4)') 1 BOLD,SAMPRE,NORMAL WRITE(*,'(1X/'' Gain /mV: '',A4,F6.1,A4)') 1 BOLD,GAIN,NORMAL WRITE(*,'('' Time constant /s: '',A4,F6.3,A4)') 1 BOLD,TIMEC,NORMAL WRITE(*,'('' Phase /deg: '',A4,F6.1,A4)') 1 BOLD,PHASE,NORMAL WRITE(*,'('' SIPƒOW scan speed: '',A4,A,A4)') 1 BOLD,SCANSP,NORMAL WRITE(*,'('' Points per second: '',A4,F7.2,A4)') 1 BOLD,PPS,NORMAL WRITE(*,'(1X/'' Modulation freq. /KHz: '',A4,F8.3,A4)') 1 BOLD,FRMOD,NORMAL WRITE(*,'('' Modulation ampl. /mV: '',A4,F6.1,A4)') 1 BOLD,FRAMPL,NORMAL WRITE(*,'(1X/1X,A4,I5,A4,'' points, ranging from'' 1 ,A4,I6,A4,'' to'',A4,I6,A4)')BOLD,NPTS,NORMAL,BOLD, 1 ISMALL,NORMAL,BOLD,ILARGE,NORMAL C if(npts.gt.maxpts)then write(*,'(1x//1x,i5,'' points in spectrum which exceeds'', * '' present maximum of '',i5//)')npts,maxpts stop endif DO 20 N=1,NPTS READ(2,ERR=494)ISPEC(N) 20 CONTINUE c goto 495 494 write(*,'(1x//'' PROBLEMS WITH INPUT OF INTENSITIES at pt. '', * i5//)')n stop 495 continue C IF(COMENT.EQ.COM1.OR.PPS.GT.50.)THEN READ(2)FSTART,FEND,FINCR WRITE(*,'('' Frequency from '',A4,F9.2,A4,'' to '',A4,F9.2, 1 A4,'' MHz'')')BOLD,FSTART,NORMAL,BOLD,FEND,NORMAL C IF(FEND.LE.FSTART.or.fincr.lt.0.d0)THEN WRITE(*,'(1x//'' PROBLEMS WITH FREQUENCY LIMITS - correct'', * '' with MODSPE''//)') STOP ENDIF C DO 4566 N=1,NPTS FREQS(N)=(FSTART+(N-1)*FINCR)*1000.D0 4566 CONTINUE IF(MAXX.EQ.0)MAXX=640 IF(NPTS.LT.MAXX)THEN DO 4596 N=NPTS+1,MAXX FREQS(N)=(FSTART+(N-1)*FINCR)*1000.D0 ISPEC(N)=ISPEC(NPTS) 4596 CONTINUE NPTS=MAXX ENDIF FEND=FREQs(MAXX)*0.001D0 GOTO 4565 ENDIF pause C 4565 CLOSE(2) C C C...Scaling and plot C 500 IF(ISMALL.EQ.ILARGE)THEN WRITE(*,'(1X/'' ****ERROR, zero dynamic range in data'', * A/)')CHAR(7) GOTO 1410 ENDIF CALL LOOKFM C 1410 WRITE(*,'(1X/10X,''0 = EXIT''/10X,''1 = another spectrum'' 1 /10X,''2 = another look at the last spectrum'',10X, 2 ''..... ''\)') READ(*,1,ERR=1410)IFLAG IF(IFLAG.EQ.1)GOTO 503 IF(IFLAG.EQ.2)GOTO 500 C 530 stop end C C------------------------------------------------------------------------ C SUBROUTINE graphicsmode() C C This sets the required graphics mode card. It also C determines the pixel limits on x and y axes (0,maxx), (0,maxy) C INCLUDE 'FGRAPH.FD' MSF5+PS1 c USE MSFLIB PS4 C RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy INTEGER*2 dummy,maxx,maxy,mymode,myrows,mycols,linofs integer*4 dummy4,blue,red RECORD /videoconfig/myscreen COMMON /limits/maxx,maxy,linofs,curpos,ixy,wxy, * mymode,myrows,mycols,blue,red C C...Determine current graphics mode. C CALL getvideoconfig(myscreen) C C...Set graphics mode C C...this setting was preferred until graphics cards started showing c it as a ribbon narrower than screen height (640*350 and 25*80 chars. EGA) c mymode=$ERESCOLOR c myrows=25 C C...this setting should have widest compatibility (640*480, 30*80 chars. VGA) c (the 16 color mode usually delivers faster scrolling) c mymode=$VRES256COLOR mymode=$VRES16COLOR myrows=30 C C...this is for 800*600, 37*100 chars. SVGA which is available only for MFPS c (the 256 color mode experiences problems with some cards) c mymode=$SRES256COLOR c mymode=$SRES16COLOR c myrows=37 c dummy = setvideomoderows ( mymode, myrows ) myrows=dummy if(myrows.ne.25.and.myrows.ne.30.and.myrows.ne.37)then write(*,'(1x//i5,a,a//)')myrows, * ' <--- this is the number of text lines in this mode', * ' and it is not yet supported' pause endif C IF( dummy .EQ. 0 ) STOP 'Error: cannot set graphics mode' C C...Determine parameters of the graphics mode that is being used C CALL getvideoconfig( myscreen ) maxx = myscreen.numxpixels - 1 maxy = myscreen.numypixels - 1 linofs=nint(real(maxy)/real(myrows)) mycols = myscreen.numtextcols if(mycols.lt.80)then write(*,'(1x//i5,a,a//)')myrows, * ' <--- this is the number of text columns in this mode', * ' and it is too small' pause endif c c...patch for different use of SETBKCOLOR by MSPS4.0 from MSPS1.0 (and MSF5) c blue=$BLUE red=$RED if($BLUE.ne.#2a0000)then blue=1 red=4 endif c dummy4 = setbkcolor( BLUE ) call clearscreen($GCLEARSCREEN) C RETURN END C C------------------------------------------------------------------------ C SUBROUTINE LOOKFM C C Plot of spectrum with scrolling along the C X-axis and zooming along both the X and Y axes C C - ISPEC() contains the raw spectrum C - FREQS() contains the raw frequencies (INTEGER*4) C - ISCRN() contains a screen of transformed spectrum C - ISCRNF() contains a screen of transformed frequencies (INTEGER*4) C - IPSCRN() is a buffer for numerical transformations of ISCRN C - IPSCRF() is a buffer for numerical transformations of ISCRNF (INTEGER*4) C - ISC is a pointer to whether currently displayed spectrum is from ISPEC() C or from ISCRN() C INCLUDE 'FGRAPH.FD' MSF5+PS1 c USE MSFLIB PS4 C LOGICAL*2 true PARAMETER (MAXPTS=32000,TRUE=.TRUE.) RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy INTEGER*1 MARK [ALLOCATABLE] (:) INTEGER*1 COLUMN [ALLOCATABLE] (:) INTEGER*1 ROW [ALLOCATABLE] (:) INTEGER*2 ISCRN(722),IPSCRN(722) INTEGER*2 II,NE,IK,IR,NSTART,NP,ISC,NS,IX,NCEN,N,I, * NEND,IFIN,IST,NEXP,NFIT,IYCUT,IBASE INTEGER*2 maxx,maxy,linofs,mymode,myrows,mycols INTEGER*4 blue,red INTEGER*2 ISPEC(MAXPTS),NPTS,ISMALL,ILARGE,dummy, * inkey,NHORPT,NHOR2,NSPLIN INTEGER*4 INTERM,imsize,FREQS(MAXPTS),ISCRf(725), * IPSCRf(725),dummy4 REAL*8 RSMALL,RLARGE,RMBOT,RMTOP,RANGE,YMAX,YMIN, * YSTEP,YLEVEL,HTMARK,FINTERM,RATIOM,CURBOT,CURTOP REAL*8 X(1000),Y(1000),A(1000),B(1000),C(1000),D(1000), * GRA,CA,GRB,CB REAL*8 XFIT(50),YFIT(50),XPEAK,ERRORX REAL*8 YSHIFT,YYSTEP,RRSMAL,RSPEC REAL*8 F1,F2 CHARACTER OUTSTR*21,FILNAM*25,STAT*7,CHARFL CHARACTER*80 toplin,emplin,paslin,FREQLIN character*79 botlin C COMMON /FRE/FREQS COMMON /limits/maxx,maxy,linofs,curpos,ixy,wxy, * mymode,myrows,mycols,blue,red COMMON /SPEC/ISPEC,NPTS,ISMALL,ILARGE COMMON /lines/toplin,emplin,paslin,botlin COMMON /SPL/NSPLIN,X,Y,A,B,C,D,GRA,CA,GRB,CB COMMON /FRFIT/XFIT,YFIT COMMON /FNAM/FILNAM COMMON /plotda/RSMALL,RLARGE,RRSMAL,YYSTEP,YSHIFT C NFIT=7 RATIOM=1.1 RSMALL=ISMALL RLARGE=ILARGE WRITE(botlin,601) 601 FORMAT('A<-S Z<-W K<-L ', * ' H=help ') C 155 WRITE(*,'(/1x,A1,''Ready to plot - press ENTER ''\)')CHAR(7) 900 READ(*,'(I5)',ERR=900)I C C C...Plot of spectrum from ISPEC() C CALL graphicsmode() dummy4 = setbkcolor( BLUE ) NHORPT=maxx+1 NHOR2=NHORPT/2 NSTART=1 NEND=NHORPT MARKER=NHOR2 IF(NPTS.LT.NEND)NEND=NPTS C C...definition of graphics viewport C (note that pixel origin is now at absolute {0,2*LINOFS+1}) C call setviewport(0,2*LINOFS+1,maxx,maxy-LINOFS-1) YYSTEP=1.d0/DBLE(maxy-(3*linofs+2)-28)*(RLARGE-RSMALL) RRSMAL=RSMALL-28.D0*YYSTEP dummy=setwindow(TRUE,0.0d0,RRSMAL, * DBLE(maxx),RLARGE) c C...dotted cursor bar, horizontal and vertical lines used in Y and X scaling c $NODEBUG CALL setlinestyle(#9999) $DEBUG htmark=(RLARGE-RSMALL)/RATIOM RMBOT=RSMALL RMTOP=RMBOT+htmark CALL moveto_w(DBLE(MARKER),RMBOT,wxy) dummy=lineto_w(DBLE(MARKER),RMTOP) imsize=imagesize_w(DBLE(MARKER),RMTOP,DBLE(MARKER),RMBOT) ALLOCATE (MARK(imsize)) CALL getimage_w(DBLE(MARKER),RMTOP,DBLE(MARKER),RMBOT,MARK) call putimage_w(DBLE(MARKER),RMTOP,MARK,$GXOR) $NODEBUG CALL setlinestyle(#AAAA) $DEBUG CALL moveto_w(0.0D0,RMTOP,wxy) dummy=lineto_w(DBLE(maxx),RMTOP) imsize=imagesize_w(0.0D0,RMTOP,DBLE(maxx),RMTOP) ALLOCATE (ROW(imsize)) CALL getimage_w(0.0D0,RMTOP,DBLE(maxx),RMTOP,ROW) call putimage_w(0.0D0,RMTOP,ROW,$GXOR) C CALL moveto_w(0.0D0,RSMALL,wxy) dummy=lineto_w(0.0D0,RLARGE) imsize=imagesize_w(0.0D0,RLARGE,0.0D0,RSMALL) ALLOCATE (COLUMN(imsize)) CALL getimage_w(0.0D0,RLARGE,0.D0,RSMALL,COLUMN) call putimage_w(0.0D0,RLARGE,COLUMN,$GXOR) C C C...bottom information line 333 dummy=SETTEXTCOLOR(7) CALL settextposition(myrows,1,curpos) CALL outtext(botlin) DUMMY=SETTEXTCOLOR(14) CALL settextposition(myrows,45,curpos) CALL outtext(filnam) DUMMY=SETTEXTCOLOR(7) C C...Refresh display: first declare floating point bounds for graphics c and clear screen C 33 YYSTEP=1.d0/DBLE(maxy-(3*linofs+2)-28)*(RLARGE-RSMALL) RRSMAL=RSMALL-28.D0*YYSTEP dummy=setwindow(TRUE,0.0d0,RRSMAL,DBLE(maxx),RLARGE) $NODEBUG CALL setlinestyle(#FFFF) $DEBUG CALL clearscreen($GVIEWPORT) c c...box c YSHIFT=RSMALL-5.d0*YYSTEP CALL moveto_w(0.0D0,RLARGE,wxy) dummy=lineto_w(0.0D0,YSHIFT) dummy=lineto_w(DBLE(maxx),YSHIFT) dummy=lineto_w(DBLE(maxx),RLARGE) dummy=lineto_w(0.0d0,RLARGE) c c...spectrum c IX=0 CALL moveto_w(DBLE(IX),DBLE(ISPEC(NSTART)),wxy) DO 6 I=NSTART+1,NEND RSPEC=DBLE(ISPEC(I)) IF(RSPEC.LT.RSMALL)RSPEC=RSMALL dummy=lineto_w(DBLE(IX),RSPEC) IX=IX+1 6 CONTINUE ISC=0 C c...add the cursor bar C htmark=(RLARGE-RSMALL)/RATIOM RMBOT=ISPEC(NSTART+MARKER) RMBOT=RMBOT-htmark/2.D0 IF(RMBOT.LT.RSMALL)RMBOT=RSMALL IF(RMBOT.GT.RLARGE-htmark)RMBOT=RLARGE-htmark RMTOP=RMBOT+htmark call putimage_w(DBLE(MARKER),RMTOP,MARK,$GXOR) C C...Frequency marker scale, first determine markers: RM=marker spacing, C FRMARK=frequency of first marker C F1=FREQS(NSTART)*0.001D0 F2=FREQS(NEND)*0.001D0 777 call marsca(f1,f2) C C...reset X-axis of floating point window to pixel units C dummy=setwindow(TRUE,0.0d0,RRSMAL, * DBLE(maxx),RLARGE) C c c.....O P T I O N S L O O P c c...update the two top of screen information lines c 77 DUMMY=SETTEXTCOLOR(7) IF(ISC.EQ.0)THEN WRITE(toplin,600)NSTART,NEND,INT(RSMALL),INT(RLARGE), * NSTART+MARKER,DBLE(FREQS(NSTART+MARKER))*0.001D0 600 FORMAT('X:',2I6,3X,'Y:',2I7,13X,'Cursor at: ',I5,3X, * F10.3,' MHz ') ELSE INTERM=IST+MARKER*(REAL(IFIN-IST)/(NP-1)) WRITE(toplin,600)IST,IFIN,INT(RSMALL),INT(RLARGE),INTERM, * DBLE(ISCRF(1+MARKER))*0.001D0 ENDIF CALL settextposition(1,1,curpos) CALL outtext(toplin) CALL settextposition(2,1,curpos) CALL outtext(emplin) DUMMY=SETTEXTCOLOR(15) C C Options: A,S - shift screen window over the spectrum C W,Z - increase, decrease vertical scale C X - X axis zoom, to be followed by 2-9 for compression or L C for 2x expansion C Y - Y axis zoom, to be followed by setting of upper and lower C limits with W,Z - each terminated with ENTER C K,L - move cursor over the spectrum C , - center/quarter cursor C - move to beginning/end of spectrum C H - display HELP screen C R - restore initial screen C O,0 - frequency of the line peak selected by cursor C C - toggle display of information lines C 7 IK=INKEY(N) KK=CHAR(IK) IF(KK.EQ.'A'.OR.KK.EQ.'a')GOTO 36 IF(KK.EQ.'S'.OR.KK.EQ.'s')GOTO 35 IF(KK.EQ.'X'.OR.KK.EQ.'x')GOTO 50 IF(KK.EQ.'Y'.OR.KK.EQ.'y')GOTO 51 IF(KK.EQ.'K'.OR.KK.EQ.'k')GOTO 710 IF(KK.EQ.'L'.OR.KK.EQ.'l')GOTO 711 IF(KK.EQ.',')GOTO 750 IF(KK.EQ.'W'.OR.KK.EQ.'w')GOTO 800 IF(KK.EQ.'Z'.OR.KK.EQ.'z')GOTO 820 IF(KK.EQ.'H'.OR.KK.EQ.'h')GOTO 630 IF(KK.EQ.'O'.OR.KK.EQ.'o'.OR.KK.EQ.'0')GOTO 901 IF(KK.EQ.'G'.or.KK.eq.'g')then call clearscreen($GCLEARSCREEN) call gleout GOTO 333 ENDIF C IF(KK.EQ.'R'.OR.KK.EQ.'r')THEN RSMALL=ISMALL RLARGE=ILARGE IF(ISC.EQ.1)GOTO 104 GOTO 33 ENDIF C IF(IK.EQ.-71)THEN NSTART=1 NEND=NSTART+maxx IF(NEND.GT.NPTS)NEND=NPTS GOTO 33 ENDIF C IF(IK.EQ.-79)THEN NEND=NPTS NSTART=NEND-maxx IF(NSTART.LT.1)NSTART=1 GOTO 33 ENDIF IF(IK.NE.13)GOTO 7 C C...exit C CALL settextposition(2,1,curpos) CALL outtext(emplin) CALL settextposition(1,1,curpos) CALL outtext(emplin) DUMMY=SETTEXTCOLOR(15) dummy4 = setbkcolor( RED ) WRITE(OUTSTR,'(A)')'ARE YOU SURE ?' CALL settextposition(1,1,curpos) CALL outtext(outstr(1:14)) CALL settextposition(1,20,curpos) WRITE(*,'(1X,A1,$)')CHAR(7) 916 IK=INKEY(N) KK=CHAR(IK) IF(KK.EQ.'Y'.OR.KK.EQ.'y')GOTO 915 IF(KK.NE.'N'.AND.KK.NE.'n')GOTO 916 C DUMMY=SETTEXTCOLOR(7) dummy4 = setbkcolor( BLUE ) CALL settextposition(1,1,curpos) CALL outtext(toplin) GOTO 7 C 915 DEALLOCATE(MARK) DEALLOCATE(COLUMN) DEALLOCATE(ROW) dummy=setvideomode($DEFAULTMODE) GOTO 37 C C...Shift screen window to right of spectrum (with S) C 35 NE=NEND+NHOR2 IF(KK.EQ.'s')NE=NEND+50 IF(NE.GT.NPTS)NE=NPTS NEND=NE NSTART=NEND-maxx IF(NSTART.LT.1)NSTART=1 GOTO 33 C C...Shift screen window to left of spectrum (with A) C 36 NS=NSTART-NHOR2 IF(KK.EQ.'a')NS=NSTART-50 IF(NS.LT.1)NS=1 NSTART=NS NEND=NSTART+maxx IF(NEND.GT.NPTS)NEND=NPTS GOTO 33 C C...Shift cursor to the left (with K) C 710 call putimage_w(DBLE(MARKER),RMTOP,MARK,$GXOR) MARKER=MARKER-8 IF(KK.EQ.'k')MARKER=MARKER+7 IF(MARKER.LT.0)MARKER=0 C 719 IF(ISC.EQ.1)GOTO 177 RMBOT=ISPEC(NSTART+MARKER) RMBOT=RMBOT-htmark/2.D0 IF(RMBOT.LT.RSMALL)RMBOT=RSMALL IF(RMBOT.GT.RLARGE-htmark)RMBOT=RLARGE-htmark RMTOP=RMBOT+htmark call putimage_w(DBLE(MARKER),RMTOP,MARK,$GXOR) GOTO 77 C C...Shift cursor to the right (with L) C 711 call putimage_w(DBLE(MARKER),RMTOP,MARK,$GXOR) MARKER=MARKER+8 IF(KK.EQ.'l')MARKER=MARKER-7 IF(MARKER.GT.maxx)MARKER=maxx GOTO 719 C C...Center cursor, on second keypress move the cursor into the center of the C opposite screenhalf C 750 call putimage_w(DBLE(MARKER),RMTOP,MARK,$GXOR) IF(MARKER.EQ.maxx/2)THEN IF(LAST.LT.MAXX/2)MARKER=0.75*MAXX IF(LAST.GT.MAXX/2)MARKER=0.25*MAXX LAST=MAXX/2 GOTO 719 ENDIF LAST=MARKER MARKER=maxx/2 GOTO 719 C C...Y axis zoom C 51 YSTEP=(RLARGE-RSMALL)/(maxy-(3*LINOFS+2)-48) YLEVEL=RLARGE-0.1*(RLARGE-RSMALL) CALL putimage_w(0.0D0,YLEVEL,ROW,$GXOR) dummy=0 CALL settextposition(1,1,curpos) WRITE(toplin,955)YLEVEL CALL outtext(toplin) C 60 IK=INKEY(I) KK=CHAR(IK) IF(KK.EQ.'W'.OR.KK.EQ.'w'.OR.KK.EQ.'Z'.OR.KK.EQ.'z')GOTO 61 IF(IK.EQ.13)GOTO 63 GOTO 60 C C...cursor line to top of screen with W, to bottom with Z C (upper case letters give fast shift, lower case slow shift) 61 ISTEP=8 IF(KK.EQ.'w'.OR.KK.EQ.'z')ISTEP=1 IF(KK.EQ.'Z'.OR.KK.EQ.'z')ISTEP=-ISTEP CALL putimage_w(0.0D0,YLEVEL,ROW,$GXOR) YLEVEL=YLEVEL+ISTEP*YSTEP IF(YLEVEL.LT.RSMALL)YLEVEL=RSMALL IF(YLEVEL.GT.RLARGE)YLEVEL=RLARGE CALL putimage_w(0.0D0,YLEVEL,ROW,$GXOR) CALL settextposition(1,1,curpos) WRITE(toplin,955)YLEVEL 955 FORMAT('Y level: ',F8.0) CALL outtext(toplin) GOTO 60 C 63 IF(dummy.EQ.0)THEN dummy=1 YMAX=YLEVEL YLEVEL=RSMALL+0.1*(RLARGE-RSMALL) CALL putimage_w(0.0D0,YLEVEL,ROW,$GXOR) CALL settextposition(1,1,curpos) WRITE(toplin,955)YLEVEL CALL outtext(toplin) GOTO 60 ENDIF C YMIN=YLEVEL IF(YMAX.LE.YMIN)GOTO 76 RLARGE=YMAX RSMALL=YMIN IF(ISC.EQ.0)GOTO 33 GOTO 104 C C...Y axis compression C 800 IF(kk.eq.'W')THEN smult=-0.25 ELSE smult=-0.05 ENDIF goto 810 C C...Y axis expansion C 820 IF(kk.eq.'Z')THEN smult=0.25 ELSE smult=0.05 ENDIF 810 RANGE=RLARGE-RSMALL RLARGE=RLARGE+RANGE*smult RSMALL=RSMALL-RANGE*smult IF(ISC.EQ.1)GOTO 104 GOTO 33 C C...X axis transformations C 50 NCEN=NSTART/2+NEND/2 53 IK=INKEY(I) IF(IK.EQ.0)GOTO 53 KK=CHAR(IK) IF(KK.EQ.'L'.OR.KK.EQ.'l')GOTO 100 IF(IK.GE.50.AND.IK.LE.57)GOTO 54 GOTO 76 C C ..... compression of the X axis (up to nine times - by adding up C the required number of consecutive points) 54 IK=IK-48 IR=NHORPT*IK IST=NCEN-IR/2 IF(IST.LT.1)IST=1 IFIN=IST+IR IF(IFIN.GT.NPTS)THEN IFIN=NPTS IST=IFIN-IR IF(IST.LT.1)IST=1 ENDIF 370 IF(ISC.EQ.1)GOTO 170 C 170 NP=0 II=0 INTERM=0 FINTERM=0. DO 56 N=IST,IFIN II=II+1 INTERM=INTERM+ISPEC(N) FINTERM=FINTERM+FREQS(N) IF(II.LT.IK)GOTO 56 NP=NP+1 ISCRN(NP)=INTERM/IK ISCRF(NP)=FINTERM/IK II=0 INTERM=0 FINTERM=0. 56 CONTINUE GOTO 104 C C ...... two times expansion of the X axis (using interpolation with C Newton's formula up to second differences -IPSCRN() is used C for temporary storage of points and differences) 100 IF(ISC.EQ.0)THEN I=0 DO 111 N=NSTART,NEND I=I+1 ISCRN(I)=ISPEC(N) ISCRF(I)=FREQS(N) 111 CONTINUE NP=I IST=NSTART IFIN=NEND ENDIF C C...determine the region to be magnified, window moved Left,Right with C A,S resp., capitals give a faster shift, termination with ENTER NL=NHOR2/2 NR=NL+NHOR2 call putimage_w(DBLE(NL),RLARGE,COLUMN,$GXOR) call putimage_w(DBLE(NR),RLARGE,COLUMN,$GXOR) C 1 IK=INKEY(I) KK=CHAR(IK) IF(KK.EQ.'A'.OR.KK.EQ.'a')GOTO 2 IF(KK.EQ.'S'.OR.KK.EQ.'s')GOTO 3 IF(IK.EQ.13)GOTO 4 GOTO 1 C 2 ISHIFT=-8 IF(KK.EQ.'a')ISHIFT=-1 GOTO 5 3 ISHIFT=8 IF(KK.EQ.'s')ISHIFT=1 C 5 call putimage_w(DBLE(NL),RLARGE,COLUMN,$GXOR) call putimage_w(DBLE(NR),RLARGE,COLUMN,$GXOR) NL=NL+ISHIFT NR=NR+ISHIFT IF(NL.LT.0)THEN NL=0 NR=NL+NHOR2 ENDIF IF(NR.GT.maxx)THEN NR=maxx NL=NR-NHOR2 ENDIF call putimage_w(DBLE(NL),RLARGE,COLUMN,$GXOR) call putimage_w(DBLE(NR),RLARGE,COLUMN,$GXOR) GOTO 1 4 call putimage_w(DBLE(NL),RLARGE,COLUMN,$GXOR) call putimage_w(DBLE(NR),RLARGE,COLUMN,$GXOR) C C...expand the selected region c NL,NR - limits of window in ISCRN operated on c IST,IFIN - limits of window in ISPEC operated on c NEXP - expansion multiplier c NEXP=NINT(REAL(NHORPT)/(IFIN-IST)) IF(NEXP.EQ.0.AND.IR.NE.0)NEXP=NINT(REAL(IR)/(IFIN-IST)) IF(NEXP.EQ.0)GOTO 33 IST=IST+NL/NEXP IFIN=IST+NHOR2/NEXP I=0 DO 102 N=NL+1,NR-1 I=I+1 IPSCRN(I+NHOR2)=ISCRN(N) INTERM=ISCRN(N+1)-ISCRN(N) IPSCRF(I+NHOR2)=ISCRF(N) FINTERM=ISCRF(N+1)-ISCRF(N) IF(INTERM.LT.-32000)INTERM=-32000 IF(INTERM.GT.32000)INTERM=32000 IF(FINTERM.LT.-1200000000.)FINTERM=-1200000000. IF(FINTERM.GT.1200000000.)FINTERM=1200000000. IPSCRN(I)=INTERM IPSCRF(I)=FINTERM 102 CONTINUE I=0 DO 103 N=2,maxx,2 I=I+1 ISCRN(N-1)=IPSCRN(I+NHOR2) INTERM=ISCRN(N-1)+0.5*IPSCRN(I)-0.125*IPSCRN(I+1)+ * 0.125*IPSCRN(I) ISCRF(N-1)=IPSCRF(I+NHOR2) FINTERM=ISCRF(N-1)+0.5*IPSCRF(I)-0.125*IPSCRF(I+1)+ * 0.125*IPSCRF(I) IF(INTERM.LT.-32000)INTERM=-32000 IF(INTERM.GT.32000)INTERM=32000 IF(FINTERM.LT.-1200000000.)FINTERM=-1200000000. IF(FINTERM.GT.1200000000.)FINTERM=1200000000. ISCRN(N)=INTERM ISCRF(N)=FINTERM 103 CONTINUE ISCRN(maxx)=IPSCRN(NHORPT) ISCRF(maxx)=IPSCRF(NHORPT) NP=maxx C C...Scale and plot the processed screen in ISCRN() C - this is necessary for X axis compression and zoom which remain C in action until A and S are used. Thus Y axis operations are possible C on X-processed spectrum C 104 YYSTEP=1.d0/DBLE(maxy-(3*linofs+2)-28)*(RLARGE-RSMALL) RRSMAL=RSMALL-28.D0*YYSTEP dummy=setwindow(TRUE,0.0d0,RRSMAL, * DBLE(maxx),RLARGE) CALL clearscreen($GVIEWPORT) YSHIFT=RSMALL-5.d0*YYSTEP c c...box c CALL moveto_w(0.0D0,RLARGE,wxy) dummy=lineto_w(0.0D0,YSHIFT) dummy=lineto_w(DBLE(maxx),YSHIFT) dummy=lineto_w(DBLE(maxx),RLARGE) dummy=lineto_w(0.0d0,RLARGE) c c...spectrum C IX=0 RSPEC=DBLE(ISCRN(1)) IF(RSPEC.LT.RSMALL)RSPEC=RSMALL CALL moveto_w(DBLE(IX),RSPEC,wxy) DO 58 I=2,NP-1 RSPEC=DBLE(ISCRN(I)) IF(RSPEC.LT.RSMALL)RSPEC=RSMALL dummy=lineto_w(DBLE(IX),RSPEC) IX=IX+1 58 CONTINUE ISC=1 C C...bottom information line dummy=SETTEXTCOLOR(7) CALL settextposition(myrows,1,curpos) CALL outtext(botlin) DUMMY=SETTEXTCOLOR(14) CALL settextposition(myrows,45,curpos) CALL outtext(filnam) DUMMY=SETTEXTCOLOR(7) C C...information for marker scale, add cursor and update of top C two information lines c F1=iscrf(1)*0.001D0 F2=iscrf(np-1)*0.001D0 C 177 htmark=(RLARGE-RSMALL)/RATIOM RMBOT=ISCRN(1+MARKER) RMBOT=RMBOT-htmark/2.D0 IF(RMBOT.LT.RSMALL)RMBOT=RSMALL IF(RMBOT.GT.RLARGE-htmark)RMBOT=RLARGE-htmark RMTOP=RMBOT+htmark call putimage_w(DBLE(MARKER),RMTOP,MARK,$GXOR) C GOTO 777 C C...Peak frequencies: O,o - frequency of transition underneath the cursor C 0 - set number of points for fitting, on -ve number C execute PEAKFINDER C 901 IF(KK.EQ.'0')THEN CALL clearscreen($GCLEARSCREEN) 902 WRITE(*,905)NFIT 905 FORMAT(1X/' Current no. of points for fitting lineshape: ',I2/ * ' New number (odd, -ve for PEAKFINDER): ',$) READ(*,'(I5)',ERR=902)I IF(ABS(I).LT.5.OR.ABS(I).GT.49)GOTO 902 IF(ABS(I).EQ.2*(ABS(I)/2))GOTO 902 NFIT=ABS(I) IF(I.LT.0.AND.ISC.EQ.0)GOTO 930 GOTO 632 ENDIF C C C...P.E.A.K.F.I.N.D.E.R.............................. C 930 IF(I.LT.0.AND.NFIT.GE.5.AND.ISC.EQ.0)THEN SUM=0.0 DO 911 I=1,NPTS SUM=SUM+ISPEC(I) 911 CONTINUE IMEAN=SUM/NPTS CALL clearscreen($GCLEARSCREEN) WRITE(*,910) 910 FORMAT(1X/1x,20(1H=),' P E A K F I N D E R ',20(1H=)/) 914 WRITE(*,912)ISMALL,ILARGE,IMEAN 912 FORMAT(1X/' Spectral limits: ',2I6/ * ' Mean spectral value =',I6// * ' Enter the cutoff and the baseline (integers)'/ * ' [two zeros give exit back to display] .... ',$) READ(*,*,ERR=914)IYCUT,IBASE IF(IYCUT.LT.ISMALL.OR.IYCUT.GT.ILARGE)GOTO 914 IF(IBASE.LT.ISMALL.OR.IBASE.GT.ILARGE)GOTO 914 IF(IYCUT.EQ.0.AND.IBASE.EQ.0)GOTO 632 IF(IBASE.GE.IYCUT)GOTO 914 C STAT='NEW' 927 WRITE(*,'(1X/'' OUTPUT FILE NAME : '',$)') READ(*,'(a)',ERR=927)OUTSTR STAT='NEW' 918 OPEN(3,FILE=OUTSTR,STATUS=STAT,ERR=917) GOTO 920 C 917 WRITE(*,'(1X,a1/ * '' THIS FILE ALREADY EXISTS, OVERWRITE (Y/N)? '',$)')CHAR(7) READ(*,'(a)',ERR=917)CHARFL IF(CHARFL.EQ.'Y'.OR.CHARFL.EQ.'y')THEN STAT='UNKNOWN' GOTO 918 ENDIF IF(CHARFL.EQ.'N'.OR.CHARFL.EQ.'n')THEN 919 WRITE(*,'('' New file name: '',$)') READ(*,'(a)',ERR=919)FILNAM GOTO 918 ENDIF C 920 CALL AUTOPK(IYCUT,IBASE,NFIT) CLOSE(3) GOTO 632 ENDIF C.................................................... C C...Frequency of line under the cursor C IF(KK.EQ.'O'.or.KK.EQ.'o')THEN DUMMY=SETTEXTCOLOR(11) I=0 DO 904 II=-NFIT/2,NFIT/2,1 I=I+1 IF(ISC.EQ.0)THEN IX=NSTART+MARKER+II IF(IX.LT.1.OR.IX.GT.NPTS)THEN WRITE(FREQLIN,906) 906 FORMAT(' ERROR: fitting interval exceeding data bounds') CALL settextposition(2,1,curpos) CALL outtext(FREQlin(1:80)) GOTO 7 ENDIF ELSE IX=1+MARKER+II IF(IX.LT.1.OR.IX.GT.MAXX)THEN WRITE(FREQLIN,906) CALL settextposition(2,1,curpos) CALL outtext(FREQlin(1:80)) GOTO 7 ENDIF ENDIF IF(ISC.EQ.0)THEN XFIT(I)=DBLE(FREQS(IX))*0.001D0 YFIT(I)=ISPEC(IX) ELSE XFIT(I)=DBLE(ISCRF(IX))*0.001D0 YFIT(I)=ISCRN(IX) ENDIF 904 CONTINUE C CALL PEAKF(NFIT,XPEAK,ERRORX) C WRITE(toplin,907)DBLE(FREQs(NSTART+MARKER))*0.001D0, * DBLE(FREQS(NSTART+MARKER+1)-FREQS(NSTART+MARKER))*0.001D0 907 FORMAT(' Cursor at: ',F13.3,' local deltaF/pt: ', * F7.3) CALL settextposition(1,1,curpos) CALL outtext(toplin) WRITE(FREQlin,903)XPEAK,ERRORX,NFIT 903 FORMAT('Fitted peak frequency: ',F14.4,' +-',F7.4, * ' MHz, using',I3,' points') CALL settextposition(2,1,curpos) CALL outtext(FREQlin(1:80)) C IF(ISC.EQ.0)THEN CURBOT=ISPEC(NSTART+MARKER+NFIT/2) ELSE CURBOT=ISCRN(1+MARKER+NFIT/2) ENDIF CURBOT=CURBOT-htmark/2.D0 IF(CURBOT.LT.RSMALL)CURBOT=RSMALL IF(CURBOT.GT.RLARGE-htmark)CURBOT=RLARGE-htmark CURTOP=CURBOT+htmark call putimage_w(DBLE(MARKER+NFIT/2),CURTOP,MARK,$GXOR) IF(ISC.EQ.0)THEN CURBOT=ISPEC(NSTART+MARKER-NFIT/2) ELSE CURBOT=ISCRN(1+MARKER-NFIT/2) ENDIF CURBOT=CURBOT-htmark/2.D0 IF(CURBOT.LT.RSMALL)CURBOT=RSMALL IF(CURBOT.GT.RLARGE-htmark)CURBOT=RLARGE-htmark CURTOP=CURBOT+htmark call putimage_w(DBLE(MARKER-NFIT/2),CURTOP,MARK,$GXOR) C GOTO 7 ENDIF GOTO 7 C C...Help screen C 630 CALL clearscreen($GCLEARSCREEN) CALL HELP C 631 IK=INKEY(I) IF(IK.NE.13)GOTO 631 632 DUMMY=SETTEXTCOLOR(7) IF(ISC.EQ.1)GOTO 104 GOTO 333 C C...Error in options C 76 WRITE(*,'(2A1,$)')CHAR(7),CHAR(7) GOTO 33 C 37 RETURN END C C------------------------------------------------------------------------ C SUBROUTINE GLEOUT c implicit real*8 (a-h,o-z) PARAMETER (MAXPTS=32000, plotl=273.) c INTEGER*2 ISPEC(maxpts),ISMALL,ILARGE,NPTS INTEGER*4 FREQS(maxpts) CHARACTER filnam*25,filgen*10,filout*12 c COMMON /SPEC/ISPEC,NPTS,ISMALL,ILARGE COMMON /FRE/FREQS COMMON /FNAM/FILNAM c if(nstr.eq.0)nstr=1 if(miny.eq.0.and.maxy.eq.0)then miny=ismall maxy=ilarge endif c c...determine generic file name - fnam.ext type filename in the current c directory c filgen=filnam do 14 nc=1,10 if(filgen(nc:nc).eq.' '.or.filgen(nc:nc).eq.'.')goto 15 14 continue 15 nc=nc-1 if(nc.gt.6)nc=6 c c...OPTIONS c if(RM.eq.0.d0)RM=1.d0 FSP1=dble(freqs(1))*0.001d0 FSP2=dble(freqs(NPTS))*0.001d0 if(FSTART.eq.0.d0)FSTART=FSP1 if(FSCAL.eq.0.0d0)FSCAL=(FSP2-FSP1)/PLOTL c 59 WRITE(*,56) 56 FORMAT(1x,61(1H-)/22x,'min',9x,'max',9x,'range',4x,'10*mark') WRITE(*,55)' SPECTRUM:',FSP1,FSP2,FSP2-FSP1, * int((FSP2-FSP1)/(10.d0*rm)) 55 FORMAT(a,5x,3f12.2,i7/1x,61(1H-)) c RANGE=FSCAL*plotl F1=FSTART n=1 60 F2=f1+range WRITE(*,61)' PLOT:',n,F1,F2,range,int(range/(10.d0*rm)) 61 Format(a,i2,3x,3f12.2,i7) if(f2.lt.fsp2)then n=n+1 f1=f1+range goto 60 endif c 58 WRITE(*,57)nstr,rm,fscal,miny,maxy,fstart 57 FORMAT(1x/ * ' 1: Strips per page =',i7/ * ' 2: Marker spacing =',f11.3,' MHz'/ * ' 3: Plot scaling =',f11.3,' MHz/mm'/ * ' 4: Y-limits =',2I7/ * ' 5: Start frequency =',F11.3// * ' Select 1-5 (ENTER=OK) ..... ',$) C READ(*,'(I2)',err=59)I if(i.lt.0.or.i.gt.5)goto 59 c if(i.eq.1)then write(*,'(1x/'' Number of strips per page (1,2,or 3) = '',$)') read(*,'(i2)',err=59)n if(n.lt.1.or.n.gt.3)goto 59 nstr=n goto 59 endif c if(i.eq.2)then write(*,'(1x/'' New marker spacing: '',$)') read(*,'(F20.10)',err=59)temp if(temp.lt.0.001.or.temp.gt.1000.d0)goto 59 rm=temp goto 59 endif c if(i.eq.3)then write(*,'(1x/'' New plot scaling: '',$)') read(*,'(F20.10)',err=59)temp if(temp.le.0.001d0)goto 59 if(temp.gt.1000.d0)goto 59 fscal=temp goto 59 endif c if(i.eq.4)then write(*,70)ismall,ilarge 70 format(1x/' Y-axis limits of data: ',2i7// 1 ' Specify new MINY,MAXY: ',$) read(*,'(2i15)',err=59)ia,ib if(ib.le.ia)goto 59 if(ib.le.ismall.and.ia.le.ismall)goto 59 if(ib.ge.ilarge.and.ia.ge.ilarge)goto 59 miny=ia maxy=ib goto 59 endif c if(i.eq.5)then write(*,'(1x/'' New start frequency = '',$)') read(*,'(F20.10)',err=59)temp if(temp.gt.fsp2)goto 59 if(temp.lt.fsp1-plotl*fscal)goto 59 fstart=temp goto 59 endif c c...write a single .DAT file for the whole spectrum c filout=filgen(1:nc)//'.dat' write(*,'(1x/a)')' Data written to '//filout OPEN(3,file=filout,status='unknown') write(3,1)'! Spectrum from file: '//filnam write(3,1)'!' 1 format(a) scale=maxy-miny do 100 n=1,npts write(3,101)dble(freqs(n))*0.001d0,(ispec(n)-miny)/scale 100 continue 101 format(f12.4,f9.6) close(3) c c...generate the necessary .GLE files c RANGE=FSCAL*plotl F1=FSTART n=1 65 F2=f1+range call wrigle(f1,f2,rm,n,nstr,filgen,nc) if(f2.lt.fsp2)then n=n+1 f1=f1+range goto 65 endif c WRITE(*,'(1x/'' ---- DONE, Press ENTER'')') READ(*,'(I2)',err=52)I 52 RETURN END C c C------------------------------------------------------------------------ C subroutine wrigle(f1,f2,rm,n,nstr,fnam,nc) c C Write/append a spectral strip to a .GLE file C c F1,F2 - frequency limits C RM - marker spacing C n - number of spectral strip c nstr - number of spectral strips per page c fnam - generic file name c nc - number of characters to be used from FNAM c implicit real*8 (a-h,o-z) PARAMETER (MAXPTS=32000, plotl=273.) c INTEGER*2 ISPEC(maxpts),ISMALL,ILARGE,NPTS INTEGER*4 FREQS(maxpts) CHARACTER fnam*10,filout*12,filnam*25,outstr*30 c COMMON /SPEC/ISPEC,NPTS,ISMALL,ILARGE COMMON /FRE/FREQS COMMON /FNAM/FILNAM c maxlab=5 topstr=0 nn=(n-1)/nstr+1 if(n-((n-1)/nstr)*nstr.eq.1)topstr=1 xs=-5.45 xtxt=0.3 c C...single strip c if(nstr.eq.1)then ys= 2.0 sizey=20. ytxt=19.5 endif c c...two strips c if(nstr.eq.2)then sizey=11. if(topstr.eq.1)then ys=11.0 else ys= 1.8 endif ytxt=20.9 endif c c...three strips c if(nstr.eq.3)then sizey=7.4 ytxt=21.2 if(topstr.eq.1)then ys=14.6 else nnn=n-(n/nstr)*nstr if(nnn.ne.0)then ys=8.2 else ys=1.8 endif endif endif c c...write .GLE file(s) c write(outstr,'(I2)')nn if(nn.lt.10)then filout=fnam(1:nc)//outstr(2:2)//'.gle' else filout=fnam(1:nc)//outstr(1:2)//'.gle' endif if(nstr.eq.1.or.topstr.eq.1)then write(*,'(a)')' Control file written to '//filout OPEN(4,file=filout,status='unknown') else OPEN(4,file=filout,status='old',access='append') endif c if(topstr.eq.1)then write(4,2) write(4,1)'! Plot of spectrum from file: '//filnam write(4,2) 2 format('!',75(1h-)) write(4,1)'!' write(4,1)'size 29.5 21' 1 FORMAT(a) write(4,1)' ' write(4,1)'set lwidth 0.025' write(4,1)'set join round' endif c write(4,1)' ' write(outstr,'(a,2f6.2)')'amove',xs,ys write(4,1)outstr write(4,1)'begin graph' write(4,1)' nobox' write(outstr,'(a,f6.2)')' size 38.57',sizey write(4,1)outstr filout=fnam(1:nc)//'.dat' write(4,1)' d1 bigfile '//filout write(4,'(a,f10.2,a,F10.2,a,F9.2,a,F9.3)') * ' xaxis min ',F1,' max ',F2,' dticks ',10.d0*RM, * ' dsubticks ',RM write(4,1)' x2ticks off' write(4,1)' xticks length 0.3' write(4,1)' xsubticks length 0.12' write(4,1)' xlabels hei 0.5 font texcmr' c write(4,1)' yaxis min 0.0 max 1.0' write(4,1)' ylabels off' write(4,1)' yticks off' write(4,1)' d1 lstyle 1 smooth' c c...deal with more than MAXLAB marker labels c tenm=rm*10.d0 ftenm=dint(f1/tenm)*tenm if(ftenm.le.f1)ftenm=ftenm+tenm firstm=ftenm c if(dint((f2-f1)/tenm).gt.real(maxlab))then mult=1 30 mult=mult+1 if((f2-f1)/(mult*tenm).gt.maxlab)goto 30 c 31 flastm=ftenm+6.d0*tenm call xlab(firstm,f2,ftenm,flastm,tenm,mult) if(flastm.lt.f2-tenm)then ftenm=flastm+tenm goto 31 endif endif c goto 26 c 26 write(4,1)'end graph' c c...legend line c if(n.eq.(n/nstr)*nstr)then write(4,1)' ' write(4,1)'set font texcmr' write(4,1)'set hei 0.7' write(outstr,'(2f6.1)')xtxt,ytxt write(4,1)'amove'//outstr write(4,1)'text '//filnam write(4,1)'!' write(4,2) endif c close(4) c return end C C------------------------------------------------------------------------ C subroutine marsca(f1,f2) c c Plot marker scale for frequency limits F1,F2 c INCLUDE 'FGRAPH.FD' MSF5+PS1 c USE MSFLIB PS4 c RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy c LOGICAL*2 true PARAMETER (TRUE=.TRUE.) c INTEGER*2 maxx,maxy,linofs,mymode,myrows,mycols,dummy,nbufer,nm INTEGER*4 blue,red CHARACTER*80 toplin,emplin,paslin,marlin CHARACTER botlin*79,BUFREQ*8 REAL*8 FSTEP,F1,F2,RM,FRMARK,FLONG,H,YY REAL*8 RSMALL,RLARGE,RRSMAL,YYSTEP,YSHIFT COMMON /limits/maxx,maxy,linofs,curpos,ixy,wxy, * mymode,myrows,mycols,blue,red COMMON /lines/toplin,emplin,paslin,botlin COMMON /plotda/RSMALL,RLARGE,RRSMAL,YYSTEP,YSHIFT c FSTEP=F2-F1 RM=100000.D0 1111 NM=FSTEP/RM IF(NM.LT.15)THEN RM=RM*0.1D0 GOTO 1111 ENDIF FRMARK=DINT(F1/RM)*RM IF(FRMARK.LT.F1)FRMARK=FRMARK+RM C C...plot the marker scale; NOTE that the X-axis of the floating point window C is set to frequencies C marlin=emplin FSTEP=(F2-F1)/maxx flong=0.0d0 dummy=setwindow(TRUE,F1,RRSMAL,F2,RLARGE) c 1114 YY=RSMALL-8.D0*YYSTEP H=DNINT(FRMARK/RM) IF(DNINT(10.D0*DINT(H*0.1D0)).EQ.H)THEN YY=RSMALL-13.D0*YYSTEP IF(FLONG.EQ.0.D0)FLONG=FRMARK NBUFER=(FRMARK-F1)/(F2-F1) * 80.D0 IF(NBUFER-3.GE.1.AND.NBUFER+4.LE.79)THEN WRITE(BUFREQ,'(F8.1)')FRMARK IF(NBUFER-3.LE.4)THEN marlin(NBUFER-3:NBUFER+4)=BUFREQ GOTO 1000 ENDIF IF(marlin(NBUFER-6:NBUFER-6).EQ.' ')THEN marlin(NBUFER-3:NBUFER+4)=BUFREQ ENDIF ENDIF ENDIF C 1000 DUMMY=SETCOLOR(15) CALL moveto_w(FRMARK,YSHIFT,wxy) dummy=lineto_w(FRMARK,YY) FRMARK=FRMARK+RM IF(FRMARK.LE.F2)GOTO 1114 c c...write the marker labels c DUMMY=SETTEXTCOLOR(15) CALL settextposition(int2(myrows-1),1,curpos) CALL outtext(marlin) c return end C C------------------------------------------------------------------------ C subroutine xlab(firstm,f2,frtenm,flastm,tenm,mult) c c firstm - frequency of first annotated marker c f2 - upper frequency limit of plot c frtenm,flastm - frequency of first and last big markers for annotation c tenm - big marker spacing c mult - label spacing which is MULT*TENM c implicit real*8 (a-h,o-z) character*127 marlin c c...the xplaces line c ftenm=frtenm write(4,'(a)')'!' write(marlin(1:9),'(a)')' xplaces ' marind=10 22 if(tenm.lt.0.01d0) * write(marlin(marind:marind+8),'(f9.3)',err=25)ftenm if(tenm.lt.0.1d0.and.tenm.ge.0.01d0) * write(marlin(marind:marind+8),'(f9.2)',err=25)ftenm if(tenm.lt.1.d0 .and.tenm.ge.0.1d0) * write(marlin(marind:marind+8),'(f9.1)',err=25)ftenm if(tenm.ge.1.d0) * write(marlin(marind:marind+8),'(i9)',err=25)nint(ftenm) marind=marind+9 if(marlin(marind-9:marind-9).ne.' ')then if(marind.le.127)marlin(marind:marind)=' ' marind=marind+1 endif ftenm=ftenm+tenm if(ftenm.le.flastm.and.ftenm.lt.f2)then goto 22 else write(4,'(a)')marlin(1:marind-1) endif c c...the xnames line c write(marlin(1:8),'(a)')' xnames ' marind=9 ftenm=frtenm c 30 if(dint((ftenm-firstm)/(mult*tenm))*mult*tenm.ne. * (ftenm-firstm))then write(marlin(marind:marind+8),'(a)')' " " ' marind=marind+9 else 23 if(tenm.lt.0.01d0) * write(marlin(marind:marind+10),'(a,f9.3,a)',err=25) * '"',ftenm,'"' if(tenm.lt.0.1d0.and.tenm.ge.0.01d0) * write(marlin(marind:marind+10),'(a,f9.2,a)',err=25) * '"',ftenm,'"' if(tenm.lt.1.d0 .and.tenm.ge.0.1d0) * write(marlin(marind:marind+10),'(a,f9.1,a)',err=25) * '"',ftenm,'"' if(tenm.ge.1.d0) * write(marlin(marind:marind+10),'(a,i9,a)',err=25) * '"',nint(ftenm),'"' marind=marind+11 endif c ftenm=ftenm+tenm if(ftenm.le.flastm.and.ftenm.lt.f2)then goto 30 else write(4,'(a)')marlin(1:marind-1) write(4,'(a)')'!' endif c return c 25 write(4,27) 27 format('!'/'! SORRY - Could not generate xnames/xplaces lines'/ * '!') return end C C------------------------------------------------------------------------ C SUBROUTINE HELP C WRITE(*,632) 632 FORMAT(9X,'A V A I L A B L E O P T I O N S:'// * 9X,'A,S - shift screen window over the spectrum'/ * 9X,'W,Z - increase, decrease vertical scale',/ * 9X,'K,L - move cursor over the spectrum'/ * 9X,' (all of the above are fast/slow for ', * 'upper/lower case)'/ * 9X,' , - center/quarter cursor'/ * ' - move to beginning/end of spectrum'// * 9X,' X = X axis transformations:'/ * 9X,' - if followed by 2-9 then appropriate degree ' * 'of compression') WRITE(*,633) 633 FORMAT( * 9X,' - if followed by L then 2x expansion, window ', * 'is to be positioned'/ * 9X,' with K,L and terminated with ENTER'// * 9X,' Y - fine Y axis scaling, upper and lower limits ', * 'are to be set'/ * 9X,' with W,Z and in each case terminated with ENTER'/ * 9X,'O/0 - peak frequency/fitting width and PEAKFINDER'/ * 9X,' R - rescale Y axis to original values'/ * 9X,' G - gle output'// * 9X,' H - display this HELP screen (exit with ENTER)',$) C RETURN END C C------------------------------------------------------------------------ C SUBROUTINE AUTOPK(IYCUT,IBASE,NFIT) C IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-N) PARAMETER (MAXPTS=32000) C INTEGER*2 ISPEC(MAXPTS) INTEGER*4 FREQS(MAXPTS) CHARACTER*25 FILNAM REAL*8 X(1000),Y(1000),A(1000),B(1000),C(1000),D(1000) REAL*8 FPLU(1000) INTEGER*4 INTPLU(1000) REAL*4 ERPLU(1000) EQUIVALENCE (A(1),FPLU(1)),(B(1),ERPLU(1)),(C(1),INTPLU(1)) C COMMON /FRE/FREQS COMMON /SPEC/ISPEC,NPTS,ISMALL,ILARGE COMMON /SPL/NSPLIN,X,Y,A,B,C,D,GRA,CA,GRB,CB COMMON /FRFIT/XFIT(50),YFIT(50) COMMON /FNAM/FILNAM C c C...establish maxima greater than IYCUT on the basis of five peaked points c and fit their position, two iterations of the fit are carried out to c compensate for the inaccuracy in the initial central point c IX=NFIT/4 I=2*IX I2X=I nplu=0 WRITE(*,938) 938 FORMAT(1x//' identified lines: ',$) c c...loop over the spectrum 1514 I=I+1 IF(I.GT.(NPTS-I2X))GOTO 1515 IF(ISPEC(I).LT.IYCUT)GOTO 1514 IF(ISPEC(I).GT.ISPEC(I-I2X).AND.ISPEC(I).GT.ISPEC(I-IX).AND. * ISPEC(I).GT.ISPEC(I+I2X).AND.ISPEC(I).GT.ISPEC(I+IX))THEN c NTIMES=0 922 J=0 DO 921 II=-NFIT/2,NFIT/2,1 J=J+1 K=I+II XFIT(J)=DBLE(FREQS(K))*0.001D0 YFIT(J)=ISPEC(K) 921 CONTINUE C CALL PEAKF(NFIT,XPEAK,ERRORX) NTIMES=NTIMES+1 delta=xpeak-dble(freqs(i))*0.001d0 deltaf=dble(freqs(i+1)-freqs(i))*0.001d0 C nplu=nplu+1 fplu(nplu)=xpeak erplu(nplu)=errorx INTPLU(NPLU)=ISPEC(I) intplu(nplu)=INTPLU(NPLU)-ibase c IF(NPLU.EQ.10*(NPLU/10))WRITE(*,'(I5,$)')NPLU I=I+I2X endif GOTO 1514 c C...output frequencies C 1515 WRITE(*,'(1X/'' finished location'')') write(3,926)filnam,IYCUT,IBASE,NFIT,NPLU 926 format(78(1H-)/' PEAK FREQUENCIES MEASURED IN SPECTRUM: ', * a//' cutoff, baseline: ',2I7,7X,'fitting width:',I5/ * ' number of lines: ',i7/78(1H-)/) C C...Synthetic table of results C WRITE(3,950) 950 FORMAT(2(' F',14X,'Int ',3x),' F',14X,'Int'/) C if(nplu.lt.12)then do 800 i=1,11 write(3,947)FPLU(i),ERPLU(i),INTPLU(i) 800 continue goto 946 endif j=nplu/3 jj=j do 944 i=1,j write(3,948)FPLU(i),ERPLU(i),INTPLU(i), * FPLU(i+j),ERPLU(i+j),INTPLU(i+j), * FPLU(i+2*j),ERPLU(i+2*j),INTPLU(i+2*j) 944 continue jj=3*j 945 if(jj.lt.nplu)then jj=jj+1 write(3,949)FPLU(JJ),ERPLU(jj),INTPLU(jj) goto 945 endif c 948 FORMAT(2(F10.3,' +-',F5.3,I6,3x),F10.3,' +-',F5.3,I6) 949 FORMAT(54x,F10.3,' +-',F5.3,I6) 947 FORMAT(27x,F10.3,' +-',F5.3,I6) C 946 WRITE(3,'(78(1H-))') WRITE(*,940)NPLU 940 FORMAT(1X//' PEAKFINDER measured ',i4,' transitions'/35X, * 'Press ENTER to continue .... ',$) READ(*,'(I1)',ERR=941)I C 941 RETURN END C C------------------------------------------------------------------------ C SUBROUTINE PEAKF(N,XPEAK,ERRORX) C C Position of line maximum is established using a linear transformation C of the parabola C 2 Y-Yo C from Y = a + b X + c X to ---- = b + c ( X - Xo) C X-Xo C C The central XY point is used for Xo,Yo and a straight line fit gives C b and c. Peak of a parabola is at -b/2c. This routine will locate both C upward and downward peaks (c -ve and +ve), with reliability increasing C with the proximity of the central point in the data to the peak C C N - number of XY data pairs (odd) C X,Y - arrays containg XY coordinates of spectral points C XPEAK - on exit the required central fitted peak position C ERRORX - on exit error on the fitted peak position C IMPLICIT REAL*8 (A-H,O-Z) INTEGER*2 N COMMON /FRFIT/X(50),Y(50) C C...value of X is given a small fractional shift so that no two points C have the same frequency NCENT=N/2+1 DO 1 I=1,N IF(I.EQ.NCENT)GOTO 1 X(I)=X(I)-X(NCENT)+I*1.D-7 Y(I)=(Y(I)-Y(NCENT))/X(I) 1 CONTINUE C C...The number of points in the fit is N-1 since the central point is C used for biasing C SUMX=0.D0 SUMY=0.D0 SUMXY=0.D0 SUMX2=0.D0 SUMY2=0.D0 DO 2 I=1,N IF(I.EQ.NCENT)GOTO 2 SUMX=SUMX+X(I) SUMY=SUMY+Y(I) SUMXY=SUMXY+X(I)*Y(I) SUMX2=SUMX2+X(I)*X(I) SUMY2=SUMY2+Y(I)*Y(I) 2 CONTINUE C C...coefficients RN=N-1 CXX=SUMX2-SUMX*SUMX/RN CXY=SUMXY-SUMX*SUMY/RN A1=CXY/CXX IF(A1.EQ.0.D0)THEN ERRORX=0.D0 XPEAK=0.D0 RETURN ENDIF A0=(SUMY-A1*SUMX)/RN XPEAK=X(NCENT)-0.5D0*A0/A1 C C...error CYY=SUMY2-SUMY*SUMY/RN ERA1S=((CYY/CXX)-(CXY/CXX)**2)/(RN-2.D0) ERA0S=SUMX2*ERA1S/RN ERRORX=ABS(0.5D0*(A0/A1))*DSQRT(ERA1S/A1**2+ERA0S/A0**2) C WRITE(*,*)X(NCENT) C WRITE(*,*)'A1 ',A1,DSQRT(ERA1S) C WRITE(*,*)'A0 ',A0,DSQRT(ERA0S) C RETURN END C C------------------------------------------------------------------------ c c integer*2 function INKEY(N2) msps c c By L Pszczolkowski: c c...This emulates for MSF PS1.0 the INKEY function of Z.Czumaj which c in turn emulated for MSF5.0 the INKEY function from IIUWGRAF graphics c library for the Hercules card c c The function GETCHARQQ returns the ASCII character if the corresponding c key was pressed. If function or direction key was pressed then 0 c or hex E0 is returned and aniother call to GETCHARQQ is required to c get the extended code of the character c c INCLUDE 'FLIB.FD' PS1 c USE MSFLIB PS4 c c INTEGER*2 IK,n2 msps c CHARACTER*1 KK msps c c KK=GETCHARQQ() msps c IK=ICHAR(KK) msps c IF(IK.EQ.0 .OR. IK.EQ.224 ) THEN msps c KK=GETCHARQQ() msps c IK=-ICHAR(KK) msps c ENDIF msps c n2=ik msps c INKEY=IK msps c END msps C_____________________________________________________________________________ C_____________________________________________________________________________