$DEBUG C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C MODSPE - MODIFICATION OF SPECTRA FROM INSPEC, SCan, FREQLIN or C ASCII input. C C - compression of spectrum by an integral factor C - zooming/compression of spectrum along X-axis by a non-integral factor C - change of comment and other descriptive information C - reversal of spectrum (along X or Y axes) C - least squares smoothing C - ASCII output as floating point X,Y pairs C - chopping out of a portion of the spectrum C - subtraction of processed spectrum from the original (for background C subtr. where background is created by smoothing with appropriately C large window) C - conversion of recorded spectrum into a file suitable for the stick C plotting program ASPEC (if voltages have been recorded conversion to C approximate frequencies is possible on the basis of global BWO C calibration) C C Version 9.VI/1997 ----- Zbigniew KISIEL ----- C __________________________________________________ C | Institute of Physics, Polish Academy of Sciences | C | Al.Lotnikow 32/46, 02-668 Warszawa, POLAND | C | kisiel@ifpan.edu.pl | C_________________________/-------------------------------------------------- C C Modification history: C c 7.4.95: Wrap around of spectrum for smoothing to minimize edge effects c 23.4.95: Commenting of file structure and merging of linearized files c 13.10.95: Reminder of file name prior to output and changes in printing C 8.11.95: Improved merging of linearized spectra c 6.02.96: Correct chopping of linearized spectra c 12.10.96: Bound limiting on smoothing to avoid artefacts on strong lines C 9.06.97: Elimination of bug in frequency reversal of linear spectrum c c------------------------------------------------------------------------------ C C To preserve compatibility with previous spectral recordings the variable c PPS is used as a flag of the type of spectrum being accessed: c c PPS -ve : spectrum with measured BWO voltages c PPS < -500 : as above but also with the frequency values for each c data point (compatible with S) c PPS +ve : spectrum without BWO voltages (compatible with INSPEC) c PPS > +50 : data points linear in frequency (compatible with c FREQLIN and SS) c c The structure of binary spectral files is: c c HEADER records - miscellaneous variables carrying descriptive information c about the spec trum c ISPEC - INTEGER*2 data points ie. intensities, NPOINT in number c c then optionally according to the value of PPS but in following sequence: c c for linearized spectra: c FSTART,FEND,FINCR - frequency limits and increment per data point (MHz) c NCALPT - number of calibration points c XCALPT,YCALPT - data pairs defining calibration points NCALPT in no. c c or c c for spectra with BWO votages: C NVKM - number of BWO voltage measurements c IVKM,VKM - voltage measurements, NVKM in number c c + for spectra with frequency channel: c FREQS - INTEGER*4 frequencies of data points, in kHz, NPOINT in number C C.......................................................................... C C The original spectrum is kept in IOLD(), NPTOLD and C if there are BWO voltages: VKMOLD(), IVKMOL(), NVKMOL, V1OLD, V2OLD C if frequency linearized: FSTOLD, FENOLD, FINOLD, XCALOL(), C YCALOL(), NCALOL C C---The currently worked on spectrum is in ISPEC() of length NPTS. A copy C is also kept in IPLOT() for use in operations such as smoothing, axis C reversal etc. Since IPLOT() is also changed by LOOK its contents is C restored on exit from LOOK. C---The BWO voltage measurements are in VKM(), the corresponding spectral C points are in IVKM(), and there are NVKM such pairs. The voltage C limits of the spectrum are VKMST, VKMEND. The variable PPS C is given a negative value to indicate that voltages are present. C---The calibration frequency points are in XCALPT(),YCALPT(), there C are NCALPT such pairs and XCALPT() contains frequencies while YCALPT() C contains interpolated point positions. Variables FSTART, FEND and FINCR C define the frequency scale. A linearized spectrum is recognised through a C standard comment assigned by FREQLIN or by PPS>50, if this is fulfilled c then the variable LINEAR is set to 1. C C---The program will carry out limited operations on a file with recorded C frequency scale, but only the ones that do not affect the frequency scale C (ie. the point order) are safe C C The program uses MSF-5.0 graphics and adapts to the graphics card C encountered. However if HERCULES graphics is used the file MSHERC.COM C has to be run first. ANSI.SYS also has to be preloaded. C C=========================================================================== C C...Initialization commands for graphics C INCLUDE 'FGRAPH.FI' INCLUDE 'FGRAPH.FD' 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 PARAMETER (NMAXPT=32000, maxfre=27000, maxvol=500, maxcal=200, * maxspl=500, maxsmo=499) C COMMON /SPEC/freqs(maxfre),ISPEC(NMAXPT),NPTS,ISMALL,ILARGE 1 /PLOTC/IPLOT(NMAXPT) 1 /INFO/COMENT,IDAY,IMON,IYEAR,IHOUR,IMIN,ISEC, 1 LAMP,VKMST,VKMEND,GRID,SAMPLE,SAMPRE,GAIN,TIMEC,PHASE, 1 SCANSP,FRMOD,FRAMPL COMMON /OLD/IOLD(NMAXPT),nptold,nvkmol,ivkmol(maxvol),v1old,v2old, 1 vkmold(maxvol),ncalol,fstold,fenold,finold,xcalol(maxcal), 1 ycalol(maxcal) COMMON /CALVOL/VKM,IVKM,NVKM,PPS COMMON IPLX,IPLY,ISTP COMMON /SPL/NSPLIN,X,Y,A,B,C,D,GRA,CA,GRB,CB COMMON /PRETTY/BOLD,NORMAL COMMON /LINFRE/FSTART,FEND,FINCR COMMON /CALFRE/XCALPT,YCALPT,NCALPT,COM1,LINEAR C INTEGER*4 INTERM,ismal4,ilarg4,freqs CHARACTER FILNAM*25,STAT*7,CHARFL,filinp*25 CHARACTER*72 COMENT,COM1 CHARACTER*6 LAMP,SCANSP CHARACTER*20 SAMPLE CHARACTER*4 BOLD,NORMAL INTEGER*2 NPTS,ISMALL,ILARGE,ISPEC,IPLOT,IOLD,IDAY,IMON,IYEAR, * IHOUR,IMIN,ISEC,IPLX,IPLY,ISTP,NSPLIN,NFUNCT,N,I,M,NN,NCALPT, * NCALOL,LINEAR,nptold INTEGER*2 IVKM(maxvol),NVKM,IVKMOL,NVKMOL REAL*4 XX,YY,VKM(maxvol),VKMOLD,TEMP,PPS REAL*8 SPOL(maxsmo),BWOCAL(2,3),XCALPT(maxcal),YCALPT(maxcal), * FSTART,FEND,FINCR,XSCAL,XMIN,XMAX,XOUT,XCALOL, * YCALOL,FENOLD,FSTOLD,FINOLD,DELTA,DELTAL,RTEMP REAL*8 X(maxspl),Y(maxspl),A(maxspl),B(maxspl),C(maxspl), * D(maxspl),GRA,CA,GRB,CB,XXX,YYY COM1=' ----- FREQUENCY LINEARIZED SPECTRUM -----' DELTAL=0.D0 LINEAR=0 ixmod=0 C C...Parameters A,B,C determined from BWO calibrations for approximate C reproduction of source frequency with the polynomial C C Nu/MHz = A * X**1/2 + B * X + C * X**3/2 where X is V.km voltage in Volts C C First entry OB-24d, second OB-30d DATA BWOCAL(1,1),BWOCAL(1,2),BWOCAL(1,3) * /133222.9D0,-17138.3D0,1268.84D0/ DATA BWOCAL(2,1),BWOCAL(2,2),BWOCAL(2,3) * /190365.1D0,-20891.2D0,1074.6D0/ 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 )/' MODSPE - Modification of spectra', * ' from INSPEC, SC and FREQLIN '/1X,78(1H )/1x,78(1H_)/ * ' version 9.VI.1997',T64,'Zbigniew KISIEL ') WRITE(*,155)CHAR(27),'[0m' C c...Read the spectrum c call READSP(DELTAL,FILNAM) filinp=filnam C C C...selection of modification option C C reset IPLOT C 1282 DO 1283 N=1,NPTS IPLOT(N)=ISPEC(N) 1283 CONTINUE C 1281 WRITE(*,1200) 1200 FORMAT(1X/' OPTIONS:'//6X,'0 = Exit',T40, * '1 = View spectrum'/6X,'2 = Reverse X-axis of spectrum',T40, * '3 = Compress spectrum'/6X,'4 = Change description',T40, * '5 = Restore original spectrum'/6X,'6 = Smooth spectrum',T40, * '7 = ASCII output'/6X,'8 = Chop spectrum',T40, * '9 = Subtract from original sp.'/5X, * '10 = Rescale Y-axis',T39,'11 = Convert spectrum to sticks'/5X, * '12 = Fine tune X-axis',T39,'13 = Invert Y-axis'/5X, * '14 = NARROWING',T39,'15 = hardcopy printout') IF(PPS.LT.-500.)WRITE(*,1201) 1201 FORMAT(5X,'16 = Eliminate unlocks',T39, * '17 = Squeeze and linearize'/5X,'18 = Coadd two parts of sp.', * T39,'19 = save in FREQLIN format'/5X,'20 = correct harmonic', * T39,'21 = append spectrum') IF(PPS.GT.50.)WRITE(*,990) 990 FORMAT(5X,'16 = Merge LINEARIZED spectra') C WRITE(*,1202) 1202 FORMAT(/1X,T40,'... ',$) C READ(*,1,ERR=1281)IFLAG IF(IFLAG.LT.0.OR.IFLAG.GT.21)GOTO 1281 IF(PPS.GT.50.0.AND.IFLAG.EQ.16)GOTO 1208 IF(PPS.GT.-500.0.AND.IFLAG.GT.15)GOTO 1281 IFLAG=IFLAG+1 GOTO(500,501,502,503,504,505,506,507,508,509,510,511,512,513,614, * 715,1203,1204,1205,1206,1207,1208),IFLAG C C...Inspection of spectrum C 501 CALL LOOK GOTO 1282 C C...Reversal of horizontal scale C 502 ixmod=1 DO 1511 N=1,NPTS/2 I=NPTS+1-N II=ISPEC(I) ISPEC(I)=ISPEC(N) ISPEC(N)=II IF(PPS.LT.-500.)THEN INTERM=FREQS(I) FREQS(I)=FREQS(N) FREQS(N)=INTERM ENDIF 1511 CONTINUE if(pps.gt.50.)then rtemp=fstart fstart=fend fend=rtemp fincr=-fincr goto 5131 endif C TEMP=VKMST VKMST=VKMEND VKMEND=TEMP C IF(NVKM.NE.0)THEN DO 606 N=1,NVKM IVKM(N)=NPTS+1-IVKM(N) 606 CONTINUE NN=NVKM/2 DO 605 N=1,NN I=NVKM+1-N M=IVKM(I) IVKM(I)=IVKM(N) IVKM(N)=M TEMP=VKM(I) VKM(I)=VKM(N) VKM(N)=TEMP 605 CONTINUE ENDIF C 5131 WRITE(*,3512)BOLD,NORMAL,CHAR(7) 3512 FORMAT(1X/1X,A,'***** Reversal completed *****',2A) GOTO 1282 C C...Reversal of Y-axis C 513 DO 5130 N=1,NPTS ISPEC(N)=ILARGE-(ISPEC(N)-ISMALL) 5130 CONTINUE GOTO 5131 C C...Compression of spectrum C 503 ixmod=1 WRITE(*,514) 514 FORMAT(1X/' Integral compression factor: '\) READ(*,530,ERR=503)ICOMPR 530 FORMAT(I5) IF(ICOMPR.EQ.0)GOTO 1281 IF(ICOMPR.LT.2)GOTO 503 N=NPTS/ICOMPR 516 WRITE(*,515)NPTS,N 515 FORMAT(1X/' Spectrum will be compressed from',I6,' to',I6, * ' points, OK? '\) READ(*,530,ERR=516)I IF(I.NE.1)GOTO 503 C NPTS=N IF(NVKM.NE.0)M=1 ISMALL=32000 ILARGE=-32000 DO 517 N=1,NPTS RSUM=0.0 I=ICOMPR*(N-1) DO 519 NN=1,ICOMPR RSUM=RSUM+IPLOT(I+NN) IF(NVKM.NE.0.AND.M.LE.NVKM)THEN IF(I+NN.EQ.IVKM(M))THEN IVKM(M)=N M=M+1 ENDIF ENDIF 519 CONTINUE ISPEC(N)=RSUM/ICOMPR IF(ISPEC(N).LT.ISMALL)ISMALL=ISPEC(N) IF(ISPEC(N).GT.ILARGE)ILARGE=ISPEC(N) 517 CONTINUE IF(NVKM.NE.0)NVKM=M-1 C WRITE(*,518)BOLD,NORMAL,CHAR(7) 518 FORMAT(1X/1X,A,'***** Compression completed *****',2A) GOTO 1282 C C...Fine tuning of spectrum along the X-axis = zooming and compression C by a non-integral factor C 512 ixmod=1 WRITE(*,3514) 3514 FORMAT(1X/' Zoom/Compression of spectrum along the X-axis, ', * 'specify'/' point spacing in transformed spectrum in units of ', * 'present spacing: '\) READ(*,3515,ERR=512)DELTA 3515 FORMAT(F10.5) IF(DELTA.LT.0.001D0.OR.DELTA.GT.1000.D0)GOTO 512 INTERM=NPTS/DELTA 3517 WRITE(*,3516)BOLD,INTERM,NORMAL 3516 FORMAT(1X/' Transformed spectrum will be',A,I6,A, *' points long - OK ? '\) READ(*,530,ERR=3517)J IF(J.NE.1.AND.J.NE.0)GOTO 3517 IF(J.NE.1)GOTO 512 C XX=1.D0-DELTA J=0 C---------------- C INTERPOLATION LOOP C 801 XX=XX+DELTA IF(XX.GT.NPTS)GOTO 3 J=J+1 C C...centre the three data points to be used for interpolation on the C interpolation point I=XX U=XX-I IF(I.EQ.1)GOTO 802 IF(U.LT.0.5D0)THEN I=I-1 U=U+1.D0 ENDIF IF(I.GT.NPTS-2)THEN I=NPTS-2 U=XX-I ENDIF C C...quadratic interpolation for equally spaced intervals 802 D1=ISPEC(I+1)-ISPEC(I) D2=(ISPEC(I+2)-ISPEC(I+1))-D1 IPLOT(J)=ISPEC(I)+U*D1+0.5D0*U*(U-1.)*D2 IF(IPLOT(J).LT.ISMALL)ISMALL=IPLOT(J) IF(IPLOT(J).GT.ILARGE)ILARGE=IPLOT(J) GOTO 801 C---------------- 3 NPTS=J DO 2 N=1,NPTS ISPEC(N)=IPLOT(N) 2 CONTINUE C IF(LINEAR.EQ.1)THEN FINCR=FINCR*DELTA DO 702 N=1,NCALPT YCALPT(N)=YCALPT(N)/DELTA 702 CONTINUE ENDIF C IF(NVKM.NE.0)THEN DO 3519 N=1,NVKM IVKM(N)=IVKM(N)/DELTA 3519 CONTINUE ENDIF C WRITE(*,3518)BOLD,NORMAL,CHAR(7) 3518 FORMAT(1X/1X,A,'***** X-axis transformation completed *****',2A) GOTO 1281 C C...Change of comment and of other descriptive information C 504 WRITE(*,'(1X/'' Current comment:''/1X,A//1X,A4,'' New comment: '' * ,A4,\)')COMENT,BOLD,NORMAL READ(*,1300,ERR=504)COMENT 1300 FORMAT(A) 2505 WRITE(*,'(1X/'' Change other parameters? '',$)') READ(*,'(I5)',ERR=2505)IFLAG IF(IFLAG.LT.0.OR.IFLAG.GT.1)GOTO 2505 IF(IFLAG.EQ.0)GOTO 1281 1304 WRITE(*,'(1X/'' Lamp: '',A,'' --> '',$)')LAMP READ(*,1300,ERR=1304)LAMP IF(PPS.GT.0)THEN 1305 WRITE(*,'('' VkmStart,VkmEnd /mV: '',2F10.2,'' --> '' 1 \)')VKMST,VKMEND READ(*,*,ERR=1305)VKMST,VKMEND ENDIF 1307 WRITE(*,'('' Grid /V: '',F6.0,'' --> ''\)')GRID READ(*,*,ERR=1307)GRID 1308 WRITE(*,'(1X/'' Sample: '',A,'' --> ''\)')SAMPLE READ(*,1300,ERR=1308)SAMPLE 1309 WRITE(*,'('' Sample pressure /mTorr: '',F6.0,'' --> ''\)')SAMPRE READ(*,*,ERR=1309)SAMPRE 1310 WRITE(*,'('' Gain /mV: '',F6.1,'' --> ''\)')GAIN READ(*,*,ERR=1310)GAIN 1311 WRITE(*,'('' Time constant /s: '',F6.2,'' --> ''\)')TIMEC READ(*,*,ERR=1311)TIMEC 1320 WRITE(*,'('' Phase /deg: '',F6.0,'' --> ''\)')PHASE READ(*,*,ERR=1320)PHASE 1312 WRITE(*,'('' SIPLOW scan speed: '',A,'' --> ''\)')SCANSP READ(*,1300,ERR=1312)SCANSP 1314 WRITE(*,'(1X/'' Modulation freq. /kHz: '',F6.1,'' --> ''\)') * FRMOD READ(*,*,ERR=1314)FRMOD 1315 WRITE(*,'('' Modulation ampl. /mV: '',F6.1,'' --> ''\)')FRAMPL READ(*,*,ERR=1315)FRAMPL 1316 WRITE(*,'('' Points per second: '',F6.1,'' --> ''\)')PPS READ(*,*,ERR=1316)PPS GOTO 1281 C C...Return to the original spectrum C 505 ISMALL=32000 ILARGE=-32000 NPTS=NPTOLD VKMST=V1OLD VKMEND=V2OLD DO 523 N=1,NPTS ISPEC(N)=IOLD(N) IF(ISPEC(N).LT.ISMALL)ISMALL=ISPEC(N) IF(ISPEC(N).GT.ILARGE)ILARGE=ISPEC(N) 523 CONTINUE C IF(NVKMOL.NE.0)THEN NVKM=NVKMOL DO 610 N=1,NVKM VKM(N)=VKMOLD(N) IVKM(N)=IVKMOL(N) 610 CONTINUE VKMST=V1OLD VKMOLD=V2OLD ENDIF C IF(LINEAR.EQ.1)THEN NCALPT=NCALOL DO 701 N=1,NCALPT XCALPT(N)=XCALOL(N) YCALPT(N)=YCALOL(N) 701 CONTINUE FSTART=FSTOLD FEND=FENOLD FINCR=FINOLD ENDIF C WRITE(*,524)BOLD,NORMAL,CHAR(7) 524 FORMAT(1X/1X,A,' ***** Original spectrum restored *****',2A) GOTO 1282 C C C...Least squares smoothing with smoothing interval of length C 2m+1 and elements of the smoothing (cubic) polynomial given by: C C 3(3m**2 + 3m -1 - 5s**2) C c(s) = ------------------------ C (2m+1) (2m-1) (2m+3) C C where s runs from -m to +m (T.H.Edwards and P.D.Wilson, Applied C Spectroscopy 28,541-545(1974)) C 506 WRITE(*,540) 540 FORMAT(1X/12x,'Number of points (odd) in smoothing interval'/ *' (-ve value allows bound selection for artefact control)'/ * 40x,'..... ',$) READ(*,530,ERR=506)NSPT IF(IABS(NSPT).LT.3.OR.IABS(NSPT).GT.maxsmo)GOTO 506 IF((IABS(NSPT)/2)*2.EQ.IABS(NSPT))GOTO 506 IF(NSPT.LT.0)THEN NSPT=-NSPT ISCUT=1 548 WRITE(*,547) 547 FORMAT(1X/' Cutoff limits for the smooth: ',$) read(*,*,err=548)icutlo,icuthi if(icutlo.ge.icuthi)goto 548 ELSE ISCUT=0 ENDIF C M=NSPT/2 T1=3.D0/((2*M+1)*(2.D0*M-1.D0)*(2*M+3)) T2=3*M*M+3.D0*M-1.D0 DO 542 I=1,NSPT IS=I-M-1 SPOL(I)=T1*(T2-5*IS*IS) 542 CONTINUE C ISTRT=M+1 IFIN=NPTS-M DO 543 I=1,NPTS SUM=0 DO 544 J=1,NSPT IS=J-M-1 II=I+IS IF(II.LT.1)II=-II+1 IF(II.GT.NPTS)II=NPTS-(II-NPTS-1) IF(ISCUT.NE.1)THEN SUM=SUM+ISPEC(II)*SPOL(J) ELSE SUM=SUM+MIN(MAX(ISPEC(II),ICUTLO),ICUTHI)*SPOL(J) ENDIF 544 CONTINUE INTERM=SUM IF(INTERM.GT.32767)INTERM=32767 IF(INTERM.LT.-32767)INTERM=-32767 IPLOT(I)=INTERM 543 CONTINUE DO 545 I=1,NPTS ISPEC(I)=IPLOT(I) 545 CONTINUE C WRITE(*,546)BOLD,NORMAL,CHAR(7) 546 FORMAT(1X/1X,A,'***** Smoothing completed *****',2A) GOTO 1282 C C...Hardcopy, plot on either an Epson compatible printer or Roland plotter C 715 WRITE(*,730) 730 FORMAT(1X/' OPTIONS OF PLOTTED OUTPUT:'/20X,'0 = exit'/20X, * '1 = on NL-10 or FX-800 printer'/20X, * '2 - Roland DXY-880A plotter',12X,'..... '\) READ(*,1,ERR=715)IFLAG IF(IFLAG.LT.0.OR.IFLAG.GT.2)GOTO 715 IF(IFLAG.EQ.1)CALL PEPSON(FILNAM) IF(IFLAG.EQ.2)CALL PROLAN GOTO 1282 C C...Trial option C 614 WRITE(*,620) 620 FORMAT(1X/' X limits for transformation: ',$) READ(*,*,ERR=614)IXMIN,IXMAX IF(IXMAX.LE.IXMIN)GOTO 614 IF(IXMIN.LT.0)GOTO 614 IF(IXMAX.GT.NPTS)GOTO 614 621 WRITE(*,615) 615 FORMAT(1X/' Coefficients c.i, c.i+1, c.i+2, c.I+3: ',$) READ(*,*,ERR=621)CNI,CNI1,CNI2,CNI3 NSPT=7 M=NSPT/2 SUM=ABS(CNI)+2.D0*(ABS(CNI1)+ABS(CNI2)) SPOL(4)=CNI/SUM SPOL(3)=CNI1/SUM SPOL(5)=CNI1/SUM SPOL(2)=CNI2/SUM SPOL(6)=CNI2/SUM SPOL(1)=CNI3/SUM SPOL(7)=CNI3/SUM C ISTRT=IXMIN+M+1 IFIN=IXMAX-M LSMALL=32000 LLARGE=-32000 MSMALL=32000 MLARGE=-32000 BASES=0.D0 DO 616 I=ISTRT,IFIN SUM=0.D0 DO 617 J=1,NSPT IS=J-M-1 SUM=SUM+ISPEC(I+IS)*SPOL(J) 617 CONTINUE INTERM=SUM IF(INTERM.GT.32000)INTERM=32000 IF(INTERM.LT.-32000)INTERM=-32000 IPLOT(I)=INTERM IF(IPLOT(I).LT.MSMALL)MSMALL=IPLOT(I) IF(IPLOT(I).GT.MLARGE)MLARGE=IPLOT(I) IF(ISPEC(I).LT.LSMALL)LSMALL=ISPEC(I) IF(ISPEC(I).GT.LLARGE)LLARGE=ISPEC(I) BASES=BASES+ISPEC(I) 616 CONTINUE SCALE=(REAL(LLARGE)-real(LSMALL))/(REAL(MLARGE)-real(MSMALL)) BASEP=0.D0 DO 618 I=ISTRT,IFIN INTERM=(IPLOT(I)-MSMALL)*SCALE+LSMALL ISPEC(I)=INTERM BASEP=BASEP+ISPEC(I) 618 CONTINUE basep=basep/(ifin-istrt+1) bases=bases/(ifin-istrt+1) DO 622 I=ISTRT,IFIN ISPEC(I)=REAL(ISPEC(I))-(BASEP-BASES) 622 CONTINUE C WRITE(*,619)BOLD,NORMAL,CHAR(7) 619 FORMAT(1X/1X,A,'***** Transformation completed *****',2A) GOTO 1282 C C...ASCII output, frequency linearized spectrum has frequency values C as X-axis, for other spectra this is selectable C 507 WRITE(*,577)1,npts 577 FORMAT(1X/' Spectral point limits are: ',2i6/ * ' IXMIN,IXMAX (range of points to be output): '\) READ(*,*,ERR=507)IXMIN,IXMAX IF(IXMAX.LE.IXMIN)GOTO 579 IF(IXMIN.LT.0)GOTO 579 IF(IXMAX.GT.NPTS)GOTO 579 GOTO 5578 579 WRITE(*,600)CHAR(7) 600 FORMAT(' **** ERROR in bounds',A/) GOTO 507 C 5578 IF(PPS.LT.-500.)GOTO 574 C IF(LINEAR.EQ.0)THEN 578 WRITE(*,570) READ(*,*,ERR=578)XMIN,XMAX IF(XMIN.GE.XMAX)THEN WRITE(*,600)CHAR(7) GOTO 507 ENDIF ELSE XMIN=FSTART+((FEND-FSTART)/(NPTS-1))*(IXMIN-1) XMAX=FSTART+((FEND-FSTART)/(NPTS-1))*(IXMAX-1) ENDIF 570 FORMAT(1X/' XMIN,XMAX (Floating pt. limits for X in output): '\) C 572 WRITE(*,573) 573 FORMAT(1X/' YMIN,YMAX (limits for Y): '\) READ(*,*,ERR=572)YMIN,YMAX IF(YMIN.GE.YMAX)THEN WRITE(*,600)CHAR(7) GOTO 572 ENDIF IYS=ISMALL IYL=ILARGE IF(IXMAX-IXMIN+1.NE.NPTS)THEN IYL=0 IYS=17000 DO 5701 I=IXMIN,IXMAX IF(ISPEC(I).LT.IYS)IYS=ISPEC(I) IF(ISPEC(I).GT.IYL)IYL=ISPEC(I) 5701 CONTINUE ENDIF C 574 WRITE(*,'(1X//'' NAME OF OUTPUT FILE ? ''\)') READ(*,'(A)',ERR=574)FILNAM OPEN(3,FILE=FILNAM,STATUS='UNKNOWN',ERR=574) WRITE(3,1300)COMENT WRITE(3,'('' --->'',I6,'' data pairs follow'')')IXMAX-IXMIN+1 C IF(PPS.LT.-500.)THEN DO 5502 I=IXMIN,IXMAX WRITE(3,'(F10.3,I7)')DBLE(FREQS(I))*0.001D0,ISPEC(I) 5502 CONTINUE GOTO 5503 ENDIF C XSCAL=(XMAX-XMIN)/(IXMAX-IXMIN) YSCAL=(YMAX-YMIN)/(IYL-IYS) DO 575 I=IXMIN,IXMAX XOUT=(I-IXMIN)*XSCAL+XMIN YY=(ISPEC(I)-IYS)*YSCAL+YMIN if(linear.eq.0)then WRITE(3,576)XOUT,YY else WRITE(3,5576)XOUT,YY endif 575 CONTINUE 576 FORMAT(1P(E12.5,E13.5)) 5576 FORMAT(F12.4,1PE13.5) 5503 CLOSE(3) GOTO 1282 C C...Chop spectrum C 508 ixmod=1 WRITE(*,'(1X/5X,''1 = spectrum to be chopped out''/ * 5X,''2 = points to be discarded .... '',$)') READ(*,*,ERR=508)IFLAG IF(IFLAG.LT.1.or.IFLAG.GT.2)GOTO 508 776 WRITE(*,777)1,NPTS 777 FORMAT(1X/' Spectral point limits are: ',2i6/ * ' Point limits for chopping out/discarding: ',$) READ(*,*,ERR=776)IXMIN,IXMAX IF(IXMAX.LT.IXMIN)GOTO 580 IF((IXMAX.EQ.IXMIN).AND.(IFLAG.EQ.1))GOTO 580 IF(IXMIN.LT.0)GOTO 580 IF(IXMAX.GT.NPTS)GOTO 580 GOTO 581 580 WRITE(*,600)CHAR(7) GOTO 776 C 581 ISMALL=32000 ILARGE=-32000 C IF(NVKM.NE.0.AND.IFLAG.EQ.1)THEN XXX=IXMIN CALL VALY(YYY,XXX,NFUNCT) VKM(1)=YYY IVKM(1)=1 VKMST=YYY II=2 III=2 ENDIF IF(IFLAG.EQ.2.AND.NVKM.NE.0)THEN IF(IXMIN.EQ.1)THEN XXX=IXMAX+1 CALL VALY(YYY,XXX,NFUNCT) VKM(1)=YYY IVKM(1)=1 VKMST=YYY II=2 III=2 ELSE II=1 III=1 ENDIF ENDIF C C...move points C I=0 DO 582 N=1,NPTS IF(IFLAG.EQ.1.AND.(N.LT.IXMIN.OR.N.GT.IXMAX))GOTO 582 IF(IFLAG.EQ.2.AND.(N.GE.IXMIN.AND.N.LE.IXMAX))GOTO 582 I=I+1 ISPEC(I)=ISPEC(N) if(i.eq.1)fstart=fstold+(n-1)*fincr fend=fstold+(n-1)*fincr IF(PPS.LT.-500.)FREQS(I)=FREQS(N) IF(ISPEC(N).LT.ISMALL)ISMALL=ISPEC(N) IF(ISPEC(N).GT.ILARGE)ILARGE=ISPEC(N) IF(NVKM.EQ.0)GOTO 582 778 IF(iii.GT.nvkm)GOTO 582 IF(IVKM(III).GT.N)GOTO 582 IF(IVKM(III).LT.N)THEN III=III+1 GOTO 778 ELSE VKM(II)=VKM(III) IVKM(II)=I II=II+1 III=III+1 ENDIF 582 CONTINUE C IF(IFLAG.EQ.1.AND.NVKM.NE.0)THEN XXX=IXMAX CALL VALY(YYY,XXX,NFUNCT) VKM(II)=YYY IVKM(II)=I VKMEND=YYY NVKM=II ENDIF IF(IFLAG.EQ.2.AND.NVKM.NE.0)THEN IF(IXMAX.EQ.NPTS)THEN XXX=IXMIN-1 CALL VALY(YYY,XXX,NFUNCT) VKM(II)=YYY IVKM(II)=I VKMEND=YYY NVKM=II ELSE NVKM=II-1 ENDIF ENDIF NPTS=I C IF(NVKM.NE.0)THEN NSPLIN=NVKM DO 638 N=1,NVKM X(N)=IVKM(N) Y(N)=VKM(N) 638 CONTINUE CALL SPLINE ENDIF C WRITE(*,583)BOLD,NORMAL,CHAR(7) 583 FORMAT(1X/1X,A,'***** Chopping completed *****',2A) GOTO 1282 C C...Subtraction from the original spectrum (result rescaled to range of C +- 20000 during subtraction to avoid possible overflow problems) C 509 if(ixmod.eq.1)then WRITE(*,779)BOLD,NORMAL,char(7) 779 FORMAT(1X/1X,A,' ***** This option is not allowed since the', * ' X-axis has been modified'/8x,'by one of previous operations'/ * 20x,'- DO SUBTRACTIONS FIRST, X-AXIS OPERATIONS SECOND',2a/) goto 1282 endif c ismal4=1000000 ilarg4=-1000000 DO 2520 N=1,NPTS INTERM=IOLD(N) INTERM=INTERM-ISPEC(N) IF(interm.LT.ismal4)ismal4=interm IF(interm.GT.ilarg4)ilarg4=interm 2520 CONTINUE temp=40000./(ilarg4-ismal4) ISMALL=-20000 ILARGE=20000 DO 2500 N=1,NPTS INTERM=IOLD(N) INTERM=INTERM-ISPEC(N) ISPEC(N)=(INTERM-ismal4)*temp-20000. 2500 CONTINUE WRITE(*,2501)BOLD,NORMAL,CHAR(7) 2501 FORMAT(1X/1X,A,'***** Completed *****',2A) GOTO 1282 C C...Rescaling of the Y-axis C 510 WRITE(*,2510)ISMALL,ILARGE 2510 FORMAT(1X/' Present Y-axis limits: ',I6,',',I6,10X, * 'New limits: ',$) READ(*,*,ERR=510)IS,IL IF(IS.GE.IL)GOTO 510 IF(IS.LT.-32767.OR.IL.GT.32767)GOTO 510 INTERM=ILARGE RANGE=INTERM-ISMALL SCALE=(IL-IS)/RANGE DO 2511 N=1,NPTS INTERM=ISPEC(N) ISPEC(N)=(INTERM-ISMALL)*SCALE+IS 2511 CONTINUE ISMALL=IS ILARGE=IL WRITE(*,2501)BOLD,NORMAL,CHAR(7) GOTO 1282 C C...Elimination of (some) unlocks in spectrum with recorded frequency channel C 1203 CALL UNLOCK GOTO 1282 C C...Linearisation of spectrum with recorded frequency channel C 1204 IXMOD=1 CALL SQUINT(DELTAL) GOTO 1282 C C...Coaddition of up/down or down/up parts of the linearized spectrum C 1205 CALL COADD(DELTAL) GOTO 1282 C C...Saving of linearized spectrum in FREQLIN standard C 1206 CALL SAVFRE(deltal) GOTO 1282 C C...Correction of erronous harmonic used for calculation of frequency C 1207 CALL CORHAR GOTO 1282 C C...Appending of spectrum C 1208 CONTINUE CALL APPEND(PPS) GOTO 1282 C C...Execution of simple peakfinder and conversion of spectrum into ASPEC C compatible sticks C 511 SUM=0.0 DO 1512 I=1,NPTS SUM=SUM+ISPEC(I) 1512 CONTINUE IMEAN=SUM/NPTS WRITE(*,'(1X/'' Mean spectral value ='',I6)')IMEAN WRITE(*,'( '' Y-axis cutoff for peak-finder: '',$)') READ(*,*,ERR=511)IYCUT IF(IYCUT.LT.ISMALL.OR.IYCUT.GT.ILARGE)GOTO 511 C 1516 WRITE(*,'(1X/'' OUTPUT FILE NAME : ''\)') READ(*,1300,ERR=1302)FILNAM STAT='NEW' 497 OPEN(3,FILE=FILNAM,STATUS=STAT,ERR=498) GOTO 495 C 498 WRITE(*,'(1X,a1/'' THIS FILE ALREADY EXISTS, OVERWRITE (Y/N)? '' * ,$)')CHAR(7) READ(*,1300,ERR=498)CHARFL IF(CHARFL.EQ.'Y'.OR.CHARFL.EQ.'y')THEN STAT='UNKNOWN' GOTO 497 ENDIF IF(CHARFL.EQ.'N'.OR.CHARFL.EQ.'n')THEN 496 WRITE(*,'('' New file name: '',$)') READ(*,1300,ERR=496)FILNAM GOTO 497 ENDIF c 495 IFLAG=1 IF(NVKM.NE.0.AND.PPS.GT.-500.)THEN 1518 WRITE(*,'(1X/'' OUTPUT FREQUENCY IN: 1 = points''/ * 25X,''2 = frequency, OB-24d calibr.''/ * 25X,''3 = frequency, OB-30d calibr. ... '',$)') READ(*,*,ERR=1518)IFLAG IF(IFLAG.LT.1.OR.IFLAG.GT.3)GOTO 1518 IF(IFLAG.GT.1)THEN X12=BWOCAL(IFLAG-1,1) X10=BWOCAL(IFLAG-1,2) X32=BWOCAL(IFLAG-1,3) ENDIF ENDIF C C...simple peakfinder - maximum established to within a pixel on the basis C of five points (useful in this form for narrow lines oly) I=2 N=0 1514 I=I+1 IF(I.GT.NPTS-1)GOTO 1515 IF(ISPEC(I).LT.IYCUT)GOTO 1514 IF(ISPEC(I).GT.ISPEC(I-2).AND.ISPEC(I).GT.ISPEC(I-1).AND. * ISPEC(I).GT.ISPEC(I+2).AND.ISPEC(I).GT.ISPEC(I+1))THEN XXX=I IF(IFLAG.GT.1)THEN CALL VALY(YYY,XXX,NFUNCT) YYY=0.001D0*YYY YY=DSQRT(YYY) XXX=X12*YY+X10*YYY+X32*YY*YYY ENDIF IF(PPS.LT.-500.)XXX=FREQS(I) XX=ISPEC(I)-IMEAN WRITE(3,1517)XXX,XX 1517 FORMAT(F14.6,1PE10.2,' 1, 0, 1 0, 0, 0 a') I=I+3 N=N+1 ENDIF GOTO 1514 C 1515 CLOSE(3) WRITE(*,'(1X/1X,I5,'' lines identified'')')N GOTO 1281 C C...Exit and disk output C 500 WRITE(*,520)bold,FILINP,normal 520 FORMAT(1X/' Do you want to save the modified spectrum from ', * 'file: '/30x,3a,' .... ? '\) READ(*,1,ERR=500)IFLAG 1 FORMAT(I5) IF(IFLAG.NE.1)GOTO 1410 1302 WRITE(*,'(1X/'' OUTPUT FILE NAME : ''\)') READ(*,1300,ERR=1302)FILNAM CALL SAVESP(FILNAM) C 1410 WRITE(*,1411) 1411 FORMAT(1X/' Any further modifications ? '\) READ(*,530,ERR=1410)IFLAG IF(IFLAG.NE.0)GOTO 1282 C STOP END C C------------------------------------------------------------------------ C SUBROUTINE CORHAR IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-N) PARAMETER (NMAXPT=32000, maxfre=27000) INTEGER*4 FREQS C COMMON /SPEC/freqs(maxfre),ISPEC(NMAXPT),NPTS,ISMALL,ILARGE C 2 WRITE(*,1) 1 FORMAT(1X/' Numbers of current and required harmonics, ', * 'respectively: ',$) READ(*,*,ERR=2)NCUR,NREQ C R=REAL(NREQ)/REAL(NCUR) DO 3 N=1,NPTS FREQ=REAL(FREQS(N))*0.001D0 FREQ=(FREQ+20.D0)*R-20.D0 FREQS(N)=FREQ*1000.D0 3 CONTINUE C RETURN END C C------------------------------------------------------------------------ C SUBROUTINE UNLOCK IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-N) PARAMETER (NMAXPT=32000, maxfre=27000) INTEGER*4 FREQS C COMMON /SPEC/freqs(maxfre),ISPEC(NMAXPT),NPTS,ISMALL,ILARGE C c...IX determines how close to the unlocked point are to be the points used c for identifying and correcting the unlock. IX=2 defines the simplest, c 'single point' unlock for which the unlocked frequency is reliably c given by frequencies of the nearest neighbours c open(4,file='unlock',status='unknown') DO 2 IX=2,4 WRITE(*,3)IX-1 3 FORMAT(1X/I2,' point unlocks eliminated at point number:'/) DO 1 I=1+ix,NPTS-ix c c...identification: unlock is defined to be present if frequency of a point c calculated as a mean of a pair of straddling points differs from c its recorded frequency by a certain fraction of the mean local gradient c freq=dble(freqs(i)) delm=DBLE(FREQS(I-ix+1))-DBLE(FREQS(I-ix)) delp=DBLE(FREQS(I+ix))-DBLE(FREQS(I+ix-1)) IF(DELM.EQ.0.D0.OR.DELP.EQ.0.D0)GOTO 1 IF(ABS(DELM/DELP).GT.2.D0.OR.ABS(DELM/DELP).LT.0.5D0)GOTO 1 delmn=0.5d0*(delm+delp) IF(DELMN.EQ.0.D0)GOTO 1 fmean=0.5d0*(dble(freqs(i+ix-1))+dble(freqs(i-ix+1))) if(abs((fmean-freq)/delmn).lt.1.d0)goto 1 c c...corrective action: this is applied if there is satisfactory correspondence c between the frequencies of the unlocked point predicted from two pairs c of points, one below, one above this point. The questionable frequency c is then replaced by the mean frequency from two closest straddling c points. c write(4,*)'unlock at point = ',i predm=dble(freqs(i-ix+1))+(ix-1)*delm predp=dble(freqs(i+ix-1))-(ix-1)*delp if(abs((predm-predp)/delmn).lt.1.d0)then freqs(i)=fmean write(4,*)ix-1,' point unlock eliminated at point = ',i WRITE(*,5)I 5 FORMAT(I6,$) endif 1 CONTINUE WRITE(*,'(1X)') 2 CONTINUE CLOSE(4) WRITE(*,'(1X/'' Press ENTER to continue .... '',$)') READ(*,'(I1)',ERR=6)I C 6 RETURN END C C------------------------------------------------------------------------ C SUBROUTINE COADD(DELTA) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-N) PARAMETER (NMAXPT=32000, maxfre=27000) INTEGER*4 FREQS,INTERM C COMMON /SPEC/freqs(maxfre),ISPEC(NMAXPT),NPTS,ISMALL,ILARGE 1 /PLOTC/IPLOT(NMAXPT) C IF(DELTA.EQ.0.D0)THEN WRITE(*,'(1X/'' **** Run this option AFTER linearisation'')') RETURN ENDIF C C...cases: /\ and / C \ \/ IF( (FREQS(NPTS).LT.FREQS(1).AND.FREQS(2).GT.FREQS(1)) .OR. * (FREQS(NPTS).GT.FREQS(1).AND.FREQS(2).LT.FREQS(1)) )THEN I=1 FSTART=FREQS(1) DO 3 J=NPTS,1,-1 IF( ABS((DBLE(FREQS(J))-FSTART)/DELTA).LT.0.1D0)GOTO 2 3 CONTINUE WRITE(*,5) 5 FORMAT(1X/' **** Something wrong in coaddition limits'/) ENDIF C C...cases: /\ and \ C / \/ IF( (FREQS(NPTS).GT.FREQS(1).AND.FREQS(2).GT.FREQS(1)) .OR. * (FREQS(NPTS).LT.FREQS(1).AND.FREQS(2).LT.FREQS(1)) )THEN J=NPTS FSTART=FREQS(J) DO 4 I=1,NPTS IF( ABS((DBLE(FREQS(I))-FSTART)/DELTA).LT.0.1D0)GOTO 2 4 CONTINUE WRITE(*,5) ENDIF WRITE(*,5) C C...Coadd C 2 WRITE(*,'(1X/'' Starting points for coaddition:'', 2I6/ * '' point spacing:'',F10.6, * '' MHz'')') * I,J,DELTA*0.001D0 IF(I.EQ.J)THEN WRITE(*,5) RETURN ENDIF ISMALL=32000 ILARGE=-32000 II=1 DEL=FREQS(I+1)-FREQS(I) C 6 INTERM=0.5D0*(DBLE(ISPEC(I))+DBLE(ISPEC(J))) FREQS(II)=FREQS(I) IF(INTERM.GT.32000)INTERM=32000 IF(INTERM.LT.-32000)INTERM=-32000 ISPEC(II)=INTERM IF(ISPEC(II).LT.ISMALL)ISMALL=ISPEC(II) IF(ISPEC(II).GT.ILARGE)ILARGE=ISPEC(II) II=II+1 I=I+1 J=J-1 IF(DBLE(FREQS(I+1)-FREQS(I))/DEL.LT.0.D0)GOTO 7 IF( ABS((DBLE(FREQS(I))-DBLE(FREQS(J)))/DELTA).LT.0.1D0) GOTO 6 C 7 NPTS=II-1 WRITE(*,'(1X/'' Coadded spectrum is'',I6,'' points long'')')NPTS C RETURN END C C------------------------------------------------------------------------ C SUBROUTINE LOOK C C Plot of spectrum with scrolling along the C X-axis and zooming along both X and Y axes C C - ISPEC() contains the raw spectrum C - ISCRN() contains a screen of transformed spectrum C - IPSCRN() is a buffer for numerical transformations of ISCRN C - ISC is a pointer to whether currently displayed spectrum is from ISPEC() C or from ISCRN() C INCLUDE 'FGRAPH.FD' C PARAMETER (NMAXPT=32000, maxfre=27000, maxvol=500, maxcal=200, * maxspl=500, ratiom=1.1) 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,NFUNCT INTEGER*2 maxx,maxy,ISPEC(NMAXPT),NPTS,ISMALL,ILARGE,dummy, * mygmod,linofs,inkey,NHORPT,NHOR2,NVKM,IVKM(maxvol),NSPLIN, * NCALPT,LINEAR,IXMIN,IXMAX INTEGER*4 INTERM,imsize,freqs,MINFR,MAXFR REAL*4 VKM(maxvol),PPS REAL*8 RSMALL,RLARGE,RMBOT,RMTOP,RANGE,YMAX,YMIN, * YSTEP,YLEVEL,XX,YY,HTMARK,FSTART,FEND,FINCR,XCALPT(maxcal), * YCALPT(maxcal),FMARK,FREQ,PRED(6) REAL*8 X(maxspl),Y(maxspl),A(maxspl),B(maxspl),C(maxspl), * D(maxspl),GRA,CA,GRB,CB CHARACTER OUTSTR*21,COM1*72 CHARACTER*79 toplin,botlin,emplin,paslin C COMMON /limits/maxx,maxy,mygmod,linofs,curpos,ixy,wxy COMMON /SPEC/freqs(maxfre),ISPEC,NPTS,ISMALL,ILARGE COMMON /lines/toplin,botlin,emplin,paslin COMMON /CALVOL/VKM,IVKM,NVKM,PPS COMMON /SPL/NSPLIN,X,Y,A,B,C,D,GRA,CA,GRB,CB COMMON /LINFRE/FSTART,FEND,FINCR COMMON /CALFRE/XCALPT,YCALPT,NCALPT,COM1,LINEAR C linofs=14 RSMALL=ISMALL RLARGE=ILARGE WRITE(botlin,601) 601 FORMAT('A<-x->S Z<-y->W K<-marker->L Also:', * ' Xn XL Y R F G H=help') C IF(NVKM.NE.0)THEN NSPLIN=NVKM DO 637 N=1,NVKM X(N)=IVKM(N) Y(N)=VKM(N) 637 CONTINUE CALL SPLINE ENDIF C 155 WRITE(*,'(/1x,A1,''Ready to plot - press ENTER ''\)')CHAR(7) 900 READ(*,'(I5)',ERR=900)I C C...Plot of spectrum from ISPEC() C CALL graphicsmode() dummy=setactivepage(1) dummy=setvisualpage(1) pixcol=getcolor() NHORPT=maxx+1 NHOR2=NHORPT/2 NSTART=1 NEND=NHORPT MARKER=NHOR2 IF(NPTS.LT.NEND)NEND=NPTS C C...horizontal lines, bottom info line and definition of graphics viewport C (note that pixel origin is now at absolute {0,linofs+1}) CALL moveto(0,linofs,ixy) dummy=lineto(maxx,linofs) CALL moveto(0,maxy-linofs,ixy) dummy=lineto(maxx,maxy-linofs) CALL settextposition(25,1,curpos) CALL outtext(botlin) call setviewport(0,linofs+1,maxx,maxy-linofs-1) dummy=setwindow(.TRUE.,0.0d0,RSMALL, * DBLE(maxx),RLARGE) C C...dotted marker bar, horizontal and vertical lines $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...spectrum C 33 dummy=setwindow(.TRUE.,0.0d0,RSMALL, * DBLE(maxx),RLARGE) $NODEBUG CALL setlinestyle(#FFFF) $DEBUG CALL clearscreen($GVIEWPORT) IX=0 CALL moveto_w(DBLE(IX),DBLE(ISPEC(NSTART)),wxy) DO 6 I=NSTART+1,NEND dummy=lineto_w(DBLE(IX),DBLE(ISPEC(I))) IX=IX+1 6 CONTINUE ISC=0 c c...marker and heading 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...if frequency channel present then draw the autoscaled point number- C frequency plot C IF(PPS.LT.-500.)THEN MINFR=1200000000 MAXFR=0 DO 331 I=NSTART,NEND IF(FREQS(i).LT.MINFR)MINFR=FREQS(i) IF(FREQS(i).GT.MAXFR)MAXFR=FREQS(i) 331 CONTINUE dummy=setwindow(.TRUE.,0.0d0,DBLE(MINFR), * DBLE(maxx),DBLE(MAXFR)) IX=0 CALL moveto_w(DBLE(IX),DBLE(FREQS(NSTART)),wxy) DO 666 I=NSTART+1,NEND dummy=lineto_w(DBLE(IX),DBLE(FREQS(I))) IX=IX+1 666 CONTINUE dummy=setwindow(.TRUE.,0.0d0,RSMALL, * DBLE(maxx),RLARGE) ENDIF C C......O P T I O N S L O O P c C...update top of screen information 77 CALL settextposition(1,1,curpos) C IF(NVKM.NE.0.AND.PPS.GT.-500.)THEN XX=NSTART+MARKER CALL VALY(YY,XX,NFUNCT) WRITE(toplin,636)NSTART,NEND,INT(RSMALL),INT(RLARGE), * NSTART+MARKER,YY 636 FORMAT('X:',2I6,5X,'Y:',2I7,12X,'Marker: ',I5,3X, * F8.3,'mV') ELSE IF(LINEAR.EQ.1)THEN FMARK=FSTART+(NSTART+MARKER-1)*FINCR WRITE(toplin,890)NSTART,NEND,INT(RSMALL),INT(RLARGE), * NSTART+MARKER,FMARK 890 FORMAT('X:',2I6,5X,'Y:',2I7,12X,'Marker: ',I5,3X, * F10.3,' MHz') ELSE IF(PPS.LT.-500.)THEN FMARK=DBLE(FREQS(NSTART+MARKER))*0.001D0 WRITE(toplin,890)NSTART,NEND,INT(RSMALL),INT(RLARGE), * NSTART+MARKER,FMARK ELSE WRITE(toplin,600)NSTART,NEND,INT(RSMALL),INT(RLARGE), * NSTART+MARKER 600 FORMAT('X:',2I6,5X,'Y:',2I7,12X,'Marker: ',I5,3X, * 'No freq. or V ') ENDIF C CALL outtext(toplin) 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 and , - move marker over the spectrum C - move to beginning/end of spectrum C H - display HELP screen C C only for spectrum with frequency channel: C F - manual change in frequencies of selected points C G - linear approximation to badly unlocked region of spectrum 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 720 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(PPS.LT.-500.0.AND.(KK.EQ.'F'.OR.KK.EQ.'f'))GOTO 901 IF(PPS.LT.-500.0.AND.(KK.EQ.'G'.OR.KK.EQ.'g'))GOTO 907 IF(KK.EQ.'R'.OR.KK.EQ.'r')THEN RSMALL=ISMALL RLARGE=ILARGE IF(ISC.EQ.1)GOTO 104 GOTO 33 ENDIF IF(IK.EQ.-71)THEN NSTART=1 NEND=NSTART+maxx IF(NEND.GT.NPTS)NEND=NPTS GOTO 33 ENDIF 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(1,1,curpos) CALL outtext(emplin) 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 CALL settextposition(1,1,curpos) CALL outtext(toplin) GOTO 7 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 marker 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 marker 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...Centre the marker C 720 call putimage_w(DBLE(MARKER),RMTOP,MARK,$GXOR) MARKER=maxx/2 GOTO 719 C C...Y axis zoom C 51 YSTEP=(RLARGE-RSMALL)/(maxy-2*(linofs+1)) YLEVEL=RLARGE-0.1*(RLARGE-RSMALL) CALL putimage_w(0.0D0,YLEVEL,ROW,$GXOR) dummy=0 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) 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) 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 INTERM=IST INTERM=INTERM+IR IF(INTERM.GT.NPTS)THEN IFIN=NPTS IST=IFIN-IR IF(IST.LT.1)IST=1 ELSE IFIN=INTERM ENDIF 370 IF(ISC.EQ.1)GOTO 170 C 170 NP=0 II=0 INTERM=0 DO 56 N=IST,IFIN II=II+1 INTERM=INTERM+ISPEC(N) IF(II.LT.IK)GOTO 56 NP=NP+1 ISCRN(NP)=INTERM/IK II=0 INTERM=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) 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) IF(INTERM.LT.-32000)INTERM=-32000 IF(INTERM.GT.32000)INTERM=32000 IPSCRN(I)=INTERM 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) IF(INTERM.LT.-32000)INTERM=-32000 IF(INTERM.GT.32000)INTERM=32000 ISCRN(N)=INTERM 103 CONTINUE ISCRN(maxx)=IPSCRN(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 dummy=setwindow(.TRUE.,0.0d0,RSMALL, * DBLE(maxx),RLARGE) CALL clearscreen($GVIEWPORT) IX=0 CALL moveto_w(DBLE(IX),DBLE(ISCRN(1)),wxy) DO 58 I=2,NP dummy=lineto_w(DBLE(IX),DBLE(ISCRN(I))) IX=IX+1 58 CONTINUE ISC=1 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 CALL settextposition(1,1,curpos) INTERM=IST+MARKER*(REAL(IFIN-IST)/(NP-1)) IF(NVKM.EQ.0)THEN WRITE(toplin,600)IST,IFIN,INT(RSMALL),INT(RLARGE),INTERM ELSE XX=INTERM CALL VALY(YY,XX,NFUNCT) WRITE(toplin,636)IST,IFIN,INT(RSMALL),INT(RLARGE), * INTERM,YY ENDIF CALL outtext(toplin) C GOTO 7 C C...Manual change in point frequency for a spectrum with recorded frequency C channel C 901 CALL clearscreen($GVIEWPORT) CALL settextposition(3,1,curpos) K=NSTART+MARKER KSTRT=K-2 KFIN=K+2 IF(KSTRT.LT.1)THEN KSTRT=1 KFIN=5 ENDIF IF(KFIN.GT.NPTS)THEN KFIN=NPTS KSTRT=KFIN-4 ENDIF WRITE(*,903)(I,I=KSTRT,KFIN),(ISPEC(I),I=KSTRT,KFIN), * (DBLE(FREQS(I))*0.001D0,I=KSTRT,KFIN), * ((DBLE(FREQS(I))-DBLE(FREQS(I-1)))*0.001D0,I=KSTRT+1,KFIN) 903 FORMAT(' CHANGE FREQUENCY OF UNLOCKED POINT:'// * ' point no: ',5I11/ * ' intensity: ',5I11/ * ' frequency: ',5F11.3/ * ' differences: ',4X,5F11.3) PRED(1)=(DBLE(FREQS(KSTRT+1))+DBLE(FREQS(KFIN-1)))*0.0005D0 PRED(2)=(DBLE(FREQS(KSTRT))+DBLE(FREQS(KFIN)))*0.0005D0 PRED(3)=(DBLE(FREQS(KSTRT))+2.D0/3.D0* * (DBLE(FREQS(KFIN-1))-DBLE(FREQS(KSTRT))))*0.001D0 PRED(4)=(DBLE(FREQS(KSTRT+1))+1.D0/3.D0* * (DBLE(FREQS(KFIN))-DBLE(FREQS(KSTRT+1))))*0.001D0 PRED(5)=(DBLE(FREQS(KSTRT+1))+ * (DBLE(FREQS(KSTRT+1))-DBLE(FREQS(KSTRT))))*0.001D0 PRED(6)=(DBLE(FREQS(KFIN-1))- * (DBLE(FREQS(KFIN))-DBLE(FREQS(KFIN-1))))*0.001D0 WRITE(*,904)PRED,K 904 FORMAT(1X/' Predictions for central point: 2,4 ',F10.3/ * 1X,T34,'1,5 ',F10.3/1X,T34,'1,4 ',F10.3/1X,T34,'2,5 ',F10.3/ * 1X,T34,'1,2 ',F10.3/1X,T34,'4,5 ',F10.3//' ENTER to ignore or' * /5X,'new frequency for point ',I5,': ',$) READ(*,'(F15.5)',ERR=901)FREQ IF(FREQ.EQ.0.D0)GOTO 33 FREQS(K)=FREQ*1000.D0 GOTO 33 C C...Linear approximation to a section of frequency channel C 907 CALL clearscreen($GVIEWPORT) CALL settextposition(5,1,curpos) WRITE(*,908) 908 FORMAT(' LINEAR APPROXIMATION TO A SECTION OF THE FREQUENCY', * ' CHANNEL:'// * ' defining points (exit if any is zero) : ',$) READ(*,*,ERR=907)IXMIN,IXMAX IF(IXMIN.EQ.0.OR.IXMAX.EQ.0)GOTO 33 IF(IXMIN.GE.IXMAX)GOTO 907 IF(IXMIN.LT.1.OR.IXMAX.GT.NPTS)GOTO 907 C AAA=FREQS(IXMIN) BBB=(DBLE(FREQS(IXMAX))-DBLE(FREQS(IXMIN)))/DBLE(IXMAX-IXMIN) DO 909 I=IXMIN+1,IXMAX-1 FREQS(I)=AAA+BBB*DBLE(I-IXMIN) 909 CONTINUE GOTO 33 C C...Help screen C 630 CALL clearscreen($GVIEWPORT) CALL settextposition(3,1,curpos) 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',/ * 3X,'K,L and , - move marker over the spectrum'/ * ' - move to beginning/end of spectrum'/ * 9X,' (all cursor operations are fast/slow for ', * 'upper/lower case)'/ * 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,' R - rescale Y axis to original values'// * 7X,' ------- only for spectra with frequency channel ------'/ * 9X,' F - change frequency of a point (for unlocks)'/ * 9X,' G - replace section of frequency curve with straight line'/ * /20X,'..... exit this HELP screen with ENTER ',$) C 631 IK=INKEY(I) IF(IK.NE.13)GOTO 631 IF(ISC.EQ.1)GOTO 104 GOTO 33 C C...Error in options C 76 WRITE(*,'(2A1,$)')CHAR(7),CHAR(7) GOTO 33 C 37 RETURN END C C------------------------------------------------------------------------ C SUBROUTINE graphicsmode() C C This routine determines the graphics card on the PC and sets the C highest resolution graphics mode available with this card. It also C determines the pixel limits on x and y axes (0,maxx), (0,maxy) C INCLUDE 'FGRAPH.FD' C RECORD /rccoord/curpos RECORD /xycoord/ixy RECORD /wxycoord/wxy INTEGER*2 dummy,maxx,maxy,mygmod,linofs RECORD /videoconfig/myscreen COMMON /limits/maxx,maxy,mygmod,linofs,curpos,ixy,wxy C C...Find graphics mode. C CALL getvideoconfig(myscreen) SELECT CASE( myscreen.adapter ) CASE( $CGA ) dummy = setvideomode( $HRESBW ) mygmod=$HRESBW CASE( $OCGA ) dummy = setvideomode( $ORESCOLOR ) mygmod=$ORESCOLOR CASE( $EGA, $OEGA ) IF( myscreen.monitor .EQ. $MONO ) THEN dummy = setvideomode( $ERESNOCOLOR ) mygmod=$ERESNOCOLOR ELSE dummy = setvideomode( $ERESCOLOR ) mygmod=$ERESCOLOR END IF CASE( $VGA, $OVGA, $MCGA ) C C...this setting best for colour VGA and 25 rows of text dummy = setvideomode( $ERESCOLOR ) mygmod=$ERESCOLOR C C...this setting best for mono VGA and 25 rows of text c dummy = setvideomode( $ERESNOCOLOR ) c mygmod=$ERESNOCOLOR c c...$VRES2COLOR and VRES16COLOR options have built in 32 row text screen C dummy = setvideomode( $VRES2COLOR ) C mygmod=$VRES2COLOR CASE( $HGC ) dummy = setvideomode ( $HERCMONO ) mygmod=$HERCMONO CASE DEFAULT dummy = 0 END SELECT C IF( dummy .EQ. 0 ) STOP 'Error: cannot set graphics mode' C C...Set video mode and return pixel limits C CALL getvideoconfig( myscreen ) maxx = myscreen.numxpixels - 1 maxy = myscreen.numypixels - 1 C RETURN END C C------------------------------------------------------------------------