Open Collections

UBC Theses and Dissertations

UBC Theses Logo

UBC Theses and Dissertations

Improved method of determining the component separation of blended spectral lines. Olson, Bernt Ingemar 1971

Your browser doesn't seem to have a PDF viewer, please download the PDF to view this item.

Notice for Google Chrome users:
If you are having trouble viewing or searching the PDF with Google Chrome, please download it here instead.

Item Metadata

Download

Media
831-UBC_1971_A6_7 O48.pdf [ 4.07MB ]
Metadata
JSON: 831-1.0053443.json
JSON-LD: 831-1.0053443-ld.json
RDF/XML (Pretty): 831-1.0053443-rdf.xml
RDF/JSON: 831-1.0053443-rdf.json
Turtle: 831-1.0053443-turtle.txt
N-Triples: 831-1.0053443-rdf-ntriples.txt
Original Record: 831-1.0053443-source.json
Full Text
831-1.0053443-fulltext.txt
Citation
831-1.0053443.ris

Full Text

AN IMPROVED METHOD OF DETERMINING THE COMPONENT SEPARATION OF BLENDED SPECTRAL LINES by BERNT INGEMAR OLSON B.Sc, Simon Fraser University, 1969 A THESIS SUBMITTED IN PARTIAL FULFILMENT OF THE REQUIREMENTS FOR THE DEGREE OF MASTER OF SCIENCE in the Department of GEOPHYSICS We accept t h i s thesis as conforming to the required standard THE UNIVERSITY OF BRITISH COLUMBIA A p r i l , 1971 In presenting this thesis in partial fulfilment of the requirements for an advanced degree at the University of Brit ish Columbia, I agree that the Library shall make it freely available for reference and study. I further agree that permission for extensive copying of this thesis for scholarly purposes may be granted by the Head of my Department or by his representatives. It is understood that copying or publication of this thesis for financial gain shall not be allowed without my written permission. Depa rtment The University of Brit ish Columbia Vancouver 8, Canada Date i i Abstract An automated method of determining the r e l a t i v e l i n e separations on d i g i t i z e d blended s t e l l a r spectra has been developed. A pair of standard p r o f i l e s are f i t t e d to the observed blended p r o f i l e by allowing the standards to relax in p o s i t i o n and amplitude u n t i l a least-square 'best f i t ' i s obtained. The technique has been tested on numerous blends of known separation and i t has been shown that with c e r t a i n r e s t r i c t i o n s on the r e l a t i v e amplitudes i t i s not susceptible to systematic errors. Blended hydrogen and helium l i n e s i n two B-stars have been separated to < 100 km/sec at 30 A/mm with a probable error of 15 km/sec. i i i Table of Contents page Introduction 1 Description of Microdensitometer 2 Intensity C a l i b r a t i o n 8 Continuum Determination 13 Wavelength C a l i b r a t i o n 14 Accuracy of Wavelength C a l i b r a t i o n 16 Standard P r o f i l e s 19 Determination of Line Positions 20 Accuracy of Computed Separation 26 Conclusions 29 References 40 Appendix I - Sample Line P r o f i l e s 41 Appendix II - Paper Tape Format § MDM Operation 46 Appendix III - How To Use the Program 50 Appendix IV - Input Deck:Setups 55 Appendix V - L i s t i n g of Fortran Programs 59 i v L i s t of Figures page 1. Schematic Diagram of Microdensitometer 3 2. D i s t r i b u t i o n of C a l i b r a t i o n Density Values for Several Sections With and Without Emulsion Defects 9 3. C a l i b r a t i o n Curves with Various Parameter Settings 12 4. T r i a l Positions for F i t to Two-Component Blend 22 5. Types of Multiple Blends 23 6. Results for a l l Hydrogen Lines 35 7. Results-for a l l "Helium" Lines 36 8. Results for Hydrogen Lines (Ampl/Amp2 < 1.35) 37 9. Results for "Helium" Lines (Ampl/Amp2 < 1.35) 38 10. Results of P e t r i e , Andrews, § Scarfe 39 11. Sample Line P r o f i l e s 43 12. Sample Line P r o f i l e s 44 13. Sample Line P r o f i l e s 45 V L i s t of Tables page I. Standard Deviations of Single-Line Widths 27 II. Results for i Her 32 II I . Results for n Lyr A 34 1 Introduction This project was started at the encouragement of Dr. M. W. Ovenden, who has done some studies on the systematic l i n e displacements i n close binaries (Ovenden, 1963). To explain the observed e f f e c t of a c o r r e l a t i o n of the v e l o c i t y amplitude of a l i n e with e x c i t a t i o n he put forward the r e f l e c t i o n e f f e c t model, which proposes that the inside sur-faces of the two stars are r e l a t i v e l y hotter and hence give r i s e to higher e x c i t a t i o n l i n e s (which would have smaller v e l o c i t y amplitudes). To further this research i t was deemed desirable to have a more objective and speedier method of determining the l i n e p o s i t i o n s . With t h i s object i n mind the department's automated Joyce-Loebl microdensitometer was used to d i g i t i z e short sec-tions of a r t i f i c i a l l y blended s t e l l a r spectra containing the p a r t i c u l a r l i n e ( s ) to be analyzed. The r e s u l t i n g punched paper tape output was then analyzed (by means of a computer program written in Fortran IV) for the component separations of the blended l i n e s . The plate material used was a set of 10 a r t i f i c i a l l y blended spectra of i Her (HD 160762) B3V and n Lyr A (HD 180163) B2IV taken i n 1965 with the V i c t o r i a 72-inch telescope and the IM camera (Hy dispersion = 30 A/mm). 2 Description of Microdensitometer The Joyce-Loebl microdensitometer (MDM) used for thi s project i s a null-type double-beam instrument. A single l i g h t source i s used to give o f f two beams; one of these goes through the specimen to be measured and the other i s a re f e r -ence beam. These are then passed through a synchronous shutter onto a single photomultiplier. The lamp (L) (see F i g . 1.) i s mounted on a stage that can be adjusted to give maximum output i n t e n s i t y in the two beams. The specimen beam (SB) i s defined by an i r i s diaphragm (D) and a s l i t (S), and then focussed on the specimen (X) by a condenser (C). The s l i t jaws are made of dark red glass to illuminate a larger area of the specimen than the measuring beam proper. Adjustments on the condenser mount allow a small v a r i a t i o n of the beam p o s i t i o n so i t i s properly aligned with the fixed microscope (M) which magnifies the specimen and focusses i t on a viewing screen containing the analyzing s l i t (A). The reference beam (RB) passes through two gray wedges used to regulate i t s i n t e n s i t y . One of these (Z) i s manually operated and i s used to set the zero point. Both beams are then admitted to the photomultiplier (PM) aft e r passing through a synchronous shutter (H) which trans-mits only one beam at a time. The difference between the two beams i s used to control the p o s i t i o n of the measuring wedge (W), which i s adjusted so that both the specimen beam and reference beam are of the same i n t e n s i t y . Several wedges of 3 F i g . 1. Schematic Diagram of Microdensitometer 4 d i f f e r e n t gradients are available to accommodate specimens of d i f f e r e n t density ranges, and there are provisions for inser-ting f i l t e r s (F) into the beams to control t h e i r i n t e n s i t y . In p a r t i c u l a r a blue f i l t e r may be placed in the sample beam to eliminate the e f f e c t of red l i g h t scattered by the specimen into the analyzing s l i t ; t h i s also necessitates placing a f i l t e r i n the reference beam to balance the beam i n t e n s i -t i e s . Unfortunately the net e f f e c t of this i s to considerably reduce the i n t e n s i t y incident on the photomuliplier, e s p e c i a l l y for narrow analyzing s l i t s , which i n turn causes a slower response of the measuring wedge. This has the e f f e c t of d i s -t o r t i n g the p r o f i l e s being measured and hence s h i f t i n g t h e i r apparent p o s i t i o n s . This i s e s p e c i a l l y true for the sharper l i n e s such as those i n the comparison iron arcs. For this reason no f i l t e r s were used during t h i s project. The specimen i s clamped to the specimen table, which rides on three t e f l o n pads s l i d i n g on two guide r a i l s . An angular adjustment screw f a c i l i t a t e s alignment of the speci-men with the scan d i r e c t i o n . The MDM can be operated i n eithe r analog or d i g i t a l mode. In analog mode the specimen table i s connected by means of a lever arm to a chart table which i s driven by the machine. This table moves perpendicular to the measuring wedge motion and a pen attached to the wedge assembly draws a l i n e on the chart paper. Several magnifications from 1 to 1000 are a v a i l -5 able depending on the p o s i t i o n of the fulcrum pin on the lever arm. This arrangement ensures a one-to-one p o s i t i o n a l r e l a t i o n between specimen and trac i n g . In the d i g i t a l mode the specimen table i s connected by-means of a threaded half-nut to a screw which i s driven by a stepping motor. Step size and scan length controls as well as buttons for continuous and incremental motion, scan d i r e c t i o n and start-/stop-scan buttons are located on the front panel. The "Y" d i r e c t i o n of motion has an analogous set of controls. The measuring wedge p o s i t i o n i s converted to a voltage by a pot with two outputs. One of these i s d i g i t i z e d by the MDM and fed onto a teletype paper tape punch; the other i s occasionally used to drive a chart recorder. By means of the controls the MDM can be programmed: i ) to scan an aperture within the l i m i t s of 20 cm i n "X" and 10 cm i n "Y", i i ) to have "X" d i g i t i z i n g i n t e r v a l s of 5 u, or multiples thereof, up to a l i m i t of 5 mm, and i i i ) to have "Y" scanning i n t e r v a l s of 5 y, or multiples thereof up to a l i m i t of 5 mm. At the end of each X scan the MDM returns to i t s o r i g i -nal X p o s i t i o n , takes one step i n Y, and recommences X scan-ning, u n t i l the desired scan area i s completed. Each X step consists of several discrete actions: i ) the specimen table i s moved one increment i n X, i i ) the measuring wedge i s adjusted to equalize the two beam i n t e n s i t i e s , and i i i ) the 6 wedge p o s i t i o n is d i g i t i z e d and punched out. The time for each such step i s not constant but depends on the specimen density; dark samples being scanned slower than l i g h t ones. (Typical scan rates are 160-170 pts/min.) This has the consequence that very sharp features w i l l not have accurately determined p r o f i l e s . One way to diminish this e f f e c t i s to reduce the wedge damping, permitting i t to respond more r a p i d l y , but t h i s also tends to increase the noisiness of the record which can then be reduced only by widening the s l i t . The best procedure may be to use low damping factors only for the iron arc comparison spectra, where i t i s important to have sharp p r o f i l e s , and s l i g h t l y higher damping for the s t e l l a r spectra which do not contain comparably sharp l i n e s and where i t i s desirable to have low-noise scans. During t h i s project, however, only the low damping was used since the program should be able to separate the l i n e s from even rather higher noise content. In the analog mode the density p r o f i l e i s continuously d i f f e r e n t i a t e d and the chart table slowed down on steep grad-ients to give the wedge time to reach the true p o s i t i o n and to l e t the pen move over the chart paper without skipping. This feature allows one to obtain accurate l i n e p r o f i l e s , but can be disengaged i f so desired. The variable d i g i t i z i n g stepping rate makes i t a ques-tionable procedure to use the chart recorder output (which has 7 a constant-time base) for serious work on samples requiring posi-t i o n a l measurements of features with large density v a r i a t i o n s . Low contrast p r o f i l e s are v i r t u a l l y d i s t o r t i o n free , however, and are quite acceptable. Each d i g i t i z e d output point consists of three paper tape frames of decimal d i g i t s an ASCII code and one spacer frame; producing density values from 0 to 999. There i s also connec-ted a keyboard,containing the d i g i t s 0 to 9 and seven other characters, which can be used to punch i n single frames for ad d i t i o n a l information. The f i n i s h e d output tapes were submitted to the UBC Computing Center where they were converted to magnetic tapes which were accessed by the computer program for analysis. 8 Intensity C a l i b r a t i o n To be able to assume simple addition of the two component spectra and to get accurate l i n e p r o f i l e s i t i s necessary to convert the d i r e c t l y measured photographic density to true i n t e n s i t y . This i s done by i n t e r p o l a t i o n i n the i n t e n s i t y c a l i b r a t i o n which i s impressed on each p l a t e . (The c a l i b r a -t i o n consists of a series of bands of known incident i n t e n s i t y r a t i o : log ( I n + ^ / I n ) = 0.2.) The i n t e n s i t y determination requires that: i ) a representative value of the density at each step of the c a l i b r a t i o n be obtained, and i i ) a good i n t e r p o l a t i o n scheme be used. To guard against the eventuality that the p a r t i c u l a r spot of the c a l i b r a t i o n which was used contained an emulsion defect which could r e s u l t i n an erroneous c a l i b r a t i o n point i t was decided not to use the straight mean of the sampled points in each step. Since most defects appeared to be holes in the emulsion a s l i g h t l y higher value was c a l l e d f o r , yet not so high as to cause s i g n i f i c a n t errors i n the i n t e n s i t i e s deter-mined. Several tests were done on the c a l i b r a t i o n s i n sections both with and without defects. The r e s u l t i n g d i s t r i b u t i o n s (examples i n Fig . 2.) indicated that a good choice was the 46t^1 highest (of 100) density value i n each step. Note that i t i s well within the central peak for both defective and good emulsions, even though the defects represented by the d i s t r i -butions were so large that in the upper case f u l l y 1/4 of the sampled points were affected by i t . 2 5 5 With d e f e c t I—i r~i i i n\\n n » t X46 = <*31 Mean=4 0 2 No de f e c t l 4 8 5 4 9 5 56 0 XA6=527 Mean=5 2 5 With d e f e c t n n JHl n No d e f e c t 3i+0 I 4 8 5 X46=459 1 80 Mean = ^ 7 X46 = 2 2 0 Mean=218 vo F i g . 2. D i s t r i b u t i o n of c a l i b r a t i o n density values for several sections with and without emulsion defects. Chosen value - X46. 10 The simplest i n t e r p o l a t i o n scheme, which i s the d i r e c t i n t e n s i t y derivation from an i n t e n s i t y vs density r e l a t i o n , requires that a l l the instrumental parameters stay unchanged between the c a l i b r a t i o n run and the s t e l l a r spectrum and i s hence too r e s t r i c t i v e to be e a s i l y used. The method selected, therefore, was the usual one of i n t e r p o l a t i o n i n a log inten-s i t y (I) vs log density (D) r e l a t i o n since t h i s allows one to a l t e r v i r t u a l l y a l l the parameters and s t i l l get correct inten-s i t i e s . F i g . 3a. shows the c a l i b r a t i o n curves which were obtained using several values of analyzing s l i t widths and zero points, and using two d i f f e r e n t wedges (both, unfortunately, with rather steep gradients), and F i g . 3b. shows the deviations from the r e l a t i o n defined by one of these using the above mentioned c a l i b r a t i o n method. This method makes use of the t r a n s l a t -a b i l i t y of the c a l i b r a t i o n curves along the log density axis. That i s , i f the c a l i b r a t i o n r e l a t i o n i s log I = f - l0g \ ^ dark,cal ^ c l e a r , c a l ^ " D c l e a r , c a l then the appropriate r e l a t i o n with the new instrumental para-meters i s log I = f j log | "dark,new ' Dclear,new ^ + c I \ D " Dclear,new where the constant C - log j dark,cal ^ c l e a r , c a l \^dark,new " Dclear,new The function " f " was defined by a second order curve f i t t e d to 11 the c a l i b r a t i o n points, and the s t e l l a r i n t e n s i t i e s were derived using the resultant net c a l i b r a t i o n of log I = f - l l o g ' ° d a r k > c a l " D c l e a r , c a l 1 D - D , , clear,new/ It i s seen that a good r e l a t i o n can be defined independent of s l i t width and zero point as long as the same wedge i s used (Fig. 3b.). This i s extremely important as i t permits one to a l t e r the s l i t length and adjust the focus to s u i t the p a r t i c u l a r sample being scanned. The i n t e n s i t y errors introduced by the deviation from the zero l i n e amount to 0.2 % of the continuum at the l i g h t end and 0.1 % at the dark end. 12 u A) cu o I -a 1 .2 H i .o H a) rH u O 0.8 60 O 0.6 0 .«» 0.2 0 . 0 I 0.2 S l i t Wedge Z e r o A 1 Oy F + 1 Op E + 8 o 1 Oy E X 1 Oy E • 1 Oy E F i x e d ^ c l e a r = c ^ - e a r P ^ a t e d e n s i t y D, , = f u l l d a r k d e n s i t y d a r k J + o t x T Fig. 3a, 0.0 0.2 o.«t 0.6 C a l i b r a t i o n curves with various parameter settings. 1 i 0.8 1.0 l o g I o.i i o. o 1 + T T T F i g . 3b 0.0 0.2 0.1+ 0.6 D e v i a t i o n i n l o g D from r e l a t i o n d e f i n e d by + I 1— 0.8 1.0 l o g I 13 Continuum Determination The best way to define the continuum depends on the type of spectra to be analyzed. The method used here works only for spectra which are mostly continuum with a few l i n e s superim-posed, such as are expected for B-type stars (and l a t e r types i n the photographic i n f r a - r e d ) . Since the rest of the program i s more general the only major change needed to adapt i t for other s p e c t r a l types i s a new continuum subroutine. Several suggested methods are described by Peat § Pemberton (1970) . The idea behind the routine i s to draw a l i n e through the spectrum while ignoring any features which are below i t . To this end the spectrum was approximated by twenty points, each point being the average of the surrounding region, and a second-order curve was f i t t e d to them. A l l points below t h i s l i n e were rejected and a f i n a l second-order continuum curve f i t t e d to the remaining points. The continua determined i n t h i s manner passed the test of looking l i k e the continua one would draw i n by hand. When the continuum has been found the entire spectrum i s inverted with the continuum becoming the zero l i n e . This i s done to simplify the programming during analysis. 14 Wavelength C a l i b r a t i o n A wavelength c a l i b r a t i o n i s necessary to be able to specify which of possibly several features i s to be analyzed and to fi n d i t s r a d i a l v e l o c i t y once the p o s i t i o n has been determined. This c a l i b r a t i o n should correspond to the average p o s i t i o n of the two iron arc comparison spectra, and to th i s end a two-part procedure has been adopted. F i r s t the lag between the two c a l i b r a t i o n arcs i s established and then the positions of the l i n e s i n the second spectrum are determined; the wavelength corresponding to p o s i t i o n "x" i n the s t e l l a r spectrum i s then found by i n t e r p o l a t i o n i n the X(x) r e l a t i o n for the second spec-trum using the argument "x+lag/2". This procedure i s comple-t e l y equivalent to the usual method of esta b l i s h i n g the X(x) r e l a t i o n using the mean values of the "x" coordinates for each iron l i n e . Lag determination The s h i f t between the two iron arcs i s determined by the p o s i t i o n of the peak of t h e i r c r o s s c o r r e l a t i o n curve. The approximate s h i f t i s f i r s t determined by the positions of the f i r s t d e f i n i t e features i n the two spectra and then the cross-c o r r e l a t i o n for the entire spectra i s calculated i n a small range about th i s rough p o s i t i o n . The peak i s found by f i t t i n g a parabola to the top f i v e points. Comparison l i n e positions An iron l i n e i s assumed to exist whereever f i v e or more consecutive points are above a predetermined discriminant l e v e l ; 15 which i s defined at 20 % of the height difference between the minimum of the f i r s t 200 points and the maximum of the whole spectrum. (This l e v e l i s high enough to discriminate against background and weak l i n e s - which would have a poorly determin-able position.) Once a l i n e has been found the i n d i v i d u a l component points are joined by s t r a i g h t l i n e s and the midpoints of i t s p r o f i l e determined at six lev e l s from 301 to 801 of the peak height. This range avoids asymmetries or i r r e g u l a r i t i e s sometimes found near the peak or the base of l i n e p r o f i l e s . The resultant six positions are analyzed for scatter and, i f the standard deviation i s greater than 0.1 point, the most discordant points eliminated one at a time u n t i l the standard deviation i s less than 0.1 pt or only three points remain, and a weight assigned on the basis of the number of remaining points and the peak height. These l i n e positions are than compared with a previously analyzed set of positions and associated wavelengths for the same sp e c t r a l region and suitable wavelengths assigned to the l i n e s wherever possible. The f i n a l dispersion r e l a t i o n i s determined by f i t t i n g the data to either the Hartmann formula or a third-order polynomial, whichever i s appropriate. Two short subroutines handle the conversion from p o s i t i o n to wavelength and vice versa. 16 Accuracy of Wavelength C a l i b r a t i o n The accuracy of the wavelengths determined are dependent on four factors: the i n d i v i d u a l iron arc l i n e p o s i t i o n s , the dispersion r e l a t i o n f i t t e d to those p o s i t i o n s , the s h i f t bet-ween the top and bottom iron arcs, and the l i n e a r i t y of that s h i f t across the three spectra. The i n t e r n a l error i s a function of the determination of each iron l i n e p o s i t i o n and the constancy of the 5 y steps. This has been tested on six d i f f e r e n t plates,taken at a d i s -persion of 30 A/mm at Hy. Since the plates were taken con-secutively a l l the spectrograph adjustments were the same and the dispersions should be i d e n t i c a l . Scans were made several times over the same sections on a l l six plates and the p o s i t i o n of each l i n e s p e c i f i e d r e l a t i v e to the mean of a l l the li n e s in the scan. This was done on a t o t a l of 450 l i n e s , with a resultant standard deviation of 0.47 data points (dp). This number should be interpreted as the probable error in the determination of the p o s i t i o n of each iron l i n e r e l a t i v e to the s t a r t of the scan, and already includes factors such as emulsion s h i f t s and a l l grain-caused p r o f i l e i r r e g u l a r i t i e s . The error i n the zero point of each scan has been analyzed by finding the s h i f t between the t h i r d and f i f t h scans when they were taken of exactly the same iron arc; thus for zero backlash there should be no s h i f t . The actual s h i f t d i s t r i -bution has a main body centered at +0.09 dp with a standard deviation of 0.07 dp and several outlying points at several 17 times this distance. This indicates that the backlash i s in such a d i r e c t i o n that on the second scan each feature i s registered l a t e r than on the f i r s t . A delay i s i n fact obser-vable i n an amount sometimes up to 10 dp and i t i s quite re-markable that the delay remains so nearly constant that the net s h i f t i s only 0.09 dp. It i s probably possible to e n t i r e l y eliminate the backlash problem by superimposing a suitable gr i d as an absolute r e f e r -ence frame'".-"" This could possibly take the form of a set of p a r a l l e l l i n e s etched into a clear glass plate which would be placed on the emulsion during scanning. Incorporation of such a feature would enable one to determine actual r a d i a l velo-c i t i e s even of single spectra, since the positions determined in the s t e l l a r spectrum would be f i r m l y t i e d to the comparison spectra by means of the g r i d l i n e s . Although a l l the spectra used had prismatic dispersion both prismatic- and grating-type dispersion r e l a t i o n s were f i t t e d to the l i n e positions i n an attempt to reduce the errors. However, because of the short sections involved, both proved to be about equally good. The r e s u l t i n g t o t a l error i s 0.48 dp, which at the 30 A/mm dispersion equals 0.073 A or 5 km/sec. In view of the sometimes large zero-point errors and the generally unsatisfactory s i t u a -t i o n regarding the backlash i t was decided to not try to improve on t h i s and instead do only d i f f e r e n t i a l measurements. Since 18 the slope of the regression l i n e should be better determined than i t s absolute p o s i t i o n the v e l o c i t y error i n the separation of two points should be less than 0.5 km/sec. 19 Standard P r o f i l e s The standard l i n e p r o f i l e s to be used i n the program are derived from single spectral l i n e s , which should i d e a l l y be the same as the components of the blended doublet to be analyzed. For a binary system th i s can be done i f at some point the lines of the doublet are completely separated, but i f thi s i s not poss-i b l e one can use the combined p r o f i l e when the system i s at an o r b i t a l node, so that the li n e s are superimposed on each other, i f one assumes that both p r o f i l e s are i d e n t i c a l . Since the d e r i -ved separation i s very s e n s i t i v e to the p r o f i l e width i t i s es s e n t i a l that the plates used for such an analysis be obtained exactly at the node. The single l i n e to be analyzed i s smoothed by f i t t i n g a series of short overlapping l i n e segments to the data and the resultant p r o f i l e i s symmetrized by averaging i t s two sides. Each such p r o f i l e i s given equal weight and the f i n a l average p r o f i l e i s recorded on magnetic tape together with i t s i d e n t i -cation number, weight and useable width. Each record has space to allow for four components of a double doublet, possible interblended. To further ensure the correct width the standard p r o f i l e i s analyzed for best f i t to the o r i g i n a l single l i n e s by allowing i t s width to vary and appropriately a l t e r i n g the stan-dard. This is done by means of two short a u x i l i a r y programs. 20 Determination of Line Positions It should be emphasized that the f i n a l r e s u l t i s taken to be that set of position(s) and amplitude(s) of a given set of standard p r o f i l e s , such that the deviation from the actual spec-trum i s a minimum, in the least-squares sense. This i s equivalent to asking the question: Given t h i s spectrum, how can one best f i t the standard p r o f i l e s to i t ? This method i s d i s t i n c t from requiring the l i n e components to have a constant equivalent width and was d e l i b e r a t e l y chosen to avoid t h i s r e s t r i c t i o n since i t was hoped to apply i t to close binaries where one would expect proximity e f f e c t s which might a l t e r the l i n e strength with phase. More important, however, the weaker li n e s are sometimes strongly affected by the plate grain and the equivalent width method would be in a p p l i c a b l e , whereas the present c r i t e r i o n can always be used to define a set of l i n e p o s i t i o n s . Whether such a set repre-sents the true l i n e positions i s another question, but i t i s f e l t (by the author) that this more li m i t e d goal i s a l l that can meaningfully be sought from the given data (the spectrum). The determination of the f i n a l l i n e positions i s done i n several parts. F i r s t the type of blend and the approximate spectral region of the l i n e i s s p e c i f i e d e x p l i c i t l y by the input cards. The approximate positions of the components are then found and l a s t l y these are optimized as described below. The permissible types of blend are: single l i n e (no blend), double l i n e (two-component blend) , and multiple blend (four 21 components); the multiple blend must, however, be resolvable in to s i n g l e - and/or double-line blends. Approximate positions The p o s i t i o n of a one-component l i n e i s found by evaluating the sum-of-squares of the difference (SSQ) between the actual spectrum and the standard p r o f i l e for a range of positions about the center and with an amplitude to f i t the data, and then f i t t i n g a parabola to y i e l d the minimum SSQ p o s i t i o n . For a two-component blend the appropriate spectral range is f i r s t analyzed for b e s t - f i t p o s i t i o n using only one h a l f of the standard p r o f i l e with an amplitude of 0.6 times the maximum amplitude i n that range (Fig. 4); t h i s process i n e f f e c t searches for the side of one of the components. An entire p r o f i l e , centered on t h i s b e s t - f i t p o s i t i o n , i s then subtracted from the data and the remaining component located as described above. This process i s repeated, a l t e r n a t e l y subtracting one component and finding the p o s i t i o n and amplitude of the other u n t i l the positions have s t a b i l i z e d to within 0.1 dp (at which point the precese p o s i t i o n scheme i s engaged). The procedure for a multiple blend depends on the type of blend one has . I f i t i s of type 1 (Fig. 5.) each two-component l i n e i s analyzed separately as described above. If a type 2 blend i s present the outside components are f i r s t located approx-imately and subtracted o f f ; then the central blend i s treated p r e c i s e l y , as above, and subtracted o f f and the outside compo-nents redone p r e c i s e l y . 22 / \ / V < 0.6 / , ' / ' / / / / / /'' ' •' / / , / / / s / / / J \ \ \ SSQ X . i n d i v i d u a l components r e s u l t a n t p r o f i l e 1/2 s t a n d a r d p r o f i l e F i g . 4a. S e v e r a l t r i a l p o s i t i o n s f o r f i t to a two-component b l e n d . P o s i t i o n F i g . 4b. Sum of squared d e v i a t i o n s f o r p o s i t i o n s i n 4a, 23 I WA Type 1. I I WA WB Type 2. F i g . 5. Types of m u l t i p l e blends. 24 Precise p o s i t i o n scheme The p r e c i s e - p o s i t i o n routine can handle a one- or two-component blend. The l i m i t s of the spectral region to be ana-lyzed are f i r s t established and r i g i d l y adhered to throughout so as to provide a constant-length base for the SSQ b e s t - f i t c r i t e r i o n . Given the approximate position(s) and amplitude(s) a net p r o f i l e i s constructed from the standard p r o f i l e ( s ) for a g r i d of positions and amplitudes and t h i s p r o f i l e i s evaluated against the observed spectrum. For one- and two-component blends t h i s involves a t o t a l of nine and eighty-one SSQ's, re s p e c t i v e l y . This data i s f i r s t checked to see whether the o r i g i n a l center points i n both p o s i t i o n and amplitude y i e l d the minimum SSQ; i f not, the step i s repeated using the minimum point as the new center. A parabola i s then f i t t e d to t h i s data along each of the mutually orthogonal axes corresponding to positions and amplitudes and a minimum point determined for each axis. The actual symmetry axes of t h i s two- (four-) dimensional paraboloid (the SSQ array) w i l l in general not be along the chosen axes and hence the calculated minimum point w i l l not be the true minimum. This procedure i s repeated u n t i l the minimum SSQ ceases to improve. The g r i d point separation for evaluation of the SSQ data was i n i t i a l l y set at one dp in p o s i t i o n and a factor of 0.025 in amplitude. These are now reduced by a factor of /IC 7 u n t i l either four such g r i d scale reductions have been done or there 25 is no s i g n i f i c a n t decrease in the minimum SSQ upon making such a step. This results i n an i n t e r n a l p o s i t i o n a l accuracy of 0.01 datum point. It should be noted that the good feature of this approach i s that a l l the f i t t i n g parameter determinations are done simultaneously. This avoids any u n s t a b i l i t y i n the convergence scheme such as could occur i f the approximate p o s i t i o n scheme were extended, when the solut i o n might o s c i l l a t e about the true value, and never converge. 26 Accuracy of the Computed Separations Because the technique employed i s one of p r o f i l e f i t t i n g the derived l i n e separations are very sen s i t i v e to the widths of the standard p r o f i l e s . The error i n the widths has been analyzed by matching standards of d i f f e r e n t half-widths to each single l i n e (by a u x i l i a r y program BETFIT) and determining the optimum width for each l i n e . The standard deviation for the same l i n e on d i f f e r e n t plates ranged from 0.70 to 1.70 dp (table I ) . As each optimum width was determined by drawing a curve and finding i t s minimum these numbers are rather uncer-t a i n , but a standard deviation of 1 dp seems i n order. Further-more, since the standard deviations show no c o r r e l a t i o n with the width of the p r o f i l e , one can conclude that the scatter i s mostly caused by emulsion e f f e c t s . Since t h i s uncertainty exists also for the blended p r o f i l e s a net probable error of 1.5 dp can be expected, although for a p a r t i c u l a r plate the errors can of course be larger. At the Hy dispersion of 30 A/mm t h i s i s equivalent to 15 km/sec. Since the calculated l i n e positions are derived by per-mitting the standard p r o f i l e s to relax i n both p o s i t i o n and amplitude there are four independent parameters to be f i t t e d to the data. This, however, i s not necessarily the best available model of the l i n e p a i r ; in p a r t i c u l a r , for the set of plates analyzed here i t i s known that the l i n e strengths (amplitudes) are nearly the same. Thus, i n t h i s case, one should obtain more accurate separations i f some r e s t r i c t i o n were placed on the r e l a t i v e amplitudes. It is r e a d i l y seen 27 Line St. Dev'n (dp) Half-Width He I 4922 1.70 16.92 HB 4861 1.03 36.39 Mg II 4481 1.07 10.50 He I 4471 0.70 18.67 He I 4387 1.51 16.92 Hy 4340 0 .77 44.93 H6 4101 1.33 55.52 He 3970 1.33 55.17 Table I. Standard Deviations of Single-Line Widths 28 that i f t h i s r e s t r i c t i o n were of the form that the amplitude r a t i o be within c e r t a i n l i m i t s , then any increase in accuracy would be t o t a l l y spurious since the p r o f i l e s would relax toward th e i r u n r e s t r i c t e d values u n t i l the the amplitude r a t i o reached i t s l i m i t and then stop. Hence a r e s t r i c t i o n must be of the form that the amplitude r a t i o be equal to a p a r t i c u l a r value. Such a r e s t r i c t i o n should have yielded more accurate separations here than thos a c t u a l l y derived. In general, though, no such r e s t r i c t i o n can be placed on the p r o f i l e s since the l i n e strengths may well be variable (random grain noise or r e a l proximity e f f e c t s i n the stars themselves or on the p l a t e ) . Because of t h i s the r e s t r i c t i o n had not been incorporated into the program although i t i s f e l t that for some p a r t i c u l a r cases i t would be very u s e f u l . 29 Conclusions The r e s u l t s of the in v e s t i g a t i o n are tabulated (Tables II § III) and presented graphically (Fig.s 6 - 9 ) . The tables show the component amplitudes and t h e i r separation for each l i n e and the true separation: Amp 1 * Derived Separation Amp 2 Those l i n e s with ( Amp 1 / Amp 2 ) < 1.35 are denoted by an ast e r i s k (*)... Fig.s 6 and 7 represent the res u l t s for the hydrogen (H3,Hy,H6,He) and "helium" (He I 4009,4026,4121,4144, 4387,4471,4922; Mg II 4481) l i n e s , r e s p e c t i v e l y . As can be seen there i s a large scatter about the zero deviation l i n e , e s p e c i a l l y at small separations for the wider hydrogen l i n e s . This i s caused by one of the standards f i l l i n g up almost the entire observed p r o f i l e and forcing the other out into the wings with a greatly reduced amplitude. For the narrower "helium" l i n e s the wings are small or non-existent and the small-separation scatter i s caused instead by the grain noise a f f e c t i n g the weakest li n e s (4009,4121,4481) adversely. These accidental e f f e c t s are less l i k e l y to be present in those cases where the amplitudes of the components are more nearly the same. Fig.s 8 and 9 show the r e s u l t of l i m i t i n g the data to those cases where the r e l a t i v e amplitude i s less than 1.35. This r e s t r i c t i o n e n t i r e l y eliminates the large scattering and one i s l e f t with an approximately Gaussian d i s t r i b u t i o n about the true l i n e with a standard deviation of roughly the expected amount. Those cases where the amplitude r a t i o i s 30 larger may s t i l l give good r e s u l t s , however, since to the f i r s t order both standard p r o f i l e s w i l l be sh i f t e d by the same amount and only the amplitudes changed as they are f i t t e d under the observed p r o f i l e . It should be noted that with this r e s t r i c t i o n there i s no systematic deviation from the true l i n e . This r e s u l t i s a s i g n i f i c a n t improvement over that of P e t r i e , et al.(1967), who, measuring the same plates with an osc i l l o s c o p e - d i s p l a y scanning device and with a v i s u a l projection comparator, found separations which were systematically too small for both the hydrogen l i n e s and the wider helium l i n e s when using the oscilloscope device, and the reverse e f f e c t for the helium l i n e s when measured v i s u a l l y (Fig. 10.). If the r e s t r i c t i o n discussed i n the previous section there i s every hope of being able to extend this r e s u l t to smaller separations than those used here. This also indicates that the present model of the resultant spectrum as the simple sum of the two components i s quite s a t i s f a c t o r y and that there i s no need to invoke emulsion proximity e f f e c t s , at least for the reasonably wide l i n e s found in early-type s t a r s . The p o s s i b i l i t y of very wide ( r o t a t i o n a l l y broadened) l i n e doublets giving r i s e to a spurious central t h i r d component as discussed by Tatum (1968) has no e f f e c t on the separations derived by thi s method and need not be considered a spe c i a l case. Again, since the errors are not correlated with the l i n e width one should be able to improve the accuracy by going to 31 higher dispersions and f i n e r grained emulsions (than IlaO). This w i l l , however, produce a loss i n time r e s o l u t i o n , and may in some cases even cause an a r t i f i c i a l l i n e broadening by the star s ' o r b i t a l motion. It i s encouraging to note that quite f a i n t features can often be separated with accuracy comparable to that of the stronger l i n e s (see also Appendix I ) , but i t should be empha-sized that the main improvement indicated by this work i s that there are no systematic deviations from the true separations and that the technique i s equally applicable to both wide and narrow l i n e s , whereas the corrections indicated by P e t r i e , et a l . are dependent on the type of l i n e being measured, the measurement technique, and (presumably) the observer himself. Line True Separation 12.99 14.48 22.32 26.02 HB 4861 0.39 39.12 0 .06 0.39 40.81 0.04 0.21 * 23.67 0.19 0.26 28.78 0.19 Hy 4 340 0.35 19.82 0.19 0.45 90.88 0.04 0.23 * 22.15 0.20 0.25 * 27.21 0.25 HS 4101 0.36 11.77 0.16 0.27 * 10.46 0.22 0.22 * 23.01 0.20 0.25 * 20.01 0.24 He 3970 0.43 26.39 0.13 0.33 14.67 0.19 0.24 * 23.20 0.19 0.32 22.19 0.23 He I 4922 0.14 18.28 0.07 0.09 12.46 0.08 0.09 19.89 0.05 0.08 * 22.05 0.08 He I 4471 0.25 18.11 0.08 0.16 23.40 0.14 0.16 ' 27.28 0.14 He I 4387 0.12 * 12.30 0.11 0.11 * 16.61 0.10 0.11 * 20.68 0.10 0.15 * 24.81 0.13 Table II. Results for x Her (see text p.29) Line True Separation 12.99 14 .48 22.32 26.02 He I 4144 0.15 9.74 0.11 0.10 * 11.99 0 .08 0.11 * 25.84 0.10 0.12 * 26.86 0.10 He I 4121 0.07 * 11.97 0.06 0.10 52.32 0 .05 0.07 9.10 0.05 0.08 23.95 0.05 He I 4026 0.23 * 13.73 0.18 0.22 * 15.01 0.18 0.18 * 20.81 0.17 0.23 ft 26.16 0.19 He I 4009 0.17 26.13 0.05 0.10 * 17.75 0.09 0.09 * 20.45 0.07 0.11 ft 24.65 0.10 Table II. (cont.) Line True Separation 8.95 12.95 15.93 31.09 40.04 40.55 HB 4861 0.27 13.18 0.19 0.22 * 11.65 0.17 0.23 ft 13.28 0.20 0.22 ft 32.40 0.18 0.20 ft 39.25 0.20 0.23 42 19 0.22 Hy 4340 0.49 68.05 0.03 0.29 11.81 0.18 0.25 * 13.98 0.22 0.27 ft 36.48 0.21 0.25 ft 40.47 0.24 0.23 * 43.54 0.22 HS 4101 0.30 4.93 0.20 0.43 22.91 0.05 0.36 18.17 0.15 0.28 30.20 0.20 0.25 ft 36.30 0.20 He 3970 0.39 15.68 0.18 0.28 * 15.93 0.24 0.24 ft 27 .86 0.23 0.23 * 38.47 0.22 0.22 * 38.94 0.21 Mg II 4481 0.11 7.79 0.04 0.09 48.27 0.05 0.10 8.06 0.04 0 .09 30.99 0.05 0.08 39.42 0.07 0.17 17.94 0.06 He I 4471 0.14 7 .93 0.10 0.15 14.51 0.11 0.15 16.43 0.09 0.15 ft 32.70 0.13 0.14 39.32 0.13 0.14 ft 42 .35 0.10 He I 4387 0.12 15.20 0.08 0.13 18.99 0.08 0.11 30.14 0.11 0.12 * 38.51 0.10 0.12 38.31 0.08 Table I I I . Results for n Lyr A (see text p.29) 35 F i g . 6. A l l hydrogen l i n e s (lie ,Hy ,H6 ,He) F i g . 7. A l l "helium" lines (HeI4009 ,4026 ,4121 ,4144 ,4387 ,4471 , 4922 ,MgII4481) 37 38 Computed S e p a r a t i o n 39 i . o 0.5 -x x Group I • O s c i l l o s c o p e : H 3 , Y , 6,e x V i s u a l : H3 ,y ,6 c o ca oo 0) 1-1 H 0.0 1 . 0 o 0 . 5 -ca u ca (X <u w •a > u CO CO £> O- 1 . o 100 200 300 400 500 km/sec 1 1 1 1 1 \-Group I I O s c i l l o s c o p e : 4 0 2 6 , 4 4 7 1 0.5 -Group I I I O s c i l l o s c o p e : 4 1 2 0 , 4 3 8 8 , 4481 1 .0 Group IV V i s u a l : 4 0 2 6 , 4 1 2 0 , 4 3 8 8 , 4 4 7 1 , 4 4 8 1 F i g . 10. Results of P e t r i e , Andrews, 5 Scarfe. 40 References Ovenden, M. W. On the Reflection E f f e c t and the Determi-nation of the Masses of Spectroscopic Binary Stars. Monthly Notices of the Royal Astronomical Society 126, 77 (1963). Peat, D. W. S. Pemberton, D. H. On the Automatic Reduction of S t e l l a r Spectrograms. The Observatory 90, 141 (1970). P e t r i e , R. M., Andrews, D. H. 5 Scarfe, C. D. E f f e c t of Blending on the O r b i t a l Elements of a Double-Line B-type Binary. I. A. U. Symposium no. 30_, 221 (1967). Tatum, J . B. The Blending E f f e c t i n the Measurement of Spectroscopic Binary Spectra. Monthly Notices of the Royal Astronomical Society 141 , 43 (1968). 41 APPENDIX I Sample Line P r o f i l e s 42 Microdensitometer tracings o£ a few of the l i n e s analyzed are presented. F i g . 11. shows some single p r o f i l e s from which the standard p r o f i l e s were derived. Fig.s 12 and 13 show the same regions with blended l i n e s at various separations. The noise content of the tracings i s r e a l ( i . e . not produced by the instrument) and i s approximately the same as that of the d i g i t i z e d data. 43 S e p a r a t i o n = 0.0 dp S e p a r a t i o n = 0.0 dp I 1 J i I i l . l . l . 1 0 100 200 300 400 500 600 F i g . 11. Sample l i n e p r o f i l e s . 44 ' f He I 4387 Hy S e p a r a t i o n = 15.9 dp HY S e p a r a t i o n = 40.0 dp \ i I L 0 100 _ J I J _ 2 0 0 3 0 0 J i 1 L. * 0 0 5 0 0 6 0 0 F i g . 12. Sample l i n e p r o f i l e s . 45 H6 S e p a r a t i o n + 13.0 dp H6 S e p a r a t i o n «=» 26.0 dp I 1 1 I I 1 I • I . I . \ 0 1 00 2 0 0 3 00 tt 0 0 500 6 0 0 F i g . 13. Sample l i n e p r o f i l e s . 46 APPENDIX II Paper Tape Format MDM Operation 47 The standard paper tape format is as follows: i) l a b e l l i n g , i i ) c a l i b r a t i o n data, and i i i ) main scans. The labels should always be present and should consist of: * i) beginning marker "B" , i i ) four numbers of maximum f i v e d i g i t s each, representing the tape number, plate number, and two wavelengths (usually the s t a r t i n g and stopping points of the main scan), each separated by one blank frame, and i i i ) end marker "D". If the beginning marker i s missing the * program rewinds the tape (to make sure that the next marker has not been bypassed) and continues analysis. Missing l a b e l l i n g data w i l l be replaced by zeroes. The i n t e n s i t y c a l i b r a t i o n data i s not always required (e.g. i f only the iron arc comparison spectrum i s to be ana-lyzed), but when i t i s present i t should consist of: i) beginning marker "C", i i ) one clea r plate scan, i i i ) one f u l l dark scan, iv) at least three scans along the c a l i -bration steps, s t a r t i n g from the darkest end, and v) end marker "D". If the beginning marker or the c a l i b r a t i o n data i s missing the program w i l l use the measured densities d i r e c t l y and proceed, unless a standard p r o f i l e determination is to be done and the marker i s missing, i n which case the run i s aborted. The scans must be at least 20 data points in length but need not exceed 100. A shorter scan i s equivalent to an end marker and a longer scan w i l l be discarded a f t e r the f i r s t 100 points. Characters i n double quotes (" ") re f e r to keyboard symbols. 48 The main scans should consist of: i ) beginning marker "A", i i ) one clear plate scan, and i i i ) f i v e other scans. The beginning marker must always be present. The f i v e scans are analyzed on the assumption that the f i r s t two are not s i g n i f i c a n t , and the t h i r d , fourth, and f i f t h are the top comparison (max. useable length = 1000 pts) , s t e l l a r spectrum (1000 p t s ) , and bottom comparison (2000 p t s ) , r e s p e c t i v e l y . The f i r s t two scans are intended to smooth out the d i r t d i s -t r i b u t i o n on the carriage drivescrew and provide for reason-ably constant backlash in the carriage motion to permit wavelength i n t e r p o l a t i o n between the iron arcs. It i s possible to simulate any of these six scans by the keyboard return button in which case appropriate action w i l l be taken. Note that the s l i t parameters need not be the same as for the c a l i b r a t i o n runs. The f i r s t two scans can be of any length. To keep these short while s t i l l having longer main scans and keeping the carriage i n continuous motion to combat the backlash i t i s necessary to change the scan dimensions while the carriage i s moving. This can be done as usual by the front panel thumb-wheels providing that at no time during the res e t t i n g the scan dimensions be less than the extent already covered. For this purpose a p o s i t i o n between contacts on the thumbwheels i s read as zero. 49 It has been found most convenient to do the Y-stepping automatically for the c a l i b r a t i o n data but manually for the main scans since the pre c i s i o n required for the Y-position i s much higher for the s t e l l a r spectrum when i t should f i l l the whole s l i t length. 50 APPENDIX III How To Use the Program 51 The complete analysis of a p a r t i c u l a r spectral l i n e blend in a star i s done i n several parts. The following assumes that suitable plates are available of the l i n e components both singly and blended and that ..pes have been made of the appropriate spectral regions according to the s p e c i f i c a t i o n s in Appendix II. Deck setups and card formats are i n Appen-dix IV. A. To provide a wavelength c a l i b r a t i o n i t i s necessary to i d e n t i f y the iron arc l i n e s in the region involved. This i s done by f i r s t doing a scaling run to f i n d the iron arc l i n e p o s i t i o n s . Input comprises an a r b i t r a r y IDCODE and the parameter l i s t with LNOLKS = 1. Output w i l l consist of one card giving the number of l i n e s present (N) and N cards of l i n e p o s i t i o n s . To these cards must be added the dispersion r e l a t i o n code (IW): 0=prismatic, l=grating; and the wave-lengths corresponding to the l i n e positions where known (blank wavelengths are ignored i n the a n a l y s i s ) . These N+l cards w i l l be known as the wavelength c a l i b r a t i o n data and are part of the input deck for a l l subsequent runs. For the best results i t i s safest to have a l l the scans for a p a r t i c u l a r spectral region begin i n the same place, just before a strong c a l i b r a t i o n l i n e , so that the f i r s t l i n e found w i l l always be the same. A f a l s e wavelength scale may be established i f this l i n e i s not properly located. Only the l a b e l l i n g and the iron arcs are required for the analysis. 52 B. For standard p r o f i l e construction two magnetic tapes are required: one (on device 0) contains the previously-determined p r o f i l e s and the other (device 1) w i l l contain the updated information. Input data consists of the i d e n t i f i -cation code (IDCODL) assigned to the set of standard p r o f i l e s ; parameter l i s t witli LYFORP = 1; wavelength c a l i b r a t i o n data; a four-element array (IS) of 0's and l ' s to determine which of the four p r o f i l e s are to be analyzed (see the "standard p r o f i l e s " section), and the length of the l i n e segments (18,<=48) to be f i t t e d to the p r o f i l e for smoothing purposes; and the l e f t - and right-hand wavelength l i m i t s (WL,WR) within which to look for each of the above li n e s (these default to encompass the whole scan). The updated p r o f i l e s are always p l o t t e d . C. When a standard p r o f i l e has been constructed i t i s necessary to adjust i t s width to give a best f i t to the single l i n e p r o f i l e s . To do this the program i s run as a s i n g l e - l i n e analysis (see section D) on the single p r o f i l e s with the parameter IPUNCrP = 1. The output from th i s w i l l be: i ) the main scan length, i i ) the s t e l l a r spectrum i t s e l f , and i i i ) the position,amplitude and search l i m i t s determined by the main program, on device 2, along with the usual p r i n t o u t . Device 2 may be assigned to the card punch to save the data or, usually, to a f i l e for immediate analysis. The a u x i l i a r y program BETFIT i s now to be used to read i n t h i s data from device 2 as well as the p r o f i l e IDCODE and 53 number (NUM) from device 5 and the p r o f i l e i t s e l f from the tape on device 0. The output w i l l be a table of squared devia-tions from the observed spectrum for a range of values of standard p r o f i l e widths and po s i t i o n s ; these should enable one to choose a better value for the p r o f i l e width. F i n a l p r o f i l e determination involves writing the improved p r o f i l e on the tape (by program EDITOR) and deleting the old p r o f i l e (by program RUBOUT), both of which require two tapes and a few input cards (see Appendix IV). D. A s i n g l e - l i n e analysis requires the magnetic tape of standard p r o f i l e s . The input data i s the p r o f i l e IDCODE, parameter l i s t with LINES = -1, wavelength c a l i b r a t i o n data, and the wavelength l i m i t s (WL,WR) between which the l i n e w i l l be found. A blend analysis requires s i m i l a r input but with LINES = 1 or 2 for a two- or four-component blend, r e s p e c t i v e l y , and i f LINES = 2, one extra card with the blend type (KBLND = 1 or 2) and the positions WA and WB (see f i g . 5). E. Also present in the parameter l i s t are: IPLOTT (= 1 produces a plo t of the s t e l l a r spectrum), 15 ( s p e c i f i e s the averaging length for smoothing the s t e l l a r spectrum; default = 1), IXTRA and NUMPRF. IXTRA f 0 produces an a r t i f i -c i a l Gaussian p r o f i l e instead of the paper tape input (which is not required) with noise dependent on the value of IXTRA. 54 This also requires input cards specifying the number of components (NL) and the maximum noise amplitude (AMP) as well as the p o s i t i o n , amplitude and half-width of each component. IXTRA < 0 w i l l produce a plot of the p r o f i l e . NUMPRF s p e c i f i e s which standard p r o f i l e i s to be used. NUMPRF = 1, 2, 3 or 4 loads only that corresponding p r o f i l e in the active array; = 34 loads the l a s t two; defaults to normal loading. 55 APPENDIX IV Input Deck Setups 56 Parameters are sp e c i f i e d only when a p a r t i c u l a r value i s required. Device assignments are only for those which are needed. The two magnetic tapes must be mounted with the proper *pseudodevicenames* ' s; tapes on device 1 must be mounted with the write-enable ring i n ; converted paper tapes must be mounted as *PTAPE*; and C= must be s p e c i f i e d i f the card punch *PUNCH* i s to be used. A. Scaling Devices: 4=*PTAPE*, 8=*PUNCH*, 9=*DUMMY* Read (1) IDCODE Read (2) LINES,LNOLKS,LYFORP,IPLOTT,IXTRA,15,IPUNCH,NUMPRF LN0LKS=1, LYFORP=0, IXTRA=0. B. P r o f i l e construction Devices: 0=*oldtape*, l=*newtape*, 3=-Q, 4=*PTAPE*, 8=*DUMMY*, 9=*DUMMY* or -PLOT Read (1) IDCODE Read (2) LINES,LNOLKS,LYFORP,IPLOTT,IXTRA,15,IPUNCH,NUMPRF Read (2) NumberlronLines,IW Read (3) Position,Wavelength (1,NumberlronLines) Read (4) IS(1,4) ,18 Read (5) WL,WR (1,4) no default IDCODE, LNOLKS=0, LYF0RP=1, IXTRA=0. 57 C. Blend Analysis Devices: 0=*currenttape*, 2=-A, 4=*PTAPE*. 8=*DUMMY*, 9=*DUMMY* or -PLOT Read (1) IDCODE Read (2) LINES,LNOLKS,LYFORP,IPLOTT,IXTRA,15,1PUNCH,NUMPRF Read (2) NumberIronLines,IW Read (3) Position,Wavelength (1.NumberlronLines) Read (6) KHLND,WA,WB ( i f f LINES=2) Read (5) WL,WR IDCODE, LINES=-1,1,2, LNOLKS=0, LYFORP=0, IXTRA=0 D. A r t i f i c i a l P r o f i l e s Devices 4= (not used) Read (1) IDCODE Read (2) LINES,LNOLKS,LYFORP,IPLOTT,IXTRA,I 5,1PUNCH,NUMPRF Read (6) NL,AMP Read (5) Position,Amplitude ,Halfwidth (l,NL) a etc. IXTRA^O Replaces Wavelength C a l i b r a t i o n 58 E. BETFIT Devices: 0=*currenttape*, 2=-A, 8=*PUNCH* Read (7) IDCODE,NUM Read (7) Lengthofspectrum Read (8) Spectrum (1,Lengthofspectrum) Read (9) Position,Amplitude,Le£tlimit,Rightlimit F. EDITOR Devices: 0=*oldtape*, l=*newtape*, 3=-A Read (7) Oldldcode,NewIdcode Read (5) NewHalfWidth (1.4) (separately) G. RUBOUT Devices: 0=*oldtape*, l=*newtape* Read (7) Oldldcode Formats: (1) • • (H2) (2) • • (715) (3) • • (10X,2F20 .7) (4) -- (411,16) (5) • • (3F10.3) (6) • - (I10.2F10 .3} (7) • - (2110) (8) • - (10F8.4) (9) - (2F20.5,2I10) 59 APPENDIX V L i s t i n g of Fortran Programs DIMENSION P(20),IFET(1000),STAR(1000), I F EB ( 2000) ,IFB( 1000), 1 RINTH 1000) ,STARAV( 1000) ,S 1(401) ,S2(401) ,S3( 401) ,S4( 401) , P0( 50) , 2 W(50),JMAX(3) LOGICAL LFAY COMMON /AX/MDIM /KODER/ IDCODE /DIVS/ MM1,MM2 /LOG/ LFAY COMMON /PLT/ IPLOTT EQUIVALENCE ( I F B ( 1 ) , I FEB ( 1) ) , (STAR( 1),RI NT I( 1) ) LFAY = .FALSE. P(20) = 1.0 CALL PLOTS READ (5,100) IDCODE 100 FORMAT (112) READ (5,101) LINES,LNOLKS,LYFORP,IPLOTT,IXTRA,15,IPUNCH,NUMPRF 101 FORMAT (1015) IF (I5.EQ.0) 15 = 1 IF (LNOLKS .EQ.l .AND. LYFORP.EQ.l) WRITE (6,149) 149 FORMAT (///////• AWWRRGGHHHH') IF (LNOLKS.EQ.l .AND. LYFORP.EQ.l) STOP IF (IXTRA.NE.O) CALL FAKLYN (RINTI,JX,IXTRA,I PLOTT,LYFORP,&237) CALL LABELS IF (LNOLKS.NE.l) CALL CALIB (P,LYFORP) CALL READIN (IFET ,STAR,I FEB,P,JMAX) JX = JMAX(2) IF (JMAX(3).GE.200) LFAY = .TRUE. IF (.NOT.LFAY) WRITE (6,150) 150 FORMAT (//• NO FE ARC',//) IF (.NOT.LFAY .AND. LNOLKS.EQ.l) STOP IF (LFAY) CALL LAGS (IFB,IFET,JMAX(1)) IF (LNOLKS.EQ.l) GO TO 235 233 CALL SMOOTH (STAR ,STARAV,JX,15) CALL CONTIN (STARAV,JX,P 1,P2,P3) CALL SMOOTH (STAR,STARAV,JX,15) IF (IPLOTT.NE.O) CALL DRAWIT (STARAV,JX,LYFORP) DO 234 J = 1, JX RINTI(J) = 1.0 - STARAV(J) / (PI + P2*J + P3*J**2) 234 CONTINUE 237 IF (IPUNCH.NE.0) WRITE (2,151) JX IF (IPUNCH.NE.O) WRITE (2,152) ( R I N T K J ) , J=1,JX) 151 FORMAT (15) 152 FORMAT (10F8.4) IF (.NOT.LFAY) GO TO 236 235 CALL FESKAL (I FEB , JMAX(3),NL,PO,W) IF (LNOLKS.EQ.l) STOP CALL SKALE2 (PO,NL,W,JMAX(3)) 236 IF (LYFORP.EQ.l) CALL STANRD (RINTI,JX) CALL GTPRFL (S1,S2,S3,S4,L1,L2,L3,L4,A1,A2,A3,A4,LINES,NUMPRF) IF (LINES.NE.2) GO TO 269 READ (5,115) KBLND , WA,WB 115 FORMAT (I10.2F10.3) MM1 = 1 IF (WA.GT.10.0) MM 1 = LOCAT(WA) MM2 = JX IF (WB.GT.10.0 .AND. KBLND.EQ.2) MM2 = LOCAT(WB) 269 READ (5,110,END=260) WL,WR 110 FORMAT (2F10.3) IA = 1 IF (WL.GT.10.0) IA = LOCAT(WL) IB = JX IF (WR.GT.10.0) IB = LOCAT(WR) 270 IF (LINES.EQ.-l) CALL MCH1 (RI NT I , JX , I A,IB,SI,L1) IF (LINES. EQ.l) CALL MCH2 (RINT I,JX,I A,IB,S1,S2,S3,S4,L1,L2,L3,L4 1 A1,A2,A3,A4,1) IF (LINES.EQ.l) STOP IF (KBLND.EQ.2) GO TO 272 WRITE (6,180) 180 FORMAT ('1THE FOLLOWING REFERS TO THE LEFT BLEND',//) CALL MCH2 (RI NT I,JX,I A,MM 1,SI,S2,S3,S4,LI,L2,L3,L4,A1,A2,A3,A4,1) DO 271 J = 1, 401 S K J ) = S3(J) S2(J) = S4(J) 271 CONTINUE LI = L3 L2 = L4 WRITE (6,181) 181 FORMAT ( • 1THE FOLLOWING REFERS TO THE RIGHT BLEND1,//) CALL MCH2 ( RI NT I,JX,MM 1,IB,SI,S2,S3,S4,L1,L2,L3,L4,A1,A2,A3,A4,1) STOP 272 CALL MCH2 ( RI NT I , JX , I A , I B , S 1, S 2 , S 3 , S4 , L I , L'2 , L3 , L4, A1, A2 , A3 , A4, 2 ) STOP 260 IA = 1 IB = JX GO TO 270 END SUBROUTINE LABELS DIMENSION IA(5),KK(4) COMMON /STUF/ KL DO 199 J = l t 4 199 KK(J) = 0 K = 0 DO 200 J = 1, 600 CALL PTAPE(I ) IF (I.EQ.-66 .OR. I.EQ.194) GO TO 201 200 CONTINUE REWIND 4 DO 207 J = 1, 65 CALL PTAPE(I) 207 CONTINUE WRITE (6,151) 151 FORMAT (//' NO START TO LABEL FOUND - REWINDING *PTAPE*',//) RETURN 201 DO 202 JJ = 1, 4 DO 203 J = 1, 6 CALL PT APE(I) IF ( I . E Q . - 6 8 .OR. I.EQ.196) K = 1 IF (K.EQ.l) GO TO 204 IF (I.EQ.O) GO TO 204 IF (IABS(I) .GT.128) I = IABS(I) - 128 I A(J) = IABS(I) - 48 203 CONTINUE 204 JM = J - 1 DO 206 JJJ = 1, JM KK(JJ) = KK(JJ) + I ACJJJ) * 10**(JM-JJJ) 206 CONTINUE IF (K.EQ.l) GO TO 205 202 CONTINUE 205 WRITE (6,150) KK 150 FORMAT (///' ITAPE LABEL # ' » 1 5 , 1 5 X , 1 PLATE # ',15,//,' LINES ',15, 1 5X,I5,///) KL = KK(1) RETURN END SUBROUTINE CALIB (P,LYFORP) DIMENSION I A ( 3 ) » I C A L ( 1 0 0 ) , C ( 1 0 ) , T ( 1 0 ) , P ( 2 0 ) , E 1 ( 5 ) , E 2 ( 5 ) , Y F ( 2 0 ) , 1 W(20) COMMON ICAL,C,T,YF,W,E1,E2,IA,BLANK(1832) COMMON /AX/ MDIM IOK = 1 JJ = 0 DO 300 J = 1, 1000 CALL PTAPE(I) IF (I.EQ.67 .OR. I.EQ.-195) GO TO 301 300 CONTINUE IF (LYFORP .EQ.l) WRITE (6,160) 160 FORMAT (//• NO START OF CALIBRATION FOUND - LYF0RP=1 1T0P*,//) IF (LYFORP.EQ.l) STOP WRITE (6,151) 151 FORMAT (//' NO START OF CALIBRATION FOUND - REWINDING *PTAPE 1AND SETTING P(J) = DELTA(J,2) • ,//> GO TO 297 298 WRITE (6,161) 161 FORMAT (//• START OF CALIBRATION FOUND BUT NOT SUFFICIENT DATA 1 REWINDING *PTAPE* AND SETTING P(J) = DELTA(J,2)',//) 297 DO 299 J = 1, 19 P(J) = 0.0 299 CONTINUE P(2) = 1.0 P(20) = 1.0 IF (I.EQ.-68 .OR. I.EQ.196) RETURN REWIND 4 . DO 207 J = 1, 65 CALL PTAPE(I) 207 CONTINUE RETURN 301 J J = JJ + 1 NX = 0 DO 303 J = 1, 100 CALL PTAPE(I) IF (I.EQ.-95 .OR. I.EQ.223) GO TO 302 IF (I.EQ.-68 .OR. I.EQ.196) GO TO 307 IF (I.GT.128) I = 1 - 1 2 8 IA(1) = I - 4 8 CALL PTAPE(I) IF (I.GT.128) I = I - 128 IA( 2) = I =48 CALL PTAPE(I) IF (I.GT.128) 1 = 1 = 128 IA(3) = 1 - 4 8 CALL PTAPE(I) IF (I.NE.42) GO TO 316 ICAL (J) = 100*IA(1) + 10*IA(2) + IA(3) NX = NX + 1 GO TO 303 316 DO 317 JL = 1, 20 CALL PTAPE(I) IF (I.EQ.-95 .OR. I.EQ.223) GO TO 302 IF (I.EQ.-68 .OR. I.EQ.196) GO TO 307 IF (I.EQ.42) GO TO 3 03 317 CONTINUE WRITE (6,152) J J , J 152 FORMAT (/» TAPE FUCKED UP AT J J = » , I 5 , » J=',I5,' STOP*) STOP 303 CONTINUE DO 309 J = 1, 1000 CALL PTAPE( I) IF (I.EQ.-95 .OR. I.EQ.223) GO TO 304 309 CONTINUE 302 IF (J.GT.l) GO TO 304 JJ = JJ - 1 GO TO 301 304 NXF =0.46 * NX IF (NX.LT.20) GO TO 307 ISQ = 0 ISM = 0 DO 315 J = 1, NX ISM = ISM + ICAL(J) ISQ = ISQ + ICAL(J) ** 2 315 CONTINUE YF(JJ) = ISM / FLOAT(NX) W(JJ) = SQRT{ABS(ISQ/FLOAT(NX) - Y F ( J J ) * * 2 ) ) IF (JJ.EQ.2) RMN = AM INI (YF(1),YF(2 ) ) IF (JJ.EQ.2) DEN = ABS (YF(2)-YF(1)) IF (JJ.LE.2) GO TO 301 DO 305 J J J = 1, NXF MX = ICAL(JJJ) DO 306 J = J J J , NX IF (ICALlJ) .LE.MX ) GO TO 306 IT = ICAL(J) ICAL(J) = MX MX = IT 306 CONTINUE 305 CONTINUE CUJ-2) = AL0G10 ((FLOAT (MX)-RMN) / DEN) JJX = JJ - 2 IF (JJ.LT.12) GO TO 301 DO 308 J = 1, 10000 CALL PTAPE(I) IF (I.EQ.-68 .OR. I.EQ.196) GO TO 307 308 CONTINUE 307 WRITE (6,162) 162 FORMAT (• ENO OF CALIBRATION LOCATED',/) IF (JJ.EQ.l) GO TO 298 DO 310 J = 1, 10 T(J) = 2.2 - 0.2*J P(J) = 0.0 310 CONTINUE JXP = JJX + 2 NX = JJX DO 311 J = 2, NX IF ( C ( J - l ) - C ( J ) . G T . 0 . 4 .OR. C ( J - l ) - C ( J ) . L T . 0 . 0 ) JJX = J IF (JJX.EQ.J) GO TO 312 311 CONTINUE 312 WRITE (6,155) ( C ( I ) , 1=1,JJX) WRITE (6,156) ( Y F ( I ) , 1=1, JXP) WRITE (6,157) (W(I), 1=1,JXP) 155 FORMAT (/• CALIBRATION POI NTS:• ,T42,10F8.3) 156 FORMAT (/' MEAN VALUES:• ,T25,12F8 .2) 157 FORMAT (/» ST DEVS:•,T25, 12F8.2) IF (JJX.LT.3) IOK = 0 IF (JJX.LT.3) GO TO 999 IF (JJX.EQ.3) MDIM = 2 IF (JJX.GE.4) MDIM = 3 EXTERNAL AUX CALL LQF (C,T,YF,W,E1,E2,P,0.0,JJX,MDIM,1,ND,0.1,AUX) P(20) = DEN WRITE (6,158) ( T ( J ) , J=1,JJX) WRITE (6,159) ( Y F ( J ) , J=1,JJX) 158 FORMAT (/• CALIBRATION FIT - D •,5X,10F7.3) 159 FORMAT (T28,10F7.3) 999 WRITE (6,150) MD IM , IOK 150 FORMAT (///' CALIBRATION DIMENSION =' ,15,10X,*THRU OK =',I2) IF (JJX.LT.3) GO TO 298 RETURN END SUBROUTINE READ IN (IFET,STAR,I FEB,P,JMAX) DIMENSION P( 20) , I FET( 1000) , STAR( 1000) , IFEB( 2000) , IA( 3) , JFK (-3 ) , 1 N FK(10,3),JMAX(3) DATA JFK/3*G7, NFK/30*0/ DEN = P(20) DO 199 J = 1, 3 199 JMAX (J) = 0 KK = 0 ISTOP = 0 DO 200 J = 1, 10000 CALL PTAPE(I) IF (I.EQ.-65 .OR. I.EG.193) GO TO 201 200 CONTINUE WRITE (6,153) 153 FORMAT (//' NO START TO MAIN SCANS FOUND - STOP',///) STOP 201 RMN = 0.0 JG = 0 DO 230 J = 1, 201 KOO = 0 DO 231 JJ = 1, 3 CALL PTAPE(I) IF (I.EQ.-95 .OR. I.EQ.223) GO TO 211 IF (I.GT.128) I = I - 128 -IF (I.LT.48 .OR. I.GT.57) KOO = 1 IA(JJ) = I =48 231 CONTINUE CALL PTAPE(I) IF (I.NE.42) GO TO 221 IF (KOO.EQ.l) GO TO 230 JG = JG + 1 RMN = ( 100*IA( 1) + 10*IA{ 2) + IA( 3) + (JG-1)*RMN) / JG GO TO 230 221 DO 222 JK = 1, 20 IF (JK/4*4.EQ.JK) JX = JX + 1 CALL PTAPE(I) IF (I.EQ.-95 .OR. I.EQ.223) GO TO 211 IF (I.EQ.42 .AND. KK.EQ.O) GO TO 230 IF (I.EQ.42 .AND. KK.GT.O) GO TO 205 222 CONTINUE WRITE (6,154) KK,JJ,J, JX, JK, JG, I ,K00 154 FORMAT (/• FUCK',1015) STOP 230 CONTINUE 211 DO 212 JJ = 1, 2 DO 202 J = 1, 10000 CALL PTAPE(I) IF (I.EQ.-95 .OR. I.EQ.223) GO TO 203 202 CONTINUE 203 IF (JJ.EQ.2) GO TO 213 212 CONTINUE 213 DO 207 KK = 1, 3 NF = 0 JFAKE = 0 JX = 0 J = 0 204 J = J + 1 KOO = 0 CALL PTAPE (I) IF (I.EQ.-95 .OR.I.EQ.223 .OR.I.EQ.O) GO TO 209 IF (I.GT. 128) 1 = 1 " 128 IF (I.LT.48 .OR. I.GT.57) KOO = 1 IA(1) = I - 48 CALL PTAPE(I) IF ( I .GT. 128) I = I - 128 IF (I.LT.48 .OR. I.GT.57) KOO = 1 IA(2) = 1 - 4 8 CALL PTAPE(I) IF (I.GT.128) I = I - 128 IF (I.LT.48 .OR. I.GT.57) KOO = 1 IA(3) = 1 - 4 8 CALL PTAPE(I) IF (I.NE.42) GO TO 221 IF (KOO.EQ.l) GO TO 205 J J J = 100*IA(1) + 10*1 A(2) + IA(3) IF (JJJ-RMN.LE.0.0 .AND. KK.EQ.2) GO TO 234 IF (KK.EQ.l) IFET(J) = JJJ IF (KK.EQ.2) DJ = AL0G10 ( (JJJ-RMN) / 0 EN) IF (KK.EQ.2) STAR(J) = 10.0 ** ( P ( l ) + P(2)*DJ + P(3)*DJ**2) IF (KK.EQ.3) IFEB(J) = J J J GO TO 208 234 STAR(J) = 0.0 GO TO 208 205 NF = NF+1 IF (NF.LE.10) NFK( NF , KK) = J IF ((J.LE.2).AND.(KK.EQ.1)) GO TO 216 JFAKE = JFAKE + 1 IF (J.GE.3) GO TO 206 IF (KK.EQ.l) IFET(J) = 0 IF (KK.EQ.2) STAR(J) = 0.0 IF (KK.EQ.3) IFEB(J) = 0 GO TO 208 206 IF (KK.EQ.l) IFET(J) = 2*IFET(J-1) - IFETIJ-2) IF (KK.EQ.2) STAR(J) = 2.0 * STAR(J-l) - STAR(J=2) IF (KK.EQ.3) IFEB(J) = 2*IFEB(J-1) - IFEB(J-2) 208 JX = JX + 1 IF ( (KK.LE.2) .AND. (JX.GE.1000) ) GO TO 210 IF (J.LT.2000) GO TO 204 210 DO 217 J = 1, 10000 CALL PTAPE(I) IF (I.EQ . -95 .OR. I.EQ.223) GO TO 209 217 CONTINUE 209 JFK(KK) = JFAKE JMAX(KK) = JX 207 CONTINUE JX = JMAXl 2) DO 220 J = JX, 1000 STAR(J) = STAR(JX) 220 CONTINUE 216 WRITE (6,151) JFK,JMAX,KK 151 FORMAT (//• # PUNCH ERRORS =•,315,10X,•TOTAL SCAN L ENGTHS = • ,3 I 5 , 1 10X,'IN OR AT END OF SCAN # « , I 2 , / ) IF (((FLOAT(JFK(1)).GT.0.03*JX).OR.(FLOAT(JFK(3)).GT.0.03*JX)) 1 .OR.(FLOAT(JFK(2)).GT.0.01*JX)) ISTOP = 1 WRITE (6,150) NFK 150 FORMAT (//• TAPE ERRORS AT' ,5X,10 15,2(/• •,19X,10 I 5),/) WRITE (6,152) ISTOP 152 FORMAT (///' THRU READIN I STOP = M l ) IF (ISTOP.EQ.l) STOP RETURN END SUBROUTINE FAKLYN ( RR , JX , IX , IP , LF, * ) DIMENSION Rl 1006) ,RR( 1000) , P ( 4 ) , A ( 4 ) , W ( 4 ) COMMON P,A,W ,BLANK(1993) JX = 1000 Y = RAND(FLOAT(IX)) YY = 0.0 READ (5,100) NLtAMP 100 FORMAT (I 10 » F10 .5 ) IF (NL.GT.4) NL = 1 READ (5,101) ( ( P ( J ) , A ( J ) , W ( J ) ) , J=1,NL) 101 FORMAT (3F10.5) WRITE (6,150) N L , A M P , ( ( P ( J ) , A ( J ) , W ( J ) ) , J=1,NL) 150 FORMAT ( / / » 1 I N FAKLYN', //• NO OF LINES = » , I 1,10 X, • NO ISE AMPLITUDE 1 = ',F8.5,//' POSITION AMPLITUDE HALF-WIDTH:',/,4(30X,3(F10.5, 2 5X) , / )) DO 199 J = 1, NL W(J) = W(J) / 2.38 199 CONTINUE DO 200 J J = 1, JX RS = 0.0 DO 201 J = 1, NL IF ( A B S ( J J - P ( J ) ) . G T . 4 . 0 * W ( J ) ) GO TO 201 RS = RS + A ( J ) * EXP (-{ J J - P ( J) )**2/ ( 2.0*W( J ) * * 2 ) ) 201 CONTINUE R( J J ) = RS 200 CONTINUE DO 202 J = 1, JX Y = RAND(O.O) IS = -1 IF (Y.GT.0.5) IS = +1 Y = RAND(0.0) YP = YY YY = IS * AMP * Y YF = (3.0 * YY + 1.0 * YP) / 4.0 R( J) = R( J) + YF 202 CONTINUE IF (IP.NE.O .AND. IX.LT.O) CALLDRAWIT (R,JX,-1) CALL SMOOTH (R,RR,JX,5) IF (IP.NE.O) CALL DRAWIT (RR,JX,->1) IF (LF.EQ.O) CALL PLOTND WRITE (6,151) 151 FORMAT (• EXITING FROM FAKLYN') RETURN 1 END SUBROUTINE DRAWIT (R,JX,LYFORP) DIMENSION R(1000) ,X( 1000),Y(1000) ,0V(125) ,0(6) COMMON X,Y,RX,RN,F,A,B COMMON /STUF/ KK /PLT/ IP EQUIVALENCE (0V( 1) ,X(1)) DATA BL/' • / , AST/'*'/, D/200 . 0 , 100 . 0 , 50 . 0, 25 . 0,10 . 0, 5 . 0 / IF (LYFORP.LT.O) GO TO 204 B = FLOAT( KK) RX = R ( 1) DO 200 J = 2, JX IF (R(J).LE.RX) GO TO 200 RX = R(J) 200 CONTINUE DO 201 J = 1, 5 IF (RX.LE.D(J) .AND. RX.GT.D(J+1)) GO TO 208 201 CONTINUE GO TO 209 208 RX = D(J) 209 F = 10.0 / RX A = 0.0 204 IF (LYFORP.LT.O) F = 10.0 IF (LYFORP.LT.O) A = 2.0 DO 202 J = 1, JX X(J) = 0.04 * J Y( J) = F * R( J) + A 202 CONTINUE IF ( IP .LT.O) GO TO 205 IF (LYFORP.LT.O) GO TO 203 CALL SYMBOL (0.5,4.0,0.28,7HTAPE #,90.0,7) CALL NUMBER (0.5,6.0,0.28,B,90.0,-1) CALL NUMBER (0.0,9.9,0.2 1,RX,0.0,2) CALL PLOT (1.0,0.0,-3) 203 CALL LINE (X,Y,JX,1) IF (LYFORP.EQ.O) CALL PLOTND IF (LYFORP.NE.O) CALL PLOT (JX/25+3.0,0.0,=3) IF (LYFORP.GE.O) WRITE (6,150) RX 150 FORMAT (///' PLOTTING MAIN SCAN',//* PEAK CORRESPONDS TO STARAV =' 1 ,F8.3,//) RETURN 205 IF (LYFORP.GE.O) WRITE (6,151) KK , RX 151 FORMAT ( 11TAPE #• ,I 5,T120,•RX=',F6.3,/,T25,• I• ,Tl25,• I 1,/) IF (LYFORP.LT.O) WRITE (6,152) 152 FORMAT ( ' 1FAKLYN PROFILE',/) DO 206 J = 1, 125 OV(J) = BL 206 CONTINUE DO 207 J = 1, JX OV ( 10.0*Y( J) ) = AST WRITE (6,153) OV 153 FORMAT ('9• , T25 , • I • ,125A 1) IF (J/10*10.EQ.J) WRITE (6,154) J 154 FORMAT ('+',T17,I4) OV ( 10 . 0 * Y ( J ) ) = BL 207 CONTINUE WRITE (6,155) 155 FORMAT ('1•) IF (LYFORP.EQ.O) CALL PLOTND RETURN END SUBROUTINE LAGS ( I T , I B , JX ) DIMENSION IT(1000),IB(1000),IC(31),Y(5),R(7) COMMON /SKALE/ R,SH,IW DISC = 0.14 IX = IT(1) DO 200 J = 2, JX IF (IT(J) .GT.IX) IX = IT(J) 200 CONTINUE IM = IT I 1) DO 201 J = 2, 100 IF ( I T ( J ) .LT.IM) IM = IT(J) 201 CONTINUE IM = IM + 5 215 DISC = DISC + 0.05 IL = IM + DISC * ( IX-IM) JB = 1 207 DO 202 J = JB, JX IF ( I T U ) .GT .ID GO TO 203 202 CONTINUE 203 JA = J DO 204 J = JA, JX IF ( I T ( J ) . L T . I L ) GO TO 205 204 CONTINUE 205 JB = J IF {JB-JA.LE.2) GO TO 207 JD = 1 208 DO 206 J = JD, JX IF ( I B U ) .GT.IL) GO TO 209 206 CONTINUE 209 JC = J DO 230 J = JC, JX IF (IB(J).LT.IL) GO TO 231 230 CONTINUE 231 JD = J IF (JD-JC.LE.2) GO TO 208 LAG = UC+JD ~JA-JB) / 2 IF (IABS(LAG).GT.60) GO TO 215 JB = MAXO ( 16,16-LAG) JD = MINO ( JX-15-LAG, JX~15) DO 210 L = 1, 31 IS = 0 LA = L =» 16 + LAG DO 211 J = JB, JD IS = IS + I T U ) * I B U + LA) 211 CONTINUE IC(L) = IS 210 CONTINUE WRITE (6,150) IC, LAG 150 FORMAT (//• IN LAGS - CROSSCORRELAT ION VALUES' , / /,2( IX, 12110,,/ 1 ) , IX,7110,//' CENTERED ON LAG =',I6,/) KP = IC(3) MX = 3 DO 213 J = 3, 29 IF (IC(J).LE.KP) GO TO 213 KP = I C U ) MX = J 213 CONTINUE IF (MAXO(IC(1),10(31)).GE.IC(MX)) GO TO 215 DO 214 JJ = 1, 5 Y(JJ) = FLOAT (IC(JJ+MX-3)) 214 CONTINUE CALL FITPIK (Y,5,PK,IOK) SH = MX + PK - 19.0 + LAG WRITE (6,152) SH 152 FORMAT (///' SHIFT =',F12.7) B = (IC(1)+IC(2)+IC(30)+IC(31)) / 4.0 D = B + 0.5 * (KP - B) DO 220 J = 1, 31 IF (FLOAT(IC(J)).GT.D) GO TO 221 220 CONTINUE 221 PL = ( J - l ) + (D - I C ( J - l ) ) / ( IC (J) - I C ( J - l ) ) DO 222 K = J , 31 IF (FLOAT(IC(K)).LT.D) GO TO 223 222 CONTINUE 223 PR = (K-l) + (IC( K - l ) - D) / (IC( K - l ) - ICIK)) P = (PL + PR) / 2.0 HW = PR - PL CON = (KP-B)/(JD-JB+1.0)/HW SKEW = 360.0/6.283 185 * ATAN ( ( M X + P K - 3 . 0 - P ) / ( HW*CON) ) WRITE (6,155) HW,P,CON,SKEW 155 FORMAT (/• HALF-WIDTH OF CRO SS CORR EL AT I ON CURVE = • , F 8.3 , 5 X, « M ID PO I INT A T ' , F 8 . 3 , / « CONTRAST = HT/HW =•,G20.8,/' SKEW = « , G 2 0 . 8 , ' DEGREE 2S' ) IF (HW.LT.4.0) GO TO 215 RETURN END SUBROUTINE SMOOTH (SI,SO,JX,NAVG) DIMENSION SI(1000) ,SO(1000) NAVG = 2 * (NAVG/2) + 1 IF (NAVG.EQ.l) GO TO 224 IF (JX.GT.NAVG) GO TO 219 WRITE (6,150) 150 FORMAT (//« IN SMOOTH - JX.LE.NAVG - STOP',///) STOP 219 NO = NAVG/2 NAP = NO + 1 NAPP = NAP + 1 JXM = JX - NO S = 0.0 DO 220 J = 1, NAVG S = S + S K J ) 220 CONTINUE SO(NAP) = S / NAVG DO 221 J = NAPP, JXM SO (J) = SO ( J - l ) + (S I ( J + N O ) » S I ( J - N A P ) ) / F LOAT(NAVG) 221 CONTINUE DO 222 J = 1, NO S0(J) = S0(NAP) 222 CONTINUE DO 223 J = JXM, JX SO (J) = SO (JXM) 223 CONTINUE RETURN 224 DO 225 J = 1, JX SOU) = S K J ) 225 CONTINUE RETURN END SUBROUTINE CONTIN ( SI • JX ,.P1, P2, P 3) DIMENSION SK 1000),X(20) , Y ( 20 ) , YF { 20) , EL ( 5 ) , E2 ( 5) , P ( 20) , W( 20 ) , 1 R( 1000) COMMON R,X,Y,YF,P ,W,E1,E2,BLANK(895) COMMON /AX/ MDIM DO 79 J = 1, JX R( J) = SI ( J) 79 CONTINUE JO = JX / 20 DO 230 NJ = 1, 20 JB = JO * (NJ-1) + 1 JE = JO * NJ S = 0.0 SS = 0.0 DO 231 J = JB, JE S = S + R( J) SS = SS + R ( J ) * * 2 231 CONTINUE X(NJ) = F LOAT((JB+ JE)/2) Y(NJ) = S / (JE-JB+1) SIG = SQRT (SS/(JE-JB+1) - Y(NJ)**2) Y(NJ) = Y(NJ) + SIG P(NJ) = 0.0 230 CONTINUE MDIM = 3 EXTERNAL AUX CALL LQF (X,Y,YF,W,E1,E2,P,0.0,20,MDIM,1,ND,0.1,AUX) S = 0.0 DO 232 J = 1, 20 S = S + ( Y ( J ) - Y F ( J ) ) * * 2 232 CONTINUE S = SQRT (S/20.0) NJ = 0 DO 233 J = 1, 20 D = Y (J) - YF(J) IF ( (D.LT.O.O) .OR. (D.GT.S) ) GO TO 233 NJ = NJ + 1 X(NJ) = X( J) Y(NJ) = Y(J) P(NJ) = 0.0 233 CONTINUE CALL LQF (X,Y,YF,W,E1,E2,P,0.0,NJ,MDIM,1,ND,0.1,AUX) PI = P(1) P2 = P( 2) P3 = P(3) DO 234 J = 1, JX, 50 JJ = J/50 + 1 X(JJ) = J Y(JJ) = PI + P2*J + P3*J**2 234 CONTINUE WRITE (6,150) ( X ( J ) , J=1,JJ) 150 FORMAT (//• CONTINUUM POINTS:',//1 X',T9,20F6.0) WRITE (6,151) ( Y ( J ) , J=1,JJ) 151 FORMAT (• Y',T10,20F6.1) RETURN END SUBROUTINE FESKAL (L,JX,NL,POS,W) DIMENSION L(2000),IW(50),ID(50),HT(50),W(50),POS(50), 1 IAMP(6),PA(6),PB(6),P(6),I0K(6) COMMON IW,ID,I AMP ,PA,PB,P,I OK,BLANK(1875) DATA K/O/, JB/1/, JJJ/O/ IMX = L ( l ) DO 200 J = 2, JX IF (L(J) .LE.IMX) GO TO 200 IMX = L(J) 200 CONTINUE IMN = L( 1) DO 201 J = 2, 200 IF ( L ( J) .GE . IMN) GO TO 20 1 IMN = L(J) 201 CONTINUE IMN = IMN + 5 IDS = IMN + 0.2 * (IMX-IMN) DO 206 JJ = 1, 50 J J J = JJJ + 1 DO 210 J = JB, JX IF (L( J) .GT.IDS) GO TO 211 210 CONTINUE K = 1 GO TO 207 211 JA = J DO 212 J = JA, JX IF ( L (J) .LE.IDS) GO TO 213 212 CONTINUE K = 1 GO TO 207 213 JB = J IW(JJJ) = (JA+JB) / 2 ID(JJJ ) = JB-JA IF (ID(JJJ) .LE.4) J J J = JJJ - 1 206 CONTINUE 207 NL = J J J IF (K.EQ.1) NL = J J J - 1 DO 214 I = 1, NL JA = MAXO (1,IW(I)-ID(I)/2) JB = MINO {JX,IW(I)+ID(I)/2) IX = L( JA) DO 208 J = JA, JB IF (L (J) .LE.IX) GO TO 208 IX = L(J) 208 CONTINUE HT(I) = (IX - IMN) / FLOAT(IMX - IMN) DO 209 J = 3, 8 IAMPU-2) = IMN + 0.1 * J * HT(I) * (IMX - IMN) 209 CONTINUE DO 220 J = 1, 100 JJ = IW(I) - J IF (L(JJ).LT.IAMP(l)) GO TO 221 220 CONTINUE 221 JO = JJ DO 222 J = JO, JB DO 223 JJ = 1, 6 IOK(JJ) = 0 IF ( (L(J) .LE.IAMP(JJ)) .AND. (L(J+1) .GT.I AMP(JJ) ) ) IOK(JJ) = 1 223 CONTINUE DO 224 JJ = 1, 6 IF(IOK(JJ).EQ.l)PA(JJ)=FLOAT(J)+FLOAT(I AMP(JJ)-L(J) ) / ( L ( J + l ) - L ( J) ) 224 CONTINUE IF (I0K(6).EQ.l) GO TO 225 222 CONTINUE 225 JO = J JB = JB + 10 DO 226 J = JO, JB DO 227 JJ = 1, 6 IOK( JJ ) = 0 IF ( (L(J) .GE.I AMP(JJ ) ) .AND. ( L ( J+1).LT.I AMP( JJ) ) ) IOK(JJ) = 1 227 CONTINUE DO 228 JJ = 1, 6 IF(IOK(JJ).EQ.1)PB(JJ)=FLOAT(J)+FLOAT(L(J)-IAMP(JJ))/(L(J)-L(J+1)) 228 CONTINUE IF (IOK(1).EQ.l) GO TO 229 226 CONTINUE 229 DO 230 J = 1, 6 P(J) = {PA(J) + PB(J)) / 2.0 230 CONTINUE N = 6 235 S = 0.0 DO 231 J = 1, N S = S + P(J) 231 CONTINUE AVG = S / N S = 0.0 DO 232 J = 1, N S = S + (P(J) - AVG) ** 2 232 CONTINUE SIG = SQRT (S/N) IF ( (SIG.LE.0.1) .OR. (N.LE.3) ) GO TO 233 PX = ABS (P(1)-AVG) DO 236 J = 2, N IF (ABS(P(J)-AVG) .LE.PX) GO TO 236 PX = ABS (P(J)-AVG) 236 CONTINUE M = 0 DO 234 J = 1, N IF (ABS(P<J)=AVG).GE.PX) GO TO 2 34 M = M + 1 P ( M) = P ( J) 234 CONTINUE N = M GO TO 235 233 POS( I ) = AVG W(I) = (N/6.0) * (0.4*HT(I) + 0.6) IF (ABS(POS(I)-IW(I)).GT.FLOAT(ID(I))/2.0) W(I) = 0.0 214 CONTINUE WRITE (6,150) NL 150 FORMAT (///• NUMBER OF IRON ARC LINES =• ,I 5 , / / , T 2 0 , » P O S IT I ON• , 1 T40,'REL. HEIGHT*,T61,'WEIGHT*,/) WRITE (8,151) NL 151 FORMAT (15) DO 250 J = 1, NL WRITE (6,152) POS(J),HT(J),W(J) WRITE (8,152) POS(J) 250 CONTINUE 152 FORMAT (10X, 3F20.7) RETURN END SUBROUTINE SKALE2 (POSB,NLB,WB,JX) DIMENSION POSA(50),POSB(50) ,WB(50),P(5 0) ,R(7) , El( 10),E2(10), 1 WAV(50),D(50),YF(50),MD(50) REAL*8 WAVEA(50),WAVEB(50),X(3),WL(3),C(6),DEN,DO,WLO,CON COMMON WAVEB,X,WL,C,DEN,DO,WLO,CON,P,El,E2,D,YF,WAV,BLANK(1653) COMMON /SKALE/ R,SH,IW /AX/ MDIM READ (5,101) NLA,IW 101 FORMAT (215) READ (5,106) ((POSA(J),WAVEA(J)), J=1,NLA) 106 FORMAT (10X,2F20.7) DO 79 J = 1, 50 WAVEB(J) = 0.0 P(J) = 1000.0 79 CONTINUE DO 200 J = 1, NLA JJ = J IF (POSA(J).GE.FLOAT(JX)) GO TO 201 200 CONTINUE JJ = J J + 1 201 NU = JJ - 1 DO 209 MN = 1, NLB N = MN + 1 DO 210 JJ = 1, NU DIFF = POSB(MN) - POSA(JJ) DO 211 J = N, NLB IF (WB(J).GT.0.6) GO TO 212 211 CONTINUE GO TO 220 212 DO 213 JI = 1, NU IF (ABS(POSB(J)-POSA(JI)-DIFF).LE.3.0) GO TO 220 213 CONTINUE 210 CONTINUE 209 CONTINUE 220 DO 202 JJ = lt NU XP = POSA(JJ) + DIFF DO 203 J = I t NLB P ( J) = POSB( J) - XP IF (WB(J).LT.0.3) P(J) = 1000.0 203 CONTINUE MN = 1 PM = ABS(P(1)) DO 204 J = 2, NLB IF (ABS(P(J)).GE.PM) GO TO 204 PM = ABS( P ( J) ) MN = J 204 CONTINUE IF (ABS(P(MN)).GT.4.0) GO TO 202 WAVEB(MN) = WAVEA(JJ) 202 CONTINUE N = 0 DO 205 J = 1, NLB IF (WAVEB(J).EQ.O.O) GO TO 205 N = N + 1 POSB(N) = POSB(J) WAVE B(N) = WAVEB(J) WB(N) = WB(J) 205 CONTINUE IF (IW.NE.O) GO TO 260 X( 1) = DB LE ( POSB ( 1 ) ) WL( 1) = WAVEB( 1) X(3) = DBLE(POSB(N)) WL(3) = WAVEB(N) X2 = (X( 1) + X( 3) ) / 2D0 NM = N «=• 1 DO 252 J = 2, NM D(J) = ABS (POSB(J)- X2) 252 CONTINUE MDD = 2 DM = D ( 2) DO 253 J = 2, NM IF (D(J).GE.DM) GO TO 253 DM = D(J) MDD = J 253 CONTINUE X(2) = DBLE(POSB(MDD)) WL(2) = WAVEB(MDD ) C< 1) = WL( 1) - WL{ 2) C(2) = X( 2) - X(1) C(3) = WL(2)*X(2) -WL(1)*X(1) C(4) = WL( 1) - WL (3) C( 5) = X(3) - X( 1) C(6) = WL(3)*X(3) -WL(1)*X(1) DEN = C(1)*C(5) - C(2)*C(4) DO = (C(3)*C(5) - C(2)*C(6)) / DEN WLO = (C(1)*C(6) - C(3)*C(4)) / DEN CON = ODO DO 254 J = 1, 3 CON = CON + (WL(J) - WLO) * (DO + X(J)) 254 CONTINUE CON = CON / 3D0 DO 255 J = 1, N DU) = WAVEB(J) - (WLO + CON / (DO + DBLE ( POSB(J) ) )') 255 CONTINUE S = 0.0 DO 256 J = 1, N S = S + D(J) ** 2 256 CONTINUE S = AMAX1 (SQRT(S/N),0.05) NM = 0 DO 257 J = 1, N IF (ABS(DU) ) .LE.S) GO TO 257 NM = NM + 1 WBU) = 0.0 257 CONTINUE MD IM = MINO (4, N-NM-1) DO 262 J = 1,7 ' 262 P(J) = 0.0 IF (MDIM.LE.l) GO TO 258 EXTERNAL AUX CALL DPLQF {POSB,D,YF,WB,E1,E2,P,1.0,N,MDIM,1,ND,0.1,AUX) DO 259 J = 1, 4 P(8-J) = P(5=J) 259 CONTINUE 258 P ( l ) = WLO P(2) = CON P(3) = DO WRITE (6,150) 150 FORMAT (///' PRISM DISPERSION',/) GO TO 270 260 DO 261 J = 1, N WAV(J) = WAVEB(J) P(J) = 0.0 261 CONTINUE WRITE (6,155) 155 FORMAT (//• THE FOLLOWING GARBAGE IS FROM SKALE2') MDIM = MINO (5,N-1) EPS = 0.00001 NIT = 3 DO 265 I = 2, MDIM DO 268 J = 1, 50 MD (J) = 0 IF (J.LE.I) MD(J) = 1 268 CONTINUE IF (I.EQ.MDIM) EPS = EPS / 10.0 IF (I.EQ.MDIM) NIT = 5 CALL DPRLQF (POSB ,WAV,YF,WB,E1,E2,P,1.0,N,MDIM,NIT,ND,EPS,AUX,MD) 265 CONTINUE S = 0.0 DO 266 J = 1, N S = S + ( W AV ( J ) - YF ( J ) ) 266 CONTINUE P(1) = P(1) + S / FLOAT(N) MP = MDIM + 1 DO 207 J = MP, 7 P ( J) = 0.0 207 CONTINUE WRITE (6,151) 151 FORMAT (///• GRATING DISPERSION',/) 270 DO 271 J = 1, 7 R ( J ) = P ( J ) 271 CONTINUE IF (IW.EQ.l) GO TO 273 S = 0.0 DO 267 J = 1, N IF (WB(J).EQ.O.O) GO TO 267 S = S + ( WAVEB( J )-WLAMDA( POSB( J) ) ) 267 CONTINUE R(1) = P( 1) + S/(N-NM) 273 WRITE (6,152) 152 FORMAT ( T 2 3 ,1P O S I T I O N ' » T 4 0 , 'WAVELENGTH',T60,* FIT WAVEL.',T85, 1 'ERROR',/) DO 280 J = 1, N D(J) = WL AMDA ( POSB ( J ) ) YF(J) = WAVEB(J) - D( J) 280 CONTINUE WRITE (6,153) ((POSB(J),WAVEB( J) ,D(J),YF( J)) , J=1,N) 153 FORMAT (10X,4F20.4) RETURN END SUBROUTINE STANRD (R,JX) DIMENSION R(1000) ,IS(4),ST(512),S(401),SB(401),X(401),Y(401), 1 CODE(3),STP(512),MID(5) INTEGER*2 PARK 13 )/24, ' F I LE S= 1 ,NORE W , COP Y ERROR S • / , 1 PAR2(9) /16,'NOREW,COPYERRORS'/ COMMON ST,S8,X,Y,BLANK(290) /KODER/ IDCODE EQUIVALENCE (ST{257),S(20 1)) DATA LL /-IO/, LR /-13/ DO 198 J = 1, 401 198 X< J) = 0.04 * ( J - l ) CALL SYMBOL (0.5,5.0,0.28,6HIDCODE,90.0,6) WRITE (3,160) IDCODE 160 FORMAT (I 12) BACKSPACE 3 READ (3,161) CODE 161 FORMAT (3A4) ' CALL SYMBOL (0.5,7.0,0.28,CODE,90.0,12) CALL PLOT (1.0,0.0,-3) END FILE 1 CALL SKIP (1,0,0) DO 52 J = 1, 50 READ (0) IDNO IF (IDNO.EQ.IDCODE) GO TO 51 IF (IDNO.EQ.999999) GO TO 55 CALL SKIP (0,-1,0) CALL TAPCPY (PARI ) 52 CONTINUE 51 WRITE (6,150) IDCODE 150 FORMAT (//« CORRECT IDCODE LOCATED ON TAPE - IDCODE ='I10,//) IB4 = 1 GO TO 199 55 WRITE (6,152) IDCODE 152 FORMAT (//• NO MATCHING IDCODE FOUND - WRITING IDCODE 1 • ON TAPE',//) IB4 = 0 199 WRITE ( 1) IDCODE WRITE (6,153) J 153 FORMAT (/• THIS DATA GOES ON AFTER TAPEMARK # ',12,/) READ (5,100) IS, 18 100 FORMAT (411,16) DO 299 1 = 1 , 4 IF (IS(I).EQ.O) GO TO 220 LLP = LL LRP = LR READ (5,101,END=228) WL,WR 101 FORMAT (2F10.3) LL = 1 IF (WL.GT.10.0) LL = LOCAT(WL) LR = JX IF (WR.GT.10.0) LR = LOCAT(WR) IF (LL.EQ.LLP .AND. LR.EQ.LRP) GO TO 240 GO TO 229 228 LL = 1 LR = JX 229 MX = LL XM = R(MX) DO 200 J = LL, LR IF (R(J) .LE .XM) GO TO 200 XM = R(J) 200 CONTINUE AMP = G.9 5 * XM DO 260 JJ = 1, 5 DX = (0.9-0.1*JJ) * XM JK = LL NW = 0 DO 261 JI = 1, 10 DO 204 J = JK, LR IF (R(J) .GT .DX) GO TO 205 204 CONTINUE GO TO 260 205 MX = J DO 206 J = MX, LR IF (R(J).LT.DX) GO TO 207 206 CONTINUE GO TO 260 207 IF (J-MX.GT.NW) MID(JJ) = (MX+J)/2 NW = MAXO (J-MX,NW) JK = J 261 CONTINUE 260 CONTINUE CALL SSORT (MID,5,1) MX = MID(3) ML = MAXO (LL,MX-256) MR = MINO (LR,MX+255) DO 201 J = 1, 512 ST(J) = 0.0 201 CONTINUE JL = 257 - MX DO 202 J = ML, MR ST(J+JL) = R(J) 202 CONTINUE DO 203 J = 258, 512 ST(J) = (ST(J) + ST(514-J)) / 2.0 ST(514-J) = ST(J) 203 CONTINUE CALL SPROFL (ST,5 12,257, 18) DO 241 J = 1, 512 STP(J) = ST(J) 241 CONTINUE AMPP = AMP GO TO 242 240 DO 243 J = 1, 512 ST(J) = STP(J) 243 CONTINUE AMP = AMPP 242 DO 213 J = 258, 512 IF (ST(J).LT.0.1) GO TO 214 213 CONTINUE 214 L = 2 * (J-257) - 1 IF (IB4.EQ.1) GO TO 215 N = 1 297 B = 2.5 * (4-1 ) DO 230 J = 1, 401 Y(J) = 2.0 * S(J) + B 230 CONTINUE CALL LINE (X,Y,401,1) 298 WRITE (1) N,L, AMP WRITE (1) S GO TO 299 215 READ (0) NB, LB, AMPB READ (0) SB SUM = 0.G DO 2 1 9 J = 1, 4 0 1 SUM = SUM + ( S( J ) - SB( J ) ) * * 2 2 1 9 C O N T I N U E N = NB + 1 DO 2 1 6 J = 1, 4 0 1 S ( J ) = ( N B * S B ( J ) + S ( J ) ) / N 2 1 6 C O N T I N U E AMP = <NB*AMPB + AMP) / N DO 2 1 7 J = 2 0 2 , 4 0 1 I F ( S ( J ) . L T . 0 . 1 ) GO TO 218 2 1 7 C O N T I N U E 218 L = 2 * ( J - 2 0 1 ) - 1 WRITE ( 6 , 1 5 5 ) I,NB,L,SUM 155 FORMAT (/' P R O F I L E # ' , I 2 , 1 0 X , ' # P R E V I O U S C O N T R I B U T I O N S 1 / ' U S E A B L E LENGTH =1, 1 3 , 1 0 X , ' S U M SQUARES = ' , F 1 0 . 6 ) GO TO 297 2 2 0 I F ( I B 4 . E Q . 1 ) GO TO 221 DO 222 J = 1, 4 0 1 S ( J ) = 0.0 222 C O N T I N U E N = 0 GO TO 298 221 READ (0) N, L , AMP READ ( 0 ) S GO TO 2 9 7 299 C O N T I N U E C A L L S K I P (-1,0,1) C A L L S K I P ( 1 , 1 , 1 ) DO 3 0 0 I = 1, 4 READ ( 1 ) N , L , AMP READ (1) SB WRITE ( 6 , 1 5 1 ) I, N, L , AMP 3 0 0 C O N T I N U E 151 FORMAT (/• STANDARD #' , 1 2 , 1 0 X ,1 NO OF P R O F I L E S = WEIGHT 1 1 0 X , ' U S E A B L E LENGTH =',I 3,10X,•A MPLITUDE =',F8.4,/) C A L L PLOTND I F ( I B 4 . E Q . 0 ) GO TO 301 C A L L T A P C P Y ( P A R 2 ) GO TO 3 0 3 301 END F I L E 1 N = 9 9 9 9 9 9 WRITE ( 1 ) N END F I L E 1 END F I L E 1 3 0 3 REWIND 1 REWIND 0 STOP END SUBROUTINE SPROFL (RR,JX,JXP,18) DIMENSION R(512),RR(512),S(48),X(48),SF(48),W(48),El(3),E2(3), 1 P(3),Y(3),WT(48) COMMON /AX/ MDIM MDIM = 3 F = 1.0 18 = MINO (48,18/2*2) IF (I8.LE.0) 18 = 48 14 = 18/2 15 = 14 + 1 DO 229 J = 1, 14 WT(J) = 0.15 + 0.7 * ( J - l ) / ( 14-1) WT( I8+1-J) = WT ( J) 229 CONTINUE DO 230 J = 1, JX R(J) = 0.0 230 CONTINUE DO 204 J = 1, 18 X(J) = FLOAT ( J ) 204 CONTINUE DO 200 J = JXP, JX IF (RR(J).LT.0.1*RR(JXP)) GO TO 201 200 CONTINUE J = JX 201 LIM = MINO (JXP+2*(J-JXP),JX-I5) DO 250 JC = JXP, LIM, 14 DO 202 J = 1, 18 S( J) = RR( JC+J-I5 ) 202 CONTINUE DO 203 J = 1, 3 P(J) = 0.0 203 CONTINUE EXTERNAL AUX CALL LQF (X,S,SF,W,E1,E2,P,0.0,I8,MDIM,1,ND,0.1,AUX) IF (SF( 18) .GT.SFQ4) .AND. JC.LT.JXP+3*(LIM-JXP)/4) F = F + 0.5 DO 205 J = 1, 18 RUC+J-I5) = R(JC+J-I5) + WT(J) * SF(J) 205 CONTINUE 250 CONTINUE DO 210 J = 1, 3 Y(J) = (1.0 - 0.25*J) * R(JXP) 210 CONTINUE DO 211 JJ = 1, 3 DO 212 J = JXP, JX IF (R(J) .LT.Y(JJ)) GO TO 213 212 CONTINUE 213 X(JJ) = J - l + (R( J - l ) - Y ( JJ) ) / (R( J - l ) - R ( J) ) 211 CONTINUE X(4) = X ( l ) + 3.0 * (X ( 3) -X ( 2) ) + 1.0 X(5) = X(2) + 3.0 * (X(4)-X(3)) + 3.0 JA = X(3) + 1.0 JB = X(4) FR = 0.25 * R(JXP) / (X(3)-X(4)) 216 DO 215 J = JA, JB R(J) = (R(J) + F * F R * ( J - X ( 4 ) ) ) / (1.0+F) 215 CONTINUE IF (R(JB).LE.0.0 .OR. FLOAT(JB).GT.X(4)+1.0) GO TO 214 JA = JB + 1 JB = X(5) FR = -0.25 * R(JXP) / (X(5)-X(4)) GO TO 216 214 JB = X(3) + 1.0 DO 217 J = JB, JX IF (R(J) .LE.O.O) GO TO 218 217 CONTINUE 218 DO 219 JJ = J , JX R(JJ) = 0.0 219 CONTINUE JJ = MAXO ( IFIXIXl 1)),JXP + 1) DO 223 J = J J , JX IF (R (J) .EQ.O.O) GO TO 225 IF (R( J) .GE.Rl J-D) GO TO 224 223 CONTINUE 224 DO 226 JJ = 1, 13 JB = J - JJ IF (R(JB).GE.2.0*R(J)) GO TO 227 226 CONTINUE 227 DO 228 JJ = JB, J R(JJ) = RUB) * (1.0 - FLOAT( JJ-JB)/( J-JB) ) 228 CONTINUE GO TO 218 225 DO 220 J = 2, JXP RU) = RUX+2-J) 220 CONTINUE XM = R(JXP) DO 222 J = 1, JX IF (R ( J) .GT .XM) XM = R( J) 222 CONTINUE DO 221 J = 1, JX RR( J) = R( J) / XM 221 CONTINUE RETURN END SUBROUTINE GTPRFL (S1,S2,S3,S4,LI,L2,L3,L4,A 1,A2,A3,A4,LINES, 1 NUMPRF) DIMENSION SI(401),S2(401),S3(401),S4(401) COMMON /KODER/ IDCODE DO 52 J = 1, 100 CALL SKIP (1,0,0) READ (0) IDNO IF (IDNO.EQ.IDCODE) GO TO 51 IF (IDNO.EQ.999999) GO TO 55 52 CONTINUE 55 WRITE (6,151) IDCODE 151 FORMAT (///' NO IDNO FOUND MATCHING IDCODE =' ,113,//) REWIND 0 STOP 51 WRITE (6,150) IDNO, J 150 FORMAT (//• CORRECT IDCODE LOCATED ON TAPE - IDNO =',110, 1 / ' LOCATED AFTER TAPEMARK # » , I 2 , / / ) 59 READ (0,END=57) N,L1,A1 READ (0) SI IF (LINES.EQ.-l .AND. NUMPRF.LE . 1) GO TO 57 IF (NUMPRF.EQ.2) GO TO 58 READ (0) N, L2, A2 READ (0) S2 IF (NUMPRF.EQ.34) GO TO 59 IF (LINES.EQ.l .AND. NUMPRF.LE.1) GO TO 57 IF (NUMPRF .EQ.3) GO TO 58 READ (0) N, L3, A3 READ (0) S3 IF (NUMPRF.EQ.4) GO TO 58 READ (0) N, L4, A4 READ (0) S4 57 REWIND 0 RETURN 58 READ (0) N,L1,A1 READ (0) SI GO TO 57 END S U B R O U T I N E MCH1 ( R , J X , I A , I B , S T D O , L U S E O ) D I M E N S I O N R( 1 0 0 0 ) , R R ( 1 0 0 0 ) , S T D O ( 4 0 1 ) , S S Q ( 1 0 0 0 ) ,Y( 5 ) , S T U D < 4 0 1 ) COMMON RR,SSQ,Y E Q U I V A L E N C E { S S Q ( 1 ) , S T U D ( 1 ) ) DO 7 9 J = 1, J X RR( J ) = R( J ) 7 9 CONTINUE MX = I A XM = R R ( M X ) DO 8 0 J = I A , I B I F ( R R ( J ) .LE.XM) GO TO 8 0 XM = R R ( J ) MX = J 8 0 CONTINUE AMP = ( R R ( M X - 2 ) + R R ( M X - l ) + R R ( M X ) + R R ( M X + 1 ) + R R ( M X + 2 ) ) / 5.0 6 9 J A = MX - 15 J B = MX + 15 I F ( J A . L T . I A + L U S E O / 2 ) JA = I A + L U S E O / 2 IF ( J B . G T . I B - L U S E O / 2 ) JB = I B - L U S E O / 2 J l = 2 0 1 - L U S E O / 2 J 2 = 2 0 1 + LUSEO/2 75 DO 81 J J = J A , J B J C = J J =• 2 0 1 S = = 0 . 0 DO 8 2 J = J l , J 2 S = = S + (AMP * ST D O ( J ) R R { J + J C ) ) ## 2 82 CONTINUE S S Q ( J J ) = S 81 CONTINUE XM = S S Q ( J A ) MX = J A DO 83 J = J A , J B I F ( S S Q ( J ) . G E . X M ) GO TO 8 3 XM = S S Q ( J ) MX = J 83 CONTINUE DO 8 4 J = 1, 5 Y ( J ) = S S Q I M X + J - 3 ) 8 4 CONTINUE C A L L F I T P I K ( Y , 5 , P K , I 0 K ) PK = MX + PK - 3.0 C A L L F I N E F T ( R , J X , I A,I B , S T D O , S T U D ,LUSEO,10,PK,W , A M P , P L , 1 ) W = WLAMDA ( P K ) WRITE ( 6 , 1 5 0 ) AMP,PK,W 1 5 0 FORMAT (//' FROM MCH1 ' , // « A M P L I T U D E = • , F l 0 . 5 , 10X , ' POS IT I ON =', 1 F 1 0 . 5 , 1 0 X , » W A V E L E N G T H = ' , F 1 0 . 3 , / ) WRITE ( 2 , 1 5 1 ) P K , A M P , I A , I B 151 FORMAT ( 2 F 2 0 . 5 , 2 I 1 0 ) C A L L SMOOTH ( R R , S S Q , J X , 1 5 ) XM = S S Q ( I A) DO 2 0 0 J = I A , I B I F ( S S Q ( J ) . L E . X M ) GO TO 2 0 0 XM = S S Q ( J ) 2 0 0 CONTINUE XM = 0.3 * XM IBG = I A DO 2 0 1 J J = 1, 10 DO 2 0 2 J = I B G , I B I F ( S S Q ( J ) . G T . X M ) GO TO 2 0 3 2 0 2 C O N T I N U E GO TO 210 203 PL = (XM-SSQl J - l ) ) / (SSQ(J) - SSQ(J-l)) + ( J - l ) DO 204 K = J , IB IF ( SSQ(K) .LT.XM) GO TO 205 204 CONTINUE GO TO 210 205 PR = (SSQ(K~1)-XM) / (SSQ(K-l) ° S S Q ( K ) ) + (K-l) RR(JJ) = (PL + PR) / 2.0 RRUJ+10) = PR - PL IBG = K JJX = JJ 201 CONTINUE 210 DX = RR(11) DO 211 J = 1, JJX IF (RR(10+J).LE.DX) GO TO 211 DX = RR ( 10+J) 211 CONTINUE DO 212 J = 1, JJX IF (RR(10+J).GE.DX) GO TO 215 212 CONTINUE 215 P = RR(J) Wl = RR(10+J) WL = WLAMDA(P) WRITE (6,155) P,WI,WL 155 FORMAT (/' POSITION OF MIDPOINT OF WINGS = » , F 8 . 3 , 10-X, ' WIDTH •=•• t 1 F8.3,10X, 'WAVELENGTH = ',F10.3,//) STOP END SUBROUTINE MCH2 (RR,JX,IA,IB,S1,S2,S3,S4,L1,L2,L3,L4,A1,A2,A3,A 4, 1 LINES) DIMENSION R(1000),SI(401),S2(401),S3(401),S4(401),SSQ(1000), . 1 HT(100),P(100),SU(401),RS(1000),RW(1000), SS ( 401, 2 ) , Y ( 5) , L W( 4) , 2 SG(4),C(4),A(2),WL(4),RR(1000),SUU(401) REAL*8 W0RD(2) / ' FIRST SECOND'/ COMMON RW,SSQ,Y COMMON /DIVS/ MM 1 ,MM2 WRITE (6,150) 150 FORMAT (• THE FOLLOWING OUTPUT IS FROM SUBROUTINE MCH2 ',//) KK = 1000 KJL = 1000 KL J = 0 IF (LINES.EQ.l) GO TO 300 DO 79 J = 1, JX R ( J ) = RR( J) 79 CONTINUE IK = IA + MAX0(Ll ,L2) / 2 IL = MM 1 - MAXO(Ll,L2)/2 K = 1 209 AMP = R(IK) MP = IK DO 202 J = IK, IL IF (R(J) .LE.AMP) GO TO 202 AMP = R(J) MP = J 202 CONTINUE AMP = (R(MP=>2)+R(MP-l)+R(MP)+R(MP + l)+R(MP + 2) ) / 5.0 IF (K.LE.2 .AND. (AMP.GT.1.4*AMAX 1(A1,A2) .OR. AMP.LT.0.6*AMINl(A1 1 ,A2))) WRITE (6,166) K,AMP,A1,A2 IF (K.GE.3 .AND. (AMP.GT. 1.4*AMAX1{A3,A4) .OR. AMP.LT.0.6*AMIN1 ( A3 1 ,A4))) WRITE (6,166) K,AMP,A3,A4 166 FORMAT (//• AMPLITUDE OF OUTSIDE LINE PECULIAR1,/' K =',I2,5X, 1 'AMP =' ,F8.4,10X,'REF AMPS =• ,F8.4 , 5X,F8.4,//) IF (K.EQ.3) GO TO 210 A(l ) = AMP LU = L l DO 205 J = 1, 401 SU(J) = S1IJ) 205 CONTINUE 206 JK = 201 - LU/2 - 1 DO 200 JJ = IK, I L JL = JJ - LU/2 - 1 S = 0.0 DO 201 J = 1, LU S = S + (R(JL+J) - AMP * SUUK+J)) ** 2 201 CONTINUE SSQ(JJ) = S 200 CONTINUE MX = IK SX = SSQ(MX) DO 203 J = IK, IL IF (SSQ(J).GE.SX) GO TO 203 SX = SSQ(J) MX = J 203 CONTINUE DO 204 J =1, 5 Y(J) = SSQ(MX-3+J) 204 CONTINUE CALL FITPIK (Y,5,PK,I0K) PK = PK - 3.0 + MX P(K) = PK C(K) = SSQ(MX) GO TO (212,208,213,215), K 212 LU = L2 DO 207 J = 1, 401 SU(J) = S2(J) 207 CONTINUE K = 2 GO TO 206 208 IK = MM2 + MAXO (L3,L4) / 2 IL = IB - MAX0(L3,L4) / 2 K = 3 GO TO 209 210 LU = L3 A (2) = AMP DO 211 J = 1, 401 SU(J) = S3(J) 211 CONTINUE GO TO 206 213 LU = L4 DO 214 J = 1, 401 SU ( J ) = S4(J) 214 CONTINUE K = 4 GO TO 206 215 SG(1) = SQRT (C(1)/L1) SG(2) = SQRT (C(2)/L2) SG(3) = SQRT (C(3)/L3) SG(4) = SQRT (C(4)/L4) X = AM IN 1 (SG(1),SG(2)) IF (X.EQ.SG(2)) LL = 2 IF (X.EQ.SG(1)) LL = 1 YY= AMIN1 (SG(3),SG(4)) IF(YY.EQ.SG(3)) LR = 3 IF(YY.EQ.SG(4)) LR = 4 IF ((LL.EQ.l).AND.(LR.EQ.4) .OR. (LL.EQ.2).AND.(LR.EQ.3))GO TO 216 X = SQRT ( (C( 1)+C(4))/(L1+L4) ) YY= SQRT ((C(2)+C(3))/(L2+L3)) Z = AMIN1 (X,YY) IF (Z.EQ.YY) LL = 2 IF (Z.EQ.X) LL = 1 LR = 5 - LL 216 DO 217 J = 1,4 WL(J) = WLAMDA (P(J)) 217 CONTINUE WRITE (6,151) A, (P ( I ) , 1= 1,4) ,WL,C, SG,LL ,LR 151 FORMAT (' PRELIMINARY DATA ON OUTSIDE LINES',///1 AMPLITUDES', 1 2 ( 3 0 X , F 1 0 . 5 ) , / / » POSITIONS',10X,4F20.7,//' WAVELENGTHS',8X, 2 4F20.7,//' SUM SQUARES',8X,4F20.7,//1 ST DEVS',12X,4F20.7, 3 / / / • LEFT LINE = # ' , I 2 , 10X , ' R IGHT LINE = #',I2,//) DO 218 J = 1, JX RS(J) = RR(J) 218 CONTINUE AM P = A ( 1) MD = IFIX (P(LL)) IF (P(LL)-MD.GT.0.5) MD = MD + 1 IF (LL.EQ.2) GO TO 219 DO 220 J = 1, 401 220 SU( J) = SK J) GO TO 222 219 DO 221 J = 1, 401 221 SU(J) = S2(J) 222 JK = MD - 201 JL = MAXQ (1,202-MD) J LL = MINO (401,201+IB-MD) DO 223 J = J L , J LL RS(J+JK) = RSU+JK) - AMP * SUU) 223 CONTINUE IF (ABS(MD-P(LR)).LE.2.0) GO TO 228 MD = IFIX (P(LR)) IF (P(LR)-MD.GT.0.5) MD = MD + 1 IF (LR.EQ.4) GO TO 224 DO 225 J = 1, 401 225 SUU) = S3( J) GO TO 227 224 DO 226 J = 1, 401 226 SUl J) = S4( J) 227 AMP = A(2) GO TO 222 228 IK = MM1 IL = MM2 DO 229 J = 1, JX RW(J) = RS(J) 229 CONTINUE 400 XM = RW(IK) DO 230 J = IK, IL IF (RW(J).LE.XM) GO TO 230 XM = RW(J) 230 CONTINUE AMP = 0.6 * XM IF (LL.EQ.2) LU = L l / 2 + 1 IF (LL.EQ.l) LU = L2/2 + 1 IF (LL.EQ.2) GO TO 235 DO 233 J = 1, 401 233 SUU) = S2U) GO TO 234 235 DO 236 J = 1, 401 236 SUU) = S K J ) 234 JL = 201 - LU DO 231 JJ = IK, IL JK = JJ - LU S = 0.0 DO 232 J = 1, LU S = S + (RWU+JK) - AMP * SUU+JD) 232 CONTINUE SSQ(JJ) = S 231 CONTINUE MX = IK SX = SSQ(MX) DO 237 J = IK, IL IF (SSQ(J).GE.SX) GO TO 237 SX = SSQ(J) MX = J 237 CONTINUE JK = MX - LU JL = 201 - LU LU = 2 * LU - 1 DO 238 J = 1, LU RW(J+JK) = RWU + JK) - AMP * SUU+JL) 238 CONTINUE IF (KJL.EQ.5) GO TO 304 IF (LL.EQ.2) GO TO 240 DO 239 J = 1, 401 S S ( J , l ) = S3(J) 239 SS(J,2) = S2(J) LW(1) = L3 LW(2) = L2 GO TO 243 240 DO 241 J = I t 401 SSIJ, 1 ) = S4(J) 241 SS(J,2) = S K J ) LW(1) = L4 LW(2) = Ll 243 KK = 1 242 K = 0 TEST = 10.0 SQT = 1000.0 250 K = K + 1 IP = 1 IF (K/2*2.EQ.K) IP = 2 IF (KK.EQ.2) IP = 3 - IP 282 MX = IK XM = RW(MX) DO 251 J = IK, IL IF (RW(J) .LE.XM) GO TO 251 XM = RW(J) MX = J 251 CONTINUE AMP = 0.0 DO 252 J = 1, 5 AMP = AMP + RW(MX-3+J) / 5.0 252 CONTINUE IF (KK.LE.2) GO TO 413 KP = KK / 2 PK = FLOAT(MX) DO 507 J = 1, 401 SU(J) = SS(J,KP) 507 CONTINUE CALL FINEFT (RW,JX,IK,IL,SU,SUU,LW(KP),10,PK,XM ,AMP,STDEV,1) GO TO (413,413,283,284), KK 413 JA = MAXO (MX=LW(IP)/4,IA+LW(IP)/4) JB = MINO (MX+LW(IP)/4,IB-LW(IP)/4) JI = 201 - LW(IP)12 J2 = 201 + LW(IP)/2 408 DO 253 JJ = JA, JB JC = JJ - 201 S = 0.0 DO 254 J = J I , J2 S = S + (AMP * SS(J,IP) - RW(J+JO) ** 2 254 CONTINUE SSQ (JJ) = S 253 CONTINUE MX = JA XM = SSQ(MX) DO 255 J = JA, JB IF (SSQ(J).GE.XM) GO TO 255 XM = SSQ(J) MX = J 255 CONTINUE 406 SQLL = SQL SQL = SQT SQT = XM 421 DO 256 J = 1, 5 Y (J) = SSQ(MX + J-3) 256 CONTINUE CALL FITPIK (Y,5,PK,I0K) PK = MX + PK - 3.0 IF (KK.EQ.3) GO TO 283 IF (KK.EQ.4) GO TO 284 DELP = DEL DEL = PK - MX IF (K.NE.l .OR. KK.NE.2) GO TO 264 PK = PKK AMP-= AMK DEL = DELK MX = IFIX(PK) IF (DEL.LT.0.0) MX = MX + 1 IF (HEO.GT.HET) GO TO 264 K = K + 1 IP = 3 - IP 264 P(K) = PK HT(K) = AMP IF (K.LE.2) GO TO 257 TEST = ABS ( P ( K) -P ( K-2) ) IF (TEST.LT.0.02 .AND. I END.EQ.l) GO TO 261 I END = 0 IF (TEST.LT.0.02 ) IEND = 1 257 JK = MX — LW(IP) JL = MX + LW(IP) IF (JK.LT.IA) JK = IA IF (JL.GT.IB) JL = IB JD = MAXO (0,JK=MX+LW{IP)) DO 258 J = IA, IB RW(J) = RS(J) 258 CONTINUE JM = 201 - LW(IP) - JK + JD 274 DO 259 J = JK, JL JJ = J + JM IF (DEL.GT.0.0) RW(J) = RS(J) - AMP * (SS(JJ,IP) - DEL*(SS(JJ, IP) 1 - S S ( J J - l . I P ) ) ) IF (DEL.LE.0.0) RW(J) = RS(J) - AMP * (SS(JJ,IP) - DEL*(SS(JJ+1, I P 1 ) - SS(JJ,IP))) 259 CONTINUE IF (KK.EQ.3) GO TO 275 IF (KK.EQ.4) GO TO 276 IF (K.LT.2) IEND = 0 260 IF (K.LT.50) GO TO 250 261 WRITE (6,160) WORD(KK) 160 FORMAT (///,A8,« RUN-THRU OF BLENDED PORTION',///) WRITE (6,171) 171 FORMAT (' + ' ,T30,'AMPLITUDE' ,T45,'POSIT ION',T70,'AMPLITUDE',T85, 1 'POSITION',/) IF (K/2*2.EQ.K) GO TO 425 K = K + 1 P(K) = P(K-2) HT(K) = HT(K-2) S = SQT SQT = SQL SQL = S 425 DO 262 J = 1, K, 2 WRITE (6,172) H T ( J ) , P ( J ) , H T ( J + l ) , P ( J + l ) 262 CONTINUE 172 FORMAT (30X,F8 .4,6X ,F8.4,18X,F8.4 ,6X ,F8.4) WL(1) = WLAMDA(P(K-1)) WL( 2) = WLAMDA ( P ( K) ) WRITE (6,161) WL(1),WL(2) 161 FORMAT (/' WAVELENGTHS', 2(30X,F10.3),/) NI = 1 + 3*LL + KK - 2*LL*KK N2 = 5 - NI IF (KJL.NE.5) GO TO 290 NI = KK N2 = 3 - NI 290 WRITE (6,162) NI, N2 162 FORMAT (• CORRESPONDING STANDARD PROFILES:',T47,'#',I2,T87,,12) IF (KK.EQ.2) GO TO 267 JK = LW(1) JL = LW(2) GO TO 268 267 JK = LW(2) JL = LW(1) 268 AMK = SQL AMP = SQT 266 SG( 1) = SQRT ( AMK/JK) SG(2) = SQRT (AMP/JL) SG (2+KK) = SQRT (SG(1)**2 + SG(2)**2) WRITE (6,163) AMK,JK,SG( 1),AMP,JL,SG(2) ,SG(2 + KK) 163 FORMAT (/» GOODNESS OF FIT CRITERIA',/• SUMSQRS NPTS ST DEV , 1 T30,F10.6,I5,F10.6,T70,F10.6,15,F10.6,/' TOT ST DEV =',F10.6,//) IF (KK.NE.2) GO TO 510 IF (ABS(P(K.-POO).GT.l.O .OR. ABS( P ( K-l )-P OT ) . GT . 1. 0) GO TO 510 IF (KLJ.EQ.l) GO TO 511 PKK = POO IF (HEO.GT.HET) PKK = POT H = HEO HEO = HET HET = H KL J = 1 WRITE (6,176) 176 FORMAT (/' STANDARD PROFILES SELF-REREVERSED - TRY AGAIN') GO TO 512 511 WRITE (6,175) 175 FORMAT (/• NO GO ON STANDARD-PROFILE POSITION REVERSAL - PREVIOU IS VALUES CORRECT',/) GO TO 270 510 DO 500 J = 1, 401 SUU) = SS(J,N1) SUU(J) = SS(J,N2) 500 CONTINUE POO = P(K-l) POT = P(K) HEO = HT(K-l) HET = HT(K) 502 IF (KK.LE.2) CALL FINEFT (RS,JX,IK,IL,SU,SUU,LW(N1),LW(N2),POO, 1 POT,HEO,HET,2) IF (KK.EQ.2) GO TO 270 271 C(2) = AM INI (POO,POT) C ( l ) = HEO IF (C(2) .EQ.POT) C(1) = HET C(4) = AMAX1 (POO,POT) C(3) = HEO 505 174 506 512 263 270 272 273 275 277 276 C(3) = HET IF (C(4).EQ.POO) LW(3) = 1 IF (POO.GT.POT) LW(3) = 2 IF (KK.EQ.2) LW(3) = 3 - LW(3) LW(4) = 3 - LW(3) WL(3) = C(2) - IFIX(C(2)) IF (WLO) .GT.0.5) WL(3) = 1.0 - WLO) WL(4) = C(4) - IFIX(C(4)) IF (WL(4).GT.0.5) WL(4) = 1.0 - WL(4) LA = JK IF (POT. LT. POO) LA = JL LB = JL IF (POT.LT.POO) LB = JK IF (KK.EQ.2) GO TO 272 S = 0.0 DO 505 J = 1, 401 S = S + ( S U ( J )°S U U ( J ) ) ** 2 CONTINUE IF (S.GT.1E-4) GO TO 506 WRITE (6,174) S FORMAT (/» BOTH STANDARD PROFILES IF (KJL.EQ.5) RETURN GO TO 272 PKK = POT IF (HEO.GT .HET) PKK = POO DELK = PKK - IFIX(PKK) IF (DELK.GT .0.5) DELK = 1.0 - DELK AMK = (HEO+HET) / 2.0 DO 263 J = 1, JX RW(J) = RS(J) CONTINUE KK = 2 GO TO 242 IF (KJL.EQ.5) RETURN IF (SG(4).LT.SG(3 )) GO TO 271 DO 273 J = 1, JX RW(J) = RR(J) RS(J) = RR(J) CONTINUE AMP = C(1) DEL = WL(3) JK = C(2) - DEL - LA/2 JL = JK + LA - 1 JM = 201 - LA/2 - JK IP = LW(3) KK = 3 GO TO 274 DO 277 J = 1, JX RS(J) = RW(J) CONTINUE AMP = C(3) DEL = WL(4) JK = C(4) - DEL - LB/2 JL = JK + LB - 1 JM = 201 - LB/2 - JK IP = LW(4) KK = 4 GO TO 274 IF (LL.EQ.2) GO TO 278 IDENTICAL SUMSQR =• ,G14. 7, /) DO 279 J = 1, 401 SS ( J , l ) = S K J ) 279 SS(J,2) = S4(J) LW(1) = LI LW(2) = L4 GO TO 281 278 DO 280 J = 1, 401 SS(J,1) = S2(J) 280 SS(J,2) = S3(J) LW(1) = L2 LW(2) = L3 281 IK = IA + LW(1) IL = POO KK = 3 GO TO 282 283 WL(1) = WLAMDA(PK) 'A(l) = AMP P ( 1) = PK SG(1) = STDEV IK = IL IL = IB - LW(2) KK = 4 GO TO 282 284 WL(2) = WLAMDA(PK) WRITE (6,165) A(l) ,AMP,P( 1),PK,WL( 1),WL(2) ,SG(1) ,STDEV 165 FORMAT (/// ' FINAL DATA ON OUTSIDE LINES1,//' AMPLITUDES',T21, 1 2F20.7,//' POSITIONS',T21,2F20.7,//• WAVELENGTHS',T21,2F20.7, 2 //• ST DEVS' ,T21 ,2F20.10,///) RETURN 300 DO 302 J = 1, JX RW(J) = RR(J) 302 RS( J) = RR( J ) IK = MAXO (IA, 1+M AX 0( L1, L2 ) ) IL = MINO ( IB,JX-MAXO(L1,L2)) LL = 2 KJL = 5 GO TO 400 304 DO 301 J = 1, 401 SS(J,1) = S K J ) 301 SS(J,2) = S2(J) LW(1) = LI LW(2) = L2 GO TO 243 END SUBROUTINE F I N E FT ( R R R , J X , I A , I B , S I , S 2 , L 1 , L 2 , P 1 , P 2 , H 1 , H 2 , N ) D IMENSION R R R ( 1 0 0 0 ) , S 1 ( 4 0 1 ) , S 2 ( 4 0 1 ) , V ( 4 ) , V A R ( 4 , 9 ) , D T ( 4 ) , P 0 ( 1 6 ) , 1 P L ( 4 ) R E A L * 8 R ( 1 0 0 0 ) , R R ( 1 0 0 0 ) , S S Q ( 8 1 ) , S , S M , Y ( 3 ) , D , D I F F , S S ( 4 ) , Q S X , Q S M J K L = 3 - N DO 325 J = 1 , JX R R ( J ) = D B L E ( R R R ( J ) ) 325 CONTINUE I I = MAXO ( I A , I F I X ( A M I N K P 1 - L 1 / 2 - 3 . P 2 - L 2 / 2 - 3 ) ) ) I J = MINO ( I B , I F I X ( A M A X l ( P l + L l / 2 + 3 , P 2 + L 2 / 2 + 3 ) ) ) IF ( N . E Q . l ) I I = MAXO ( I A , I F I X ( P 1 - L 1 / 2 - 3 ) ) IF ( N . E Q . l ) I J = MINO ( I B , I F I X ( P l + L l / 2 + 3 ) ) RINT = 1 . 0 337 KKK = - 2 IF ( R I N T . L T . O . 5 . O R . N . E Q . l ) KKK = -1 FAC = 1 .0 306 DO 3 0 0 J = 1 , 3 V A R ( 1 , J ) = P I + ( J - 2 . 0 ) * I A B S ( K K K ) * RINT * FAC V A R ( 2 , J ) = P2 + ( J - 2 . 0 ) * I A B S ( K K K ) * RINT * FAC V A R ( 3 , J ) = HI + 0 . 0 2 5 * ( J - 2 . 0 ) * I ABS ( K K K ) * RINT * FAC V A R ( 4 , J ) = H2 + 0 . 0 2 5 * ( J - 2 . 0 ) * I A B S ( K K K ) * RINT * FAC 300 CONTINUE KL IM = 81 GO TO 3 2 0 3 0 1 MS = 41 SM = SSQ(41 ) DO 3 0 2 J = 1 , 81 NK = ( J - 2 ) / 3 IF ( N . E Q . L A N D . ( . N O T . ( ( N K * 3 ) . E Q . J-2 . A N D . ( ( N K - 1 ) / 3 - 1 ) / 3 * 3 . EQ . 1 ( N K - 1 ) / 3 - D ) ) GO TO 302 IF ( S S Q ( J ) . G E . S M ) GO TO 302 MS = J SM = S S Q ( J ) 302 CONTINUE IF ( M S . E Q . 4 1 . A N D . K K K . E Q . - l . A N D . F A C . L T . O . 5 ) GO TO 303 IF ( M S . E Q . 4 1 . A N D . K K K . E Q . - l . A N D . F A C . G T . 0 . 5 ) FAC = 0 . 3 P I = VAR ( 1 , ( M S - 1 ) / 2 7 + 1 ) P2 = VAR ( 2 t ( M S - ( M S - l ) / 2 7 * 2 7 - l ) / 9 + l ) HI = VAR ( 3 , ( M S - ( M S - l ) / 9 * 9 - l ) / 3 + 1) H2 = VAR { 4 , M S - ( M S - l ) / 3 * 3 ) IF ( M S . E Q . 4 1 . A N D . K K K . E Q . - 2 ) KKK = -1 GO TO 306 303 KL IM = 9 311 KKK = 0 250 KKK = KKK + 1 DO 200 J = 1 , 9 VAR ( 1 , J ) = P I IF ( J . E Q . 2 ) V A R ( 1 , J ) = P I ESQ RINT IF ( J . E Q . 3 ) V A R ( 1 , J ) = P 1 + RINT V A R ( 2 , J ) = P2 IF ( J . E Q . 4 ) V A R ( 2 , J ) = P2 R INT IF ( J . E Q . 5 ) V A R ( 2 , J ) = P2 + RINT V A R ( 3 , J ) = HI IF ( J . E Q . 6 ) V A R ( 3 , J ) = HI C D 0 . 0 1 * RINT IF ( J . E Q . 7 ) V A R ( 3 , J ) = H 1 + 0 . 0 1 * RINT V A R ( 4 , J ) = H2 IF ( J . E Q . 8 ) V A R ( 4 , J ) = H2 0 . 0 1 * RINT IF ( J . E Q . 9 ) V A R ( 4 , J ) = H2 + 0 . 0 1 * RINT 200 CONTINUE 3 2 0 DO 210 K = 1, K L I M IF (N.NE.l .OR. KLIM.EQ.9) GO TO 321 NK = (K=>2) / 3 IF (N.EQ.LAND.(.NOT. ((NK*3).EQ.K-2 .AND. ((NK-1)/3-1)/3*3.EQ. 1 (NK-1) /3-D ) ) GO TO 210 321 DO 201 J = 1, JX R(J) = ODO 201 CONTINUE IF (KKK.GE.O) GO TO 209 V( 1) = VAR( 1, ( K-l) /27 + 1) V(2) = VAR( 2, (K-( K-l)/27'*27-l)/9+1) V(3) = VAR13, (K-(K-l)/9*9-l)/3+1) V(4) = VAR(4,K-(K-l)/3*3) GO TO 208 209 DO 202 J = 1,4 V(J) = VAR(J,K) 202 CONTINUE 208 DO 205 JL = 1, N IV = I F I X l V ( J L ) ) IM = MAXO ( I A+l, IV-2 00) IN = MINO (IB,IV+200) DEL = V(JL) - IV AMP = V(2+JL) DO 211 J = IM, IN J J = 2 0 1 - I V + J IF ( JL.EQ.2) GO TO 2 04 R(J) = DBLE (AMP * ( S K J J ) - DEL* ( S 1 ( J J ) - S 1 ( J J - l ) ) ) ) GO TO 211 204 R(J) = R(J) + DBLE(AMP*(S2(JJ)-DEL*(S2(JJ)-S2(JJ-1)))) 211 CONTINUE 205 CONTINUE S = ODO DO 207 J = I I , IJ S = S + ( R R ( J ) - R ( J ) ) * * 2 207 CONTINUE SSQ(K) = S 210 CONTINUE IF (KKK.LT.O) GO TO 301 IF (SSQ(1).LT.SSt2) .OR. KKK.LE.10) GO TO 310 IF (RINT.LE.0.011) GO TO 226 350 RINT = RINT / SQRT(IO.O) 331 PI = P0(9) P2 = P0(10) HI = P0( 11) H2 = P0(12) GO TO 337 310 SS(4) = SS(3) SS(3) = SS(2) SS( 2) = SS(1) SS(1) = SSQ(1) Y( 1) = SSQ(1) DO 220 JJ = 1, 4, JKL Y(2) = SSQ(2*JJ) Y(3) = SSQ(2*JJ+1) DIFF = DBLE(VAR(JJ,1)) - DBLE(VAR(JJ,2*JJ)) YM = DMIN1 (Y(1),Y(2),Y(3)) 227 IF ((Y(2)-2.0*Y(1)+Y(3)).EQ.O.O) GO TO 335 D = -0.5D0 * DIFF * (Y(2)-Y(3)) / ( Y ( 2)-2D0*Y ( 1)+Y { 3 ) ) IF(DABS(D).GT.DIFF) GO TO 335 GO TO 223 335 IF (DABS(YM=Y(2)).LE.1D-8) D = DIFF IF (DABS(YM-Y(3)).LE.lD-8) D = - DIFF IF ( D A B S C Y M » Y ( 1 ) ) . L E . 1 D - 8 ) D = ODO 223 DT(JJ) = D IF (JJ.EQ.l) P I = P I - D IF (J J .EQ .2) P2 = P2 ™ D IF (JJ.EQ.3) HI = HI - D IF (JJ.EQ.4) H2 = H2 - D 220 CONTINUE DO 330 J = 1, 4 P0(J+12) = POU+8) P0(J+8) = P0(J+4) PO (J+4) = PO(J) 330 CONTINUE P0( 1) = PI P0C2) = P2 P0(3) = HI P0(4) = H2 345 IF (KKK/4*4.NE.KKK) GO TO 340 DO 3 43 JJ = 1, N • LK = 0 DO 341 J = I t 9,8 DO 341 I = 5, 13, 8 LK = LK + 1 PL(LK) = POU+JJ-l) / PCHI + J J - l ) 341 CONTINUE DO 342 J = 2, 4 IF (PLCJ) -l.O.EQ.0.0) GO TO 342 IF ((PL(1)-1.0) / (PL ( J ) - l . O ) .LT. 0.0) GO TO 340 342 CONTINUE 343 CONTINUE PI = (P0(1) + P0(5)) / 2.0 P2 = (P0(2) + P0(6)) / 2.0 P0(1) = PI P0(2) = P2 340 CONTINUE IF (RINT.GT.0.2 .OR. KKK.LE.4) GO TO 346 QSX = DMAX1 (SS(1) ,SS(2),SS(3),SS(4)) QSM = DM IN 1 (SS(1),SS(2),SS(3),SS(4)) IF (QSX-QSM.GE.1D-7) GO TO 346 PX = AMAX1 (P0(1) ,P0(5),P0(9) ,P0( 13) ) PM = AMIN1 (P0{1),P0(5),P0(9),P0(13)) IF (PX-PM.GE.2.5E-4) GO TO 346 IF (N.EQ.l) GO TO 226 PX = AMAX1 (P0(2) ,P0(6),P0( 10) ,P0(14)) PM = AMIN1 (P0(2),P0(6),P0(10),P0(14)) IF (PX-PM.GE.2.5E-4) GO TO 346 GO TO 226 346 CONTINUE 228 IF (KKK.LT.30) GO TO 250 IF (RINT .GT.0.05) GO TO 350 226 WRITE (6,150) P1,H1,P2,H2 150 FORMAT (///» FINAL VALUES FROM FINEFT:',//' P0S1 = « , F 1 0 . 4 , 5 X , 1 'AMP1 = • ,F10.4, 15X, ' P0S2 = • , F 10 .4 , 5X, • AMP 2 =',F10.4) QSX = WLAMDA (PI) QSM = WLAMDA (P2) WRITE (6,156) QSX,QSM 156 FORMAT (/• WAVELENGTHS',T20,F10.3,T72,F10.3) WRITE (6,155) N, RINT 155 FORMAT (/• NUMBER OF LINES FITTED =' ,13,5X,1 LAST BRACKETTING USEO 1= RINT = • ,F7.3) STDEV = DSQRT (SSQ(1)/(IJ-I I)) NP = IJ-II+1 WRITE (6,151) SSQ(1),NP,STDEV 151 FORMAT (//• FIT CRITERIA:1,5X,1SUMSQR = • , G 1 6 . 7 , 5 X , » N P T S = » , I 4 , 5 X , 1 • ST DEV = • ,G17.8) WRITE (6,152) DT 152 FORMAT (/« LAST CALCULATED CORRECTIONS: » , 5 X , 4 F 1 0 . 4 ) IF (N.EQ.l) H2 = STDEV RETURN END FUNCTION WLAMDA (P) DIMENSION R(7) LOGICAL LFAY COMMON /SKALE/ R,SH,IW /LOG/ LFAY IF (.NOT.LFAY) WLAMDA = P IF (.NOT.LFAY) RETURN X = P - SH/2.0 IF (IW.NE.O) GO TO 26 WLAMDA = R(l) + R{ 2)/(X+R(3) ) + R K ) + R(5)*X + R(6)*X**2 + 1 R(7)*X**3 RETURN 26 WLAMDA = 0.0 DO 27 J = 1, 5 WLAMDA = WLAMDA + R(J) * X**(J-1) 27 CONTINUE RETURN END FUNCTION LOCAT(WL) LOGICAL LFAY COMMON /LOG/ LFAY IF (.NOT.LFAY) LOCAT = IFIX(WL) IF (.NOT.LFAY) RETURN WB = WLAMDA(1.0) WA = WLAMDAt300.0) POSN = 300.0 * (WL-WB) / (WA-WB) PP = 300.0 26 DO 27 J = 1, 50 WB = WA WA = WLAMDA(POSN) PPP = PP PP = POSN POSN = PPP + (PP-PPP) * (WL-WB) / (WA-WB) IF (ABS(POSN-PP).LT.5.0) GO TO 28 27 CONTINUE GO TO 26 28 LOCAT = IFIX (POSN) RETURN END SUBROUTINE FITPIK (Y,N,PK,IOK) DIMENSION Y(15),XX(4),XY(3),P(5) IF ( (N.LT.3) .OR. IOK = 1 DO 2 I = 1, 3 XX( I) = 0.0 XY(I) = 0.0 CONTINUE XX(4) = 0.0 DO 3 I = 1, N XX ( 1) = XX(1) XX( 2) = XX( 2) XX(3) = XX(3) XX(4) = XX(4) XY(1) = XY(1) XY(2) = XY(2) XY(3) = XY(3) CONTINUE P ( 1) = XX( 1) = XX( 1) = N N N = -XY(1) * = +XY( 1) * (ABS(A2) = - 0.5 (N.GT.15)) GO TO 99 FLOAT(I) FLOAT!1**2) FLOAT(1**3) FLOAT!1**4) Y( I ) Y d ) Y( I ) F LOAT( I) F LOAT(I * •2) P (2) P(3) P (4) P(5) A l =A2 IF PK IF IF * X X(4) - X X(2) * XX(3) - XX(2) * XX(4) - XX(2) * XX (3) - X X ( 1) * X X ( 2 ) - XX(1) P( 1) + XY(2) * P(2) - XY(2) * LT.O.0001) GO TO Al / A2 ({PK.LT.N/2.0-0.5).OR.(PK.GT.N/2.0+1.5)) (IOK.EQ.O) WRITE (6,150) XX(3 ) XX(2) * XX(2) * XX(2) * XX(1) P(3) - XY(3) P(4) + XY(3) 99 P ( 4) P( 5) IOK = 0 150 FORMAT (//' IN FITPIK RETURN 99 IOK = 0 PK = FL0AT(N/2+l) WRITE (6,150) RETURN END IOK=0 CONTINUING',//) FUNCTION AUX (P,D,X,L) DIMENSION P(50),D(50) COMMON /AX/ MDIM D(l) = 1.0 AUX = P(1) DO 1 J = 2, MDIM D( J) = D( J - l ) * X 1 AUX = AUX + P(J) * D(J) RETURN END DIMENSION S ( 4 0 1 ) , T ( 4 0 1 ) , P(IOOO), SIG ( 5,7 ) , PO( 5 ) ,HW( 7) 1 ,X (5) ,PF(5) ,W(5) , E 1 ( 3 ) , E 2 ( 3 ) , C ( 5 ) , S A ( 7 ) DATA X / l . 0 , 2 . 0 , 3 . 0 , 4 . 0 , 5 . 0 / C C * * * PROGRAM T I T L E : BETFIT C r THIS PROGRAM TRIES TO FIND A BETTER F I T T I N G PROFILE TO A SET OF DAT/ C *** THE EXISTING PROFILE BY TRYING A RANGE OF POSITIONS AND HALF-WIDTHS. C *** INPUT CONSISTS OF FIRST THE IDCODE OF THE BASE PROFILE AND THE ORD E C *** SECOND THE LENGTH OF THE DATA, THE DATA I T S E L F , AND THE BEST F I T POS C *** PLUS AMPLITUDE AND THE RANGE TO LOOK IN. C *** OUTPUT CONSISTS OF PRINTED VALUES OF THE STANDARD•DEVI AT ION OF THE F C *** FOR THE RANGES OF POSITION AND WIDTHS . C READ (5,100) IDCODE, NUM 100 FORMAT (2110) IF (NUM.LE.O .OR. NUM.GT.4) NUM = 1 DO 200 J = 1, 100 CALL SKIP ( 1 , 0 , 0 ) READ (0) ID IF ( ID. EQ. IDCODE) GO TO 201 IF (ID.EQ.999999) GO TO 202 200 CONTINUE 202 WRITE (6,150) IDCODE 150 FORMAT (/» CAN''T FIND IDCODE•,I 10,20X, •PUNCHING DATA') GO TO 211 . 201 DO 203 J = 1, NUM READ (0) N,L,A READ (0) S 203 CONTINUE DO 204 J = 202, 401 IF ( S ( J ) .LE.0.5) GO TO 205 204 CONTINUE 205 HWOLD = 2.0 * ( ( J-201) + ( 0.5-SC J - l ) )/( S( J) -S( J - l ) ) ) DO 206 J = 202, 401 IF { S ( J ) .LE.O.O) GO TO 207 206 CONTINUE 207 L = 2 * ( J - 2 0 1 ) - 1 210 READ (2,101) JX 101 FORMAT (15) READ (2,102) ( P ( J ) , J=1,JX) 102 FORMAT (10F8.4) READ (2,103) POS,AMP , I A, I B 103 FORMAT (2F20.5,21 10) REWIND 0 IF (ID.EQ.999999) GO TO 211 JA = MAXO(IA,IFIX(POS-L/2+1.0)) J B = M I N O lIB,IFIX(POS+L/2-1.0)) DO 220 IH = 7,13 HWNEW = 0.1 * IH * HWOLD HW(IH-6) = HWNEW CALL SQZ(S,T,HWOLD,HWNEW) DO 221 1 = 1 , 5 PS = POS + (1-3) * 0.75 P 0 ( I ) = PS DEL = 1.0 - (PS-IFIX(PS)) SQ = 0.0 J L = 200 - I F I X ( P S ) DO 222 J = JA, JB J J L = J + J L SQ = SQ + (P(J) - AMP*(T(JJL)+DEL*(T{JJL+1)-T(JJL))))**2 222 CONTINUE SIG(I,IH-6) = SQRT (SQ/(JB-JA)) 221 CONTINUE 220 CONTINUE WRITE (6,151) IDCODE, NUM, HW 151 FORMAT ( •1IDC0DE' , I 10,5X,'PROFILE #' ,13,//,T61,•HALF WIDTHS' 1 T18,7F15.3,/) WRITE (6,152) (P O ( J ) , ( S I G ( J , I ) , 1=1,7), J=l,5) 152 FORMAT (• P •,F9.4,10X,7G15.7) EXTERNAL AUX DO 230 JJ = 1, 7 DO 231 J = 1, 5 PO(J) = SIG(J,JJ) C(J) = 0.0 231 CONTINUE CALL LQF (X,P0,PF,W,E1,E2,C,0.0,5,3,1,ND,0.1,AUX) SQ = -C(2) / (2.0*C(3)) SA(JJ) = C( 1)+C(2)*SQ+C(3)*SQ**2 230 CONTINUE WRITE (6,154) SA 154 FORMAT (/' M I N « , T 2 3 , 7 G 1 5 . 7 ) STOP 211 WRITE (8,101) JX WRITE (8,102) ( P ( J ) , J=1,JX) WRITE (8,103) POS,AMP,IA,IB REWIND 0 STOP END SUBROUTINE SQZ {S,T,HWOLD,HWNEW) DIMENSION S(401),T(401) F = HWOLD / HWNEW DO 200 J = 201, 401 FJ = 201.0 + F * ( J-201) T(J) = S(FJ) + (FJ-IFIX(FJ) ) * (SIFJ+l.O)-S( FJ) ) IF (T (J) .LE.O.O) GO TO 201 200 CONTINUE J = 401 201 DO 202 JJ = J , 401 202 T(J) = 0.0 DO 203 J = 1, 200 203 T(J) = T(402-J) RETURN END DIMENSION S H 4 0 1 ) , S 0 ( 4 0 1 ) C C * * * PROGRAM T I T L E : EDITOR C C * * * THIS PROGRAM WILL NARROW OR EXPAND THE HORIZONTAL SCALE OF A L I N E PF C * * * IT READS IN THE INPUT AND OUTPUT IDENTIFICATION CODES AND THE OUTPU1 C * * * HALFWIDTH. INPUT TAPE IS 0, OUTPUT TAPE IS 1, INTERMEDIATE F I L E IS C *** NO INFORMATION IS DELETED. THE ALTERED PROFILE I S STORED IMMED IATEL C * * * AFTER THE INPUT PROFILE ON THE TAPE. C INTEGER*2 PAR 1(13) /24,•FILES=1,NOREW,COPYERRORS'/, 1 PAR2I9) /16,'NOREW,COPYERRORS»/ READ (5,100) IDIN, IDOUT 100 FORMAT (2110) END F I L E 1 CALL SKIP ( 1 , 0 , 0 ) DO 200 J = 1, 100 READ (0) IDCODE IF (IDCODE.EQ.IDIN) GO TO 201 IF (IDCODE.EQ.999999) GO TO 202 CALL SKIP (0,-1,0) CALL TAPCPY(PARI) 200 CONTINUE 201 WRITE (6,150) IDIN 150 FORMAT (/• GOT I T ' , 110) GO TO 203 202 WRITE ( 6 , 151) IDIN 151 FORMAT (//' NO GO ON ', 110) CALL SKIP (0,-1,0) GO TO 231 203 WRITE (1) IDCODE DO 220 1 = 1 , 4 READ (0) N , L , A WRITE ( 1 ) N,L,A READ (0) SI WRITE ( 1 ) SI READ (5,101,END=205) HWIDTH 101 FORMAT (F10.5) 205 IF (HWIDTH.LE.0.0) HWIDTH = 1 . 0 IF ( S I ( 2 0 1 ) .LE.O. 1) F = 1.0 IF ( S K 201) .LE.O.1) GO TO 232 DO 222 J = 202, 401 IF ( S K J ) . L E . O . 5 ) GO TO 223 222 CONTINUE 223 F = 2.0 * ( ( J - 2 0 1 ) + ( 0 . 5-SI ( J - l ) ) / ( SI ( J) -SI ( J - l ) ) ) / HW IDT H IF (HWIDTH.LE.1.1 ) F = 1.0 232 DO 225 J = 201, 401 F J = 201.0 + F * ( J - 2 0 1 ) S O U ) = S K F J ) + ( F J - I F I X ( F J ) ) * < SI ( F J + 1.0)-SI ( FJ) ) IF ( S O ( J ) . L E . O . O ) GO TO 226 225 CONTINUE J = 401 226 DO 227 J J = J , 401 227 S O U ) = 0.0 DO 228 J = 1, 200 228 S O ( J ) = S 0 ( 4 0 2 - J ) L = L/F WRITE (3) N,L , A WRITE (3) SO WRITE (6,152) I,HWIDTH,F 152 FORMAT (/' PROFILE # ' , I 3, 1 0 X , » N E W HALF-WIDTH• , F 1 0 . 4 , 5 X , « M U L T FACT 0 1 R « , F 1 0 . 4 ) 220 CONTINUE CALL SKIP (1,0,0) END FILE 1 REWIND 3 WRITE (1) IDOUT WRITE (6,153) IDOUT 153 FORMAT (/' NEW IDCODE =',I10) DO 230 1 = 1 , 4 READ (3) N , L , A READ (3) SO WRITE (1) N,L , A WRITE (1) SO 230 CONTINUE END FILE 1 231 CALL TAPCPY (PAR2) REWIND 0 REWIND 1 STOP END INTEGER*2 PAR1(13)/24,•FILES=1,NOREW,COPYERRORS•/, 1 PAR2(9)/16,'NORE W•COPYERRORS 1/ C C PROGRAM TITLE: RUBOUT C C * * * THIS PROGRAM WILL DELETE THE FILE STARTING WITH A SPECIFIED IDCODE F C * * * THE MAG TAPES. TAPES ON DEVICES 0 & 1 REQUIRED. DEVICE 1 RING IN. C READ (5,100) IDCODE 100 FORMAT (110) CALL SKIP (1,0,0) END FILE 1 DO 200 J = 1, 100 READ (0) IDNO IF (IDNO.EQ.IDCODE) GO TO 201 IF (IDNO.EQ.999999) GO TO 202 CALL SKIP (0,-1,0) CALL TAPCPY(PARl) 200 CONTINUE 202 WRITE (6,150) IDCODE 150 FORMAT (/' C A N « ' T FIND IDCODE =',I10) CALL SKIP ( 0,-1,0) GO TO 299 201 CALL SKIP ( 1,0,0) WRITE (6,151) IDNO 151 FORMAT (/' FILE IDCODE ',110,' DELETED') 299 CALL TAPCPY (PAR2) REWIND 0 REWIND 1 STOP END 

Cite

Citation Scheme:

        

Citations by CSL (citeproc-js)

Usage Statistics

Share

Embed

Customize your widget with the following options, then copy and paste the code below into the HTML of your page to embed this item in your website.
                        
                            <div id="ubcOpenCollectionsWidgetDisplay">
                            <script id="ubcOpenCollectionsWidget"
                            src="{[{embed.src}]}"
                            data-item="{[{embed.item}]}"
                            data-collection="{[{embed.collection}]}"
                            data-metadata="{[{embed.showMetadata}]}"
                            data-width="{[{embed.width}]}"
                            data-media="{[{embed.selectedMedia}]}"
                            async >
                            </script>
                            </div>
                        
                    
IIIF logo Our image viewer uses the IIIF 2.0 standard. To load this item in other compatible viewers, use this url:
https://iiif.library.ubc.ca/presentation/dsp.831.1-0053443/manifest

Comment

Related Items