"

                ***************************             NOTE implication of
                *                         *              ||  NOGENERATE versus
                *  COMPILER INSTRUCTIONS  *              ||  GENERATE def'ns.
                *                         *              ||
                ***************************             \||/
         (These only in/exclude MORTRAN statements       \/
              so beware of percent-F code sections!)
"
%'/IRAF_CODE/'='GENERATE'               " This version IRAF "
%'/IRAF_END/'='ENDGENERATE'
%'/FIGARO_CODE/'='NOGENERATE'               " This version is not FIGARO "
%'/FIGARO_END/'='ENDGENERATE'

%'/UNIX_CODE/'='GENERATE'               " This version UNIX "
%'/UNIX_END/'='ENDGENERATE'
%'/VMS_CODE/'='NOGENERATE'                  " This version is not VMS "
%'/VMS_END/'='ENDGENERATE'

%'/TEK_CODE/'='NOGENERATE'                " This version TEK plots "
%'/TEK_END/'='ENDGENERATE'
%'/PGP_CODE/'='GENERATE'                  " This version is not PGPLOT "
%'/PGP_END/'='ENDGENERATE'
"

                **************************
                *                        *
                *  CHANGEABLE VARIABLES  *
                *                        *
                **************************

"
%'MAX LINES'='500'
%'MAX DIODE'='10000'
%'MAX CONT'='1000'
%'MAX WIDTH'='40'
%'MAX_PLOT'='300'      "max. number of plot windows allowed "
%'NTEKPTS'='1024'
%'MAXSEP'='6.0D+00'    "max. pix separation between predicted and measured wave"
%'MINSEP'='2.0D+00'     "min. pixel separation for independent lines in blend"

/UNIX_CODE/;
%'FPMINVAL'='1.0D-33'   "constants near the floating point limits of machine"
%'FPMAXVAL'='1.0D+33'   "ditto"
/UNIX_END/;
/VMS_CODE/;
%'FPMINVAL'='1.0D-33'
%'FPMAXVAL'='1.0D+33'
/VMS_END/;
"

                  **********************
                  *                    *
                  *  MISC. VARIABLES   *
                  *                    *
                  **********************

"
%'NUMBER OF LINES'='NOLINES'
%'NO OF REF LINES'='NORFLN'
%'NUMBER OF GOOD LINES'='NOGDLN'
%'LEFT LIMIT'='LFTLIM'
%'RIGHT LIMIT'='RHTLIM'
%'TELLURIC FLAG'='TELFLAG'
%'POSITION'='POSN'
%'CHI_ARRAY'='CHIRAY'
%'OCHI_RATIO'='OCHIRAT'
%'CHI_RATIO'='CHIRAT'
"


                 ********************
                 *                  *
                 *     FUNCTIONS    *
                 *                  *
                 ********************


"
%'CONTINUUM'='CONTUM'
%'CONTINUUM IS OUT OF ORDER'='CNTIOO'
%'BAD DIODE'='BADIOD'
%'TELLURIC DIODE'='TELDIOD'
%'TELLURIC LINES INTERFERE WITH SPECTRUM'='TLINWS'
%'CONTINUUM IS BAD'='CNTBAD'
%'NO TURNOVER'='NOTURN'
%'RIGHT WING BLENDED'='RHTWGB'
%'LEFT WING BLENDED'='LFTWGB'
%'BAD PLOT'='BADPLT'
%'LINE IS OUT OF BOUNDS'='LNOOBD'
%'LINE IS WIDE'='LINIWD'
%'POINT DIODE'='CALL PNT'
%'POINT IS INCONSISTENT'='PTIINC'
%'DEPTH IS TOO LARGE'='DEPTOL'
%'LINE ABSENT'='LNABST'
%'LINE IS TO BE REDONE'='LNITBR'
%'CONTINUUM_UNCERTAINTY'='CNTUNC'
"
              ******************************
              *                            *
              *  MACROS FOR PROGRAM WIDTH  *
              *                            *
              ******************************
"
"
First are the reduction-package-dependent routines:
"
/IRAF_CODE/;
%'INITIALISE PROGRAM'='CALL INITPG'
%'READ HEADER INFO'='CALL RDHDIF'
%'PROMPT FOR STARTING SPEC AND STEP'='CALL PTSSAS'
%'READ SPECTRUM'='CALL RDSPEC'
/IRAF_END/;
/FIGARO_CODE/;
%'READ SPECTRUM'='CALL FIG_RDSPEC'
/FIGARO_END/;

%'READ EQUISPEC WAVELENGTHS'='CALL RDEQWV'
%'READ WCS WAVELENGTHS'='CALL RDWCSWV'
%'GET_WAT2_CARDS'='CALL GTWATC'
%'GET_WAVELENGTH_PARAMS'='CALL GETWVP'
%'SET_SPECID'='CALL SETSPECID'
%'CHECK_WAV_PARAMS'='CALL CKWVP'

%'MEASURE ALL LINES'='CALL MEASALN'
%'REMEASURE LINES'='CALL RMEASLN'
%'CROSS CORRELATE'='CALL CROSS'
%'SET UP CROSS CORRELATION PLOT FILE'='CALL SUCCPF'
%'MEASURE GOOD LINES'='CALL MEGDLN'
%'MAKE CONTINUUM FITS'='CALL MKCNFTS'
%'QUICK CONTINUUM FITS'='CALL QKCNFT'
%'READ GOOD LINES ONLY'='CALL RDGDLO'
%'READ CURRENT CONTINUUM'='CALL RDCUCT'
%'COMPUTE CONTINUUM CENTRES AND FLUX VALUES'='CALL CCCAFV'
%'MEASURE LINES IN CURRENT ORDER'='CALL MLICUO'
%'READ LINE AND CONTINUUM LISTS'='CALL RDLNCL'
%'SORT CONTINUUM'='CALL SORTCON';
%'GRAB_COEFFS'='CALL GRABCOF'
%'CHECK FOR BLENDS'='CALL CKFRBL';
%'FIND RV'='CALL RADIALV'
%'REMOVE RV REF'='CALL RMRVRF'
%'COMPUTE NEW RV AND SIGMA'='CALL CMNRVAS'
%'COMPUTE LINE RV'='CALL CMLINRV'
%'COMPUTE DELTA EW'='CALL CPDELE'
%'FIND ORDER'='CALL FNDORD'
%'GET STD LINE MINIMUM'='CALL GTSTDMIN'
%'GET MINIMUM'='CALL GETMIN'
%'GET MEDIAN'='CALL GTMEDN'
%'CHANGE PLOT BOUNDS'='CALL CHGPLBU'
%'READ TELLURIC PARAMETERS'='CALL READTP'
%'PRODUCE H2O LINE FILE'='CALL PRHLFL'
%'NORMALISE TELLURIC SPECTRUM'='CALL NORTEL'
%'CORRECT TELLURIC BOUNDS'='CALL CORTELB'
%'MERGE TELLURIC LINES INTO LINELIST'='CALL MLTILL'
%'INSERT BEFORE LINE'='CALL INSBFL'
%'SCALE TELLURIC LINES'='CALL SCALTL'
%'REMOVE BAD FACTORS'='CALL REMBDF'
%'SORT FACTOR LIST'='CALL SRTFCL'
%'REMOVE FACTOR'='CALL REMFAC'
%'DIVIDE TELLURIC LINES OUT'='CALL DIVTEL'
%'REMOVE TELLURIC LINES FROM LIST'='CALL RMTLFL'
%'FIT CONTINUUM'='CALL FITCONT'
%'LOWER CONTINUUM'='CALL LOWRCNT'
%'GET NUMBER OF SIGMA'='CALL GETNSIG'
%'FIND CENTRAL DIODE NUMBER AND DEPTH'='CALL FCDNAD'
%'REMOVE LINE FROM GOOD LIST'='CALL RMLFGL'
%'DETERMINE LIMIT'='CALL DETLIM'
%'OBTAIN FWHM'='CALL OBFWHML'
%'DETERMINE SIGMA AND ERROR'='CALL DETSAE'
%'TEST HALF LINE'='CALL TSTHLN'
%'GET 3 SIGMA CHISQ'='CALL G3SIGCH'
%'COMPUTE DEGREES OF FREEDOM'='CALL COMDGFR'
%'FIT SINGLE GAUSSIAN'='CALL FT1GAUS'
%'FIT DOUBLE GAUSSIAN'='CALL FT2GAUS'
%'FIT TRIPLE GAUSSIAN'='CALL FT3GAUS'
%'FIND TRIPLE LINE BOUNDS'='CALL FN3LBD'
%'FIND DOUBLE LINE BOUNDS'='CALL FN2LBD'
%'SET MULTIPLE GAUSSIAN SWITCH'='CALL SMGSWI'
%'CHECK LINE QUALITY'='CALL CHKLQY'
%'SET BAD GAUSSIAN SWITCHES'='CALL STBDGS'
%'GET BEST FWHM'='CALL GTBSFW'
%'FIND BROAD LINES'='CALL FNBRDLN'
%'REFIT BROAD LINE WITH FIXED FWHM'='CALL RBLWFF'
%'OBTAIN FIXED FWHM BOUNDS'='CALL OBFFWBS'
%'FIT WEAK LINES'='CALL FITWKL'
%'SINGLE FIT TO BAD LINES'='CALL SFTBLS'
%'GUESS LINE CENTRE'='CALL GUESLC'
%'FIRST GUESS FOR A VALUES'='CALL FRGUAV'
%'TEST SET LIMIT'='CALL TSETLM'
%'SET UP POINTS'='CALL SETUPTS'
%'FIT BLEND'='CALL FTBLND'
%'FIT BLENDED LINES'='CALL FTBLIN'
%'REDO LINES'='CALL RDOLIN'
%'FIND REDO LINE'='CALL FNDRDL'
%'FIND START AND END OF BLEND'='CALL FNDSAE'
%'DETERMINE WIDTH TO DEPTH RELATION'='CALL DETWTD'
%'DETERMINE MEAN FWHM'='CALL DMNFWH'
%'DISCARD BAD WIDTHS'='CALL DISBDW'
%'MINSUM WIDTH TO DEPTH RELATION'='CALL MINWTD'
%'GET DEPTH'='CALL GETDEPT'
%'FIND DEPTH OF SMALLEST GOOD LINE'='CALL FNDSGL'
%'FIT DISPERSION CURVE'='CALL FITDSP'
%'MEASURE EQUIVALENT WIDTH'='CALL MEASEW'
%'PRODUCE FWHM-DEPTH PLOT FILE'='CALL PFWDPF'
%'PRODUCE MOOG INPUT FILE'='CALL PRDMIF'
%'WRITE HEADERS'='CALL WRHDRS'
%'PRODUCE SPECTRUM PLOT FILE'='CALL PRSPPF'
%'DETERMINE PLOT BOUNDS'='CALL DETPLB'
%'PRINT HEADER INFO FOR PLOT'='CALL PHINFP'
%'PRINT FLUXS'='CALL PRNTFX'
%'PRINT CONTINUUM'='CALL PRNTCN'
%'PRINT LINE FLUXS'='CALL PRTLNF'
%'GET LINE BOUNDS'='CALL GETLNB'
%'EVALUATE LINE FLUX'='CALL EVALNF'
%'PRINT POINT'='CALL PRNTPT'
%'FINISH UP'='CALL FINSH'
%'CLOSE FILES'='CALL CLSFILS'
%'EXTRAPOLATE'='CALL POLATE'
%'INTERPOLATE'='CALL POLATE'
%'READ FLAGS'='CALL READFLG'
%'READ REFERENCE LINES & GET DISPERSION'='CALL RRLAGD'
%'CORRECT CONTINUUM LIMITS'='CALL CORCNL'
%'REMOVE CONTINUUM POINT'='CALL REMCTP'
%'ESTIMATE LINE CENTRES'='CALL ESLNCT'
%'ESTIMATE AND CHECK LINE CENTRES'='CALL EACKLC'
%'REMOVE FROM LIST'='CALL REMFLS'
%'SET FLAGS'='CALL SETFLG'
%'PERFORM FIT'='CALL PERFIT'
%'FIT PARABOLA'='CALL PARABOL'
%'FIT LINE'='CALL FITLINE'
%'AVERAGE'='CALL AVRGE'
%'FIND NEAREST CONTINUA'='CALL FNDCNT'
%'POLYNOMIAL FIT'='CALL POLYLIN'
"

           ******************************
           *                            *
           *   SCREEN PLOTTING MACROS   *
           *                            *
           ******************************

"
%'PERFORM TEKTRONIXS SCREEN PLOTTING'='CALL PTSCPL'
%'PLOT WINDOW IS IN SPECTRUM'='PLWIISP'
%'LEAF THROUGH SPECTRUM'='CALL LFTSPC'
%'PLOT SPECTRUM ON SCREEN'='CALL PLTSCR'
%'DISPLAY LINES TO USER'='CALL DSPLUS'
%'MARK LINES'='CALL MRKLIN'
%'PUT LINE LABEL'='CALL PTLINL'
%'SET TERMINAL WINDOW'='CALL SETWIN'
%'SET DATA WINDOW'='CALL SEDWIN'
%'OVERPLOT DATA'='CALL OVRPDAT'
%'PLOT CONTINUUM'='CALL PLTCTM'
%'FIND MINIMUM'='CALL FNDMIN'
%'FIND MAXIMUM DATA'='CALL FNDMAD'
%'FIND MAXIMUM CONTINUUM'='CALL FDMXCT'
%'DELETE CONTINUUM'='CALL DELCNT'
%'ADD CONTINUUM'='CALL ADDCT'
%'SINGLE CONTINUUM FLUX'='CALL SINGLE_CONTINUUM_FLUX'
%'REPLACE CONTINUUM'='CALL REPLCT'
%'DISPLAY CONTINUUM REGIONS ON PAGE'='CALL DCRONP'
%'PLOT DATA ARRAY'='CALL PLDTAY'
%'CONTINUUM PLOT'='CALL CONPLT'
%'REPLOT CONTINUUM'='CALL RPLTCT'
%'FIND CONTINUUM'='CALL FINDCT'
%'CONTINUUM FIT'='CALL CONFIT'
%'DOT TO DOT'='CALL DTTODT'
%'PLOT FULL SPECTRUM'='CALL PLFLSP'
%'OUTPUT CURRENT LINE FLUX'='CALL OPCRLF'
%'INTERACT WITH USER'='CALL INTUSR'
%'DISPLAY PROMPT'='CALL DISPRM'
%'BLOWUP SCREEN'='CALL BLOWUP'
%'PLOT NEXT LINE'='CALL PLNXTL'
%'PLOT LAST LINE'='CALL PLLSTL'
%'ZERO PLOT'='CALL ZROPLT'
%'OPEN SYNTHESIS FILE'='CALL OPSYNF'
%'PLOT SYNTHESIS'='CALL PLTSYN'
%'REPLOT SYNTHESES'='CALL REPSYN'
%'MEASURE FEATURE'='CALL MEASFET'
%'INTEGRATE'='CALL INTEGRT'
%'AGAIN'='CALL AGAN'
%'REJECT LINE'='CALL REJECT'
%'INTERACTIVE SINGLE GAUSSIAN'='CALL INSNGS'
%'INTERACTIVE MULTIPLE GAUSSIAN'='CALL INMLGS'
%'FIND LINE'='CALL FINDLN'
%'PROMPT FOR BOUNDS'='CALL PRMBOU'
%'PROMPT FOR CENTRE AND DEPTH'='CALL PRMCAD'
%'FIND SIGMA'='CALL FNDSIG'
%'REPLACE EW'='CALL REPLEW'
%'PLOT LINE FLUX'='CALL PLTLFX'
%'NUMBER OF PAGES'='NOPAGE'
"
 
          *********************************
          *                               *
          * PLOT PACKAGE DEPENDENT MACROS *
          *                               *
          *********************************


"
/TEK_CODE/;
%'SET SCREEN BOUNDS'='CALL TWINDO'
%'SET USER WINDOW'='CALL DWINDO'
%'PLOT AXES'='CALL PLAXES'
%'DRAW TICKMARKS'='CALL DRTICK'
%'LABEL AXES'='CALL LABAXS'
%'MOVE PEN TO USER'='CALL MOVEA'
%'DRAW TO USER'='CALL DRAWA'
%'ERASE SCREEN'='CALL NEWPAG'
%'FIND USER WINDOW BOUNDS'='CALL SEEDW'
%'MARK CURSOR POSITION'='CALL VCURSR'
%'PLOT PLUS'='CALL PLPLUS'
%'PLOT SMALL PLUS'='CALL PLSPLS'
%'PLOT BIG PLUS'='CALL PLTBGP'
%'PAPER COPY'='CALL PAPCPY'
%'INITIALISE COMMAND AREA'='CALL INCDAR'
/TEK_END/;

/PGP_CODE/;
%'SET SCREEN BOUNDS'='CALL PGP_TWINDO'
%'SET USER WINDOW'='CALL PGP_DWINDO'
%'DRAW PGPLOT BOX'='CALL PGP_BOX'
%'MOVE PEN TO USER'='CALL PGP_MOVEA'
%'DRAW TO USER'='CALL PGP_DRAWA'
%'ERASE SCREEN'='CALL PGPAGE'
%'FIND USER WINDOW BOUNDS'='CALL PGP_SEEDW'
%'MARK CURSOR POSITION'='CALL PGP_VCURSR'
%'PAPER COPY'='CALL PAPCPY'
%'INITIALISE COMMAND AREA'='CONTINUE'
/PGP_END/;
"

            ************************
            *                      *
            *   UTILITY MACROS     *
            *                      *
            ************************


"
%'GAUSS FIT'='CALL GAUSFT'
%'INITIALISE PARAMETERS'='CALL INITPA'
%'FIND NUMBER OF ZEROS'='CALL FNDZRO'
%'FIND DERIVATIVES'='CALL FNDERI'
%'GET EXPLICIT DERIVATIVES'='CALL GEXDER'
%'DETERMINE PHI'='CALL DETPHI'
%'FIND PARAMETER CORRECTIONS'='CALL FNDPCR'
%'CHECK FOR IMSL ERROR'='CALL CKFIME'
%'COMPUTE RESIDUALS'='CALL CMPRES'
%'FIND X CORRECTIONS'='CALL FNDXCR'
%'CORRECT PARAMETERS'='CALL CORPAR'
%'COMPUTE CHISQ'='CALL CMPCHI'
%'FINAL COVARIANCE MATRIX'='CALL FINCOVM'
%'SET VSINI'='CALL SETVSNI'


"   FUNCTIONS  "

%'GAUSS_PROF'='GAUSPRF'
%'ROT_PROF'='ROTPROF'


"   VARIABLES   "

%'CONVERGENCE'='CONVRG'
%'GAUSSIANS SWITCHED'='GASSWD'

"

            *************************
            *                       *
            *  COMMON BLOCK MACROS  *
            *                       *
            *************************


"
%'COMMON-BLOCK-LINES'='COMMON /LINID/LINEID;
                       CHARACTER*(10) LINEID(MAX LINES);
 COMMON /LINO/NUMBER OF LINES,NUMBER OF GOOD LINES,NO OF REF LINES,GOOD,NREDO,
              ILEFT,IRIGHT,BLEND;
  INTEGER NUMBER OF LINES,NUMBER OF GOOD LINES,NO OF REF LINES,GOOD(MAX LINES),
          ILEFT(MAX LINES),IRIGHT(MAX LINES),BLEND(MAX LINES),NREDO;
             COMMON /LSPEF/WAVELENGTH,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIMUM DEPTH,
         DELTA_RV,LEFT DIODE,RIGHT DIODE,INTERCEPT,SIGFWHM,SIGFRAC,DISP,OFFSET,
         PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM,REDO,LLIMIT,ULIMIT,DELTA_EW;
  REAL*8 MINIMUM DEPTH,WAVELENGTH(MAX LINES),FWHM(MAX LINES),CENTRE(MAX LINES),
          DELTA_RV(MAX LINES),DEPTH(MAX LINES),LEFT DIODE(MAX LINES),
          RIGHT DIODE(MAX LINES),
         EW(MAX LINES),INTERCEPT,SLOPE,SIGFWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET,
   REDO(100),GF(MAX LINES),EPLOW(MAX LINES),ATOM(MAX LINES),DISP1,DISP2,LLIMIT,
   ULIMIT, DELTA_EW(MAX LINES);
   COMMON/LOGLIN/WEAK(MAX LINES); LOGICAL WEAK;'


%'COMMON-BLOCK-WIDE'='COMMON/WIDLIN/WIDE(50);REAL*8 WIDE;
                      COMMON/IWIDLI/IWIDE;INTEGER IWIDE;'

%'COMMON-BLOCK-CONTINUUM'='COMMON /CBLK1/NOCONT,CONORD,
       CONTINUUM RIGHT,CONTINUUM LEFT,CONTINUUM SIZE;
       INTEGER NOCONT,CONTINUUM SIZE(MAX CONT),CONORD(100),
CONTINUUM RIGHT(MAX CONT),CONTINUUM LEFT(MAX CONT);
   COMMON/CBLK2/CONTINUUM FLUX,SIGMA FLUX,CONTINUUM CENTRE,ACON,CHI_SCALE;
    REAL*8 CONTINUUM FLUX(MAX CONT),SIGMA FLUX(MAX CONT),
           CONTINUUM CENTRE(MAX CONT),ACON(50,100),CHI_SCALE;
   COMMON/CBLK3/NORMALISED,AUTO CONTINUUM,FITCON,PLOTCON,OLD_CONTINUUM;
          LOGICAL NORMALISED,AUTO CONTINUUM,FITCON,PLOTCON,OLD_CONTINUUM;'

%'COMMON-BLOCK-ITERATE'='COMMON/ITRCOM/ DA(9),DX;  REAL*8 DA,DX;'

%'COMMON-BLOCK-ROTATION'='COMMON/ROTCOM/ VSINI;  REAL*8 VSINI;'

%'COMMON-BLOCK-IMAGE'='COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURRENT_IMAGE_ROW,
  NUMBER OF ORDERS,CURRENT ORDER,NUMBER OF SPECTRA,CURRENT SPECTRUM,
  SPEC_START,SPEC_STEP;
  INTEGER IM,IVM,NAXIS,AXLEN,CURRENT_IMAGE_ROW,NUMBER OF ORDERS,CURRENT ORDER,
  NUMBER OF SPECTRA,CURRENT SPECTRUM,SPEC_START,SPEC_STEP;
  COMMON/IRAFRL/W1(100),DW(100),PIX1(100);
  REAL*8 W1,DW,PIX1; COMMON/IRAFLO/VARIANCE_FILE; LOGICAL VARIANCE_FILE;'

%'COMMON-BLOCK-FOCUS'='COMMON/FOCUSL/FOCUS_PARS,GLOBAL_FOCUS;
                       LOGICAL FOCUS_PARS(100),GLOBAL_FOCUS;
                       COMMON/FOCUSR/WFC,A_FOCUS,GLOBAL_WFC,GLOBAL_A;
                       REAL*8 WFC(100),A_FOCUS(100,6),GLOBAL_WFC,GLOBAL_A(6);'


%'COMMON-BLOCK-SPECTRUM'='COMMON/SPBLK1/SPECTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV;
  REAL*8 SPECTRUM(MAX DIODE),VARSPEC(MAX DIODE),SN,LAMBDA(MAX DIODE),RV,SIGRV;
  COMMON /SPBLK2/SPTITLE,RFTITLE;CHARACTER*(18)SPTITLE,RFTITLE;
  COMMON /SPBLK3/NUMBER OF DIODES;INTEGER NUMBER OF DIODES;'

%'COMMON-BLOCK-FLAGS'='COMMON/FLAGS/EFLAG,CFLAG,WIDFLG;
                       INTEGER EFLAG,CFLAG,WIDFLG;
                       COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF;
                       LOGICAL DEFAULT,FIXFWHM,INST_PROF;'
%'COMMON-BLOCK-CONT-FIT'='COMMON/CPARMS/A,B,C;
                          REAL*8 A,B,C;'
%'COMMON-BLOCK-PLOTS'='COMMON/LPLOT/ PLOTALL,SCREEN,CONTINUUM PLOTTING;
                           LOGICAL PLOTALL,SCREEN,CONTINUUM PLOTTING;
                       COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE;
                           CHARACTER*32 SOFT_DEVICE,HARD_DEVICE;
                       COMMON/IPLOT/ NPLOTL,NPLOTR,NUMBER OF PLOTS,
                                     SCREEN LEFT,SCREEN RIGHT;
                       INTEGER NPLOTL(MAX_PLOT),NPLOTR(MAX_PLOT),
                               NUMBER OF PLOTS,SCREEN LEFT,SCREEN RIGHT;
                      COMMON/RPLOT/ WPLOTL,WPLOTR;
                      REAL*8 WPLOTL(MAX_PLOT),WPLOTR(MAX_PLOT);'
%'COMMON-BLOCK-BADDIODE'='COMMON/IBADD/ NOBAD,BAD LEFT(300),BAD RIGHT(300);
                          INTEGER NOBAD,BAD LEFT,BAD RIGHT'
%'COMMON-BLOCK-TELLURIC'='COMMON/LTELL/TELLURIC SET UP,TELLURIC PRESENT;
                          LOGICAL TELLURIC SET UP,TELLURIC PRESENT;
                          COMMON/ITELL/LBOUND(100),RBOUND(100),NBOUNDS,NH2O;
                          INTEGER LBOUND,RBOUND,NBOUNDS,NH2O;
                          COMMON/RTELL/H2OCENT(100),H2OFWHM(100),H2ODEEP(100),
                                       H2OSLOP,H2OINT,H2OMIN;
                          REAL*8 H2OCENT,H2OFWHM,H2ODEEP,H2OSLOP,H2OINT,H2OMIN'
%'COMMON-BLOCK-COMMANDS'='COMMON/CMANDS/ LINENO,ICOL;INTEGER LINENO,ICOL;'
%'COMMON-BLOCK-SYNTHESIS'='COMMON/FLSYN/ FILES(7);CHARACTER*7 FILES;
                           COMMON/INSYN/ NFILE;   INTEGER NFILE;
                           COMMON/WAVSYN/WZERO(7),WINC(7); REAL*8 WZERO,WINC'
"

                **************************
                *                        *
                *   COMMON BLOCK NAMES   *
                *                        *
                **************************

"
%'SPECTRUM'='SPCTRUM'
%'WAVELENGTH'='WAVELN'
%'CONTINUUM LEFT'='CONLFT'
%'CONTINUUM RIGHT'='CONRHT'
%'CONTINUUM FLUX'='CONFLUX'
%'SIGMA FLUX'='SIGFLUX'
%'CONTINUUM CENTRE'='CONCENT'
%'CONTINUUM SIZE'='CONSIZE'
%'CONT ORDER'='CONORD'
%'AUTO CONTINUUM'='AUTOCON'
%'CONTINUUM PLOTTING'='CNPLTG'
%'NORMALISED'='NRMLSD'
%'LINE ID'='LINEID'
%'LEFT DIODE'='LFTDIO'
%'RIGHT DIODE'='RHTDIO'
%'BAD LEFT'='IBADL'
%'BAD RIGHT'='IBADR'
%'TELLURIC SET UP'='TELSET'
%'TELLURIC PRESENT'='TELPRES'
%'INTERCEPT'='INCPT'
%'SIGWIDTH'='SIGWDTH'
%'MINIMUM DEPTH'='MINIDP'
%'PRESENT GRADIENT'='PRESGRD'
%'LAST GRADIENT'='LASTGRD'
%'NUMBER OF DIODES'='NPTS'
%'NUMBER OF ORDERS'='NORD'
%'NUMBER OF SPECTRA'='NSPEC'
%'NUMBER OF ROWS'='NROWS'
%'BAD ORDER'='IBADOR'
%'CURRENT ORDER'='CURORD'
%'CURRENT_IMAGE_ROW'='CURIMR'
%'CURRENT SPECTRUM'='CURSPC'
%'NEW ORDER'='NEWORD'
%'NUMBER OF PLOTS'='NPLOTS'
%'SCREEN RIGHT'='SCRGHT'
%'SCREEN LEFT'='SCLEFT'
%'DELTA_EW'='DELTEW'
%'DELTA_RV'='DELTRV'
%'VARIANCE_FILE'='VARFIL'

"
"
/IRAF_CODE/;
" This is the IRAF mortran main program; see KEEPJOB for Figaro equivalent "
PROGRAM GETJOB;

COMMON-BLOCK-SPECTRUM;
COMMON-BLOCK-FLAGS;
COMMON-BLOCK-FOCUS;
COMMON-BLOCK-IMAGE;
COMMON-BLOCK-ITERATE;
COMMON-BLOCK-ROTATION;
INTEGER I;

INITIALISE PROGRAM(RV);
READ HEADER INFO;

"first find rough RV from rvlist, followed by RV determination from GOOD lines"

FOR CURRENT SPECTRUM = SPEC_START TO NUMBER OF SPECTRA BY SPEC_STEP   <
   FIND RV;
   "
   commented out - it was a nice idea, but there's a bug, and it's slow
   QUICK CONTINUUM FITS(RV);
   MEASURE GOOD LINES(RV);
   "
   
   " now measure lines for real using new RV "
   
   MAKE CONTINUUM FITS(RV);
   MEASURE GOOD LINES(RV);
   COMPUTE NEW RV AND SIGMA;
   DETERMINE WIDTH TO DEPTH RELATION;
   WRITE HEADERS;
   FOR I = 1 TO NUMBER OF ORDERS   <
      READ SPECTRUM(I);
      READ LINE AND CONTINUUM LISTS(RV);
      " CHECK FOR BLENDS;  "
      MEASURE ALL LINES;
      >
   >
CLOSE FILES;
STOP;
END;






SUBROUTINE CHECK FOR BLENDS;

COMMON-BLOCK-LINES;
COMMON-BLOCK-FOCUS;
COMMON-BLOCK-IMAGE;
COMMON-BLOCK-ROTATION;

REAL*8 DMYSQ,RFOCUS,SIGV,SIGF,DLAM;
INTEGER I;

FOR I = 1 TO NUMBER OF LINES - 1  <
"  IF VSINI.GT.0.0D0   <
      SIGV = 0.8D0 * WAVELENGTH(I) * (VSINI / 3.0D+5);  >
"
   SIGV = 0.8D0 * WAVELENGTH(I) * (VSINI / 3.0D+5);  
   IF GLOBAL_FOCUS .OR. FOCUS_PARS(CURRENT_IMAGE_ROW)   <
      SIGF = WAVELENGTH(I) / RFOCUS(WAVELENGTH(I));  >
   DLAM = DMYSQ( SIGV**2 + SIGF**2);
   IF WAVELENGTH(I+1)-WAVELENGTH(I) .LT. 1.5D0*DLAM   <
      ILEFT(I+1) = -1;
      IRIGHT(I)  = -1; >
   IF ILEFT(I).LT.0  .AND. IRIGHT(I).LT.0   <
      ILEFT(I)  = -2;
      IRIGHT(I) = -2;   >
   >
RETURN;
END;




/IRAF_END/;

/IRAF_CODE/;  " The Figaro equivalent of this appears in subroutine KEEPJOB "
SUBROUTINE INITIALISE PROGRAM(RV);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-FLAGS;
COMMON-BLOCK-LINES;
COMMON-BLOCK-PLOTS;
COMMON-BLOCK-TELLURIC;
COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-FOCUS;
COMMON-BLOCK-ITERATE;
COMMON-BLOCK-ROTATION;
COMMON-BLOCK-IMAGE;

CHARACTER*80 IMAGE,VARIANCE,ERRMSG,ANSWER*1;
INTEGER RWMODE,BLOCKSIZE;

DATA BLEND/MAX LINES*0/;
DATA ILEFT/MAX LINES*0/;
DATA IRIGHT/MAX LINES*0/;
DATA DA,DX/9*1.0D-8,1.0D-8/;
DATA FOCUS_PARS,GLOBAL_FOCUS/101*.FALSE./;
DATA CONT ORDER/100*0/;


VSINI = 0.0D0;
RV = 0.0;
PLOTALL = .FALSE.;
SCREEN  = .TRUE.;
NUMBER OF PLOTS = 0;
NUMBER OF SPECTRA = 1;
SOFT_DEVICE=' ';
HARD_DEVICE=' ';
DEFAULT=.TRUE.;
NORMALISED = .FALSE.;
AUTO CONTINUUM = .FALSE.;
OLD_CONTINUUM = .FALSE.;
FITCON = .FALSE.;
PLOTCON=.FALSE.;
TELLURIC SET UP = .FALSE.;
TELLURIC PRESENT= .FALSE.;
FIXFWHM = .FALSE.;
INST_PROF = .FALSE.;
INTERCEPT = 0.0;
SLOPE = 0.0;
LLIMIT = 0.15;
ULIMIT = 0.50;
EFLAG=0;
CFLAG=0;
WIDFLG=1;   "WIDFLG=1 = minsum linear fit; 2 = least squares line; 0=avg"
AXLEN(1) = 1;
AXLEN(2) = 1;
BLOCKSIZE = 1;
SPEC_START=1;
SPEC_STEP=1;
OPEN(UNIT=11,FILE='SPCPLOT');
OPEN(UNIT=10,FILE='MOOGINP',STATUS='NEW');
OPEN(UNIT=12,FILE='MOOGDEPTH',STATUS='NEW');
OPEN(UNIT=15,FILE='MOOGINP.2002',STATUS='NEW');
OPEN(UNIT=9,FILE='WIDPLOT');
OPEN(UNIT=8,FILE='ERRORS');
"  removed -- no longer used OPEN(UNIT=7,FILE='REFSPEC');"
OPEN(UNIT=4,FILE='LINES',STATUS='OLD');
OPEN(UNIT=1,FILE='OUTPUT',STATUS='NEW');
REWIND 15;
REWIND 12;
REWIND 11;
REWIND 10;
REWIND 9;
REWIND 8;
REWIND 7;
REWIND 4;

" Get input filename from command line, or prompt "

WRITE(*,'(18H ENTER IMAGE NAME )');
READ(*,'(A80)')IMAGE;

" open input file "

IER = 0;
RWMODE = 0;
CALL FTGIOU(IM,IER);
CALL FTOPEN(IM,IMAGE,RWMODE,BLOCKSIZE,IER);
IF IER.NE.0  <
   CALL FTPMSG(ERRMSG);
   WRITE(*,'(A80)')ERRMSG;
   STOP;
   >

   " open variance file "

WRITE(*,'(27H IS THERE A VARIANCE FILE? )');
READ(*,'(A1)')ANSWER;
IF ANSWER.EQ.'Y' .OR. ANSWER.EQ.'y'  <
   VARIANCE_FILE = .TRUE.;
   WRITE(*,'(26H ENTER VARIANCE FILE NAME )');
   READ(*,'(A80)')VARIANCE; 
   CALL FTGIOU(IVM,IER);
   CALL FTOPEN(IVM,VARIANCE,RWMODE,BLOCKSIZE,IER);   >
ELSE  <
   VARIANCE_FILE = .FALSE.;   >
IF IER.NE.0  <
   CALL FTPMSG(ERRMSG);
   WRITE(*,'(A80)')ERRMSG;
   STOP;
   >

RETURN;
END;


SUBROUTINE READ HEADER INFO;

" This routine read FITS headers for the wavelength solution "

COMMON-BLOCK-IMAGE;
COMMON-BLOCK-LINES;
COMMON-BLOCK-SPECTRUM;

CHARACTER*68 VALSTR,COMMENT,ERRMSG*80;
INTEGER STATUS;


" determine image size "

STATUS = 0;
CALL FTGKYJ(IM,'NAXIS',NAXIS,COMMENT,STATUS);
CALL FTGKYJ(IM,'NAXIS1',AXLEN(1),COMMENT,STATUS);
IF NAXIS.GE.2   <
   CALL FTGKYJ(IM,'NAXIS2',AXLEN(2),COMMENT,STATUS);  >
NUMBER OF DIODES = AXLEN(1);
NUMBER OF ORDERS = AXLEN(2);
IF NAXIS .GE. 3 <
   WRITE(*,'(46H NOTE: 3-D PROCESSING NOT YET FULLY FUNCTIONAL)');
>

" check for wcs format  "

CALL FTGKYS(IM,'WCSDIM',VALSTR,COMMENT,STATUS);
IF STATUS .EQ. 0   <
   CALL FTGKYS(IM,'WAT0_001',VALSTR,COMMENT,STATUS);
   IF VALSTR(:15).EQ.'system=equispec'   <   

    " many spectra, one order each "

      NUMBER OF SPECTRA = NUMBER OF ORDERS;
      NUMBER OF ORDERS = 1;
      READ EQUISPEC WAVELENGTHS(NUMBER OF ORDERS);
      PROMPT FOR STARTING SPEC AND STEP(SPEC_START,SPEC_STEP,NAXIS);
      >

   ELSEIF VALSTR(:16).EQ.'system=multispec'   <
    " one spectrum with many orders "
      READ WCS WAVELENGTHS(IM,W1,DW,PIX1,NUMBER OF ORDERS);
      >
   ELSEIF STATUS.NE.0  <
      OUTPUT(6); ('ERROR: No WCS system card present');
      STOP;
      >
   >
ELSE  <
   OUTPUT(6);(37H ERROR: Spectrum is not in WCS format);
   STOP;   
   >

" get title, and S/N if required, from header "

CALL FTGKYS(IM,'title',SPTITLE,COMMENT,STATUS);
STATUS = 0;
IF .NOT.VARIANCE_FILE   <
   CALL FTGKYD(IM,'S/N',SN,COMMENT,STATUS);
   IF STATUS.NE.0   <
      OUTPUT(6);(38H No variance file and no S/N in header);
      STOP;   >
   >
WRITE(10,*)SPTITLE;
OUTPUT(1)SPTITLE;(' THE INPUT SPECTRUM TITLE IS: ',/,A80);
CALL FTCMSG;
RETURN;
END;



SUBROUTINE PROMPT FOR STARTING SPEC AND STEP(SPEC_START,SPEC_STEP,NAXIS);

"
A routine to input the first spectrum and the step size for equispec
files.
"

INTEGER SPEC_START,SPEC_STEP,NAXIS;

IF NAXIS .GT. 1   <
   OUTPUT(6);
   ('equispec file: Enter first spectrum number and step ');
   READ(5,*)SPEC_START,SPEC_STEP;
   >
ELSE  <
   SPEC_START = 1;
   SPEC_STEP  = 1;
   >

RETURN;
END;




SUBROUTINE READ EQUISPEC WAVELENGTHS(NUMBER OF ROWS);

IMPLICIT REAL*8 (A-H,O-Z);

COMMON-BLOCK-IMAGE;

INTEGER IERR(3),NUMBER OF ROWS;
CHARACTER*68 COMMENT;

IERR(1) = 0;
IERR(2) = 0;
IERR(3) = 0;
CALL FTGKYD(IM,'CRVAL1  ',W1R,COMMENT,IERR(1));
CALL FTGKYD(IM,'CDELT1  ',DWR,COMMENT,IERR(2));
CALL FTGKYD(IM,'CRPIX1  ',PXR,COMMENT,IERR(3));
IF (IERR(1).NE.0 .OR. IERR(2).NE.0 .OR. IERR(3).NE.0)   <
   OUTPUT(6);(46H CRVAL1, CDELT1, or CRPIX1 missing from header);
   CALL FTCMSG;
   STOP;   > 
FOR I = 1 TO NUMBER OF ROWS <
   W1(I) = W1R;  
   DW(I) = DWR;
   PIX1(I) = PXR;  >
RETURN;
END;



SUBROUTINE READ WCS WAVELENGTHS(IM,W1,DW,PIX1,NUMBER OF ORDERS);

CHARACTER*68 WAT2(100),COMMENT;
INTEGER NWAT2,NUMBER OF ORDERS,IM;
REAL*8 W1(100),DW(100),PIX1(100);


GET_WAT2_CARDS(IM,NWAT2,WAT2);
GET_WAVELENGTH_PARAMS(WAT2,NWAT2,W1,DW,PIX1);
CHECK_WAV_PARAMS(W1,DW,NUMBER OF ORDERS);

RETURN;
END;







SUBROUTINE GET_WAT2_CARDS(UNIT,NWAT2,WAT2);

" a routine to get up to the first 100 WAT2 string values "

INTEGER UNIT,NWAT2,STATUS,I;
CHARACTER*68 WAT2(100),KEYWD*8,COMMENT;

STATUS = 0;
KEYWD = 'WAT2_001';
FOR I = 1 TO 100   <
   IF I.LT.10 <
      WRITE(KEYWD(8:8),'(I1)')I; 
      >
   ELSEIF I.LT.100   <
      WRITE(KEYWD(7:8),'(I2)')I; 
      >

   CALL FTGKYS(UNIT,KEYWD,WAT2(I),COMMENT,STATUS);
   IF STATUS.NE.0  <
      CALL FTCMSG;
      NWAT2 = I - 1;
      RETURN;
      >
   >
RETURN;
END;



SUBROUTINE GET_WAVELENGTH_PARAMS(WAT2,NWAT2,W1,DW,PIX1);

" a routine to read the w1,dw and npix parameters from the WAT2 cards"

IMPLICIT REAL*8 (A-H,O-Z);

INTEGER NWAT2;
CHARACTER*68 WAT2(100),STRING*200,SPECID*11;
REAL*8 W1(100),DW(100),PIX1(100),WAV1,DWAV;
LOGICAL IN_STRING;

IN_STRING = .FALSE.;
NORD = 0;
IC = 0;

FOR IORD = 1 TO 100   <
   W1(I) = 0.0;
   DW(I) = 0.0;
   PIX1(I) = 0.0;  >

IORD = 1;
SET_SPECID(SPECID,IORD,IS);

" Go through the WAT2 cards one character at a time  
  if the spec id for the next line is found start recording"

FOR I = 1 TO NWAT2   <
   FOR J = 1 TO 68   <
  
      IC = IC + 1;
      STRING(IC:IC)=WAT2(I)(J:J);
      IF IC.GE.IS .OR. IN_STRING  <
         IF .NOT. IN_STRING .AND. STRING(IC-IS+1:IC) .EQ. SPECID(:IS)  <
            IN_STRING = .TRUE.; 
            IC = 0;
            >
         ELSEIF WAT2(I)(J:J) .EQ. '"'   <
            IN_STRING = .FALSE.;
            READ(STRING(1:IC),*)IDUM0,IDUM1,IDUM2,WAV1,DWAV,INUM;
            W1(IORD)   = WAV1;
            DW(IORD)   = DWAV;
            PIX1(IORD) = 1.0; 
            IC = 0;
            IORD=IORD+1;
            SET_SPECID(SPECID,IORD,IS);
            >
         >
      >
   >
RETURN;
END;





SUBROUTINE SET_SPECID(SPECID,IORD,IS);

INTEGER IORD,IS;
CHARACTER*11 SPECID;

" set the spec keyword for line number IORD , IS is the length
  of the SPECID character string
"

SPECID(:4) = 'spec';
IF IORD.LT.10  <
   WRITE(SPECID(5:5),'(I1)')IORD;   
   SPECID(6:9) = ' = "';
   IS = 9;  >
ELSEIF IORD.LT.100  <
   WRITE(SPECID(5:6),'(I2)')IORD;   
   SPECID(7:10) = ' = "';
   IS = 10;  >
ELSE   <
   WRITE(SPECID(5:7),'(I3)')IORD;   
   SPECID(8:11) = ' = "';
   IS = 11;  >

RETURN;
END;
      




SUBROUTINE CHECK_WAV_PARAMS(W1,DW,NUMBER OF ORDERS);

" make sure that wavelength solutions exist for each order "

REAL*8 W1(100),DW(100);
INTEGER I,NUMBER OF ORDERS;

FOR I = 1 TO NUMBER OF ORDERS  <
   IF W1(I).EQ.0.0D0  .OR. DW(I).EQ.0.0D0  <
      OUTPUT(6)I;
      ('ERROR: Could not find wavelength solution for order',I3);
      STOP;
      >
   >
RETURN;
END;





"  This is the old routine to read header with iraf routines on
   .imh files

SUBROUTINE READ HEADER INFO;

COMMON-BLOCK-IMAGE;
COMMON-BLOCK-LINES;
COMMON-BLOCK-SPECTRUM;

CHARACTER*80 TITLE,VALSTR,KEYWRD*8,ERRMSG,KEYS(4)*8;
INTEGER DTYPE,IER,JUNK1,JUNK2,JUNK3,IERR(100),AXIS;
REAL SNRAT,DWR,W1R;

DATA KEYS/'W0      ','WPC     ','title   ','S/N     '/;


FOR I = 1 TO 100  <   IERR(I) = 0;  >

CALL IMGSIZ(IM,AXLEN,NAXIS,DTYPE,IER);
NUMBER OF DIODES = AXLEN(1);
NUMBER OF ORDERS = AXLEN(2);
IF (NAXIS.GE.3) <
   WRITE(*,'(46H NOTE: 3-D PROCESSING NOT YET FULLY FUNCTIONAL)');
>


WRITE(KEYWRD,'(6HWCSDIM)');
CALL IMGKWC (IM, KEYWRD, VALSTR, IER);

IF (IER.NE.0)   <

   IF NAXIS.EQ.2   <
      FOR I = 1 TO NUMBER OF ORDERS <
         IF (I.LT.10)   <
            WRITE(KEYWRD,'(5HAPNUM,I1)')I;   >
         ELSE   <
            WRITE(KEYWRD,'(5HAPNUM,I2)')I;   >
         CALL IMGKWC (IM, KEYWRD, VALSTR, IERR(I));
         IF (IERR(I).NE.0)   <
            OUTPUT(6);(32H APNUM information not in header);    
            STOP;   >
         READ(VALSTR,*)JUNK1,JUNK2,W1(I),DW(I);
         >
      >
   ELSE   <
         CALL IMGKWR (IM, KEYS(1), W1R, IERR(1));
         CALL IMGKWR (IM, KEYS(2), DWR, IERR(2));
         W1(1) = DBLE(W1R);
         DW(1) = DBLE(DWR);
         IF (IERR(1).NE.0 .OR. IERR(2).NE.0)   <
            OUTPUT(6);(30H W0 or WPC missing from header);    
            STOP;   >
      >
   >
ELSE   <

   WRITE(KEYWRD,'(6Hsystem)');   
   AXIS = 0;
   CALL IMGKWA (IM, AXIS, KEYWRD, VALSTR, IERR(I));


   IF VALSTR.EQ.'equispec'   <

      NUMBER OF SPECTRA = NUMBER OF ORDERS;
      NUMBER OF ORDERS = 1;

      KEYWRD = 'CRVAL1  ';   
      CALL IMGKWR (IM, KEYWRD, W1R, IERR(1));
      KEYWRD = 'CDELT1  ';   
      CALL IMGKWR (IM, KEYWRD, DWR, IERR(1));
      IF (IERR(1).NE.0 .OR. IERR(2).NE.0)   <
         OUTPUT(6);(37H CRVAL1 or CDELT1 missing from header);    
         STOP;   >
      FOR I = 1 TO NUMBER OF SPECTRA * NUMBER OF ORDERS  <
         W1(I) = DBLE(W1R);
         DW(I) = DBLE(DWR);  >
      >
      
   ELSEIF VALSTR.EQ.'multispec'   <
      AXIS = NAXIS;
      IF NAXIS.GE.2   < AXIS = 2;  >
      FOR I = 1 TO NUMBER OF ORDERS <
         IF (I.LT.10)   <
            WRITE(KEYWRD,'(4Hspec,I1)')I;   >
         ELSE   <
            WRITE(KEYWRD,'(4Hspec,I2)')I;   >
         CALL IMGKWA (IM, AXIS, KEYWRD, VALSTR, IERR(I));
         IF (IERR(I).NE.0)   <
            OUTPUT(6);(31H spec information not in header);    
            STOP;   >
         READ(VALSTR,*)JUNK1,JUNK2,JUNK3,W1(I),DW(I);
         >
      >
   >

CALL IMGKWC (IM, KEYS(3), TITLE , IERR(3));

IF .NOT.VARIANCE_FILE   <
   CALL IMGKWR (IM, KEYS(4), SNRAT , IERR(4));
   SN = DBLE(SNRAT);
   IF (IERR(4).NE.0 )   <
      OUTPUT(6);(38H No variance file and no S/N in header);    
      STOP;   >
   >
WRITE(10,*)TITLE;
SPTITLE=TITLE;
OUTPUT(1)SPTITLE;(' THE INPUT SPECTRUM TITLE IS: ',/,A80);  
RETURN;  
END;

"


/IRAF_END/;


SUBROUTINE QUICK CONTINUUM FITS(RV);
"
  A subroutine to fit the continuum after the first, rough, RV determination.
"

IMPLICIT REAL*8 (A-H,O-Z);

COMMON-BLOCK-IMAGE;
COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-PLOTS;

INTEGER IORD,IDUM1,IDUM2;
REAL*8 RV;

READ LINE AND CONTINUUM LISTS(RV);
IF FITCON   <
   FOR IORD = 1 TO NUMBER OF ORDERS   <
      READ SPECTRUM(IORD);
      READ CURRENT CONTINUUM(RV);
      IF FITCON   <
         FIT CONTINUUM;   
      >
   >
>
RETURN;
END;


SUBROUTINE MAKE CONTINUUM FITS(RV);
"
  A subroutine to fit the continuum as the first task after RV determination 
  and plot on screen if requested.
"

IMPLICIT REAL*8 (A-H,O-Z);

COMMON-BLOCK-IMAGE;
COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-PLOTS;

INTEGER IORD,IDUM1,IDUM2,LPG;
REAL*8 RV;

READ LINE AND CONTINUUM LISTS(RV);
IF PLOTCON  <
   SOFT_DEVICE = '/GTERM' ;
/UNIX_CODE/;
   "
   Removed AMcW 15/Jan/1999
   IF (SOFT_DEVICE.EQ.' ') <
      CALL GETENV('PGSOFT',SOFT_DEVICE);
       If unsuccessful let PGBEG prompt user for device: 
      IF (SOFT_DEVICE.EQ.' ') < SOFT_DEVICE = '?'; >
   >
   "
/UNIX_END/;
/VMS_CODE/;
   IF (SOFT_DEVICE.EQ.' ') <
      LPG=6;
      CALL LIB$SYS_TRNLOG('PGSOFT',LPG,SOFT_DEVICE);
      " If unsuccessful let PGBEG prompt user for device: "
      IF (LPG.LE.0) < SOFT_DEVICE = '?'; >
   >
/VMS_END/;
/PGP_CODE/;
   CALL PGBEG(14,SOFT_DEVICE,1,1);
   CALL PGASK(.FALSE.);
"TEST"
   CALL PGSCR(1,0,240,0);
   CALL PGSCI(1);
/PGP_END/;
/TEK_CODE/;
   CALL INITT(120);
   CALL TERM(1,NTEKPTS);
/TEK_END/;
   SET TERMINAL WINDOW;
>
IF PLOTCON .OR. FITCON   <
   FOR IORD = 1 TO NUMBER OF ORDERS   <
      READ SPECTRUM(IORD);
      READ CURRENT CONTINUUM(RV);
      IF FITCON   <
         FIT CONTINUUM;   
      >
      IF PLOTCON   <
         CONTINUUM PLOT;
         INTERACT WITH USER(IDUM1,IDUM2); 
      >
   >
>
IF PLOTCON  <
/TEK_CODE/;
   CALL FINITT(0,0);
/TEK_END/;
/PGP_CODE/;
   CALL PGEND;
/PGP_END/;
>
RETURN;
END;


SUBROUTINE MEASURE GOOD LINES(RV);

" A routine which reads through the linelist and measures lines.  "

IMPLICIT REAL*8(A-H,O-Z);
COMMON-BLOCK-IMAGE;
COMMON-BLOCK-LINES;

INTEGER LMIN,LMAX,I,IORDER;
LOGICAL ZERO;

"  zero flag allows lines to be measured on first iorder=0 encounter, but not
   subsequently, so looks for lines when 1st line beyond order is found "

LMIN = 1;
ZERO=.FALSE.;

" read through the list until the first linelist line is found in the spectrum "

READ GOOD LINES ONLY(RV);
FOR LMIN = 1 TO NUMBER OF LINES   <
   FIND ORDER(WAVELENGTH(LMIN),IORDER);
   IF (IORDER.NE.0)   <
      READ SPECTRUM(IORDER);   
      EXIT;   >
   >

" read through list measuring lines in an order once all lines occuring in that
  order have been identified "

ILOW = LMIN;
FOR I = ILOW TO NUMBER OF LINES   <
   FIND ORDER(WAVELENGTH(I),IORDER);
   IF IORDER .NE. CURRENT ORDER .AND. .NOT.ZERO  <
      LMAX = I - 1;
      READ CURRENT CONTINUUM(RV);
      MEASURE LINES IN CURRENT ORDER(LMIN,LMAX);
      IF (IORDER.NE.0)  <
         READ SPECTRUM(IORDER);   >
      ELSE   <
         ZERO = .TRUE.;   >
      LMIN = I;   >
    ELSEIF ZERO .AND. IORDER.NE.0   <
       ZERO = .FALSE.;
       READ SPECTRUM(IORDER);   >
   >

"  if last line is covered in spectrum measure that order's lines  "

IF IORDER.NE.0   <
   LMAX = NUMBER OF LINES;
   READ SPECTRUM(IORDER);
   READ CURRENT CONTINUUM(RV);
   MEASURE LINES IN CURRENT ORDER(LMIN,LMAX);   >
RETURN;
END;


SUBROUTINE MEASURE LINES IN CURRENT ORDER(LMIN,LMAX);

IMPLICIT REAL*8(A-H,O-Z);
COMMON-BLOCK-LINES;
COMMON-BLOCK-SPECTRUM;
COMMON-BLOCK-IMAGE;
COMMON-BLOCK-CONTINUUM;

INTEGER LINE,LMIN,LMAX;
REAL*8 A(9),COV(9,9);
LOGICAL DELETED;

NUMBER OF DIODES = AXLEN(1);
ESTIMATE LINE CENTRES(LMIN,LMAX);
IF CONT ORDER(CURRENT_IMAGE_ROW) .EQ. 0   <
   FIT CONTINUUM;   >
FOR LINE = LMIN TO LMAX  <
   FIND CENTRAL DIODE NUMBER AND DEPTH(LINE,A,COV,DELETED);
   IF DELETED  < 
      LINE = LINE - 1;  NEXT;  >
   OBTAIN FWHM (LINE,A,COV,NUMBER OF DIODES);
   FIT SINGLE GAUSSIAN(LINE);
   COMPUTE LINE RV(LINE);
   >
RETURN;
END;
   

SUBROUTINE COMPUTE LINE RV(LINE);

IMPLICIT REAL*8 (A-H,O-Z);

COMMON-BLOCK-LINES;

W = WAV(CENTRE(LINE));
DELTA_RV(LINE) = 3.0D+05 * ( W/WAVELENGTH(LINE) - 1.0D+00 );
"
WRITE(28,'(7h wav = ,F10.3,2X,12h DELTA RV = ,F10.3)')
                          WAVELENGTH(LINE),DELTA_RV(LINE);
"
RETURN;
END;


SUBROUTINE COMPUTE NEW RV AND SIGMA;

"
computes RV and Sigma(RV) based on GOOD lines in the spectrum
"

IMPLICIT REAL*8 (A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-SPECTRUM;

DV = 0.0; DV2 = 0.0;   NZERO = 0;
FOR I = 1 TO NUMBER OF GOOD LINES   <
   IF CHANNEL(WAVELENGTH(GOOD(I))) .EQ. CENTRE(GOOD(I))  <  
      NZERO = NZERO + 1;   >
   DV = DV + DELTA_RV(GOOD(I));
   DV2 = DV2 + DELTA_RV(GOOD(I))**2;   >
IF NUMBER OF GOOD LINES-NZERO .GT. 2   <
   AN = DBLE(NUMBER OF GOOD LINES - NZERO - 1);
   SIGROT = DMYSQ(  (DV2 - DV**2/AN )/(AN-1.0) );
   SIGRV = SIGROT;
   RVERR = SIGRV/DMYSQ(AN);
   ROT = RV + DV/AN;
   RV = ROT;
   SIGROT = RVERR;   >
WRITE(6,'(19H RADIAL VELOCITY = ,F10.3,5H +/- ,F6.2)')ROT,RVERR;   
WRITE(6,'(12H SIGMA RV = ,F10.3)')SIGROT;
OUTPUT(1)RV;('RADIAL VELOCITY = ',F10.4,'  KM/S');
OUTPUT(1)SIGROT;('SIGMA RV = ',F10.3,' KM/S');
RETURN;
END;


SUBROUTINE MEASURE ALL LINES;

COMMON-BLOCK-LINES;
COMMON-BLOCK-SPECTRUM;
COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-IMAGE;

INTEGER LINE,SEARCH,IDUMMY;
REAL*8 A(9),COV(9,9);
LOGICAL DELETED;


ESTIMATE AND CHECK LINE CENTRES(NUMBER OF DIODES);

IF NUMBER OF LINES .GE. 1   <
   FIT CONTINUUM;   
   FOR LINE = 1 TO NUMBER OF LINES  <
      FIND CENTRAL DIODE NUMBER AND DEPTH(LINE,A,COV,DELETED);
      IF DELETED  < 
         LINE = LINE - 1;  NEXT;  >
      OBTAIN FWHM (LINE,A,COV,NUMBER OF DIODES);
      FIT SINGLE GAUSSIAN(LINE);   >
   FIT WEAK LINES;
   FOR LINE = 1 TO NUMBER OF LINES   <
      SINGLE FIT TO BAD LINES(LINE);   >
   FIND BROAD LINES;
   FIT BLENDED LINES(NUMBER OF LINES);
   FOR LINE = 1 TO NUMBER OF LINES  <
      MEASURE EQUIVALENT WIDTH(LINE);   >
   IF NUMBER OF LINES .GE. 1   <
      PERFORM TEKTRONIXS SCREEN PLOTTING(NUMBER OF DIODES);  >
   PRODUCE MOOG INPUT FILE(RV,SPTITLE);
   FINISH UP;
>
RETURN;
END;





SUBROUTINE REMEASURE LINES;

COMMON-BLOCK-LINES;
COMMON-BLOCK-SPECTRUM;
COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-IMAGE;

INTEGER LINE,SEARCH,IDUMMY;
REAL*8 A(9),COV(9,9);
LOGICAL DELETED;


ESTIMATE AND CHECK LINE CENTRES(NUMBER OF DIODES);
IF NUMBER OF LINES .GE. 1   <
   FOR LINE = 1 TO NUMBER OF LINES  <
      FIND CENTRAL DIODE NUMBER AND DEPTH(LINE,A,COV,DELETED);
      IF DELETED  < 
         LINE = LINE - 1;  NEXT;  >
      OBTAIN FWHM (LINE,A,COV,NUMBER OF DIODES);
      FIT SINGLE GAUSSIAN(LINE);   >
   FIT WEAK LINES;
   FOR LINE = 1 TO NUMBER OF LINES   <
      SINGLE FIT TO BAD LINES(LINE);   >
   FIND BROAD LINES;
   FIT BLENDED LINES(NUMBER OF LINES);
   FOR LINE = 1 TO NUMBER OF LINES  <
      MEASURE EQUIVALENT WIDTH(LINE);   >
>
RETURN;
END;





SUBROUTINE READ SPECTRUM(IROW);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-IMAGE;
COMMON-BLOCK-SPECTRUM;
COMMON-BLOCK-LINES;
CHARACTER*80 ERRMSG;

INTEGER I,IROW,FPIX(2),LPIX(2),NAXES(2),INCS(2),NULLVAL,IER,GROUP;
LOGICAL ANYF;

CURRENT_IMAGE_ROW = (CURRENT SPECTRUM - 1)*NUMBER OF ORDERS + IROW;

" set-up FITS reading arrays "

NAXES(1) = NUMBER OF DIODES;
NAXES(2) = NUMBER OF ORDERS*NUMBER OF SPECTRA;
FPIX(1)  = 1;
FPIX(2)  = CURRENT_IMAGE_ROW;
LPIX(1)  = NUMBER OF DIODES;
LPIX(2)  = CURRENT_IMAGE_ROW;
INCS(1)  = 1;
INCS(2)  = 1;
NULLVAL  = 0;
GROUP    = 1;
IER      = 0;

"  get spectrum data "

CALL FTGSVD(IM,GROUP,NAXIS,NAXES,FPIX,LPIX,INCS,NULLVAL,SPECTRUM,ANYF,IER);

IF IER .NE. 0 <
   CALL FTGMSG(ERRMSG);
   WRITE(*,'(8H Error: ,A80)')ERRMSG;
   STOP;
>

DISP = DW(IROW);
OFFSET = W1(IROW);
PIX_OFFSET = PIX1(IROW);
CURRENT ORDER = IROW;


"  Now read variances if a variance file was specified.  "

IF VARIANCE_FILE   <
   CALL FTGSVD(IVM,1,NAXIS,NAXES,FPIX,LPIX,INCS,NULLVAL,VARSPEC,
               ANYF,IER);
IF IER .NE. 0 <
   CALL FTGMSG(ERRMSG);
   WRITE(*,'(8H Error: ,A80)')ERRMSG;
   STOP;
   >
>

"
   Fill array LAMBDA with double precision wavelengths
      (note: not used but permits arbitrary wavelengths for future)
"
FOR I = 1 TO NUMBER OF DIODES  <
   LAMBDA(I) = OFFSET + (I-1)*DISP;  >

RETURN;
END;









"
  This is the old routine to read iraf .imh file data

SUBROUTINE READ SPECTRUM(IROW);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-IMAGE;
COMMON-BLOCK-SPECTRUM;
COMMON-BLOCK-LINES;
CHARACTER*80 LINE,ERRMSG;
INTEGER I,IER,IROW,IBAND;
REAL ROT(MAX DIODE);


CURRENT_IMAGE_ROW = (CURRENT SPECTRUM - 1)*NUMBER OF ORDERS + IROW;

IER = 0;

IF (NAXIS.EQ.1) <
   CALL IMGL1R(IM,ROT,IER);
   >
ELSEIF (NAXIS.EQ.2) <
   CALL IMGL2R(IM,ROT,CURRENT_IMAGE_ROW,IER);
   >
ELSEIF (NAXIS.EQ.3) <
   IBAND = 1;
   CALL IMGL3R(IM,ROT,CURRENT_IMAGE_ROW,IBAND,IER);
   >
IF (IER.NE.0) <
   CALL IMEMSG(IER,ERRMSG);
   WRITE(*,'(8H Error: ,A80)')errmsg;
   STOP;
>
DISP = DW(IROW);
OFFSET = W1(IROW);
CURRENT ORDER = IROW;

FOR I = 1 TO NUMBER OF DIODES  <
   SPECTRUM(I) = DBLE(ROT(I));   >


IF VARIANCE_FILE   <
   IF (NAXIS.EQ.1) <
      CALL IMGL1R(IVM,ROT,IER);
      >
   ELSE   <
      CALL IMGL2R(IVM,ROT,CURRENT_IMAGE_ROW,IER);
      >
   IF (IER.NE.0) <
      CALL IMEMSG(IER,ERRMSG);
      WRITE(*,'(8H Error: ,A80)')errmsg;
      STOP;
   >

   FOR I = 1 TO NUMBER OF DIODES  <
      VARSPEC(I) = DBLE(ROT(I));   >
>

FOR I = 1 TO NUMBER OF DIODES  <
   LAMBDA(I) = OFFSET + (I-1)*DISP;  >

RETURN;
END;

"


SUBROUTINE CORRECT TELLURIC BOUNDS(ISHIFT,NUMBER OF DIODES);

IMPLICIT REAL*8(A-H,O-Z);

INTEGER ISHIFT,NUMBER OF DIODES,I,J;
COMMON-BLOCK-TELLURIC;

FOR I = 1 TO NBOUNDS   <
   LBOUND(I) = LBOUND(I) + ISHIFT;
   RBOUND(I) = RBOUND(I) + ISHIFT;   >
"  NOW REMOVE BOUNDS NOT IN WINDOW  "
FOR I = 1 TO NBOUNDS   <
   IF LBOUND(I) .LT. 1   <
      IF RBOUND(I) .LT. 1   <
         FOR J = I TO NBOUNDS - 1   <
            LBOUND(J) = LBOUND(J+1);
            RBOUND(J) = RBOUND(J+1);   >
         NBOUNDS = NBOUNDS - 1;
         I = I - 1;   >
      ELSE   <  LBOUND(I) = 1;   >
      >
   ELSEIF RBOUND(I) .GT. NUMBER OF DIODES   <
      IF LBOUND(I) .GT. NUMBER OF DIODES   <
         FOR J = I TO NBOUNDS - 1   <
            LBOUND(J) = LBOUND(J+1);
            RBOUND(J) = RBOUND(J+1);   >
         NBOUNDS = NBOUNDS - 1;
         I = I - 1;   >
      ELSE   <  RBOUND(I) = NUMBER OF DIODES;  >
      >
   >
RETURN;
END;


SUBROUTINE NORMALISE TELLURIC SPECTRUM(SPECTRUM,NPTS);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-TELLURIC;
INTEGER DIODE;
REAL*8 SPECTRUM(MAX DIODE);
LOGICAL TELLURIC DIODE;

FOR I = 1 TO NBOUNDS   <
   IF LBOUND(I) .NE. 1  .AND. RBOUND(I) .NE. NPTS   <
      GRAD = (SPECTRUM(RBOUND(I)+1)-SPECTRUM(LBOUND(I)-1))/
             DBLE( RBOUND(I) - LBOUND(I) + 2 );
      FOR J = LBOUND(I) TO RBOUND(I)   <
         CONT = GRAD*DBLE( J - LBOUND(I) + 1 ) + SPECTRUM(LBOUND(I)-1);
         SPECTRUM(J) = SPECTRUM(J)/CONT;
         IF SPECTRUM(J) .GT. 1.0   <
            SPECTRUM(J) = 1.0;   >
         >
      >
   ELSE   <
      IF LBOUND(I) .EQ. 1   <
         DIODE = RBOUND(I) + 1;   >
      ELSEIF RBOUND(I) .EQ. NPTS   <
         DIODE = LBOUND(I) - 1;   >
      FOR J = LBOUND(I) TO RBOUND(I)   <
         SPECTRUM(J) = SPECTRUM(J)*1.0/SPECTRUM(DIODE);   >
      >
     >
FOR I = 1 TO NPTS   <
   IF .NOT. TELLURIC DIODE(I)   <
      SPECTRUM(I) = 1.0;   >
   >
RETURN;
END;


LOGICAL FUNCTION TELLURIC DIODE(I);

IMPLICIT REAL*8(A-H,O-Z);

INTEGER I;
COMMON-BLOCK-TELLURIC;

TELLURIC DIODE = .FALSE.;
FOR J = 1 TO NBOUNDS   <
   IF I .LT. LBOUND(J)   <
      RETURN;   >
   ELSEIF I .LE. RBOUND(J)   <
      TELLURIC DIODE = .TRUE.;
      RETURN;   >
   >
RETURN;
END;



SUBROUTINE SET UP CROSS CORRELATION PLOT FILE(TITLE);

IMPLICIT REAL*8(A-H,O-Z);

CHARACTER*80 TITLE;

OUTPUT(8)TITLE(1:45);(' TITLE $',A45,'$');
OUTPUT(8);(' XLABEL $DIODE SHIFT$');
OUTPUT(8);(' YLABEL $CROSS PRODUCT$');
OUTPUT(8);(' XFORMAT I5');
OUTPUT(8);(' YFORMAT F6.2');
OUTPUT(8);(' NOMARKER ');
OUTPUT(8);(' LINE ');
RETURN;
END;




SUBROUTINE READ LINE AND CONTINUUM LISTS(RV);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-FLAGS;
COMMON-BLOCK-WIDE;
COMMON-BLOCK-LINES;
COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-BADDIODE;
COMMON-BLOCK-PLOTS;
COMMON-BLOCK-TELLURIC;
COMMON-BLOCK-IMAGE;
COMMON-BLOCK-FOCUS;
COMMON-BLOCK-ROTATION;

INTEGER SEARCH,BAD ORDER;
CHARACTER*80 LINE,OLDCFILE*70;

"  NOCONT IS THE NUMBER OF CONTINUUM REGIONS USED  "

"  Reset variables from previous orders  "

I=0;   NOCONT = 0;   NOBAD = 0;   NUMBER OF GOOD LINES = 0;   NBOUNDS = 0;
IWIDE = 0; NUMBER OF PLOTS = 0;  NUMBER OF LINES = 0;  BAD ORDER = 0;
NUMBER OF DIODES = AXLEN(1);
WSTART = WAV(1.0D+00);
WEND = WAV(DBLE(NUMBER OF DIODES));
LOOP  <
   READ(4,'(A80)',END=:END:)LINE;

   IF LINE(:9).EQ.'OLDCONTIN'  <
      READ(LINE(11:),'(A70)')OLDCFILE;
      OLD_CONTINUUM = .TRUE.;
      GRAB_COEFFS(OLDCFILE,ACON,CONT ORDER);
      READ(4,'(A80)',END=:END:)LINE; 
      >

   I=I+1;
   READ(LINE,'(A10,4D10.3,3(2X,I3))')LINE ID(I),WAVELENGTH(I),ATOM(I),
       EPLOW(I),GF(I),IGOOD,ILEFT(I),IRIGHT(I);

   IF LINE ID(I).EQ.'CONTINUUM '   <
      I = I - 1;
      WAV1 = WAVELENGTH(I+1);
      WAV2 = ATOM(I+1);
      IF WAV1.LT.WEND .AND. WAV2.GT.WSTART   <
         NOCONT = NOCONT + 1;
         CONTINUUM LEFT(NOCONT)  = NINT(CHANNEL(WAV1));
         CONTINUUM RIGHT(NOCONT) = NINT(CHANNEL(WAV2));
         IF CONTINUUM LEFT(NOCONT) .LT. 1  <   CONTINUUM LEFT(NOCONT) = 1;  >
         IF CONTINUUM RIGHT(NOCONT) .GT. NUMBER OF DIODES  <
            CONTINUUM RIGHT(NOCONT) = NUMBER OF DIODES;  >
         ISIZE = CONTINUUM RIGHT(NOCONT) - CONTINUUM LEFT(NOCONT) + 1;
         IF EPLOW(I+1).EQ.0.0   <
            CONTINUUM SIZE(NOCONT) = ISIZE; 
            >
         ELSE   <
            CONTINUUM SIZE(NOCONT)  = NINT(EPLOW(I+1));
            >
         IF CONTINUUM SIZE(NOCONT).GT.ISIZE   <
            CONTINUUM SIZE(NOCONT) = ISIZE;   >
         >
      NEXT;   >
   ELSEIF LINE ID(I).EQ.'FITCONTIN'   <
      FITCON = .TRUE.;
      I = I - 1;
      NEXT;   >
   ELSEIF LINE ID(I).EQ.'AUTOCONTIN'   <
      AUTO CONTINUUM = .TRUE.;
"     NOCONT = 1;   removed AMcW 3/2000"
      I = I - 1;
      CONTINUUM RIGHT(1) = INT(WAVELENGTH(I+1));
      CONTINUUM LEFT(1) = 1;
      CONTINUUM SIZE(1) = INT(ATOM(I+1));    
      NEXT;  >
   ELSEIF LINE ID(I) .EQ. 'NORMALISED'   <
      NORMALISED = .TRUE.;   
      I = I - 1;
      NEXT;   >
   ELSEIF LINE ID(I)(:5) .EQ. 'FOCUS'   <
      READ(LINE(6:10),'(F5.1)')XROW;
      IROW = NINT(XROW);
      IF IROW.GT.0   <
         FOCUS_PARS(IROW) = .TRUE.;
         READ(LINE(11:),'(7F10.5)')WFC(IROW),(A_FOCUS(IROW,IPAR),IPAR=1,6);   >
      ELSE   <
         GLOBAL_FOCUS = .TRUE.;   
         READ(LINE(11:),'(7F10.5)')GLOBAL_WFC,(GLOBAL_A(IPAR),IPAR=1,6);   >
      I = I - 1;
      NEXT;   >
   ELSEIF LINE ID(I) .EQ. 'INST_PROF '   <
      INST_PROF = .TRUE.;
      I = I - 1;
      NEXT;   >
   ELSEIF LINE ID(I) .EQ. 'BOUNDS    '   <  "no longer used"
      NBOUNDS = NBOUNDS + 1;
      I = I - 1;
      LBOUND(NBOUNDS) = INT( WAVELENGTH(I+1) );
      RBOUND(NBOUNDS) = INT( ATOM(I+1) );
      NEXT;   >
   ELSEIF LINE ID(I) .EQ. 'PLOT      '   <
      I = I - 1;
      IF NUMBER OF PLOTS .GE. MAX_PLOT  .OR.  PLOTALL   <   NEXT;   >
      NUMBER OF PLOTS = NUMBER OF PLOTS + 1;
      WPLOTL(NUMBER OF PLOTS) = WAVELENGTH(I+1);
      WPLOTR(NUMBER OF PLOTS) = ATOM(I+1);
      NEXT;   >
   ELSEIF LINE ID(I) .EQ. 'PLOTALL   '   <
      I = I - 1;
      PLOTALL = .TRUE.;
      NUMBER OF PLOTS = 0;
      NEXT;   >
   ELSEIF LINE ID(I).EQ.'PLOTCONTIN'   <
      PLOTCON = .TRUE.;
      I = I - 1;
      NEXT;   >
   ELSEIF LINE ID(I) .EQ. 'BADDIODE  '   <
      I = I - 1;
      IF NINT(EPLOW(I+1)).EQ.CURRENT_IMAGE_ROW   <
         IF NOBAD .EQ. 300   <
            OUTPUT(8);('MAXIMUM NUMBER OF BAD DIODE REGIONS EXCEEDED');
            RETURN;   >
         NOBAD = NOBAD + 1;
         BAD LEFT(NOBAD) = NINT( WAVELENGTH(I+1) );
         BAD RIGHT(NOBAD)= NINT( ATOM(I+1) );   
         >
      NEXT;  >
   ELSEIF LINE ID(I) .EQ. 'LLIMIT    '   <  "no longer used"
      LLIMIT = WAVELENGTH(I);
      I = I - 1;
      NEXT;   >
   ELSEIF LINE ID(I) .EQ. 'ULIMIT    '   <  "no longer used"
      ULIMIT = WAVELENGTH(I);
      I = I - 1;
      NEXT;   >
   ELSEIF LINE ID(I) .EQ. 'FWHM      '   <
      FIXFWHM = .TRUE.;
      INTERCEPT     = WAVELENGTH(I);
      SLOPE         = ATOM(I);
      MINIMUM DEPTH = EPLOW(I);
      SIGFRAC       = GF(I);       "fractional uncertainty of width relation"
      "SIGFWHM = SIGFRAC**2 /(0.5*(1.0D0+MINIMUM DEPTH)*SLOPE + INTERCEPT);
            removed AMcW 1/2002"
      I = I - 1;
      NEXT;   >
   ELSEIF LINE ID(I) .EQ. 'VSINI     '   <
      WRITE(1,'(9h VSINI = ,f10.2,5h Km/s)')VSINI;
      WRITE(1,'(32h VSINI option does not work yet )');
      VSINI = WAVELENGTH(I);
      I = I - 1;
      NEXT;   >
   IF ILEFT(I) .LT. 0  .OR.  IRIGHT(I) .LT. 0   <
      IF IGOOD .EQ. 999   <
         OUTPUT(8)I;
         (' CANNOT USE LINE ',I3,' AS A GOOD LINE SINCE ONLY DEPTH',
          ' IS TO BE USED FOR ITS EW ');
         IGOOD = 0;   >
      >
   IF IGOOD .EQ. 999    <
      NUMBER OF GOOD LINES = NUMBER OF GOOD LINES + 1;
      GOOD(NUMBER OF GOOD LINES) = I;
      IGOOD = 0;   >
   IF IGOOD .EQ. 100   <
      IF IWIDE .LT. 50   <
         IWIDE = IWIDE + 1;
         WIDE(IWIDE) = WAVELENGTH(I);   >
      ELSE   <
         OUTPUT(8);(' WARNING: ONLY THE FIRST 50 WIDE LINES USED ');   >
      IGOOD = 0;
      >
   WEAK(I)  = .FALSE.;
   BLEND(I) = 0;
"
   IF GF(I) .EQ. 0.0   <   GF(I) = 1.0;   >
"
   >UNTIL I.GE.MAX LINES .OR. NOCONT.GE.MAX CONT;
OUTPUT(8);(' LINE OR CONTINUUM BUFFER MAXIMUM REACHED');
OUTPUT(8)I,MAX LINES;(I3,1X,27H LINES USED, MAX ALLOWED IS,1X,I3);
OUTPUT(8)NOCONT,MAX CONT;
   (I3,1X,30H CONTINUA USED, MAX ALLOWED IS,1X,I3);
:END:
   SORT CONTINUUM;
   NUMBER OF LINES=I-1;
   REWIND(UNIT=4);
   RETURN;
   END;




SUBROUTINE SORT CONTINUUM;

" This routine will sort the continuum list, in order of increasing 
  CONTINUUM LEFT parameter. 
"


IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-CONTINUUM;

INTEGER I,J,CLDUM,CRDUM,CSDUM;
REAL*8 CFDUM,SFDUM,CCDUM;

FOR J = 1 TO NOCONT-1   <
   FOR I = 1 TO NOCONT-J  <
      IF CONTINUUM LEFT(I).GT.CONTINUUM LEFT(I+1)  <

         CLDUM = CONTINUUM LEFT(I+1);
         CONTINUUM LEFT(I+1) = CONTINUUM LEFT(I);
         CONTINUUM LEFT(I) = CLDUM;

         CRDUM = CONTINUUM RIGHT(I+1);
         CONTINUUM RIGHT(I+1) = CONTINUUM RIGHT(I);
         CONTINUUM RIGHT(I) = CRDUM;

         CSDUM = CONTINUUM SIZE(I+1);
         CONTINUUM SIZE(I+1) = CONTINUUM SIZE(I);
         CONTINUUM SIZE(I) = CSDUM;

         CFDUM = CONTINUUM FLUX(I+1);
         CONTINUUM FLUX(I+1) = CONTINUUM FLUX(I);
         CONTINUUM FLUX(I) = CFDUM;

         SFDUM = SIGMA FLUX(I+1);
         SIGMA FLUX(I+1) = SIGMA FLUX(I);
         SIGMA FLUX(I) = SFDUM;

         CCDUM = CONTINUUM CENTRE(I+1);
         CONTINUUM CENTRE(I+1) = CONTINUUM CENTRE(I);
         CONTINUUM CENTRE(I) = CCDUM;

         >
      >
   >
RETURN;
END;



SUBROUTINE GRAB_COEFFS(FILE,A,CONT ORDER);
"
 Gets the old continuum polynomial fits from a previous OUTPUT file

  FILE           is character*70 file name
  A(50,100)      contains up to 50 polynomial coefficients for each row of an
                 image with 100 rows.
  CONT ORDER(N)  the order of the polynomial in the nth row
  NROW           the number of rows with polynomial fits
  IROW(I)        the row number of the ith polynomial fit
"

IMPLICIT REAL*8 (A-H,O-Z);

REAL*8 A(50,100);
INTEGER CONT ORDER(100),IROW(100),NROW;
CHARACTER*70 FILE,LINE*120;
LOGICAL FOUND;

OPEN(UNIT=30,FILE=FILE,STATUS='OLD');

FOUND = .FALSE.;

NROW = 0;
LOOP   <
   READ(30,'(A80)',END=:EOF:)LINE;
   IF LINE(:18).EQ.'CURRENT IMAGE ROW '   <
      NROW = NROW + 1;
      READ(LINE(19:),*)IROW(NROW);

      LOOP <
         READ(30,'(A80)',END=:EOF:)LINE;
         IF LINE(:25).EQ.'ORDER OF POLYNOMIAL FIT ='   <
            READ(LINE(26:),*)CONT ORDER(IROW(NROW));
            READ(30,'(A80)')LINE;
            READ(30,'(A80)')LINE;
            READ(30,'(5(G16.9,1X))')
                     (A(I,IROW(NROW)),I=1,CONT ORDER(IROW(NROW)));
            FOUND = .TRUE.;
         >
      >UNTIL FOUND;
   >
   FOUND = .FALSE.;
>
:EOF: CLOSE(UNIT=30);

RETURN;
END;


SUBROUTINE READ TELLURIC PARAMETERS;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-TELLURIC;

OPEN(UNIT=12,FILE='H2OLIST',STATUS='OLD');
REWIND 12;
READ(12,*)H2OSLOP,H2OINT,H2OMIN;
FOR I = 1 TO 100   <
   READ(12,*,END=:FIN:)H2OCENT(I),H2OFWHM(I),H2ODEEP(I);   >
OUTPUT(8);(/,'WARNING: ONLY THE FIRST 100 TELLURIC LINES WILL BE USED',/);
NH2O = 100;
RETURN;
:FIN:  NH2O = I - 1;
       RETURN;
       END;


SUBROUTINE CORRECT CONTINUUM LIMITS(ISHIFT,NUMBER OF DIODES);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-CONTINUUM;
INTEGER I,ISHIFT,NUMBER OF DIODES;

FOR I = 1 TO NOCONT   <
   CONTINUUM RIGHT(I) = CONTINUUM RIGHT(I) + ISHIFT;
   CONTINUUM LEFT(I)  =  CONTINUUM LEFT(I) + ISHIFT;
   IF CONTINUUM LEFT(I) .LT. 1   <
      IF CONTINUUM RIGHT(I) .LT. 1   <
         REMOVE CONTINUUM POINT(I);   >
      ELSE   <
         CONTINUUM LEFT(I) = 1;   >
      >
   ELSEIF CONTINUUM RIGHT(I) .GT. NUMBER OF DIODES   <
      IF CONTINUUM LEFT(I) .GT. NUMBER OF DIODES   <
         REMOVE CONTINUUM POINT(I);   >
      ELSE   <
         CONTINUUM RIGHT(I) = NUMBER OF DIODES;   >
      >
   >
RETURN;
END;




SUBROUTINE REMOVE CONTINUUM POINT(ICONT);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-CONTINUUM;
INTEGER ICONT,I;

IF ICONT .EQ. NOCONT   <
   ICONT = ICONT - 1;
   NOCONT = NOCONT - 1;
   RETURN;  >
FOR I = ICONT TO NOCONT - 1   <
   CONTINUUM RIGHT(I) = CONTINUUM RIGHT(I+1);
   CONTINUUM LEFT(I)  =  CONTINUUM LEFT(I+1);
   CONTINUUM SIZE(I)  =  CONTINUUM SIZE(I+1);
   CONTINUUM CENTRE(I)=  CONTINUUM CENTRE(I+1);
   CONTINUUM FLUX(I)  =  CONTINUUM FLUX(I+1);   
   SIGMA FLUX(I)      =  SIGMA FLUX(I+1);   >
ICONT = ICONT - 1;
NOCONT = NOCONT - 1;
RETURN;
END;


SUBROUTINE ESTIMATE LINE CENTRES(LMIN,LMAX);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
INTEGER I,LMIN,LMAX;

FOR I = LMIN TO LMAX   <
   CENTRE(I) = CHANNEL(WAVELENGTH(I));
   >
RETURN;
END;


SUBROUTINE ESTIMATE AND CHECK LINE CENTRES(NUMBER OF DIODES);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
INTEGER I,NUMBER OF DIODES;

FOR I = 1 TO NUMBER OF LINES   <
   CENTRE(I) = CHANNEL(WAVELENGTH(I));
   IF INT(CENTRE(I)) .LT. 3  .OR.  INT(CENTRE(I)) .GT. NUMBER OF DIODES - 2   <
      REMOVE FROM LIST(I);
      I = I - 1;   >
   >
RETURN;
END;


SUBROUTINE MERGE TELLURIC LINES INTO LINELIST;

IMPLICIT REAL*8(A-H,O-Z);

INTEGER I,K;
CHARACTER*10 ID;
COMMON-BLOCK-TELLURIC;
COMMON-BLOCK-LINES;

K = 1;  ID = 'TELLURIC  ';

FOR I = 1 TO NUMBER OF LINES + NH2O - 1   <
   IF H2OCENT(K) .LE. CENTRE(I)   <
      WAVE = WAV(H2OCENT(K));
      INSERT BEFORE LINE(I,ID,WAVE,H2OCENT(K),H2OFWHM(K),H2ODEEP(K));
      K = K + 1;   >
   ELSEIF I .GE. NUMBER OF LINES + K - 1   <
      EXIT;   >
   > UNTIL K .GT. NH2O;
IF K .GT. NH2O   <  RETURN;  >
FOR N = K TO NH2O   <
   I = I + 1;
   WAVE = WAV(H2OCENT(N));
   INSERT BEFORE LINE(I,ID,WAVE,H2OCENT(N),H2OFWHM(N),H2ODEEP(N));   >
RETURN;
END;


SUBROUTINE INSERT BEFORE LINE(I,ID,WAVE,CENT,WIDTH,DEEP);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
REAL*8 PI;
CHARACTER*10 ID;
INTEGER I,J,K;

IF NUMBER OF LINES .EQ. MAX LINES   <
   OUTPUT(8)ID,WAVE;
   ('ERROR: COULD NOT INSERT LINE WITH ID ',A10,' AT ',F9.3,' A.');
   RETURN;   >
FOR J = NUMBER OF LINES TO I BY -1   <
   LINE ID(J+1) = LINE ID(J);
   WAVELENGTH(J+1) = WAVELENGTH(J);
   ATOM(J+1) = ATOM(J);
   EPLOW(J+1) = EPLOW(J);
   GF(J+1) = GF(J);
   ILEFT(J+1) = ILEFT(J);
   IRIGHT(J+1) = IRIGHT(J);
   LEFT DIODE(J+1) = LEFT DIODE(J);
   RIGHT DIODE(J+1) = RIGHT DIODE(J);
   WEAK(J+1) = WEAK(J);
   BLEND(J+1) = BLEND(J);
   EW(J+1) = EW(J);
   CENTRE(J+1) = CENTRE(J);
   DEPTH(J+1) = DEPTH(J);
   FWHM(J+1) = FWHM(J);
   DELTA_EW(J+1) = DELTA_EW(J);
   DELTA_RV(J+1) = DELTA_RV(J);
   >
LINE ID(I) = ID;
WAVELENGTH(I) = WAVE;
CENTRE(I) = CENT;
FWHM(I) = WIDTH;
DEPTH(I) = DEEP;
ATOM(I) = 0.0;
GF(I) = 0.0;
ILEFT(I) = 0;
IRIGHT(I) = 0;
LEFT DIODE(I) = 0.0;
RIGHT DIODE(I) = 0.0;
PI = 3.141592654D+0;
EW(I) = DEPTH(I)*FWHM(I)*DISP*1000.0*0.60056121*DMYSQ(PI);
DELTA_RV(I) = 0.0;
DELTA_EW(I) = 0.0;
NUMBER OF LINES = NUMBER OF LINES + 1;
FOR J = 1 TO NUMBER OF GOOD LINES   <
   IF GOOD(J) .GE. I   <
      FOR K = J TO NUMBER OF GOOD LINES   <
         GOOD(K) = GOOD(K) + 1;   >
      EXIT;   >
   >
WEAK(I) = .FALSE.;
BLEND(I) = 0;
RETURN;
END;


SUBROUTINE REMOVE FROM LIST(LINE);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-TELLURIC;
COMMON-BLOCK-LINES;
INTEGER LINE,I;


IF LINE .NE. 1   <
   IF BLEND(LINE-1) .EQ. 2   <
      BLEND(LINE-1) = -1;   >
   ELSEIF BLEND(LINE-1) .EQ. 1   <
      BLEND(LINE-1) = 0;   >
   >
IF LINE .NE. NUMBER OF LINES   <
   IF BLEND(LINE+1) .EQ. 2   <
      BLEND(LINE+1) = 1;   >
   ELSEIF BLEND(LINE+1) .EQ. -1   <
      BLEND(LINE+1) = 0;   >
   >
IF TELLURIC PRESENT  .AND. LINE ID(LINE) .EQ. 'TELLURIC  '   <
   INDEX = 1;
   FOR I = 1 TO LINE - 1   <
      IF LINE ID(I) .EQ. 'TELLURIC  '   <
         INDEX = INDEX + 1;   >
      >
   FOR I = INDEX TO NH2O - 1   <
      H2OCENT(I) = H2OCENT(I+1);
      H2OFWHM(I) = H2OFWHM(I+1);
      H2ODEEP(I) = H2ODEEP(I+1);   >
   NH2O = NH2O - 1;   >
FOR I = LINE TO NUMBER OF LINES   <
   CENTRE(I) = CENTRE(I+1);
   FWHM(I)   = FWHM(I+1);
   DEPTH(I)  = DEPTH(I+1);
   WAVELENGTH(I) = WAVELENGTH(I+1);
   LINE ID(I) = LINE ID(I+1);
   EPLOW(I) = EPLOW(I+1);
   GF(I) = GF(I+1);
   ATOM(I) = ATOM(I+1);
   WEAK(I) = WEAK(I+1);
   BLEND(I)= BLEND(I+1);
   LEFT DIODE(I) = LEFT DIODE(I+1);
   RIGHT DIODE(I)= RIGHT DIODE(I+1);
   EW(I) = EW(I+1);
   DELTA_EW(I) = DELTA_EW(I+1);
   DELTA_RV(I) = DELTA_RV(I+1);
   ILEFT(I) = ILEFT(I+1);
   IRIGHT(I) = IRIGHT(I+1);   >UNTIL I .GE. NUMBER OF LINES - 1;
NUMBER OF LINES = NUMBER OF LINES - 1;

"
I think that this code is just WRONG, so I am replacing it below:

FOR I = 1 TO NUMBER OF GOOD LINES   <
   IF GOOD(I) .GT. LINE   <
      INDEX = 0;   >
   ELSEIF GOOD(I) .EQ. LINE   <
      NUMBER OF GOOD LINES = NUMBER OF GOOD LINES - 1;
      INDEX = 1;   >
   ELSE   <  NEXT;  >
   FOR J = I TO NUMBER OF GOOD LINES   <
      GOOD(J) = GOOD(J+INDEX) - 1;   >
   EXIT;
   >
"

" Now the replacement code "

FOR I = 1 TO NUMBER OF GOOD LINES   <
   IF GOOD(I).EQ.LINE   <
      REMOVE LINE FROM GOOD LIST(LINE);   
      RETURN;   >
   ELSEIF GOOD(I).GT.LINE   <  RETURN;  >
   >
RETURN;
END;


SUBROUTINE REMOVE LINE FROM GOOD LIST(LINE);

IMPLICIT REAL*8(A-H,O-Z);
COMMON-BLOCK-LINES;

INTEGER I,J,LINE;

FOR I = 1 TO NUMBER OF GOOD LINES   <
   IF GOOD(I) .EQ. LINE   <
      NUMBER OF GOOD LINES = NUMBER OF GOOD LINES - 1;
      FOR J = I TO NUMBER OF GOOD LINES   <
         GOOD(J) = GOOD(J+1);
         DELTA_RV(J) = DELTA_RV(J+1);   >
      RETURN;
      >
   >
RETURN;
END;


SUBROUTINE FIT CONTINUUM;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-SPECTRUM;
COMMON-BLOCK-IMAGE;

IF OLD_CONTINUUM .AND. CONT ORDER(CURRENT_IMAGE_ROW).NE.0   <
   RETURN; >
ELSE  <
   COMPUTE CONTINUUM CENTRES AND FLUX VALUES;
   PERFORM FIT; >
RETURN;
END;




SUBROUTINE COMPUTE CONTINUUM CENTRES AND FLUX VALUES;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-SPECTRUM;

REAL*8 AVG,SNSIG,SNR;
LOGICAL CONTINUUM IS BAD,BAD DIODE;
INTEGER I,J,K,MIDDLE;

"  Set up continuum arrays  "
IF AUTO CONTINUUM   <
   ISTEP = CONTINUUM RIGHT(1);
   NOCONT = NUMBER OF DIODES/CONTINUUM RIGHT(1);
   IF NOCONT .GT. MAX CONT  <
      OUTPUT(8);(' CONTINUUM BUFFER MAXIMUM REACHED');
      OUTPUT(8)NOCONT,MAX CONT;
      (I3,1X,30H CONTINUA USED, MAX ALLOWED IS,1X,I3);
      NOCONT = MAX CONT;   
      >
   FOR I = 2 TO NOCONT   <
      CONTINUUM LEFT(I) = CONTINUUM RIGHT(I-1) - CONTINUUM SIZE(1) + 1;
      CONTINUUM RIGHT(I) = CONTINUUM RIGHT(I-1) + ISTEP;   
      CONTINUUM SIZE(I) = CONTINUUM SIZE(1);
      >
   CONTINUUM RIGHT(NOCONT) = NUMBER OF DIODES;
   >
         
FOR J = 1 TO NOCONT   <
   IF CONTINUUM IS BAD(J)   <
      OUTPUT(8)J;('CONTINUUM NO. ',I3,' REMOVED DUE TO BAD DIODES');
      REMOVE CONTINUUM POINT(J);
      NEXT;   >
   CONTINUUM FLUX(J) = 0.0;
   FOR I = CONTINUUM LEFT(J) TO CONTINUUM RIGHT(J)-CONTINUUM SIZE(J)+1  <
      SXI = 0.0;
      SXIWI = 0.0;
      SXI2 = 0.0;
      SNSIG = 0.0;
      MIDDLE = 0;
      ANUM = 0.0;
      FOR K = 1 TO CONTINUUM SIZE(J)   <
         IF .NOT. BAD DIODE(I+K-1)   <
            MIDDLE = MIDDLE + I+K-1;
            SXIWI = SXIWI + SPEC(I+K-1)*SNR(I+K-1)**2;
            SXI  = SXI + SPEC(I+K-1);
            SXI2 = SXI2 + SPEC(I+K-1)**2;
            SNSIG = SNSIG + SNR(I+K-1)**2;
            ANUM = ANUM + 1.0;
            >
         > 
      AVG = SXIWI/SNSIG;
      SNSIG = 1.D0/DSQRT(SNSIG);
      IF CONTINUUM SIZE(J).GT.1   <
         CSIG = DMYSQ( ( SXI2 - (SXI**2)/ANUM )/(ANUM-1.0) );   
         CSIG = CSIG/DMYSQ(ANUM);     
         >
      IF AVG .GE. CONTINUUM FLUX(J)   <
         CONTINUUM FLUX(J) = AVG;
         SIGMA FLUX(J) = CSIG;
         IF CSIG.LT. AVG*SNSIG  <  
            SIGMA FLUX(J) = AVG*SNSIG;   
            >
         CONTINUUM CENTRE(J) = DBLE(MIDDLE)/ANUM;   
         >
      >
   IF CONTINUUM FLUX(J) .LE. 0.0   <
      OUTPUT(8)J;('CONTINUUM NO. ',I3,' REMOVED: ZERO OR NEGATIVE FLUX');
      REMOVE CONTINUUM POINT(J);
      NEXT;   >
   >

IF AUTO CONTINUUM   <
  " Removing this routine to cure bad continuum problems AMCW 1/99
   LOWER CONTINUUM(NUMBER OF DIODES);
  "
   >
RETURN;
END;


"
old function more complex and less useful

LOGICAL FUNCTION CONTINUUM IS BAD(ICONT);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-BADDIODE;

CONTINUUM IS BAD = .FALSE.;
IF NOBAD .EQ. 0   <  RETURN;  >
FOR IBAD = 1 TO NOBAD   <
   IF CONTINUUM LEFT(ICONT) .LE. BAD RIGHT(IBAD)  .AND.
      CONTINUUM LEFT(ICONT) .GE. BAD LEFT(IBAD)   <
      IF CONTINUUM RIGHT(ICONT) .LE. BAD RIGHT(IBAD)   <
         CONTINUUM IS BAD = .TRUE.;
         RETURN;   >
      OVERLAP = BAD RIGHT(IBAD) - CONTINUUM LEFT(ICONT) + 1;
      IF CONTINUUM SIZE(ICONT)-OVERLAP .LT. 1   <
         CONTINUUM IS BAD = .TRUE.;   >
      CONTINUUM SIZE(ICONT) = CONTINUUM SIZE(ICONT) - OVERLAP;
      >
   ELSEIF CONTINUUM RIGHT(ICONT) .LE. BAD RIGHT(IBAD)  .AND.
          CONTINUUM RIGHT(ICONT) .GE. BAD LEFT(IBAD)   <
          OVERLAP = CONTINUUM RIGHT(ICONT) - BAD LEFT(IBAD) + 1;
          IF CONTINUUM SIZE(ICONT)-OVERLAP .LT. 1   <
             CONTINUUM IS BAD = .TRUE.;
             RETURN;   >
          CONTINUUM SIZE(ICONT) = CONTINUUM SIZE(ICONT) - OVERLAP;
          >
   >
RETURN;
END;
"



LOGICAL FUNCTION CONTINUUM IS BAD(ICONT);
"
 For a continuum window region, if the number of pixels in subwindow is
 more than 50% of the subwindow, then continuum is bad.
"
IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-BADDIODE;

LOGICAL BAD DIODE;
INTEGER I,J,NBAD_PIX,ICONT;

CONTINUUM IS BAD = .FALSE.;
IF NOBAD .EQ. 0   <  RETURN;  >
FOR I=CONTINUUM LEFT(ICONT) TO CONTINUUM RIGHT(ICONT)-CONTINUUM SIZE(ICONT)+1 <
   NBAD_PIX = 0;
   FOR J = 1 TO CONTINUUM SIZE(ICONT)   <
      IF BAD DIODE(I+J-1)  <  NBAD_PIX = NBAD_PIX + 1;  >
      >
   IF NBAD_PIX .GT. CONTINUUM SIZE(ICONT)-NBAD_PIX   <
      CONTINUUM IS BAD = .TRUE.;
      RETURN;
      >
   >
RETURN;
END;








LOGICAL FUNCTION BAD DIODE(IPOINT);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-BADDIODE;

INTEGER I,IPOINT;
BAD DIODE = .FALSE.;
IF NOBAD .EQ. 0   <  RETURN;  >
FOR I = 1 TO NOBAD   <
   IF IPOINT .GE. BAD LEFT(I)  .AND.  IPOINT .LE. BAD RIGHT(I)   <
      BAD DIODE = .TRUE.;
      RETURN;   >
   >
RETURN;
END;


SUBROUTINE PERFORM FIT;

IMPLICIT REAL*8(A-H,O-Z);
 
REAL*8 X(1000),Y(1000),SIGMA(1000),ADUM(50),COVAR(50,50);

COMMON-BLOCK-FLAGS;
COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-CONT-FIT;
COMMON-BLOCK-IMAGE;

IF DEFAULT   <
   SET FLAGS(NOCONT);   >
IF FITCON  <
   CONT ORDER(CURRENT_IMAGE_ROW) = 0;

"  set up continuum points into arrays "

   IF NOCONT.GE.1   <
      FOR J = 1 TO NOCONT   <
         Y(J) = CONTINUUM FLUX(J);
         X(J) = CONTINUUM CENTRE(J);
         SIGMA(J) = SIGMA FLUX(J);    >

" fit continuum with average and compute Chi**2  "

      IORD = 1;
      POLYNOMIAL FIT(X,Y,SIGMA,IORD,ADUM,COVAR,CHISQ,NOCONT);
      FOR ITERM = 1 TO IORD   <
         ACON(ITERM,CURRENT_IMAGE_ROW) = ADUM(ITERM);   >
      NFREE  = NOCONT-IORD;
      GET 3 SIGMA CHISQ(NFREE,CHI3SIG);
      OCHI_RATIO = CHISQ / CHI3SIG;
      CONT ORDER(CURRENT_IMAGE_ROW) = IORD;

" make fits with higher orders; if new chi**2 is lower then use new fit "

      FOR IORD = 2 TO 5   <
         IF 3*(IORD+1) .GT. NOCONT  < EXIT;   >
         POLYNOMIAL FIT(X,Y,SIGMA,IORD,ADUM,COVAR,CHISQ,NOCONT);
         NFREE  = NOCONT-IORD;
         GET 3 SIGMA CHISQ(NFREE,CHI3SIG);
         CHI_RATIO = CHISQ / CHI3SIG;
         IF CHI_RATIO .LT. OCHI_RATIO*0.80  <
            FOR ITERM = 1 TO IORD   <
               ACON(ITERM,CURRENT_IMAGE_ROW) = ADUM(ITERM);   >
            OCHI_RATIO = CHI_RATIO;
            CONT ORDER(CURRENT_IMAGE_ROW) = IORD;   >
         ELSEIF CHI_RATIO .GT. OCHI_RATIO  <
            EXIT;   >
         >
      >
   ELSE   <
      CONT ORDER(CURRENT_IMAGE_ROW) = 1;
      ACON(1,CURRENT_IMAGE_ROW) = 1.0;   >
   >

CHI_SCALE = OCHI_RATIO;
"
  Code below is ancient stuff, and maybe should be removed someday.
  Further development of the continuum routines should be pursued also; 
  e.g. allow spline fits; allow interactive addition of continuum regions.
"
IF CFLAG.EQ.1  .AND.  NOCONT.GE.3   <
   FIT PARABOLA(CONTINUUM CENTRE,CONTINUUM FLUX,NOCONT,A,B,C);   >
ELSEIF CFLAG.EQ.2  .AND.  NOCONT.GE.2   <
   FIT LINE(CONTINUUM CENTRE,CONTINUUM FLUX,NOCONT,A,B);   >
ELSEIF CFLAG.EQ.3  .AND.  NOCONT.GE.1   <
   AVERAGE(CONTINUUM FLUX,NOCONT,A);   >
RETURN;
END;


SUBROUTINE LOWER CONTINUUM(NUMBER OF DIODES);
"
This routine will iterate on a continuum.  The method finds high points to
define the first continuum estimate, then it estimates the fraction of the
spectrum affected by line blanketing.  The average height that the estimated 
continuum lies above the true continuum is computed based on the number of
continuum pixels and the S/N.  The iteration can be continued in successive runs
by increasing the bin size; the continuum fraction, fc, and the true continuum
levels should agree.
"
IMPLICIT REAL*8 (A-H,O-Z);
REAL*8 SNR;
INTEGER MIDDLE;
LOGICAL BAD DIODE;

COMMON-BLOCK-CONTINUUM;

"  Get first continuum fraction estimate, fc."
CWINDOW = DBLE( CONTINUUM RIGHT(1) );
CBIN = DBLE( CONTINUUM SIZE(1) );
ILOW = 0;
NBAD = 0;
PROB = ( 0.5/(CWINDOW-CBIN+1.0) )**(1.0/CBIN);
GET NUMBER OF SIGMA(PROB,ANSIG);

" no longer used AMcW 4/96
  CUTOFF =  (ANSIG+1.0)/SN;
"

FOR I = 101 TO NUMBER OF DIODES - 100   <
   CUTOFF =  (ANSIG+1.0)/SNR(I);   "included 1.0 sigma below mean"
   DIODE = DBLE(I);
   IF .NOT.BAD DIODE(I)   <
      IF SPEC(I).LE.CONTINUUM(DIODE)-CUTOFF   <
         ILOW = ILOW + 1;   >
      >
   ELSE   <
      NBAD = NBAD + 1;   
      >
   >
FC = 1.0 - DBLE(ILOW)/DBLE(NUMBER OF DIODES - NBAD - 200);
"
 Now correct for pixels more than 1 sigma below mean
"
 FC = FC/0.84;
"  Compute the approximate height of the estimated continuum over the true
   continuum

Find number of line features by dividing lined pixel number by a typical 
 line base width, of 6 pixels
"
NLIN = CWINDOW*(1.0-FC)/6.0;
IF NLIN .LT. 1   <  NLIN = 0;  >
CSIZE = (CWINDOW-CBIN+1.0)*FC/(NLIN+1);   
IF CSIZE.GE.CBIN   <
   NBINS = (CWINDOW-CBIN+1.0)*FC/CBIN;
   PROB = ( 0.5/NBINS )**(1.0/CBIN);   >
ELSE   <
   PROB = ( 0.5/((CWINDOW-CBIN+1.0)*(2.0*FC)**(CBIN-1.0)) )**(1.0/CBIN);   >
GET NUMBER OF SIGMA(PROB,ANSIG);
MIDDLE = NINT( CONTINUUM CENTRE(NOCONT) - CONTINUUM CENTRE(1) );        
HEIGHT = (ANSIG)/SNR(MIDDLE);
PERCNT = HEIGHT*100.0;
IF PROB.LE.0.50   <
   WRITE(6,'(28H Shifting continuum down by ,F5.2,8H percent)')PERCNT;    >
ELSE   <
   WRITE(6,'(26H Shifting continuum up by ,F5.2,8H percent)')PERCNT;    >
FOR I = 1 TO NOCONT   <
      HEIGHT = (ANSIG)/SNR(NINT(CONTINUUM CENTRE(I)));        
      FACTOR = 1.0-HEIGHT;   
      CONTINUUM FLUX(I) = CONTINUUM FLUX(I)*FACTOR;   >
RETURN;
END;
   

SUBROUTINE GET NUMBER OF SIGMA(PROB,ANSIG);
"
A simple routine to find the number of sigma from the mean for a certain
probability.
"
IMPLICIT REAL*8 (A-H,O-Z);
INTEGER I;

IF (PROB.GT.0.50)   <
   P = 1.0 - PROB;    >
ELSE   <
   P = PROB;   >
ANSIG = 0.0;
STEP = 1.0;
PROB1 = ERFCC(ANSIG)/2.0;
FOR I = 1 TO 10000   <
   ANSIG = ANSIG + STEP;
   PROB2 = ERFCC(ANSIG)/2.0;
   IF PROB1.GE.P  .AND.  PROB2.LE.P   <
      ANSIG = ANSIG - STEP;
      STEP = STEP/10.0;   >
   ELSE   <
      PROB1 = PROB2;   >
   >UNTIL STEP.LE.0.0001;
ANSIG = DMYSQ(2.0D+00)*(ANSIG + STEP/2.0);
IF PROB.GT.0.5   <  
   ANSIG = -ANSIG;   >
RETURN;
END;
   

REAL*8 FUNCTION ERFCC(ANSIG);
"
Fit to the Complementary Error Function erfc(x) from Numerical Recipes
"
IMPLICIT REAL*8 (A-H,O-Z);
Z = DABS(ANSIG);
T = 1.0/(1.0+0.5*Z);
ERFCC = T*DEXP(-Z*Z-1.26551223+T*(1.00002368+T*(0.37409196+T*(0.09678418+
              T*(-0.18628806+T*(0.27886807+T*(-1.13520398+T*(1.48851587+
              T*(-0.82215223+T*0.17087277)))))))));
IF ANSIG.LT.0.0   <  ERFCC=2.0-ERFCC;  >
RETURN;
END;


SUBROUTINE AVERAGE(VALUE,I,A);

IMPLICIT REAL*8(A-H,O-Z);
REAL*8 VALUE(100),A;
INTEGER I;
A = 0.0;
FOR J = 1 TO I   <
   A = VALUE(J)/DBLE(I) + A;   >
RETURN;
END;


SUBROUTINE SET FLAGS(NOCONT);

IMPLICIT REAL*8(A-H,O-Z);

" CFLAG IS THE CONTINUUM FITTING FLAG WHICH CAN HAVE AN INTEGER VALUE
    UP TO FIVE.

   1 :   FIT A PARABOLA TO THE CONTINUUM REGIONS
   2 :   FIT A STRAIGHT LINE
   3 :   TAKE A SIMPLE AVERAGE OF CONTINUUM REGIONS
   4 :   INTERPOLATE BETWEEN THE CLOSEST BLUE & RED REGIONS
   5 :   AVERAGE THE CLOSEST BLUE & RED REGIONS

   EFLAG IS THE EXTRAPOLATION FLAG.  IE DETERMINES THE METHOD USED
    TO GET CONTINUUM POINTS BEYOND THE FIRST & LAST CONTINUUM REGIONS

   1 :   STRAIGHT LINE EXTRAPOLATION FROM FIRST OR LAST TWO REGIONS
   2 :   USE THE VALUE OF THE FIRST OR LAST CONTINUUM REGION
   3 :   JUST CONTINUE THE STRAIGHT LINE FIT (CFLAG MUST BE SET TO 2)

"

COMMON-BLOCK-FLAGS;
INTEGER NOCONT;

IF NOCONT.GE.6   <
   CFLAG = 4;
   EFLAG = 2;   >
ELSEIF NOCONT.GE.3   <
   CFLAG = 2;
   EFLAG = 2;   >
ELSE   <
   CFLAG = 3;
   EFLAG = 2;   >
RETURN;
END;


SUBROUTINE FIND CENTRAL DIODE NUMBER AND DEPTH(LINE,A,COV,DELETED);
IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-FLAGS;
COMMON-BLOCK-SPECTRUM;

INTEGER LINE,START,END,I,ICENTRE,INDEX,STEP;
REAL*8 A(9),COV(9,9),X(200),PHOTONS,SINGLE(9),SNR;
LOGICAL FIRST,BAD DIODE,DELETED;
DATA SINGLE/3*1.0,6*0.0/;

DELETED = .FALSE.;
FIRST = .TRUE.;
"
 commented out by AMcW Jan.1992
GUESS LINE CENTRE(LINE,CENTRE(LINE),FIRST);
"
SINGLE(1) = 1.0;     SINGLE(2) = 1.0;    SINGLE(3) = 1.0;
IF INST_PROF  < SINGLE(3) = 0.0;  >

CENTRE(LINE) = CHANNEL(WAVELENGTH(LINE));
ICENTRE=NINT(CENTRE(LINE));
START = ICENTRE - 1;  END = ICENTRE + 1;
IF ILEFT(LINE) .EQ. 1  .OR. ILEFT(LINE) .EQ. -1   <
   START = ICENTRE - 1;   >
ELSEIF ILEFT(LINE) .LE. -2   <
   START = ICENTRE;   >
IF IRIGHT(LINE) .EQ. 1  .OR.  IRIGHT(LINE) .EQ. -1   <
   END   = ICENTRE + 1;   >
ELSEIF IRIGHT(LINE) .LE. -2   <
   END   = ICENTRE;   >
FOR I = START TO END  <
   IF SPEC(I) .LT. SPEC(ICENTRE) .AND. .NOT. BAD DIODE(I)   <
      ICENTRE = I;   >
   >
IF BAD DIODE(ICENTRE)   <
   ILEFT(LINE) = -1;
   IRIGHT(LINE)= -1;
   REMOVE FROM LIST(LINE);
   DELETED = .TRUE.;
   RETURN;   >

IF SPEC(ICENTRE).GT.0.0   <
   CFLUX = SNR(ICENTRE)**2 * CONTINUUM(DBLE(ICENTRE))/SPEC(ICENTRE);
   DFLUX = DMYSQ( CFLUX + CONTINUUM_UNCERTAINTY(ICENTRE)**2 );   >
ELSE   <  
   CFLUX = SN**2;
   DFLUX = 0.0;   >

IF SNR(ICENTRE)**2 .GT. CFLUX-2.0*DFLUX   <
   OUTPUT(8)WAVELENGTH(LINE),LINE ID(LINE);
   (' LINE AT ',F9.3,' A WITH ID ',A10,' IS TOO WEAK TO BE MEASURED PROPERLY',/
    ,' THE LINE HAS BEEN REMOVED FROM THE LIST. ',/);
   REMOVE FROM LIST(LINE);
   DELETED = .TRUE.;
   RETURN; >
IF SNR(ICENTRE)**2 .GT. CFLUX-4.0*DFLUX   <
   WEAK(LINE) = .TRUE.;
   OUTPUT(8)WAVELENGTH(LINE),LINE ID(LINE);
   (' LINE AT ',F9.3,' A WITH ID ',A10,' IS TOO WEAK TO BE MEASURED PROPERLY',/
    ,' THE EQUIVALENT WIDTH WILL BE AN ESTIMATE ONLY. ',/);
   REMOVE LINE FROM GOOD LIST(LINE);
   RETURN;
   >
IF SNR(ICENTRE)**2 .GT. CFLUX-6.0*DFLUX   <
   REMOVE LINE FROM GOOD LIST(LINE);   >
IF ILEFT(LINE) .LT. 0   <
   IF IRIGHT(LINE) .LT. 0   <
      RIGHT DIODE(LINE) = DBLE(ICENTRE);
      RETURN;   >
   LEFT DIODE(LINE) = DBLE(ICENTRE);   >
IF IRIGHT(LINE) .LT. 0   <
   RIGHT DIODE(LINE) = DBLE(ICENTRE);  >

"  FITTING A GAUSSIAN TO BOTTOM POINTS WILL GIVE CENTRE AND DEPTH "

LAST = 0;  NEXT = 0;
IF LINE .GT. 1   <
   LAST = NINT( CHANNEL(WAVELENGTH(LINE-1)) );   >
IF LINE .LT. NUMBER OF LINES   <
   NEXT = NINT( CHANNEL(WAVELENGTH(LINE+1)) );   >
STEP = -1;
DETERMINE LIMIT(ICENTRE,STEP,LEFT DIODE(LINE),NUMBER OF DIODES,LAST,
                WAVELENGTH(LINE),LINE ID(LINE));
STEP =  1;
DETERMINE LIMIT(ICENTRE,STEP,RIGHT DIODE(LINE),NUMBER OF DIODES,NEXT,
                WAVELENGTH(LINE),LINE ID(LINE));
IF LEFT DIODE(LINE).EQ.DBLE(ICENTRE) .OR. RIGHT DIODE(LINE).EQ.DBLE(ICENTRE)  <
   IF LEFT DIODE(LINE) .EQ. DBLE(ICENTRE)   <
      LEFT DIODE(LINE) = DNINT(CENTRE(LINE));
      ILEFT(LINE) = -1;   >
   IF RIGHT DIODE(LINE) .EQ. DBLE(ICENTRE)   <
      RIGHT DIODE(LINE) = DNINT(CENTRE(LINE));
      IRIGHT(LINE) = -1;   >
   REMOVE LINE FROM GOOD LIST(LINE);
   RETURN;   >
TEST SET LIMIT(ICENTRE,LEFT DIODE(LINE),ILEFT(LINE),WAVELENGTH(LINE));
TEST SET LIMIT(ICENTRE,RIGHT DIODE(LINE),IRIGHT(LINE),WAVELENGTH(LINE));
INDEX = INT(LEFT DIODE(LINE));
IEND  = INT(RIGHT DIODE(LINE));
SET UP POINTS(X,INDEX,IEND,N);
FIRST GUESS FOR A VALUES(X,N,A,CENTRE(LINE),ICENTRE);
PHOTONS = SNR(ICENTRE)**2 * CONTINUUM(DBLE(ICENTRE))/SPEC(ICENTRE);
GAUSS FIT(X,A,N,PHOTONS,COV,SINGLE,CHISQ);
CENTRE(LINE) = A(2);  
"
   now compute sigmas and test center; center is refit if fit center is
   less certain than predicted center, or center is too far off due to a
   blend.

   The 1.333 factor is used to damp the transition from fit to rv -
    changed to 1.0000 for now
"
DXVEL = 1.0000 * SIGRV*WAVELENGTH(LINE)/(DISP*3.0D+05);
DXFIT = DMYSQ(COV(2,2));
DIFF = DABS(CHANNEL(WAVELENGTH(LINE)) - A(2));
IF ((DXFIT.GT.1.20*DXVEL  .OR.  (DIFF.GT. 3.0*DXVEL .AND. DIFF.GT. 3.0*DXFIT)) 
    .AND. DIFF*DISP.GT.0.02) .OR.
   (DIFF .GT. MAXSEP)   <
   A(2) = CHANNEL(WAVELENGTH(LINE));
   SINGLE(2) = 0.0;
   FOR I = 1 TO 3   <
      FOR J = 1 TO 3   <
         COV(I,J) = 0.0;   >
      >
   GAUSS FIT(X,A,N,PHOTONS,COV,SINGLE,CHISQ);  
   >
"
  now assign line parameters
"
DEPTH(LINE)  = A(1);
CENTRE(LINE) = A(2);
A1 = A(1);   A3 = A(3); NG=1;
COMPUTE DELTA EW(A1,A3,COV,SINGLE,NG,LINE);
SINGLE(2) = 1.0;  
IF DEPTH(LINE).GT.1.0   <
   DEPTH(LINE) = 1.0;  >
RETURN;
END;




REAL*8 FUNCTION CONTINUUM_UNCERTAINTY(ICENTRE);   
IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-IMAGE;

INTEGER ICENTRE;


IF NOCONT .EQ. 1   <
   CONTINUUM_UNCERTAINTY = SIGMA FLUX(1);
   RETURN;  >
ELSEIF NOCONT .EQ. 0  <   
   CONTINUUM_UNCERTAINTY = 0.0D0;   
   RETURN;  >

IF DBLE(ICENTRE) .LE. CONTINUUM CENTRE(1)   <
   CONTINUUM_UNCERTAINTY = SIGMA FLUX(1);   >
ELSEIF DBLE(ICENTRE) .GE. CONTINUUM CENTRE(NOCONT)   <
   CONTINUUM_UNCERTAINTY = SIGMA FLUX(NOCONT);   >
ELSE   <
   FOR I = 1 TO NOCONT   <
      IF DBLE(ICENTRE) .GE. CONTINUUM CENTRE(I)  .AND. 
         DBLE(ICENTRE) .LE. CONTINUUM CENTRE(I+1)   <
         CONTINUUM_UNCERTAINTY = 0.5D0*(SIGMA FLUX(I)+SIGMA FLUX(I+1));  >
      >
   >
FACTOR = CHI_SCALE /DMYSQ(DBLE(NOCONT-CONORD(CURRENT_IMAGE_ROW)));
CONTINUUM_UNCERTAINTY = CONTINUUM_UNCERTAINTY * FACTOR;
RETURN;
END;
   



SUBROUTINE FIRST GUESS FOR A VALUES(X,N,A,CENT,ICENT);

IMPLICIT REAL*8 (A-H,O-Z);
COMMON-BLOCK-FLAGS;

REAL*8 X(200),A(9);
INTEGER N,ICENT;

A(1) = 1.0 - SPEC(ICENT)/CONTINUUM(DBLE(ICENT));
A(2) = CENT;
DEEP = A(1);
WAVE = WAV(CENT);
IF FIXFWHM .OR. INST_PROF  <
   GET BEST FWHM(WAVE,DEEP,WIDTH,SIGWIDTH);
   A(3) = WIDTH*0.60056121;
>
ELSE   <
   DX1  = DABS(X(1)-CENT);
   DXN  = DABS(X(2*N-1)-CENT);
   Y1   = 1.0 - SPEC(INT(X(1)))/CONTINUUM(X(1));
   YN   = 1.0 - SPEC(INT(X(2*N-1)))/CONTINUUM(X(2*N-1));
   IF DX1.GT.DXN   <
      A(3) = DX1/DSQRT(-DLOG(Y1/A(1)));  >
   ELSE   <
      A(3) = DXN/DSQRT(-DLOG(YN/A(1)));  >
>
IF A(3).LT.1.20  <  A(3) = 1.20;  >
RETURN;
END;





"
old routine

SUBROUTINE FIRST GUESS FOR A VALUES(X,N,A,CENT,ICENT);

IMPLICIT REAL*8 (A-H,O-Z);
COMMON-BLOCK-FLAGS;

REAL*8 X(200),A(9);
INTEGER N,ICENT;

A(1) = 1.0 - SPEC(ICENT)/CONTINUUM(DBLE(ICENT));
A(2) = CENT;
DEEP = A(1);
WAVE = WAV(CENT);
IF FIXFWHM  <
   GET BEST FWHM(WAVE,DEEP,WIDTH,SIGWIDTH);   
   A(3) = WIDTH*0.60056121;   
>
ELSE   <
   YMAX = A(1);
   Y1   = 1.0 - SPEC(INT(X(1)))/CONTINUUM(X(1));
   YN   = 1.0 - SPEC(INT(X(2*N-1)))/CONTINUUM(X(2*N-1));
   DX1  = DABS(X(1)-CENT);
   DXN  = DABS(X(2*N-1)-CENT);
   WX1 = 0.5*YMAX * DX1 / (YMAX - Y1);
   WXN = 0.5*YMAX * DXN / (YMAX - YN);
   A(3) = (WX1 + WXN)*0.60056121;   
>
IF A(3).LT.1.20  <  A(3) = 1.20;  >
RETURN;
END;
"

SUBROUTINE GUESS LINE CENTRE(LINE,CENT,FIRST);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
INTEGER LINE;
LOGICAL FIRST;
REAL*8 CENT,CENT1,CENT2,WAVE1,WAVE2;

"
  This routine should be replaced by the wavelength calibration, so the
  next line of code replaces the routine.
"
CENT = CHANNEL(WAVELENGTH(LINE));
RETURN;

"  The following code is the old routine "

CENT1 = 0.0;
IF LINE .NE. NUMBER OF LINES  .AND. .NOT. FIRST   <
   FOR NEXT = LINE+1 TO NUMBER OF LINES   <
      IF ILEFT(NEXT) .GE. 0  .AND.  IRIGHT(NEXT) .GE. 0 .AND.
         LINE ID(NEXT) .NE. 'TELLURIC  '  <
         CENT1 = CHANNEL(WAVELENGTH(LINE)) - CHANNEL(WAVELENGTH(NEXT));
         CENT1 = CENT1 + CENTRE(NEXT);
         WAVE1 = WAVELENGTH(NEXT);
         EXIT;   >
      >
   >
CENT2 = 0.0;
IF LINE .NE. 1   <
   FOR LAST = LINE-1 TO 1 BY -1   <
      IF ILEFT(LAST) .GE. 0  .AND.  IRIGHT(LAST) .GE. 0  .AND.
         LINE ID(LAST) .NE. 'TELLURIC  '   <
         CENT2 = CHANNEL(WAVELENGTH(LINE)) - CHANNEL(WAVELENGTH(LAST));
         CENT2 = CENT2 + CENTRE(LAST);
         WAVE2 = WAVELENGTH(LAST);
         EXIT;   >
      >
   >
IF CENT1 .NE. 0.0  .AND.  DABS( CENT1-CHANNEL(WAVELENGTH(LINE)) ) .LT. 1.5   <
   IF CENT2 .NE. 0.0  .AND.  DABS( CENT2-CHANNEL(WAVELENGTH(LINE)) ) .LT. 1.5  <
      CENT = ( CENT1*(WAVELENGTH(LINE)-WAVE2) + CENT2*(WAVE1-WAVELENGTH(LINE)) )
             / (WAVE1-WAVE2);   >
   ELSE   <
      CENT = CENT1;   >
   >
ELSEIF CENT2.NE.0.0  .AND.  DABS( CENT2-CHANNEL(WAVELENGTH(LINE)) ).LT.1.5   <
   CENT = CENT2;   >
ELSE   <
   CENT = CHANNEL( WAVELENGTH(LINE) );   >
RETURN;
END;


SUBROUTINE TEST SET LIMIT(ICENTRE,LIMIT,ILIMIT,WAVE);

IMPLICIT REAL*8(A-H,O-Z);
INTEGER ICENTRE,ILIMIT;
REAL*8 LIMIT,WAVE;

IF IABS( ICENTRE-INT(LIMIT) ) .GT. ILIMIT  .AND.  ILIMIT .NE. 0   <
   IF INT(LIMIT) .LT. ICENTRE   <
      OUTPUT(8)WAVE;
      (' WARNING FOR LINE AT ',F9.3,' ILL DEFINED GAUSSIAN MAY RESULT FROM ',
       'USE OF LEFT LIMIT');
      LIMIT = DBLE(ICENTRE-ILIMIT);   >
   ELSE   <
      OUTPUT(8)WAVE;
      (' WARNING FOR LINE AT ',F9.3,' ILL DEFINED GAUSSIAN MAY RESULT FROM',
       ' USE OF RIGHT LIMIT');
      LIMIT = DBLE(ICENTRE+ILIMIT);   >
   >
RETURN;
END;


SUBROUTINE DETERMINE LIMIT(ICENTRE,STEP,LIMIT,NUMBER,NEXT,WAVE,ID);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 LIMIT,YCEN,DYCEN,Y,DY,YOLD,WAVE;
INTEGER ICENTRE,STEP,INDEX,NUMBER,NEXT;
CHARACTER*(10) ID;
LOGICAL BAD DIODE;

YCEN = SPEC(ICENTRE)/CONTINUUM(DBLE(ICENTRE));
IF YCEN.GT.0.0   <
   DYCEN = YCEN/SNR(ICENTRE);   >
ELSE   <
   DYCEN = 0.0;   >
FOR INDEX = ICENTRE + STEP TO ICENTRE + STEP * MAX WIDTH BY STEP   <
   IF INDEX .LT. 1  .OR.  INDEX .GT. NUMBER   <  EXIT;  >
   Y = SPEC(INDEX)/CONTINUUM(DBLE(INDEX));      
   IF Y.GT.0.0  <
      DY = Y/SNR(INDEX);   >
   ELSE <   DY = 0.0;   >
   "   CHECK FOR OVERLAPPING LINES   "
   IF STEP .EQ. -1  .AND. NEXT .NE. 0   <
      IF INDEX .LE. NEXT   <  EXIT;  >
      >
   ELSEIF STEP .EQ. 1  .AND.  NEXT .NE. 0   <
      IF INDEX .GE. NEXT   <  EXIT;  >
      >
   IF BAD DIODE(INDEX)   <
      OUTPUT(8)INDEX,WAVE;
      (' BAD DIODE NO. ',I4,' RUINS HALF OF LINE AT ',F9.3,' A');
      LIMIT = DBLE(ICENTRE);
      RETURN;   >
   "   CHECK FOR LINE CENTRE DEFINITION   "
   IF Y-2.0*DY .GT. YCEN+2.0*DYCEN   <
      LIMIT = DBLE(INDEX);
      RETURN;   >
   "   LINE TURNING DOWN   "
   IF YCEN-2.0*DYCEN .GT. Y+2.0*DY  <  EXIT;  >
   "   WATCH FOR WEAK LINES   "
   IF Y + DY .GT. 1.00   <
      LIMIT = DBLE(ICENTRE);
   OUTPUT(8)WAVE,ID;
   (' LINE AT ',F9.3,' A WITH ID ',A10,' IS TOO WEAK TO BE MEASURED PROPERLY',
    /,' THE EQUIVALENT WIDTH WILL BE AN ESTIMATE ONLY.',/);
      RETURN;   >
   >
LIMIT = DBLE(ICENTRE);
OUTPUT(8)WAVE,ID;
(' LINE AT ',F9.3,' A WITH ID ',A10,' IS ILL DEFINED OR TOO WIDE. '
 ,/,' THE EQUIVALENT WIDTH WILL BE AN ESTIMATE ONLY. ');
RETURN;
END;





SUBROUTINE OBTAIN FWHM (LINE,A,COV,NUMBER OF DIODES);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-FLAGS;

INTEGER STEP,LINE,N,I,J,NUMBER OF DIODES;
REAL*8 A(9),COV(9,9),SINGLE(9),SIGMAR,SIGMAL,DELTAR,DELTAL,RIGHT,LEFT;
DATA SINGLE/9*0.0/;

IF ILEFT(LINE) .LT. 0  .OR.  IRIGHT(LINE) .LT. 0 .OR. WEAK(LINE)   <
   FWHM(LINE) = 0.0;
   RETURN;   >
SINGLE(1) = 1.0;  SINGLE(2) = 1.0;  SINGLE(3) = 1.0;
IF INST_PROF  < SINGLE(3) = 0.0;  >

"   FIND SIGMA AND BLEND POINT FROM RIGHT SIDE OF LINE   "

STEP  = 1;
TEST HALF LINE(A,COV,SINGLE,STEP,LINE,RIGHT);
SIGMAR = DABS(A(3));
DELTAR = DMYSQ( COV(3,3) );

"   FIND SIGMA AND BLEND POINT FROM LEFT SIDE OF LINE   "

STEP  = -1;
TEST HALF LINE(A,COV,SINGLE,STEP,LINE,LEFT);
SIGMAL = DABS(A(3));
DELTAL = DMYSQ( COV(3,3) );

"   NOW CHECK FOR ASYMMETRY   "

IF SIGMAL + 2.0*DELTAL .LT. SIGMAR - 2.0*DELTAR    <
   LEFT DIODE(LINE) = LEFT;
   STEP = 1;
   TEST HALF LINE(A,COV,SINGLE,STEP,LINE,RIGHT);
   FWHM(LINE) = DABS(A(3))*1.66510921;   >
ELSEIF SIGMAR + 2.0*DELTAR .LT. SIGMAL - 2.0*DELTAL    <
   RIGHT DIODE(LINE) = RIGHT;
   STEP = -1;
   TEST HALF LINE(A,COV,SINGLE,STEP,LINE,LEFT);
   FWHM(LINE) = DABS(A(3))*1.66510921;   >
ELSE   <
   FWHM(LINE) = ( SIGMAR+SIGMAL )*0.83255460;   >

" SET UPPER BOUNDS ON RIGHT AND LEFT PIXELS  "

IF A(2)-LEFT .GT. 2.0*FWHM(LINE)   <
   LEFT = A(2) - 2.0*FWHM(LINE);  >
IF RIGHT-A(2) .GT. 2.0*FWHM(LINE)   <
   RIGHT = A(2) + 2.0*FWHM(LINE);  >

RIGHT DIODE(LINE) = RIGHT;
LEFT DIODE(LINE) = LEFT;
RETURN;
END;


SUBROUTINE FIND BROAD LINES;
"
  This subroutine will make a pass through the line list if a width to
  depth relation has been defined.  If a line has a larger fwhm than
  allowed by the width depth relation a call is made to the routine
  REFIT BROAD LINE WITH FIXED FWHM.
"
IMPLICIT REAL*8(A-H,O-Z);

REAL*8 WIDTH,DEEP;
INTEGER LINE,ICENTRE;
COMMON-BLOCK-LINES;
COMMON-BLOCK-FLAGS;
COMMON-BLOCK-IMAGE;

IF INST_PROF  <  RETURN;  >

IF NUMBER OF GOOD LINES .GE. 2  .AND.  INTERCEPT .GT. 0.0 .OR. FIXFWHM   <
   FOR I = 1 TO NUMBER OF LINES   <
      ICENTRE = NINT(CHANNEL(WAVELENGTH(I)));
      DEEP = 1.0 - SPEC(ICENTRE)/CONTINUUM(DBLE(ICENTRE));
      GET BEST FWHM(WAVELENGTH(I),DEEP,WIDTH,SIGWIDTH);   

      "  the test for a broad line is: "

      IF ( DABS(1.0-FWHM(I)/WIDTH) .GT. 3.0*SIGWIDTH/WIDTH .OR.  
         FWHM(I) .LE. 0.0  .OR. FWHM(I) .GE. DBLE(MAX WIDTH) ) .AND.
                                                   DEPTH(I) .LE. 0.50   <
         REFIT BROAD LINE WITH FIXED FWHM(I);   >
   >
>
RETURN;
END;


SUBROUTINE REFIT BROAD LINE WITH FIXED FWHM(LINE);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-SPECTRUM;

REAL*8 A(9),COV(9,9),X(200),PHOTONS,SINGLE(9);
INTEGER NPX,ICENTRE,LEFT,RIGHT;

" First set flag for fitting depth only "

SINGLE(1) = 1.0;
FOR I = 2 TO 9  <
   SINGLE(I) = 0.0;  >

" Gauss fit to center pixel only, with wavelength and fwhm fixed "
"
WRITE(25,'(12H BROAD LINE ,I3,F12.3,3F10.3)')LINE,WAVELENGTH(LINE),
               FWHM(LINE),LEFT DIODE(LINE),RIGHT DIODE(LINE);
"

CENTRE(LINE) = CHANNEL(WAVELENGTH(LINE));
ICENTRE = NINT(CENTRE(LINE));

" find mean fwhm  "

DEEP = 1.0 - SPEC(ICENTRE)/CONTINUUM(DBLE(ICENTRE));
GET BEST FWHM(WAVELENGTH(LINE),DEEP,WIDTH,SIGWIDTH);   
FWHM(LINE) = WIDTH;
NPX = 1;
SET UP POINTS(X,ICENTRE,ICENTRE,NPX);
PHOTONS = SNR(ICENTRE)**2 * CONTINUUM(DBLE(ICENTRE))/SPEC(ICENTRE);
A(2) = CENTRE(LINE);
A(3) = FWHM(LINE)*0.60056121;
GAUSS FIT(X,A,NPX,PHOTONS,COV,SINGLE,CHISQ);
"
   now compute sigmas and test center; center is refit if fit center is
   less certain than predicted center, or center is too far off due to a
   blend.
"
DXVEL = 1.0000 * SIGRV*WAVELENGTH(LINE)/(DISP*3.0D+05);
DXFIT = DMYSQ(COV(2,2));
DIFF = DABS(CHANNEL(WAVELENGTH(LINE)) - A(2));
IF ((DXFIT.GT.1.20*DXVEL  .OR.  (DIFF.GT. 3.0*DXVEL .AND. DIFF.GT. 3.0*DXFIT)) 
    .AND. DIFF*DISP.GT.0.02) .OR.
   (DIFF .GT. MAXSEP)   <
   A(2) = CHANNEL(WAVELENGTH(LINE));
   SINGLE(2) = 0.0;
   FOR I = 1 TO 3   <
      FOR J = 1 TO 3   <
         COV(I,J) = 0.0;   >
      >
   GAUSS FIT(X,A,N,PHOTONS,COV,SINGLE,CHISQ);
   SINGLE(2) = 1.0;   >

" now find additional pixels consistent with fit "

OBTAIN FIXED FWHM BOUNDS(LINE,A,COV,NUMBER OF DIODES);
LEFT = INT(LEFT DIODE(LINE));
RIGHT = INT(RIGHT DIODE(LINE));
NPX = RIGHT - LEFT + 1;

" final fit with all good pixels "

SET UP POINTS(X,LEFT,RIGHT,NPX);
GAUSS FIT(X,A,NPX,PHOTONS,COV,SINGLE,CHISQ);
"
   Re-test fit for wavelength consistency
"
DXFIT = DMYSQ(COV(2,2));
DIFF = DABS(CHANNEL(WAVELENGTH(LINE)) - A(2));
"
WRITE(26,'(34H REFIT BROAD LINE WITH FIXED FWHM )');
WRITE(26,'(25h Wav, DXvel, DXfit, Diff ,2f10.3,3f14.9)')WAVELENGTH(LINE),A(1),
 DXVEL,DXFIT,DIFF;
"
IF ((DXFIT.GT.1.20*DXVEL  .OR.  (DIFF.GT. 3.0*DXVEL .AND. DIFF.GT. 3.0*DXFIT)) 
    .AND. DIFF*DISP.GT.0.02) .OR.
   (DIFF .GT. MAXSEP)   <
   A(2) = CHANNEL(WAVELENGTH(LINE));
   SINGLE(2) = 0.0;
   FOR I = 1 TO 3   <
      FOR J = 1 TO 3   <
         COV(I,J) = 0.0;   >
      >
   GAUSS FIT(X,A,N,PHOTONS,COV,SINGLE,CHISQ);  
   >
"
  now assign line parameters
"
DEPTH(LINE)  = A(1);
CENTRE(LINE) = A(2);
A1 = A(1);   A3 = A(3); NG=1;
COMPUTE DELTA EW(A1,A3,COV,SINGLE,NG,LINE);
SINGLE(2) = 1.0;  
RETURN;
END;


SUBROUTINE OBTAIN FIXED FWHM BOUNDS(LINE,A,COV,NUMBER OF DIODES);
"
  This routine tests pixels for consistency with a gauss fit limited to
  fitting the depth only, and finds the pixels wich can be used in a
  final fit.
"
  
IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;

INTEGER STEP,LINE,N,I,J,NUMBER OF DIODES;
REAL*8 A(9),COV(9,9),SINGLE(9),SIGMAR,SIGMAL,DELTAR,DELTAL,RIGHT,LEFT;
DATA SINGLE/9*0.0/;

SINGLE(1) = 1.0;  SINGLE(2) = 0.0;  SINGLE(3) = 0.0;

"   FIND SIGMA AND BLEND POINT FROM RIGHT SIDE OF LINE   "

STEP  = 1;
TEST HALF LINE(A,COV,SINGLE,STEP,LINE,RIGHT);
A1R = A(1);

"   FIND SIGMA AND BLEND POINT FROM LEFT SIDE OF LINE   "

STEP  = -1;
TEST HALF LINE(A,COV,SINGLE,STEP,LINE,LEFT);
A1L = A(1);

" Now take side giving minimum depth and find No. of pixels on blended side "

IF A1L .LT. A1R   <
   LEFT DIODE(LINE) = LEFT;
   STEP = 1;
   TEST HALF LINE(A,COV,SINGLE,STEP,LINE,RIGHT);  >
ELSEIF A1R .LT. A1L  <
   RIGHT DIODE(LINE) = RIGHT;
   STEP = -1;
   TEST HALF LINE(A,COV,SINGLE,STEP,LINE,LEFT);  >
RIGHT DIODE(LINE) = RIGHT;
LEFT DIODE(LINE) = LEFT;
RETURN;
END;


SUBROUTINE DETERMINE SIGMA AND ERROR(A1,A2,A3,X,Y,DA1,DA2,DA3,DY);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 A1,A2,A3,DA1,DA2,DA3,DY,X,Y;

A3 = DABS(X-A2)/DMYSQ( DLOG(A1/Y) );
DA3 = DMYSQ( (0.25*(X-A2)**2/(DLOG(A1/Y))**3)*((DA1/A1)**2+(DY/Y)**2) +
            DA2**2/DLOG(A1/Y) );
RETURN;
END;


SUBROUTINE TEST HALF LINE(A,COV,SINGLE,STEP,LINE,DIODE);

" 
   This routine is called AFTER the first gaussian fit is made.  The
   purpose is to find the pixels which can be used to define the line.
   The routine sets up the first starting and ending pixels, then
   sets up an array of already accepted points, and then tests all
   subsequent points, which might be used, for consistency with the
   current gaussian fit; if future points don't agree then the end limit
   is reduced; finally the routine fits a new gaussian including the
   next point (which is already consistent with the old gaussian fit)
   and then checks that all previous points are still consistent with
   the current gaussian.

   In future I should add code to test that the residuals are in agreement
   with the input S/N ratio - this would be powerful.
"
IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-SPECTRUM;

REAL*8 A(9),DIODE,COV(9,9),X(200),PHOTONS,Y,DY,XVAL,SINGLE(9),ANEW(9);
INTEGER START,END,LINE,STEP,INDEX,I,II,J,N,NPX;
LOGICAL DEPTH IS TOO LARGE,BAD DIODE;

" SET UP FIRST POINTS "

FOR II = 1 TO 3   <  ANEW(II) = A(II);  >
IF STEP .GT. 0   <
   START = INT(LEFT DIODE(LINE));   >
ELSE  <
   START = INT(RIGHT DIODE(LINE));  >
IF IRIGHT(LINE) .GT. 0  .AND.  STEP .GT. 0   <
   END = NINT(CENTRE(LINE)) + IRIGHT(LINE);   >
ELSEIF ILEFT(LINE) .GT. 0  .AND.  STEP .LT. 0   <
   END = NINT(CENTRE(LINE)) - ILEFT(LINE);   >
ELSE   <
   END = NINT(CENTRE(LINE)) + STEP * MAX WIDTH;   >
IF END .LT. 1  <  END = 1;  >
ELSEIF END .GT. NUMBER OF DIODES  <  END = NUMBER OF DIODES;  >

"  SET UP INITIAL POINTS "

N = INT( RIGHT DIODE(LINE) - LEFT DIODE(LINE) ) + 1;
INDEX = START;
FOR I = 1 TO 2*N-1 BY 2   <
   X(I) = DBLE(INDEX);
   X(I+1) = 1.0 - SPEC(INDEX)/CONTINUUM(DBLE(INDEX));
"
  Commenting out next line to see if program functions properly
   IF X(I+1) .LT. 0.0   < X(I+1) = 0.0; >
"
   INDEX = INDEX + STEP;   >
ICENTRE = NINT(CENTRE(LINE));
PHOTONS = SNR(ICENTRE)**2 * CONTINUUM(DBLE(ICENTRE))/SPEC(ICENTRE);

" TEST EACH NEW POINT AND THEN FIT ALL POINTS TO A GAUSSIAN "

FOR I = 2*N+1 TO 2*IABS(START - END) + 1 BY 2   <
   Y = 1.0 - SPEC(INDEX)/CONTINUUM(DBLE(INDEX));
   DY =  SPEC(INDEX) / ( SNR(INDEX)*CONTINUUM(DBLE(INDEX)) );
   XVAL = DBLE(INDEX);

"       IF NEXT POINT DISAGREES LEAVE THE ROUTINE       "

   IF DEPTH IS TOO LARGE(A,SINGLE,COV,Y,DY,XVAL)  .OR.  BAD DIODE(INDEX)   
      .OR. DY/Y.LT.0.5   <
      EXIT;   >

"  check that wavelength is ok   "

   IF DABS( A(2)-CHANNEL(WAVELENGTH(LINE)) ).GT.MAXSEP   <
      EXIT;   >

"      CHECK FUTURE POINTS WITH CURRENT A VALUES        "

   FOR J = INDEX + STEP TO END BY STEP   <
      XVAL = DBLE(J);
      Y = 1.0 - SPEC(J)/CONTINUUM(DBLE(J));
      DY =  SPEC(J) / ( SNR(J)*CONTINUUM(CENTRE(LINE)) );
      IF DEPTH IS TOO LARGE(A,SINGLE,COV,Y,DY,XVAL)  .OR.  BAD DIODE(J)   
         .OR. DY/Y.LT.0.5   <
         END = J - STEP;
         EXIT;   >
   >
   X(I) = DBLE(INDEX);
   X(I+1) = Y;
"
  Commenting next line out 16/Dec/1991
   IF X(I+1) .LT.  0.0   <  X(I+1) = 0.0;  >
"
   NPX = IABS(INDEX - START) + 1;
   GAUSS FIT(X,ANEW,NPX,PHOTONS,COV,SINGLE,CHISQ);
"
  make sure that the fit is reasonable for the S/N with a Chi**2 test
"
   COMPUTE DEGREES OF FREEDOM(NPX,SINGLE,NFREE);
   GET 3 SIGMA CHISQ(NFREE,CHI3SIG);
   IF CHISQ.GT.CHI3SIG .AND. CHI3SIG.GT.0.0  <  
      WRITE(24,'(9H LINE AT ,F10.3)')WAVELENGTH(LINE);
      EXIT;  >
  "
     Check that fitted wavelength is ok
  "
  DXVEL = 1.0000 * SIGRV*WAVELENGTH(LINE)/(DISP*3.0D+05);
  DXFIT = DMYSQ(COV(2,2));
  DIFF = DABS(CHANNEL(WAVELENGTH(LINE)) - ANEW(2));
IF ((DXFIT.GT.1.20*DXVEL  .OR.  (DIFF.GT. 3.0*DXVEL .AND. DIFF.GT. 3.0*DXFIT)) 
    .AND. DIFF*DISP.GT.0.02) .OR.
     (DIFF .GT. MAXSEP)  <
      EXIT;   >

"  check previous points (not original for center & depth) with current fit  "

   FOR J = START+N*STEP TO INDEX BY STEP   <
      XVAL = DBLE(J);
      Y = 1.0 - SPEC(J)/CONTINUUM(DBLE(J));
      DY =  SPEC(J) / ( SNR(J)*CONTINUUM(CENTRE(LINE)) );
      IF DEPTH IS TOO LARGE(ANEW,SINGLE,COV,Y,DY,XVAL)  .OR.  BAD DIODE(J)   <
         DIODE = DBLE(INDEX-STEP);
         RETURN;   >
      >
   FOR II = 1 TO 3   <  A(II) = ANEW(II);  >
   INDEX = INDEX + STEP;
   > UNTIL 2*N+1 .GE. 2*IABS(START-END)+1;
DIODE = DBLE(INDEX-STEP);
RETURN;
END;


SUBROUTINE COMPUTE DEGREES OF FREEDOM(NPX,SINGLE,NFREE);

IMPLICIT REAL*8(A-H,O-Z);
REAL*8 SINGLE(9);
INTEGER NPX,NFREE,I,NPARAMS;

FOR I = 1 TO 9   <
   NPARAMS = NPARAMS + DBLE(SINGLE(I));   >
NFREE = NPX - NPARAMS;
RETURN;
END;




SUBROUTINE GET 3 SIGMA CHISQ(NFREE,CHI3SIG);

IMPLICIT REAL*8(A-H,O-Z);
REAL*8 CHI_ARRAY(20);
INTEGER NFREE;

DATA CHI_ARRAY/11.5,14.0,16.5,18.5,21.0,22.5,24.5,26.0,28.0,29.5,
               31.0,33.0,35.0,36.0,38.0,39.5,41.0,42.0,44.0,45.5/;

IF NFREE .LE. 0  <
   CHI3SIG = 0.0;   >
ELSEIF NFREE .LE. 20  < 
   CHI3SIG = CHI_ARRAY(NFREE);   >
ELSEIF NFREE .GT. 20  < 
   CHI3SIG = CHI_ARRAY(20) + 1.4d0 * DBLE(NFREE-20);   >
RETURN;
END;




"
 This is the old function, which includes analytic expressions for the
 Yest uncertainties

LOGICAL FUNCTION DEPTH IS TOO LARGE(A,COV,Y,DY,X);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 A(9),COV(9,9),Y,DY,YEST,DYEST;

DEPTH IS TOO LARGE = .FALSE.;
IF Y/A(1) .LT. 0.15   <
   DEPTH IS TOO LARGE = .TRUE.;
   RETURN;   >
YEST =  A(1)*DEXP( -((X-A(2))/A(3))**2);
T1 = COV(1,1)/A(1)**2;
T2 =   4.0*( (X-A(2))**2/A(3)**4 )*( ((X-A(2))/A(3))**2*COV(3,3) +
                                 2.0*COV(2,3)*(X-A(2))/A(3) + COV(2,2) );
T3 = 2.0*(X-A(2))*( (X-A(2))*COV(3,1)/A(3) + COV(2,1) )/(A(1)*A(3)**2);
DYEST = YEST*DMYSQ(T1+T2+T3);
IF Y - 2.0*DY .GT. YEST + 2.0*DYEST .OR. Y - 2.0*DY .GE. A(1)   <
   DEPTH IS TOO LARGE = .TRUE.;   >
RETURN;
END;

"


LOGICAL FUNCTION DEPTH IS TOO LARGE(A,SW,COV,Y,DY,X);
"  
 This version finds empirical derivatives, and is needed for vsini
 and other complicated profile functions.
"

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-ROTATION;
COMMON-BLOCK-ITERATE;

REAL*8 A(9),AOLD(9),SW(9),COV(9,9),Y,DY,YEST,DYEST,DYEST2,DMYSQ,PROFILE;
REAL*8 GRAD(9);

DEPTH IS TOO LARGE = .FALSE.;

FOR I = 1 TO 9   <
   AOLD(I) = A(I);   >
" compute empirical gradients "
YEST = PROFILE(X, A, SW, VSINI); 
FOR I = 1 TO 9   <
   IF SW(I) .EQ. 1.D0   <
      A(I) = A(I) + DA(I);
      GRAD(I) = ( PROFILE(X, A, SW, VSINI) - YEST ) / DA(I) ;
      A(I) = AOLD(I);   >
   ELSE  <
      GRAD(I) = 0.0D0;  >
   >
" expand the Taylor series terms "
DYEST2 = 0.0D0;
FOR I = 1 TO 9  <
   IF SW(I) .EQ. 1.0D0  <
      FOR J = 1 TO 9   <
         IF SW(J) .EQ. 1.0D0  <
            DYEST2 = DYEST2 + GRAD(I)*GRAD(J)*COV(I,J);   >
         >
      >
   >
DYEST = DMYSQ(DYEST2);
IF Y - 2.0*DY .GT. YEST + 2.0*DYEST .OR. Y - 2.0*DY .GE. A(1)   <
   DEPTH IS TOO LARGE = .TRUE.;   >
RETURN;
END;
      




SUBROUTINE FIT SINGLE GAUSSIAN(LINE);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-FLAGS;
COMMON-BLOCK-SPECTRUM;

REAL*8 X(200),A(9),PHOTONS,COV(9,9),SINGLE(9),SNR;
INTEGER N,I,INDEX;
DATA SINGLE/3*1.0,6*0.0/;

SINGLE(1) = 1.0;  SINGLE(2) = 1.0;  SINGLE(3) = 1.0;
IF INST_PROF  <  SINGLE(3) = 0.0;  >

IF ILEFT(LINE) .LT. 0  .OR.  IRIGHT(LINE) .LT. 0 .OR. WEAK(LINE)   <
   RETURN;   >
N = INT( RIGHT DIODE(LINE) - LEFT DIODE(LINE) ) + 1;
INDEX = INT( LEFT DIODE(LINE) );
IEND  = INT( RIGHT DIODE(LINE) );
SET UP POINTS(X,INDEX,IEND,N);
A(1) = DEPTH(LINE);
A(2) = CENTRE(LINE);
A(3) = FWHM(LINE)*0.60056121;
ICENTRE = NINT(CENTRE(LINE));
PHOTONS = SNR(ICENTRE)**2 * CONTINUUM(DBLE(ICENTRE))/SPEC(ICENTRE);
GAUSS FIT(X,A,N,PHOTONS,COV,SINGLE,CHISQ);
"
   now compute sigmas and test center; center is refit if fit center is
   less certain than predicted center, or center is too far off due to a
   blend.
"
DXVEL = 1.0000 * SIGRV*WAVELENGTH(LINE)/(DISP*3.0D+05);
DXFIT = DMYSQ(COV(2,2));
DIFF = DABS(CHANNEL(WAVELENGTH(LINE)) - A(2));
"
WRITE(26,'(21H FIT SINGLE GAUSSIAN )');
WRITE(26,'(25h Wav, DXvel, DXfit, Diff ,2f10.3,3f14.9)')WAVELENGTH(LINE),A(1),
 DXVEL,DXFIT,DIFF;
"
IF ((DXFIT.GT.1.20*DXVEL  .OR.  (DIFF.GT. 3.0*DXVEL .AND. DIFF.GT. 3.0*DXFIT)) 
    .AND. DIFF*DISP.GT.0.02) .OR.
   (DIFF .GT. MAXSEP)   <
   A(2) = CHANNEL(WAVELENGTH(LINE));
   SINGLE(2) = 0.0;
   FOR I = 1 TO 3   <
      FOR J = 1 TO 3   <
         COV(I,J) = 0.0;   >
      >
   GAUSS FIT(X,A,N,PHOTONS,COV,SINGLE,CHISQ);  
   >
"
  now assign line parameters
"
DEPTH(LINE)  = A(1);
CENTRE(LINE) = A(2);
FWHM(LINE)   = DABS(A(3))/0.60056121;
A1 = A(1);   A3 = A(3); NG=1;
COMPUTE DELTA EW(A1,A3,COV,SINGLE,NG,LINE);
SINGLE(2) = 1.0;  
RETURN;
END;


SUBROUTINE DETERMINE WIDTH TO DEPTH RELATION;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-FLAGS;

REAL*8 X(100),Y(100),SLOPE2,INTERCEPT2;
INTEGER N,KODE;

IF INST_PROF  <
   RETURN;  >
IF FIXFWHM   <
   SLOPE = 0.0;
   RETURN;   >
MINIMUM DEPTH = 1.0;
IF NUMBER OF GOOD LINES .LT. 2   <
   SIGFWHM = 0.0;
   INTERCEPT = 0.0;
   SLOPE = 0.0;
   RETURN;   >
MINSUM WIDTH TO DEPTH RELATION(KODE);
FIXFWHM = .TRUE.;
RETURN;
END;


SUBROUTINE DETERMINE MEAN FWHM;

"
 *********** This routine is not used anymore*************
"
IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-IMAGE;
COMMON-BLOCK-TELLURIC;

REAL*8 MEAN,VAR;
INTEGER EXCLUDE,LINE,IORDER;

MEAN = 0.0; VAR = 0.0; EXCLUDE = 0;
FOR I = 1 TO NUMBER OF GOOD LINES  <
   IF (DEPTH(GOOD(I)) .GE. LLIMIT .AND. DEPTH(GOOD(I)) .LE. ULIMIT)  .OR.
      TELLURIC SET UP   <
      FIND ORDER(WAVELENGTH(GOOD(I)),IORDER);
      MEAN = MEAN + WAVELENGTH(GOOD(I))/(FWHM(GOOD(I))*DW(IORDER));   >
   ELSE   <
      EXCLUDE = EXCLUDE + 1;   >
   >
IF NUMBER OF GOOD LINES .GT. EXCLUDE   <
   INTERCEPT = MEAN/DBLE(NUMBER OF GOOD LINES - EXCLUDE);   >
ELSE   <
   INTERCEPT = 0.0;
   OUTPUT(8);
   ('ERROR:  NO GOOD LINES WITHIN DEPTH LIMITS FOR FWHM TO DEPTH RELATION');
   >
SLOPE     = 0.0;
FOR I = 1 TO NUMBER OF GOOD LINES   <
   FAC = WAVELENGTH(GOOD(I))/DW(IORDER);
   IF (DEPTH(GOOD(I)) .LT. 0.10 .AND. DEPTH(GOOD(I)) .LT. 0.50)   .OR.
      TELLURIC SET UP   <
      VAR = VAR + (FAC/FWHM(GOOD(I))-INTERCEPT)**2;   >
   >
SIGFWHM = DMYSQ( VAR )/DBLE(NUMBER OF GOOD LINES -2 - EXCLUDE);
RETURN;
END;


SUBROUTINE MINSUM WIDTH TO DEPTH RELATION(KODE);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-SPECTRUM;
COMMON-BLOCK-LINES;
COMMON-BLOCK-IMAGE;
COMMON-BLOCK-FOCUS;

REAL*8 TOLER,ERROR,Q(53,4),X(4),RES(51),CU(2,53),RDUMMY(100),SL,Y0,Y1;
INTEGER K,L,M,N,KLMD,KLM2D,NKLMD,N2D,IU(2,53),S(51),ITER,KODE,IORDER;
INTEGER IAVG,INUM;

"  Note that the fwhm values are scaled to derive the resolving power
   relation "

K = NUMBER OF GOOD LINES;
L = 0;    M = 1;     N = 2;          KLMD = 51;   KLM2D = 53;
N2D = 4;  KODE = 0;  TOLER = 0.002;  ITER = 510;  NKLMD = 53;

IAVG = 0;  INUM = 0;
" DMIN = DMYSQ( 0.08**2 + (4.0/SN)**2 );   AMcW 5/99 "
DMIN = 0.10;

"  First write header of WIDPLOT file  "

WRITE(9,'(8H title $,10x,1H$)');
WRITE(9,'(17H ylabel $1/R**2$ )');  WRITE(9,'(16H xlabel /depth/ )');
WRITE(9,'(14H xformat f5.2 )'); WRITE(9,'(15H yformat e10.2 )');

"
  NOW SET UP THE Q MATRIX FOR LINEAR FIT and dummy array for average and median.
  Small reduced equivalent widths go to median/average array; strong to linear
  fit array
"

FOR I = 1 TO NUMBER OF GOOD LINES   <
   IF DEPTH(GOOD(I)).GE.DMIN   <
      FIND ORDER(WAVELENGTH(GOOD(I)),IORDER);
      R = WAVELENGTH(GOOD(I))/(FWHM(GOOD(I))*DW(IORDER));
      RW = DLOG10( 1.065*DW(IORDER)*FWHM(GOOD(I))*DEPTH(GOOD(I))/
                   WAVELENGTH(GOOD(I)) );

" Only use lines stronger than about 30mA for width to depth plot "

      IF RW .GE. -5.22   <
         INUM = INUM + 1;
         Q(INUM,1) = DEPTH(GOOD(I));
         Q(INUM,2) = 1.0;
         IF GLOBAL_FOCUS .OR. FOCUS_PARS(CURRENT_IMAGE_ROW)   <
            Q(INUM,3) = 1.0/R**2 - 1.0/RFOCUS(WAVELENGTH(GOOD(I)))**2;   >
         ELSE   <
            Q(INUM,3) = 1.0/R**2;   >

"  write info. to width plot file  "

         WRITE(9,*)DEPTH(GOOD(I)),Q(INUM,3),WAVELENGTH(GOOD(I));
         Q(INUM,4) = 0.0;      >

" set up an array of weak lines (less than 70mA) to find minimum width "

      IF RW.LT. -4.85   <
         IAVG = IAVG + 1;   
         RDUMMY(IAVG) = 1.0/R**2 - 1.0/RFOCUS(WAVELENGTH(GOOD(I)))**2;   >
   >
>
K = INUM;
"  Now place the constraints on minsum linear fit "
Q(INUM+1,1) = -1.0;
Q(INUM+1,2) =  0.0;
Q(INUM+1,3) =  0.0;
Q(INUM+1,4) =  0.0;
CALL CL1(K,L,M,N,KLMD,KLM2D,NKLMD,N2D,Q,KODE,TOLER,ITER,X,RES,ERROR,
         CU,IU,S);
IF KODE .GT. 0   <
   OUTPUT(8)KODE;  (29H MINSUM ROUTINE ABORTED CODE ,I2);  RETURN;  >
IF INUM.GT.1   <
  SIGFWHM = 1.33*ERROR/DBLE(NUMBER OF GOOD LINES-2);   >
ELSE  <
  SIGFWHM = 0.0;   >
SLOPE = X(1);
INTERCEPT = X(2);

" now obtain median R and minimum depth "

IF IAVG.GT.2 .AND. SLOPE.GT.0.0  <
   GET MEDIAN(RDUMMY,IAVG,RMEDIAN);
" allow a maximum R of 200,000 "
   IF RMEDIAN .LT. 2.5D-11   <  
      RW = 1.41D-05;
      GET DEPTH(RW,SLOPE,INTERCEPT,MINIMUM DEPTH);
      write(30,'(24h in get w to depth reln )');
      write(30,'(10hmin depth ,d15.9)')MINIMUM DEPTH;
       >
   ELSE   <
      MINIMUM DEPTH = (RMEDIAN-INTERCEPT)/SLOPE;   >
   >
ELSE   <
   RW = 1.41D-05;
   GET DEPTH(RW,SLOPE,INTERCEPT,MINIMUM DEPTH); >

" write width fit to width plot file"

Y0 = INTERCEPT + MINIMUM DEPTH * SLOPE;
Y1 = INTERCEPT + SLOPE;
WRITE(9,'(9h nomarker)');
WRITE(9,'(5h line)');
WRITE(9,'(5h 0.0 ,g13.6)')Y0;
WRITE(9,'(2g13.6)')MINIMUM DEPTH,Y0;
WRITE(9,'(5h 1.0 ,g13.6)')Y1;
RETURN;
END;


REAL*8 FUNCTION RFOCUS(W);

IMPLICIT REAL*8 (A-H,O-Z);

"
A function which calculated the Th-Ar resolving power at wavelength, w
"
COMMON-BLOCK-FOCUS;
COMMON-BLOCK-IMAGE;

REAL*8 R,W,X;
INTEGER IROW,I;

R = 0.0;
IROW = CURRENT_IMAGE_ROW;

IF FOCUS_PARS(IROW)   <
   X = W - WFC(IROW);
   FOR I = 1 TO 6   <
      R = R + A_FOCUS(IROW,I)*X**(I-1);   >
   >
ELSEIF GLOBAL_FOCUS   <
   X = W - GLOBAL_WFC;
   FOR I = 1 TO 6   <
      R = R + GLOBAL_A(I)*X**(I-1);   >
   >
RFOCUS = R;
RETURN;
END;




SUBROUTINE GET DEPTH(RW,SLOPE,INTERCEPT,MINIMUM DEPTH);

"RW is the reduced EW required "

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 RMIN,R,RW,RWCALC,SLOPE,INTERCEPT,MINIMUM DEPTH,D,DELTAD,DMYSQ;
INTEGER I,ICOUNT;

DELTAD = 0.1;
RMIN = 200000.0;
D = 1.0;
ICOUNT = 0;

FOR I = 1 TO 100000 <
   R = 1.0/(INTERCEPT + SLOPE*D);
   R = DMYSQ(R);
   RWCALC = 1.067*D/R;
   IF RWCALC .LT. RW   <
      D = D + DELTAD;   
      DELTAD = DELTAD/10.0;
      ICOUNT = ICOUNT + 1;   >
   ELSE   <
      D = D - DELTAD;   >
   IF ICOUNT.GE.6   <
      IF R.GT.RMIN  <
         OUTPUT(8);('ERROR: WIDTH TO DEPTH RELATION TOO NARROW');   >
      EXIT;   >
   >
MINIMUM DEPTH = D;
RETURN;
END;


SUBROUTINE FIND DEPTH OF SMALLEST GOOD LINE;
"
 *********  This routine is no longer in use
"

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-IMAGE;
INTEGER LINE;

MINIMUM DEPTH = 1.0;
FOR I = 1 TO NUMBER OF GOOD LINES   <
   FIND ORDER(WAVELENGTH(GOOD(I)),IORDER);
   FAC = WAVELENGTH(GOOD(I))/DW(IORDER);
   IF FAC/FWHM(GOOD(I)) .LE. INTERCEPT + SLOPE*DEPTH(GOOD(I)) + 3.0*SIGFWHM   <
      IF DEPTH(GOOD(I)) .LE. MINIMUM DEPTH  .AND.  DEPTH(GOOD(I)) .GE. LLIMIT <
         MINIMUM DEPTH = DEPTH(GOOD(I));   >
   >
>
RETURN;
END;


SUBROUTINE DISCARD BAD WIDTHS(X,Y,N);
"
 *********  This routine is no longer in use
"

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-IMAGE;
COMMON-BLOCK-LINES;
COMMON-BLOCK-TELLURIC;

INTEGER EXCLUDE,LINE,N;
REAL*8 X(100),Y(100);

EXCLUDE = 0;
FOR I = 1 TO NUMBER OF GOOD LINES   <
   FIND ORDER(WAVELENGTH(GOOD(I)),IORDER);
   FAC = WAVELENGTH(GOOD(I))/DW(IORDER);
   IF FAC/FWHM(GOOD(I)) .LE. INTERCEPT + SLOPE*DEPTH(GOOD(I)) + 3.0*SIGFWHM
      .AND.  DEPTH(GOOD(I)) .GE. 0.10  .OR.  TELLURIC SET UP   <
      X(I-EXCLUDE) = DEPTH(GOOD(I));
      Y(I-EXCLUDE) = FWHM(GOOD(I));   >
   ELSE   <
      EXCLUDE = EXCLUDE + 1;   >
   >
N = NUMBER OF GOOD LINES - EXCLUDE;
RETURN;
END;


SUBROUTINE FIT WEAK LINES;

IMPLICIT REAL*8 (A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-SPECTRUM;

REAL*8 SINGLE(9),X(200),A(9),COV(9,9);
INTEGER LINE,N;


SINGLE(1) = 1.0;  SINGLE(2) = 1.0;  
FOR I = 3 TO 9  < 
   A(I) = 0.0;
   SINGLE(I) = 0.0;  >
FOR LINE = 1 TO NUMBER OF LINES   <
   IF WEAK(LINE)  <   
      CENTRE(LINE) = CHANNEL(WAVELENGTH(LINE));
      ICENTRE = NINT(CENTRE(LINE));
      DEPTH(LINE) = 1.0 - SPEC(ICENTRE)/CONTINUUM(DBLE(ICENTRE));
      DEEP = DEPTH(LINE);
      W = WAVELENGTH(LINE);
      GET BEST FWHM(W,DEEP,WIDTH,SIGWIDTH);
      IF WIDTH .EQ. 0.0   <  RETURN;  >
      FWHM(LINE) = WIDTH;
      RIGHT DIODE(LINE) = DNINT(CENTRE(LINE) + 0.5*WIDTH);
      LEFT DIODE(LINE)  = DNINT(CENTRE(LINE) - 0.5*WIDTH);

     "  check for overlap with adjacent lines  "

     IF LINE .LT. NUMBER OF LINES   <
        IF RIGHT DIODE(LINE).GE. CHANNEL(WAVELENGTH(LINE+1))   <
           NEXT;   >
        >
     IF LINE .GT. 1   <
        IF LEFT DIODE(LINE) .LE. CHANNEL(WAVELENGTH(LINE-1))   <
           NEXT;   >
        >
     
     "  set up and run gauss fit  to depth and center "

     ISTART = INT( LEFT DIODE(LINE) );
     IEND   = INT( RIGHT DIODE(LINE));
     SET UP POINTS(X,ISTART,IEND,N);
     A(1) = DEPTH(LINE);
     A(2) = CENTRE(LINE);
     A(3) = FWHM(LINE)*0.60056121;
     ICENT = NINT(CENTRE(LINE));
     PHOTONS = SNR(ICENT)**2 * CONTINUUM(DBLE(ICENT))/SPEC(ICENT);
     FOR I = 1 TO 3   <
        FOR J = 1 TO 3   <
           COV(I,J) = 0.0;   >
        >
     SINGLE(2) = 1.0;
     GAUSS FIT(X,A,N,PHOTONS,COV,SINGLE,CHISQ);
     "
        now compute sigmas and test center; center is refit if fit center is
        less certain than predicted center, or center is too far off due to a
        blend.
     "
     DXVEL = 1.0000 * SIGRV*WAVELENGTH(LINE)/(DISP*3.0D+05);
     DXFIT = DMYSQ(COV(2,2));
     DIFF = DABS(CHANNEL(WAVELENGTH(LINE)) - A(2));
"
WRITE(26,'(34H FIT WEAK LINES                   )');
WRITE(26,'(25h Wav, DXvel, DXfit, Diff ,2f10.3,3f14.9)')WAVELENGTH(LINE),A(1),
 DXVEL,DXFIT,DIFF;
"
IF ((DXFIT.GT.1.20*DXVEL  .OR.  (DIFF.GT. 3.0*DXVEL .AND. DIFF.GT. 3.0*DXFIT)) 
    .AND. DIFF*DISP.GT.0.02) .OR.
        (DIFF .GT. MAXSEP)   <
        A(2) = CHANNEL(WAVELENGTH(LINE));
        SINGLE(2) = 0.0;
        FOR I = 1 TO 3   <
           FOR J = 1 TO 3   <
              COV(I,J) = 0.0;   >
           >
        GAUSS FIT(X,A,N,PHOTONS,COV,SINGLE,CHISQ);   
        SINGLE(2) = 1.0;>
     DEPTH(LINE)  = A(1);
     CENTRE(LINE) = A(2);
     A1 = A(1);   A3 = A(3); NG = 1;
     COMPUTE DELTA EW(A1,A3,COV,SINGLE,NG,LINE);
     >
  >
RETURN;
END;


SUBROUTINE SINGLE FIT TO BAD LINES(LINE);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-SPECTRUM;

REAL*8 SINGLE(9),X(200),A(3),COV(9,9);
INTEGER STEP,LINE;
LOGICAL FIRST,BAD DIODE,LINE ABSENT;
DATA SINGLE/9*0.0/;

FIRST = .FALSE.;
IF ILEFT(LINE) .GE. 0  .AND.  IRIGHT(LINE) .GE. 0   <
   RETURN;   >
GUESS LINE CENTRE(LINE,CENTRE(LINE),FIRST);
ICENTRE = NINT(CENTRE(LINE));
IF BAD DIODE(ICENTRE)   <
   OUTPUT(8)WAVELENGTH(LINE);
   (' REMOVED LINE AT ',F9.3,' A DUE TO BAD DIODES');
   OUTPUT(6)WAVELENGTH(LINE);
   (' REMOVED LINE AT ',F9.3,' A DUE TO BAD DIODES');
   REMOVE FROM LIST(LINE);
   LINE = LINE - 1;
   RETURN;   >
IF LINE ABSENT(CENTRE(LINE)) .AND. LINE ID(LINE) .NE. 'TELLURIC  '   <
   OUTPUT(8)LINE ID(LINE),WAVELENGTH(LINE);
   (' LINE WITH ID ',A10,' AT ',F9.3,' WAS REMOVED - TOO WEAK TO MEASURE.');
   OUTPUT(6)LINE ID(LINE),WAVELENGTH(LINE);
   (' LINE WITH ID ',A10,' AT ',F9.3,' WAS REMOVED - TOO WEAK TO MEASURE.');
   REMOVE FROM LIST(LINE);
   LINE = LINE - 1;
   RETURN;   >
DEPTH(LINE) = 1.0 - SPEC(ICENTRE)/CONTINUUM(DBLE(ICENTRE));
CHECK LINE QUALITY(LINE,ICENTRE,NUMBER OF DIODES);
SET BAD GAUSSIAN SWITCHES(SINGLE,LINE,NUMBER OF DIODES);
GET BEST FWHM(WAVELENGTH(LINE),DEPTH(LINE),FWHM(LINE),SIGWIDTH);
IF ILEFT(LINE) .LT. 0  .AND.  IRIGHT(LINE) .LT. 0  .AND. FWHM(LINE) .EQ. 0.0 <
   RETURN;   >
ELSEIF FWHM(LINE) .EQ. 0.0   <
   FWHM(LINE) = 4.5;   >
ISTART = INT( LEFT DIODE(LINE) );
IEND   = INT( RIGHT DIODE(LINE));
SET UP POINTS(X,ISTART,IEND,N);
A(1) = DEPTH(LINE);
A(2) = CENTRE(LINE);
A(3) = FWHM(LINE)*0.60056121;
ICENT = NINT(CENTRE(LINE));
PHOTONS = SNR(ICENT)**2 * CONTINUUM(DBLE(ICENT))/SPEC(ICENT);
FOR I = 1 TO 3   <
   FOR J = 1 TO 3   <
      COV(I,J) = 0.0;   >
   >
GAUSS FIT(X,A,N,PHOTONS,COV,SINGLE,CHISQ);
"
   now compute sigmas and test center; center is refit if fit center is
   less certain than predicted center, or center is too far off due to a
   blend.
"
DXVEL = 1.0000 * SIGRV*WAVELENGTH(LINE)/(DISP*3.0D+05);
DXFIT = DMYSQ(COV(2,2));
DIFF = DABS(CHANNEL(WAVELENGTH(LINE)) - A(2));
"
WRITE(26,'(25H SINGLE FIT TO BAD LINES )');
WRITE(26,'(25h Wav, DXvel, DXfit, Diff ,2f10.3,3f14.9)')WAVELENGTH(LINE),A(1),
 DXVEL,DXFIT,DIFF;
"
IF ((DXFIT.GT.1.20*DXVEL  .OR.  (DIFF.GT. 3.0*DXVEL .AND. DIFF.GT. 3.0*DXFIT)) 
    .AND. DIFF*DISP.GT.0.02) .OR.
   (DIFF .GT. MAXSEP)   <
   A(2) = CHANNEL(WAVELENGTH(LINE));
   SINGLE(2) = 0.0;
   FOR I = 1 TO 3   <
      FOR J = 1 TO 3   <
         COV(I,J) = 0.0;   >
      >
   GAUSS FIT(X,A,N,PHOTONS,COV,SINGLE,CHISQ);  >
IF ILEFT(LINE) .LT. 0  .AND.  IRIGHT(LINE) .GE. 0   <
   STEP = 1;
   TEST HALF LINE(A,COV,SINGLE,STEP,LINE,RIGHT DIODE(LINE)); >
ELSEIF IRIGHT(LINE) .LT. 0  .AND.  ILEFT(LINE) .GE. 0   <
   STEP = -1;
   TEST HALF LINE(A,COV,SINGLE,STEP,LINE,LEFT DIODE(LINE));  >
"
  now assign line parameters
"
DEPTH(LINE)  = A(1);
CENTRE(LINE) = A(2);
FWHM(LINE)   = DABS(A(3))/0.60056121;
A1 = A(1);   A3 = A(3); N = 1;
COMPUTE DELTA EW(A1,A3,COV,SINGLE,N,LINE);
RETURN;
END;


LOGICAL FUNCTION LINE ABSENT(CENTRE);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 CENTRE;
INTEGER ICENTRE;

LINE ABSENT = .FALSE.;
ICENTRE = NINT(CENTRE);
DEPTH = 1.0 - SPEC(ICENTRE)/CONTINUUM(DBLE(ICENTRE));
SIGMA = ( SPEC(ICENTRE)/CONTINUUM(DBLE(ICENTRE)) ) / SNR(ICENTRE);

IF DEPTH .LE. SIGMA   <
   LINE ABSENT = .TRUE.;   >
RETURN;
END;


SUBROUTINE CHECK LINE QUALITY(LINE,ICENTRE,NUMBER OF DIODES);

IMPLICIT REAL*8(A-H,O-Z);

INTEGER LINE,ICENTRE,NUMBER OF DIODES,STEP,NEXT,LAST;
COMMON-BLOCK-LINES;

NEXT = 0;  LAST = 0;
IF LINE .LT. NUMBER OF LINES   <
   NEXT = NINT( CHANNEL(WAVELENGTH(LINE+1)) );   >
STEP = 1;
DETERMINE LIMIT(ICENTRE,STEP,RIGHT DIODE(LINE),NUMBER OF DIODES,NEXT,
                WAVELENGTH(LINE),LINE ID(LINE));
IF LINE .GT. 1   <
   LAST = NINT( CHANNEL(WAVELENGTH(LINE-1)) );   >
STEP = -1;
DETERMINE LIMIT(ICENTRE,STEP,LEFT DIODE(LINE),NUMBER OF DIODES,LAST,
                WAVELENGTH(LINE),LINE ID(LINE));
IF RIGHT DIODE(LINE) .EQ. DBLE(ICENTRE)   <
   IRIGHT(LINE) = -1;   >
IF LEFT DIODE(LINE) .EQ. DBLE(ICENTRE)    <
   ILEFT(LINE)  = -1;   >
RETURN;
END;


SUBROUTINE SET BAD GAUSSIAN SWITCHES(SINGLE,LINE,NUMBER OF DIODES);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 SINGLE(9);
INTEGER LINE,NUMBER OF DIODES,STEP,NEXT,LAST,ILIMIT;
LOGICAL NO TURNOVER;
COMMON-BLOCK-LINES;
COMMON-BLOCK-FLAGS;

IF ILEFT(LINE) .LT. 0  .AND.  IRIGHT(LINE) .LT. 0   <
   SINGLE(1) = 1.0;  SINGLE(2) = 0.0;  SINGLE(3) = 0.0;   >
ELSE   <
   IF ILEFT(LINE) .LT. 0   <
      NEXT = 0;
      ILIMIT = INT(RIGHT DIODE(LINE));
      STEP = 1;
      IF LINE .LT. NUMBER OF LINES   <
         NEXT = NINT( CHANNEL(WAVELENGTH(LINE+1)) );   >
      DETERMINE LIMIT(ILIMIT,STEP,RIGHT DIODE(LINE),NUMBER OF DIODES,
                      NEXT,WAVELENGTH(LINE),LINE ID(LINE));   >
   ELSEIF IRIGHT(LINE) .LT. 0   <
      LAST = 0;
      ILIMIT = INT(LEFT DIODE(LINE));
      STEP = -1;
      IF LINE .GT. 1   <
         LAST = NINT( CHANNEL(WAVELENGTH(LINE-1)) );   >
      DETERMINE LIMIT(ILIMIT,STEP,LEFT DIODE(LINE),NUMBER OF DIODES,
                      LAST,WAVELENGTH(LINE),LINE ID(LINE));   >
   SINGLE(1) = 1.0;  SINGLE(2) = 0.0;  SINGLE(3) = 1.0;
   IF INST_PROF  <  SINGLE(3) = 0.0;  >
   IF RIGHT DIODE(LINE) .EQ. DBLE(ILIMIT)  .OR.
       LEFT DIODE(LINE) .EQ. DBLE(ILIMIT)  .OR.
       NO TURNOVER(LINE,CENTRE(LINE),NUMBER OF DIODES,NUMBER OF LINES)   <
      SINGLE(3) = 0.0;
      ILEFT(LINE) = -1;  IRIGHT(LINE) = -1;   >
   >
RETURN;
END;


LOGICAL FUNCTION NO TURNOVER(LINE,CENT,NUMBER OF DIODES,NUMBER OF LINES);

IMPLICIT REAL*8(A-H,O-Z);

INTEGER LINE,NUMBER OF DIODES,NUMBER OF LINES,ICENT;
REAL*8 CENT,CNEXT,CLAST;
LOGICAL FIRST;

FIRST = .FALSE.;
NO TURNOVER = .TRUE.;
CLAST = 1.0;
CNEXT = DBLE(NUMBER OF DIODES);
GUESS LINE CENTRE(LINE,CENT,FIRST);
ICENT = NINT(CENT);
IF ICENT .LE. 2  .OR. ICENT .GE. NUMBER OF DIODES - 1   <  RETURN;  >
ELSEIF SPEC(ICENT+1) .GE. SPEC(ICENT)  .AND.
       SPEC(ICENT)   .GE. SPEC(ICENT-1)   <  RETURN;  >
ELSEIF SPEC(ICENT+1) .LE. SPEC(ICENT)  .AND.
       SPEC(ICENT)   .LE. SPEC(ICENT-1)   <  RETURN;  >
IF LINE .LT. NUMBER OF LINES   <
   GUESS LINE CENTRE(LINE+1,CNEXT,FIRST);   >
IF LINE .GT. 1   <
   GUESS LINE CENTRE(LINE-1,CLAST,FIRST);   >
IF DBLE(ICENT-1) .LE. CLAST  .OR.  DBLE(ICENT+1) .GE. CNEXT   <
   RETURN;  >
NO TURNOVER = .FALSE.;
RETURN;
END;


SUBROUTINE GET BEST FWHM(WAVE,DEEP,WIDTH,SIGWIDTH);

IMPLICIT REAL*8(A-H,O-Z);
COMMON-BLOCK-IMAGE;
COMMON-BLOCK-FOCUS;
COMMON-BLOCK-LINES;
COMMON-BLOCK-FLAGS;

"
  computes an estimated fwhm based on the resolving power-depth relation 
  RIOBS2 is the inverse observed R**2, or  RIOBS2 =    1  
                                                     ----- 2
                                                     R(obs)
"

REAL*8 D,DEEP,WIDTH,WAVE,SIGWIDTH;

WIDTH = 0.0;
"
I'm commenting this part of the code out because I want to use the
focus for the FWHM in some cases.

IF SLOPE .EQ. 0.0  .AND.  INTERCEPT .EQ. 0.0   <
   RETURN;   >
"

D = DEEP;
IF DEEP .LT. MINIMUM DEPTH   <
   D = MINIMUM DEPTH;   >
RILIN2 = INTERCEPT + D*SLOPE;
IF FOCUS_PARS(CURRENT_IMAGE_ROW) .OR. GLOBAL_FOCUS   <
   RIOBS2 = 1.0/RFOCUS(WAVE)**2 + RILIN2;   >
ELSE   <
   RIOBS2 = RILIN2;   >
DELTA_W = DABS( WAVE - WAV(CHANNEL(WAVE)+1.0D+00) );
WIDTH = DMYSQ(RIOBS2) * WAVE / DELTA_W; 
"SIGWIDTH = WIDTH * 0.5 * SIGFWHM/RIOBS2;   removed AMcW 5/99 "
"SIGWIDTH = WIDTH * DMYSQ(SIGFWHM/RIOBS2);  removed AMcW 1/2002 "
SIGWIDTH = WIDTH * SIGFRAC;
IF INST_PROF   <
   SIGWIDTH = WIDTH * 0.05;   >        " assume 5% focus width uncertainty 
                                               - 5/99 AMcW "
RETURN;
END;



SUBROUTINE FIT BLENDED LINES(NUMBER OF LINES);

IMPLICIT REAL*8(A-H,O-Z);

INTEGER LINE,NUMBER OF LINES;

FOR LINE = 1 TO NUMBER OF LINES   <
   FIT BLEND(LINE);
   >
RETURN;
END;


SUBROUTINE FIT BLEND(LINE);

IMPLICIT REAL*8(A-H,O-Z);

INTEGER LINE;
LOGICAL RIGHT WING BLENDED;

IF RIGHT WING BLENDED(LINE)   <
   IF RIGHT WING BLENDED(LINE-1)   <
      FIT TRIPLE GAUSSIAN(LINE);   >
   ELSE   <
      FIT DOUBLE GAUSSIAN(LINE);   >
   >
RETURN;
END;


LOGICAL FUNCTION RIGHT WING BLENDED(LINE);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-ROTATION;

REAL*8 DEPTH1,DEPTH2,LIMIT1,LIMIT2,FWHM1,FWHM2,VWIDTH;

RIGHT WING BLENDED = .FALSE.;
W = WAVELENGTH(LINE);
VWIDTH = W * VSINI / (DISP * 3.0D+05);
IF LINE .GE. NUMBER OF LINES  .OR.  LINE .LE. 0   <
   RETURN;   >
FWHM1 = FWHM(LINE);  DEEP = DEPTH(LINE);
IF FWHM1 .EQ. 0.0   <
   GET BEST FWHM(W,DEEP,FWHM1,SIGWIDTH);   >
FWHM2 = FWHM(LINE+1);  DEEP = DEPTH(LINE+1);
IF FWHM2 .EQ. 0.0   <
   GET BEST FWHM(W,DEEP,FWHM2,SIGWIDTH);   >


ICENTRE = NINT(CENTRE(LINE));
DEPTH1 = 3.0D0 * DMYSQ(SPEC(ICENTRE)/CONTINUUM(DBLE(ICENTRE))) / SNR(ICENTRE);
ICENTRE = NINT(CENTRE(LINE+1));
DEPTH2 = 3.0D0 * DMYSQ(SPEC(ICENTRE)/CONTINUUM(DBLE(ICENTRE))) / SNR(ICENTRE);

IF DEPTH(LINE) .GT. DEPTH1   <
   LIMIT1 = CENTRE(LINE) + FWHM1*0.60056121*DMYSQ( DLOG(DEPTH(LINE)/DEPTH1) ); >
ELSE   <   LIMIT1 = CENTRE(LINE);   >
IF DEPTH(LINE+1) .GT. DEPTH2   <
   LIMIT2 = CENTRE(LINE+1)-FWHM2*0.60056121*DMYSQ(DLOG(DEPTH(LINE+1)/DEPTH2)); >
ELSE   <   LIMIT2 = CENTRE(LINE+1);   >
IF LIMIT2 .LT. LIMIT1  .OR.  
   CENTRE(LINE+1)-CENTRE(LINE) .LT. FWHM1+FWHM2+1.8D0*VWIDTH   <
   RIGHT WING BLENDED = .TRUE.;   >
RETURN;
END;


SUBROUTINE FIT TRIPLE GAUSSIAN(LINE);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-IMAGE;

LOGICAL REFIT;
INTEGER LINE,LEFT,RIGHT,I,N;
REAL*8 TRIPLE(9),X(200),COV(9,9),A(9),PHOTONS;

DATA TRIPLE/9*1.0/;

FOR I = 1 TO 9   <
   TRIPLE(I) = 1.0;  >
"
  BLEND DETERMINES WHETHER AND HOW THE LINE IS BLENDED:
         -1  THE LINE IS BLENDED ON THE LEFT WING ONLY
          0  THE LINE IS NOT BLENDED
         +1  THE LINE IS BLENDED ON THE RIGHT WING ONLY
         +2  THE LINE IS BLENDED ON BOTH THE RIGHT & LEFT WINGS
"
BLEND(LINE) = 2;  BLEND(LINE+1) = -1;
FOR INDEX = 1 TO 3   <
   L = LINE - 2 + INDEX;
   SET MULTIPLE GAUSSIAN SWITCH(TRIPLE,L,INDEX,ILEFT(L),IRIGHT(L));
   IF BLEND(LINE-1) .EQ.  2   <
      TRIPLE(1) = 0.0;
      TRIPLE(2) = 0.0;
      TRIPLE(3) = 0.0;   >
   >
FIND TRIPLE LINE BOUNDS(LINE,LEFT,RIGHT,LEFT DIODE,RIGHT DIODE);
SET UP POINTS(X,LEFT,RIGHT,N);
ICENT = NINT(CENTRE(LINE));
PHOTONS = SNR(ICENT)**2 * CONTINUUM(DBLE(ICENT))/SPEC(ICENT);
FOR I = 1 TO 3   <
   A( (I-1)*3+1 ) = DEPTH(LINE-2+I);
  "A( (I-1)*3+2 ) = CENTRE(LINE-2+I);  altered to fix centre AMcW 4/96"
   A( (I-1)*3+2 ) = CHANNEL(WAVELENGTH(LINE-2+I));
   A( (I-1)*3+3 ) = FWHM(LINE-2+I)*0.60056121;
   IF FWHM(LINE-2+I) .EQ. 0.0   <
      WAVE = WAV(A((I-1)*3+2));
      GET BEST FWHM(WAVE,DEPTH(LINE-2+I),WIDTH,SIGWIDTH);
      A( (I-1)*3+3 ) = WIDTH*0.60056121 ;   
      TRIPLE((I-1)*3+3) = 0.00;   >
   >

    " fix wavelengths if lines are too close  "

IF DABS(CHANNEL(WAVELENGTH(LINE+1))-CHANNEL(WAVELENGTH(LINE))).LE.MINSEP   <
   TRIPLE(5) = 0.0;  
   A(5) = CHANNEL(WAVELENGTH(LINE));
   TRIPLE(8) = 0.0;
   A(8) = CHANNEL(WAVELENGTH(LINE+1));   >
IF DABS(CHANNEL(WAVELENGTH(LINE-1))-CHANNEL(WAVELENGTH(LINE))).LE.MINSEP   <
   TRIPLE(2) = 0.0;  
   A(2) = CHANNEL(WAVELENGTH(LINE-1));
   TRIPLE(5) = 0.0;
   A(5) = CHANNEL(WAVELENGTH(LINE));   >

GAUSS FIT(X,A,N,PHOTONS,COV,TRIPLE,CHISQ);
"
   now compute sigmas and test center; center is refit if fit center is
   less certain than predicted center, or center is too far off due to a
   blend.
"
"
***************************************************************************
commented out as lines now fixed  AMcW 4/96
REFIT = .FALSE.;
DXVEL = 1.0000 * SIGRV*WAVELENGTH(LINE)/(DISP*3.0D+05);
FOR I = 1 TO 3   <
   K = (I-1)*3;
   DXFIT = DMYSQ(COV(K+2,K+2));
   DIFF = DABS(CHANNEL(WAVELENGTH(LINE)) - A(K+2));
IF ((DXFIT.GT.1.20*DXVEL  .OR.  (DIFF.GT. 3.0*DXVEL .AND. DIFF.GT. 3.0*DXFIT)) 
    .AND. DIFF*DISP.GT.0.02) .OR.
      (DIFF .GT. MAXSEP)   <
      REFIT = .TRUE.;
      A(K+2) = CHANNEL(WAVELENGTH(LINE));
      TRIPLE(K+2) = 0.0;
      FOR I = 1 TO 3   <
         FOR J = 1 TO 3   <
            COV(I,J) = 0.0;   >
         >
      >
   >
IF REFIT   <
   GAUSS FIT(X,A,N,PHOTONS,COV,TRIPLE,CHISQ);   >
***************************************************************************
"
"
  now assign line parameters
"
FOR I = 1 TO 3   <
   K = (I-1)*3;
   DEPTH(LINE-2+I)  = A( (I-1)*3+1 );
   CENTRE(LINE-2+I) = A( (I-1)*3+2 );
   A1 = A( (I-1)*3+1);   A3 = A( (I-1)*3+3);
   COMPUTE DELTA EW(A1,A3,COV,TRIPLE,I,LINE-2+I);
   IF FWHM(LINE-2+I) .NE. 0.0   <
      FWHM(LINE-2+I)   = DABS(A( (I-1)*3+3 ))/0.60056121;   >
   >
RETURN;
END;


SUBROUTINE FIT DOUBLE GAUSSIAN(LINE);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-IMAGE;

LOGICAL REFIT;
INTEGER LINE,LEFT,RIGHT,I,N;
REAL*8 DOUBLE(9),X(200),COV(9,9),A(9),PHOTONS;

DATA DOUBLE/6*1.0,3*0.0/;
FOR I = 1 TO 6   <
   DOUBLE(I) = 1.0;  >
FOR I = 7 TO 9   <
   DOUBLE(I) = 0.0;  >
BLEND(LINE) = 1;  BLEND(LINE+1) = -1;
FOR INDEX = 1 TO 2   <
   L = LINE -1 + INDEX;
   SET MULTIPLE GAUSSIAN SWITCH(DOUBLE,L,INDEX,ILEFT(L),IRIGHT(L));
   >
FIND DOUBLE LINE BOUNDS(LINE,LEFT,RIGHT,LEFT DIODE,RIGHT DIODE);
SET UP POINTS(X,LEFT,RIGHT,N);
ICENT = NINT(CENTRE(LINE));
PHOTONS = SNR(ICENT)**2 * CONTINUUM(DBLE(ICENT))/SPEC(ICENT);
FOR I = 1 TO 2   <
   A( (I-1)*3+1 ) = DEPTH(LINE-1+I);
  "A( (I-1)*3+2 ) = CENTRE(LINE-1+I);    altered 4/96 AMcW"
   A( (I-1)*3+2 ) = CHANNEL(WAVELENGTH(LINE-1+I));
   A( (I-1)*3+3 ) = FWHM(LINE-1+I)*0.60056121;
   IF FWHM(LINE-1+I) .EQ. 0.0   <
      WAVE = WAV(A((I-1)*3+2));
      GET BEST FWHM(WAVE,DEPTH(LINE-1+I),WIDTH,SIGWIDTH);
      A( (I-1)*3+3 ) = WIDTH*0.60056121 ;   
      DOUBLE((I-1)*3+3) = 0.0;   >
   >

" if lines are too close then fix wavelengths "

IF DABS(CHANNEL(WAVELENGTH(LINE+1))-CHANNEL(WAVELENGTH(LINE))).LE.MINSEP   <
   DOUBLE(2) = 0.0;  
   A(2) = CHANNEL(WAVELENGTH(LINE));
   DOUBLE(5) = 0.0;
   A(5) = CHANNEL(WAVELENGTH(LINE+1));   >

GAUSS FIT(X,A,N,PHOTONS,COV,DOUBLE,CHISQ);

"
   now compute sigmas and test center; center is refit if fit center is
   less certain than predicted center, or center is too far off due to a
   blend.
"
"
***************************************************************************
commented out: AMcW 4/96 since I now will fix central pixel for blends

REFIT = .FALSE.;
DXVEL = 1.0000 * SIGRV*WAVELENGTH(LINE)/(DISP*3.0D+05);
FOR I = 1 TO 2   <
   K = (I-1)*3;
   DXFIT = DMYSQ(COV(K+2,K+2));
   DIFF = DABS(CHANNEL(WAVELENGTH(LINE)) - A(K+2));
IF ((DXFIT.GT.1.20*DXVEL  .OR.  (DIFF.GT. 3.0*DXVEL .AND. DIFF.GT. 3.0*DXFIT)) 
    .AND. DIFF*DISP.GT.0.02) .OR.
      (DIFF .GT. MAXSEP)   <
      REFIT = .TRUE.;
      A(K+2) = CHANNEL(WAVELENGTH(LINE));
      DOUBLE(K+2) = 0.0;
      FOR I = 1 TO 3   <
         FOR J = 1 TO 3   <
            COV(I,J) = 0.0;   >
         >
      >
   >
IF REFIT   <
   GAUSS FIT(X,A,N,PHOTONS,COV,DOUBLE,CHISQ);   >
***************************************************************************
"
"
  now assign line parameters
"
FOR I = 1 TO 2   <
   K = (I-1)*3;
   DEPTH(LINE-1+I)  = A( (I-1)*3+1 );
   CENTRE(LINE-1+I) = A( (I-1)*3+2 );
   A1 = A( (I-1)*3+1);   A3 = A( (I-1)*3+3);
   COMPUTE DELTA EW(A1,A3,COV,DOUBLE,I,LINE-1+I);
   IF FWHM(LINE-1+I) .NE. 0.0   <
      FWHM(LINE-1+I)   = DABS(A( (I-1)*3+3 ))/0.60056121;   >
   >
RETURN;
END;


SUBROUTINE SET MULTIPLE GAUSSIAN SWITCH(SWITCH,LINE,INDEX,ILEFT,IRIGHT);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-FLAGS;

REAL*8 SWITCH(9);
INTEGER LINE,INDEX,ILEFT,IRIGHT;

"  INITIALISE SWITCHES FOR THIS GAUSSIAN  "

SWITCH(3*(INDEX-1)+1) = 1.0;
" SWITCH(3*(INDEX-1)+2) = 1.0; changed to fix centre: AMcW 4/96 "
SWITCH(3*(INDEX-1)+2) = 0.0;
SWITCH(3*(INDEX-1)+3) = 1.0;
IF INST_PROF  < SWITCH(3*(INDEX-1)+3) = 0.0;  >

"  IF ONE SIDE IS ILL DEFINED TURN SWITCH FOR CENTRE  

  commented out AMcW 4/96

IF ILEFT .LT. 0  .OR.  IRIGHT .LT. 0   <
   SWITCH(3*(INDEX-1)+2) = 0.0;   >
"

"  IF BOTH SIDES ILL DEFINED TURN OFF FWHM SWITCH  "

IF ILEFT .LT. 0  .AND.  IRIGHT .LT. 0   <
   SWITCH(3*(INDEX-1)+3) = 0.0;   >
RETURN;
END;


SUBROUTINE FIND TRIPLE LINE BOUNDS(LINE,LEFT,RIGHT,LEFT DIODE,RIGHT DIODE);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 LEFT DIODE(MAX LINES),RIGHT DIODE(MAX LINES);
INTEGER LINE,LEFT,RIGHT;

LEFT = INT( LEFT DIODE(LINE-1) );
IF INT( LEFT DIODE(LINE) ) .LT. LEFT   <
   LEFT = INT( LEFT DIODE(LINE) );   >
IF INT( LEFT DIODE(LINE+1) ) .LT. LEFT   <
   LEFT = INT( LEFT DIODE(LINE+1) );   >
RIGHT = INT( RIGHT DIODE(LINE+1) );
IF INT( RIGHT DIODE(LINE) ) .GT. RIGHT   <
   RIGHT = INT( RIGHT DIODE(LINE) );   >
IF INT( RIGHT DIODE(LINE-1) ) .GT. RIGHT   <
   RIGHT = INT( RIGHT DIODE(LINE-1) );   >
RETURN;
END;


SUBROUTINE FIND DOUBLE LINE BOUNDS(LINE,LEFT,RIGHT,LEFT DIODE,RIGHT DIODE);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 LEFT DIODE(MAX LINES),RIGHT DIODE(MAX LINES);
INTEGER LINE,LEFT,RIGHT;

LEFT = INT( LEFT DIODE(LINE) );
RIGHT= INT( RIGHT DIODE(LINE+1) );
IF INT( LEFT DIODE(LINE+1) ) .LT. LEFT   <
   LEFT = INT( LEFT DIODE(LINE+1) );   >
IF INT( RIGHT DIODE(LINE) ) .GT. RIGHT   <
   RIGHT = INT( RIGHT DIODE(LINE) );   >
RETURN;
END;


SUBROUTINE SET UP POINTS(X,LEFT,RIGHT,N);

IMPLICIT REAL*8(A-H,O-Z);

INTEGER LEFT,RIGHT,N,INDEX;
REAL*8 X(200);

N = RIGHT - LEFT + 1;
INDEX = LEFT;
FOR I = 1 TO 2*N-1 BY 2   <
   X(I) = DBLE(INDEX);
   X(I+1) = 1.0 - SPEC(INDEX)/CONTINUUM(DBLE(INDEX));
"
  Commenting out next line to see if program still works
   IF X(I+1) .LT. 0.0   <
      X(I+1) = 0.0;   >
"
   INDEX = INDEX + 1;
   >
RETURN;
END;


SUBROUTINE REDO LINES(NUMBER OF DIODES);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;

INTEGER NUMBER OF DIODES;
REAL*8 A(9),COV(9,9);
LOGICAL RIGHT WING BLENDED,DELETED;

FOR I = 1 TO NREDO   <
   FIND REDO LINE(REDO(I),LINE,WAVELENGTH,NUMBER OF LINES);
   LEFT DIODE(LINE) = 0.0;
   RIGHT DIODE(LINE)= 0.0;
   ILEFT(LINE) = 0;
   IRIGHT(LINE)= 0;
   BLEND(LINE) = 0;
   FIND CENTRAL DIODE NUMBER AND DEPTH(LINE,A,COV,DELETED);
   IF DELETED   <
     NREDO = NREDO - 1;
     FOR J = I TO NREDO   <
        REDO(J) = REDO(J+1);   >
     I = I - 1;
     NEXT;   >
   OBTAIN FWHM(LINE,A,COV,NUMBER OF DIODES);
   FIT SINGLE GAUSSIAN(LINE);
   SINGLE FIT TO BAD LINES(LINE);   >
FOR I = 1 TO NREDO   <
   FIND REDO LINE(REDO(I),LINE,WAVELENGTH,NUMBER OF LINES);
   IF RIGHT WING BLENDED(LINE)  .OR.  RIGHT WING BLENDED(LINE-1)   <
      FIND START AND END OF BLEND(LINE,ISTART,IEND,I);
      FOR J = ISTART TO IEND   <
         FIT BLEND(J);   >
      >
   >
RETURN;
END;


SUBROUTINE FIND START AND END OF BLEND(LINE,ISTART,IEND,IREDO);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;

INTEGER LINE,ISTART,IEND,IREDO;
LOGICAL RIGHT WING BLENDED;

FOR IEND = LINE TO NUMBER OF LINES   <
   IF .NOT. RIGHT WING BLENDED(IEND)   <
      EXIT;   >
   IF REDO(IREDO+1) .EQ. WAVELENGTH(IEND)  .AND.  IREDO .LT. NREDO   <
      IREDO = IREDO + 1;   >
   >
FOR ISTART = LINE TO 1 BY -1   <
   IF .NOT. RIGHT WING BLENDED(ISTART-1)   <
      EXIT;   >
   >
RETURN;
END;


SUBROUTINE FIND REDO LINE(WAVE,LINE,WAVELENGTH,N);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 WAVE,WAVELENGTH(MAX LINES);
INTEGER LINE,N;

FOR LINE = 1 TO N   <
   IF WAVE .EQ. WAVELENGTH(LINE)   <  RETURN;  >
   >
RETURN;
END;


LOGICAL FUNCTION TELLURIC LINES INTERFERE WITH SPECTRUM(IDUMMY);

IMPLICIT REAL*8(A-H,O-Z);

LOGICAL RIGHT WING BLENDED;
COMMON-BLOCK-LINES;
INTEGER I,IDUMMY;
REAL*8 LAST;

NREDO = 0;
LAST  = 0.0;
TELLURIC LINES INTERFERE WITH SPECTRUM = .FALSE.;
FOR I = 1 TO NUMBER OF LINES   <
   IF RIGHT WING BLENDED(I)   <
      IF LINE ID(I).EQ.'TELLURIC  ' .AND. LINE ID(I+1).NE.'TELLURIC  '.OR.
         LINE ID(I+1).EQ.'TELLURIC  ' .AND. LINE ID(I).NE.'TELLURIC  '   <
         TELLURIC LINES INTERFERE WITH SPECTRUM = .TRUE.;
         IF NREDO .GE. 100   <
            OUTPUT(8);('MAXIMUM NUMBER OF REDO LINES REACHED');
            EXIT;   >
         IF LINE ID(I+1) .EQ. 'TELLURIC  '  .AND. WAVELENGTH(I) .NE. LAST   <
            NREDO = NREDO + 1;
            REDO(NREDO) = WAVELENGTH(I);   >
         ELSEIF LINE ID(I) .EQ. 'TELLURIC  '   <
            NREDO = NREDO + 1;
            REDO(NREDO) = WAVELENGTH(I+1);
            LAST = REDO(NREDO);   >
         >
      >
   >
RETURN;
END;


SUBROUTINE REMOVE BAD FACTORS(FACTOR,ERROR,WEIGHT,SHIFT,NH2O);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 FACTOR(100),ERROR(100),WEIGHT(100),SHIFT(100);
INTEGER NH2O,I,COUNT;

COUNT = 1;
FOR I = 1 TO NH2O   <
   IF WEIGHT(I) .GE. 0.0   <
      FACTOR(COUNT) = FACTOR(I);
      ERROR(COUNT) = ERROR(I);
      WEIGHT(COUNT) = WEIGHT(I);
      SHIFT(COUNT)  = SHIFT(I);
      COUNT = COUNT + 1;   >
   >
RETURN;
END;


SUBROUTINE SORT FACTOR LIST(FACTOR,ERROR,WEIGHT,SHIFT,NFAC);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 FACTOR(100),ERROR(100),WEIGHT(100),TFACTOR,TWEIGHT,TERROR,SHIFT(100);
REAL*8 TSHIFT;
INTEGER NFAC,I,J;

FOR I = 1 TO NFAC - 1   <
   FOR J = 1 TO NFAC - 1   <
      IF FACTOR(J) .GT. FACTOR(J+1)   <
         TFACTOR = FACTOR(J);
         TERROR  = ERROR(J);
         TSHIFT  = SHIFT(J);
         TWEIGHT = WEIGHT(J);
         FACTOR(J) = FACTOR(J+1);
         ERROR(J)  = ERROR(J+1);
         WEIGHT(J) = WEIGHT(J+1);
         SHIFT(J)  = SHIFT(J+1);
         FACTOR(J+1) = TFACTOR;
         ERROR(J+1)  = TERROR;
         WEIGHT(J+1) = TWEIGHT;
         SHIFT(J+1)  = TSHIFT;   >
      >
   >
RETURN;
END;


SUBROUTINE REMOVE FACTOR(FACTOR,ERROR,WEIGHT,SHIFT,J,NFAC);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 FACTOR(100),ERROR(100),WEIGHT(100),SHIFT(100);
INTEGER J,NFAC;

FOR I = J TO NFAC-1   <
   FACTOR(I) = FACTOR(I+1);
   ERROR(I)  = ERROR(I+1);
   WEIGHT(I) = WEIGHT(I+1);
   SHIFT(I)  = SHIFT(I+1);   >
RETURN;
END;


SUBROUTINE DIVIDE TELLURIC LINES OUT(SPECTRUM,NUMBER OF DIODES);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
REAL*8 SPECTRUM(MAX DIODE);
INTEGER NUMBER OF DIODES,I,J;

FOR I = 1 TO NUMBER OF LINES   <
   IF LINE ID(I) .EQ. 'TELLURIC  '   <
      LIMIT1 = NINT(CENTRE(I)-2.0*FWHM(I));
      LIMIT2 = NINT(CENTRE(I)+2.0*FWHM(I));
      IF LIMIT1 .LT. 1   <  LIMIT1 = 1;  >
      ELSEIF LIMIT2 .GT. NUMBER OF DIODES   <
         LIMIT2 = NUMBER OF DIODES;  >
      A1 = DEPTH(I);
      A2 = CENTRE(I);
      A3 = FWHM(I)*0.60056121;
      FOR J = LIMIT1 TO LIMIT2   <
         FACTOR = 1.0 - A1*EXP(-( (A2-DBLE(J))/A3 )**2);
         SPECTRUM(J) = SPECTRUM(J)/FACTOR;   >
      >
   >
RETURN;
END;


SUBROUTINE REMOVE TELLURIC LINES FROM LIST;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
INTEGER I;

FOR I = 1 TO NUMBER OF LINES   <
   IF LINE ID(I) .EQ. 'TELLURIC  '   <
      REMOVE FROM LIST(I);
      I = I - 1;   >
   >
RETURN;
END;


SUBROUTINE FIT DISPERSION CURVE;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;

REAL*8 X(100),Y(100);
INTEGER EXCLUDE;

IF NO OF REF LINES  .GT.  NUMBER OF GOOD LINES   <
   RETURN;   >
EXCLUDE = 0;
FOR I = 1 TO NUMBER OF GOOD LINES   <
   IF WAVELENGTH(GOOD(I)) .GT. 0.0  .AND.
      DABS( CENTRE(GOOD(I))-CHANNEL(WAVELENGTH(GOOD(I))) ) .LT. 1.5   <
      X(I-EXCLUDE) = CENTRE(GOOD(I));
      Y(I-EXCLUDE) = WAVELENGTH(GOOD(I));   >
   ELSE   <
      EXCLUDE = EXCLUDE + 1;   >
   >
N = NUMBER OF GOOD LINES - EXCLUDE;
FIT LINE(X,Y,N,DISP,OFFSET);
IF N .GT. 2   <
   FIT PARABOLA(X,Y,N,DISP2,DISP1,OFFSET);   >
RETURN;
END;


SUBROUTINE MEASURE EQUIVALENT WIDTH(LINE);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 WIDTH,DEEP,PI;
INTEGER LINE,ICENTRE;
COMMON-BLOCK-LINES;
COMMON-BLOCK-FLAGS;
COMMON-BLOCK-IMAGE;
LOGICAL LINE IS WIDE;

PI = 3.141592654D+0;

IF NUMBER OF GOOD LINES .GE. 2  .AND.  INTERCEPT .GT. 0.0 .OR. FIXFWHM   <
   ICENTRE = NINT(CENTRE(LINE));
   DEEP = 1.0 - SPEC(ICENTRE)/CONTINUUM(DBLE(ICENTRE));
   WAVE = WAV(CENTRE(LINE));
   GET BEST FWHM(WAVE,DEEP,WIDTH,SIGWIDTH);   
   >
ELSEIF FWHM(LINE) .EQ. 0.0   <
   OUTPUT(8)LINE;
   (' CANNOT DEFINE AN EW FOR LINE ',I3,' BECAUSE NO FWHM-DEPTH RELATION',
    ' EXISTS');
   EW(LINE) = 0.0;
   RETURN;   >
ELSE   <
   WIDTH = FWHM(LINE);   >
IF LINE IS WIDE(WAVELENGTH(LINE)) .OR. SIGWIDTH.EQ.0.0  <
   EW(LINE) = FWHM(LINE)*DEPTH(LINE)*0.60056121*DMYSQ(PI) * DISP*1000.0;
   DELTA_EW(LINE)= DELTA_EW(LINE) * EW(LINE);
   RETURN;   >
IF DABS(1.0-FWHM(LINE)/WIDTH) .GT. 3.0*SIGWIDTH/WIDTH .OR.  FWHM(LINE) .EQ. 0.0
   .AND.  DEPTH(LINE) .LE. 0.60   <
   EW(LINE) = WIDTH*DEEP*0.60056121*DMYSQ(PI)*DISP*1000.0;
   DELTA_EW(LINE) = DELTA_EW(LINE) * EW(LINE);
   AREA = FWHM(LINE)*DEPTH(LINE)*0.60056121*DMYSQ(PI) * DISP*1000.0;
   OUTPUT(8)LINE ID(LINE),WAVELENGTH(LINE),FWHM(LINE),AREA,WIDTH,EW(LINE);
   (' LINE ID ',A10,' AT ',F8.3,' A. MEASURE FWHM OF ',F5.2,' DIODES GAVE AN EW
 OF ',F7.2,/,34X,' AVERAGE FWHM OF ',F5.2,' DIODES GAVE AN EW OF ',F7.2);
   FWHM(LINE) = WIDTH;
   >
ELSE   <
   EW(LINE) = FWHM(LINE)*DEPTH(LINE)*0.60056121*DMYSQ(PI) * DISP*1000.0;   
   DELTA_EW(LINE)= DELTA_EW(LINE) * EW(LINE);   >
RETURN;
END;


LOGICAL FUNCTION LINE IS WIDE(WAVE);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 WAVE;
COMMON-BLOCK-WIDE;

LINE IS WIDE = .FALSE.;
FOR I = 1 TO IWIDE   <
   IF WIDE(I) .EQ. WAVE   <
      LINE IS WIDE = .TRUE.;
      EXIT;   >
   >
RETURN;
END;


SUBROUTINE PRODUCE FWHM-DEPTH PLOT FILE(TITLE);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-FLAGS;
COMMON-BLOCK-LINES;
COMMON-BLOCK-IMAGE;
REAL*8 MINFWHM,MAXFWHM,MAXDEP;
INTEGER I,J;
CHARACTER*80 TITLE;

MINFWHM = 10000.0;  MAXFWHM = 0.0;  MAXDEP = 0.0;
WRITE(9,'(8H title $,A60,1H$)')TITLE(1:60);
WRITE(9,'(17H ylabel $1/R**2$ )');  WRITE(9,'(16H xlabel /depth/ )');
WRITE(9,'(14H xformat f5.2 )'); WRITE(9,'(15H yformat e10.2 )');
FOR I = 1 TO NUMBER OF LINES   <
   IF FWHM(I) .NE. 0.0  .AND.  FWHM(I) .LT. MINFWHM   <
      MINFWHM = FWHM(I);   >
   ELSEIF FWHM(I) .NE. 0.0  .AND.  FWHM(I) .GT. MAXFWHM   <
      MAXFWHM = FWHM(I);   >
   IF DEPTH(I) .GT. MAXDEP   <
      MAXDEP = DEPTH(I);   >
   >
WRITE(9,'(10H XMIN 0.0 )');  WRITE(9,'(6H XMAX ,F5.2)')MAXDEP+0.05;
WRITE(9,'(6H YMIN ,F5.2)')(DNINT(MINFWHM)-0.55);
WRITE(9,'(6H YMAX ,F5.2)')(DNINT(MAXFWHM)+0.55);
WRITE(9,'(10H MARKER 1 )');
FOR I = 1 TO NUMBER OF GOOD LINES   <
   WAVE = WAVELENGTH(GOOD(I));
   FIND ORDER(WAVE,IORDER);
   DELTA_W = DABS( WAVE - WAV(CHANNEL(WAVE)+1.0D+00) );
   FAC = WAVE/DELTA_W;
   R = FAC/FWHM(GOOD(I));
   >
WRITE(9,'(10H MARKER 3 )');
J = 1;
FOR I = 1 TO NUMBER OF LINES   <
   IF I .EQ. GOOD(J)   <   J = J + 1;  NEXT;   >
   WAVE = WAVELENGTH(I);
   FIND ORDER(WAVE,IORDER);
   DELTA_W = DABS( WAVE - WAV(CHANNEL(WAVE)+1.0D+00) );
   FAC = WAVE/DELTA_W;
   R = FAC/FWHM(I);
   WRITE(9,'(1H ,F7.4,2X,F13.4)')DEPTH(I),R;   >
WRITE(9,'(6H LINE )');
WRITE(9,'(10H NOMARKER )');
IF WIDFLG .EQ. -1   <   RETURN;   >
ELSEIF WIDFLG .EQ. 0   <
   WRITE(9,'(6H 0.0  ,F13.4,/,6H 0.5  ,F13.4)')INTERCEPT,INTERCEPT;   >
ELSE   <
   WIDTH = MINIMUM DEPTH * SLOPE + INTERCEPT;
   WRITE(9,'(6H 0.0  ,F13.4)')WIDTH;
   WRITE(9,'(1H ,F7.4,2X,F13.4)')MINIMUM DEPTH,WIDTH;
   WIDTH = 0.5 * SLOPE + INTERCEPT;
   WRITE(9,'(6H 0.5  ,F13.4)')WIDTH;   >
RETURN;
END;


SUBROUTINE PRODUCE H2O LINE FILE;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;

OPEN(UNIT=13,FILE='H2OLIST',STATUS='OLD');
REWIND 13;
"  THE WIDTH TO DEPTH RELATION FOR H2O  "
OUTPUT(13)SLOPE,INTERCEPT,MINIMUM DEPTH;(F12.9,2X,F15.9,2X,F15.9);
FOR I = 1 TO NUMBER OF LINES   <
   OUTPUT(13)CENTRE(I),FWHM(I),DEPTH(I);
   ('TELLURIC  ',F10.3,F10.5,F10.7);   >
RETURN;
END;




SUBROUTINE WRITE HEADERS;

COMMON-BLOCK-IMAGE;
COMMON-BLOCK-SPECTRUM;


OUTPUT(10)SPTITLE; (A80);
OUTPUT(10)CURRENT SPECTRUM,CURRENT ORDER,CURRENT_IMAGE_ROW;
         ('SPECTRUM ',I3,', ORDER ',I3,', IMAGE ROW ',I3);
OUTPUT(12)SPTITLE; (A80);
OUTPUT(12)CURRENT SPECTRUM,CURRENT ORDER,CURRENT_IMAGE_ROW;
         ('SPECTRUM ',I3,', ORDER ',I3,', IMAGE ROW ',I3);
OUTPUT(15)SPTITLE; (A80);
OUTPUT(15)CURRENT SPECTRUM,CURRENT ORDER,CURRENT_IMAGE_ROW;
         ('SPECTRUM ',I3,', ORDER ',I3,', IMAGE ROW ',I3);
RETURN;
END;




SUBROUTINE PRODUCE MOOG INPUT FILE(RV,TITLE);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;

CHARACTER*80 TITLE;
INTEGER I;

FOR I = 1 TO NUMBER OF LINES   <
   IF LINE ID(I)(1:4) .NE. 'JUNK'   <
      OUTPUT(10)LINE ID(I)(1:5),WAVELENGTH(I),ATOM(I),EPLOW(I),GF(I),EW(I);
      (A5,F10.3,F10.1,F10.3,10X,F10.3,20X,F5.1);   
      OUTPUT(12)LINE ID(I)(1:5),WAVELENGTH(I),ATOM(I),EPLOW(I),GF(I),DEPTH(I);
      (A5,F10.3,F10.1,F10.3,10X,F10.3,20X,F5.3);   
      OUTPUT(15)WAVELENGTH(I),ATOM(I),EPLOW(I),GF(I),EW(I);
      (F10.3,F10.1,F10.3,F10.3,20X,F10.1);   >
   >
RETURN;
END;


SUBROUTINE PRODUCE SPECTRUM PLOT FILE(TITLE,NUMBER OF DIODES);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-PLOTS;

CHARACTER*80 TITLE;
INTEGER NUMBER OF DIODES,I,J,LEFT,RIGHT;
LOGICAL BAD PLOT;

SCREEN =.FALSE.;
DETERMINE PLOT BOUNDS (NUMBER OF DIODES);
IF NUMBER OF PLOTS .GT. 0   <
   FOR I = 1 TO NUMBER OF PLOTS   <
      XLENGTH = DBLE( NPLOTR(I)-NPLOTL(I)+1 )*2.54/20.0;
      IF BAD PLOT(WPLOTL(I),WPLOTR(I),NUMBER OF DIODES)   <
         NEXT;   >
      PRINT HEADER INFO FOR PLOT(TITLE,WPLOTL(I),WPLOTR(I),0.0D0,
                                 1.1001D0,XLENGTH);
      PRINT FLUXS(NPLOTL(I),NPLOTR(I));
      PRINT CONTINUUM(NPLOTL(I),NPLOTR(I));
      PRINT LINE FLUXS(I);
      >
   >
ELSEIF PLOTALL   <
   I = 1;
   XLENGTH = NUMBER OF DIODES*2.54/20.0;
   WPLOTL(1) = WAV(1.0D0);
   WPLOTR(1) = WAV( DBLE(NUMBER OF DIODES) );
   NPLOTL(1) = 1;
   NPLOTR(1) = NUMBER OF DIODES;
   PRINT HEADER INFO FOR PLOT(TITLE,WPLOTL(1),WPLOTR(1),0.0D0,1.1001D0,XLENGTH);
   PRINT FLUXS(NPLOTL(1),NPLOTR(1));
   PRINT CONTINUUM(NPLOTL(1),NPLOTR(1));
   PRINT LINE FLUXS(I);
   >
RETURN;
END;


SUBROUTINE DETERMINE PLOT BOUNDS (NUMBER OF DIODES);

IMPLICIT REAL*8(A-H,O-Z);

INTEGER  NUMBER OF DIODES,I;
COMMON-BLOCK-PLOTS;
FOR I = 1 TO NUMBER OF PLOTS   <
   NPLOTL(I) = NINT( CHANNEL(WPLOTL(I)) );
   IF NPLOTL(I).LT.1 <  
      NPLOTL(I) = 1;  >

   NPLOTR(I) = NINT( CHANNEL(WPLOTR(I)) );
   IF NPLOTR(I).GT.NUMBER OF DIODES <  
      NPLOTL(I) = NUMBER OF DIODES;  >
   
   WPLOTL(I) = WAV( DBLE(NPLOTL(I)) );
   WPLOTR(I) = WAV( DBLE(NPLOTR(I)) );   >
RETURN;
END;


LOGICAL FUNCTION BAD PLOT(WAVEL,WAVER,NPTS);

IMPLICIT REAL*8(A-H,O-Z);

INTEGER NPTS;

BAD PLOT = .FALSE.;
ENDWAV = WAV(DBLE(NPTS));
IF WAVEL .LE. WAV(0.0D0)   <
   IF WAVER .LE. WAV(41.0D0)   <
      BAD PLOT = .TRUE.;   >
   WAVEL = WAV(1.0D0);   >
ELSEIF WAVER .GT. ENDWAV   <
   IF WAVEL .GT. WAV(DBLE(NPTS-41))   <
      BAD PLOT = .TRUE.;   >
   WAVER = ENDWAV;   >
RETURN;
END;


SUBROUTINE PRINT HEADER INFO FOR PLOT(TITLE,XMIN,XMAX,YMIN,YMAX,XLENGTH);

IMPLICIT REAL*8(A-H,O-Z);

CHARACTER*80 TITLE;
REAL*8 XMIN,XMAX,XLENGTH;

OUTPUT(11)TITLE(1:50);
(8H TITLE $,A50,1H$);
OUTPUT(11);
(' XLABEL /WAVELENGTH (A)/');
OUTPUT(11);
(23H YLABEL /RELATIVE FLUX/);
OUTPUT(11)XLENGTH;
(9H XLENGTH ,F6.2);
OUTPUT(11);
(14H YLENGTH 24.5 );
OUTPUT(11);
(14H XFORMAT F6.0 );
OUTPUT(11);
(14H YFORMAT F5.2 );
OUTPUT(11)XMIN;
(6H XMIN ,F6.1);
OUTPUT(11)XMAX;
(6H XMAX ,F6.1);
OUTPUT(11)YMIN;
(6H YMIN ,F10.6);
OUTPUT(11)YMAX;
(6H YMAX ,F10.6);
RETURN;END;


SUBROUTINE PRINT FLUXS(LEFT,RIGHT);

IMPLICIT REAL*8(A-H,O-Z);

INTEGER LEFT,RIGHT;

OUTPUT(11);(10H MARKER 3 );
OUTPUT(11);(8H NOLINE );
OUTPUT(11);(' COLOR BLUE ');
FOR I = LEFT TO RIGHT   <
   WAVE = WAV(DBLE(I));
   FLUX = SPEC(I);
   OUTPUT(11)WAVE,FLUX;
   (F10.3,2X,F10.6);   >
RETURN;
END;


SUBROUTINE PRINT CONTINUUM(LEFT,RIGHT);

IMPLICIT REAL*8(A-H,O-Z);

INTEGER LEFT,RIGHT,I;
REAL*8 WAVE,FLUX;

OUTPUT(11);(10H NOMARKER ,/,6H LINE ,/,13H COLOR GREEN );
FOR I = LEFT TO RIGHT   <
   WAVE = WAV(DBLE(I));
   FLUX = CONTINUUM(DBLE(I));
   OUTPUT(11)WAVE,FLUX;
   (F10.3,2X,F10.6);   >
RETURN;
END;


SUBROUTINE PRINT LINE FLUXS(IPLOT);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;

REAL*8 POSN,LEFT,RIGHT,LEFT1,RIGHT1,FLUX0,FLUX1,FLUX2;
INTEGER IPLOT,LINE,INEXT,ILAST;
LOGICAL LINE IS OUT OF BOUNDS;

POSN = 0.0;
FOR LINE = 1 TO NUMBER OF LINES    <
   INEXT = LINE + 1;  ILAST = LINE - 1;
   GET LINE BOUNDS(LINE,LEFT,RIGHT);
   GET LINE BOUNDS(INEXT,LEFT1,RIGHT1);
   IF LEFT1 .EQ. LEFT   <
      LEFT1 = RIGHT;   >
   IF POSN .LT. LEFT   <  POSN = LEFT;  >
   IF LINE IS OUT OF BOUNDS(LEFT,RIGHT,IPLOT)   <  NEXT;  >
   IF BLEND(LINE) .EQ. 0  .OR.  BLEND(LINE) .EQ. 1   <
      OUTPUT(11);(' NOMARKER ',/,' LINE ',/,' COLOR RED ',/);   >
   OUTPUT CURRENT LINE FLUX(LINE,POSN,BLEND(LINE),LEFT1,RIGHT);
   >
OUTPUT(11);(' COLOR BLACK ',/);
RETURN;
END;


SUBROUTINE GET LINE BOUNDS(LINE,LEFT,RIGHT);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-ROTATION;
REAL*8 LEFT,RIGHT,WIDTH,VWIDTH,PI;
INTEGER LINE;

PI = 3.141592654;

LEFT = 0.0; RIGHT = 0.0;
IF LINE .GT. NUMBER OF LINES   <
   RETURN;   >
ELSEIF DABS(DEPTH(LINE)) .LE. 1.0D-8   <
   RETURN;   >
WIDTH = EW(LINE)/( DEPTH(LINE)*0.60056121*DMYSQ(PI)*DISP*1000.0 );
CENT  = CENTRE(LINE);
VWIDTH = (VSINI/3.0D5)*(WAV(CENT)/DISP);
LEFT  = CENT - 1.5*WIDTH - VWIDTH;
RIGHT = CENT + 1.5*WIDTH + VWIDTH;
IF 1.5*WIDTH+VWIDTH .GT. 50.0 <
   LEFT  = CENT - 50.0;
   RIGHT = CENT + 50.0;
   >
RETURN;
END;


LOGICAL FUNCTION LINE IS OUT OF BOUNDS(LEFT,RIGHT,IPLOT);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-PLOTS;

REAL*8 LEFT,RIGHT,PLEFT,PRIGHT;
INTEGER IPLOT;

LINE IS OUT OF BOUNDS  = .TRUE.;
IF SCREEN   <
   PLEFT = DBLE(SCREEN LEFT);
   PRIGHT= DBLE(SCREEN RIGHT);
"
 This seems stupid to me!  So, I'm removing it.

   IF RIGHT .GT. PRIGHT  .AND.  LEFT .LT. PRIGHT   <
      IPLOT = INT(LEFT) - SCREEN RIGHT;   >
"
   >
ELSE   <
   PLEFT = DBLE(NPLOTL(IPLOT));
   PRIGHT= DBLE(NPLOTR(IPLOT));  >
IF LEFT .LT. PLEFT   <
   IF RIGHT .LT. PLEFT   <  RETURN;  >
   LEFT = PLEFT;
   >
ELSEIF RIGHT .GT. PRIGHT   <        
   IF LEFT .GT. PRIGHT   <  RETURN;  >
   RIGHT = PRIGHT;
   >
LINE IS OUT OF BOUNDS = .FALSE.;
RETURN;
END;


SUBROUTINE OUTPUT CURRENT LINE FLUX(LINE,POSN,BLEND,LEFT1,RIGHT);

IMPLICIT REAL*8(A-H,O-Z);

INTEGER LINE,BLEND,ILAST,INEXT;
REAL*8 POSN,LEFT1,RIGHT;
LOGICAL FIRST;

COMMON-BLOCK-PLOTS;

INEXT = LINE+1;  ILAST = LINE-1;
FIRST = .TRUE.;
LOOP   <
   EVALUATE LINE FLUX(LINE,POSN,FLUX0);
   FOR INEXT = LINE+1 TO LINE+2   <
      EVALUATE LINE FLUX(INEXT,POSN,FLUX1);
      FLUX0 = FLUX0 + FLUX1;   >
   FOR ILAST = LINE-1 TO LINE-2 BY -1   <
      EVALUATE LINE FLUX(ILAST,POSN,FLUX1);
      FLUX0 = FLUX0 + FLUX1;   >
   FLUX0 = (1.0 - FLUX0)*CONTINUUM(POSN);
   IF SCREEN   <
      IF FIRST   <
         MOVE PEN TO USER(WAV(POSN),FLUX0);
         FIRST = .FALSE.;   >
      PLOT LINE FLUX(POSN,FLUX0);   >
   ELSE   <
      PRINT POINT(POSN,FLUX0);   >
   IF BLEND .LE. 0   <
      IF POSN .GE. LEFT1 .AND. LEFT1.GT.0.0  .OR.
         POSN .GE. RIGHT   <  EXIT;  >   >
   IF POSN .GE. LEFT1 .AND. LEFT1.GT.0.0  .OR.
      POSN .GE. RIGHT   <  EXIT;  >
   POSN = POSN + 0.25;
   >REPEAT;
RETURN;
END;


SUBROUTINE EVALUATE LINE FLUX(LINE,POSN,FLUX);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-ROTATION;
REAL*8 POSN,FLUX,DEEP,SIGMA,A(9),SW(9);
INTEGER LINE;

A(1) = DEPTH(LINE);             SW(1) = 1.0D0;
A(2) = CENTRE(LINE);            SW(2) = 1.0D0;
A(3) = FWHM(LINE)*0.60056121;   SW(3) = 1.0D0;
FOR I = 4 TO 9  < SW(I) = 0.0;  >

FLUX = 0.0;
IF LINE .LE. 0  .OR.  LINE .GT. NUMBER OF LINES    <
   FLUX = 0.0;
   RETURN;   >
IF FWHM(LINE) .EQ. 0.0   <
   RETURN;   >

"*******    removing this due to possible vsini effects
IF DABS( (POSN-CENTRE(LINE))/FWHM(LINE) ) .GE. 6.0   <
   FLUX = 0.0;   >
ELSE   <
 old stuff here A.McW 3/96
   SIGMA = FWHM(LINE)*0.60056121;
   FLUX = DEPTH(LINE)*EXP(- ((POSN-CENTRE(LINE))/SIGMA)**2);   >
********  "

FLUX = PROFILE(POSN, A, SW, VSINI); 
RETURN;
END;


SUBROUTINE PRINT POINT(POSN,FLUX);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 POSN,FLUX;

OUTPUT(11)WAV(POSN),FLUX;
(F10.3,2X,F10.6);
RETURN;
END;


"
  THE FOLLOWING ROUTINES ARE FOR PLOTTING ON A TEKTRONIXS TERMINAL.
"

SUBROUTINE PERFORM TEKTRONIXS SCREEN PLOTTING(NUMBER OF DIODES);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-PLOTS;
INTEGER START,FINISH,NUMBER OF DIODES,LPG,PGOPEN;
LOGICAL PLOT WINDOW IS IN SPECTRUM;

IF .NOT. SCREEN   <
   RETURN;   >

SOFT_DEVICE = '/GTERM' ;
/UNIX_CODE/;
   "
   Removed AMcW 15/Jan/1999
   IF (SOFT_DEVICE.EQ.' ') <
      CALL GETENV('PGSOFT',SOFT_DEVICE);
       If unsuccessful let PGBEG prompt user for device: 
      IF (SOFT_DEVICE.EQ.' ') < SOFT_DEVICE = '?'; >
   >
   "
/UNIX_END/;
/VMS_CODE/;
   IF (SOFT_DEVICE.EQ.' ') <
      LPG=6;
      CALL LIB$SYS_TRNLOG('PGSOFT',LPG,SOFT_DEVICE);
      " If unsuccessful let PGBEG prompt user for device: "
      IF (LPG.LE.0) < SOFT_DEVICE = '?'; >
   >
/VMS_END/;

/PGP_CODE/;
CALL PGBEG(14,SOFT_DEVICE,1,1);
CALL PGASK(.FALSE.);
"TEST"
   CALL PGSCR(1,0,240,0);
   CALL PGSCI(1);
/PGP_END/;

/TEK_CODE/;
CALL INITT(120);
CALL TERM(1,NTEKPTS);
/TEK_END/;

" plot continuum first -AMcW 29/2/2000"

CONTINUUM PLOT;   
INTERACT WITH USER(I,ISHIFT);

IF NUMBER OF PLOTS .GT. 0   <
   DETERMINE PLOT BOUNDS (NUMBER OF DIODES);
   WSTART = WAV(1.0D0);  WEND = WAV( DBLE(NUMBER OF DIODES) );
   FOR I = 1 TO NUMBER OF PLOTS   <
      IF PLOT WINDOW IS IN SPECTRUM (WSTART,WEND,I)  <
         START = NPLOTL(I);
         FINISH= NPLOTR(I);
         CONTINUUM PLOTTING = .FALSE.;
         LEAF THROUGH SPECTRUM(START,FINISH,I);   >
      >
   >
ELSEIF PLOTALL   <
   START = 1;
   FINISH= NUMBER OF DIODES;
   CONTINUUM PLOTTING = .FALSE.;
   LEAF THROUGH SPECTRUM(START,FINISH,I);   >

/TEK_CODE/;
CALL FINITT(0,0);
/TEK_END/;

/PGP_CODE/;
CALL PGEND;
/PGP_END/;

RETURN;
END;


LOGICAL FUNCTION PLOT WINDOW IS IN SPECTRUM (WSTART,WEND,NPLOT);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-PLOTS;
COMMON-BLOCK-BADDIODE;

PLOT WINDOW IS IN SPECTRUM = .FALSE.;

"
  First check that current plot window lies within wavelength bounds of
  the spectrum. 
"

IF WPLOTR(NPLOT).GT.WSTART .AND. WPLOTL(NPLOT).LT.WEND  <

   " now check that plot window is not immersed in a BAD DIODE region "

   FOR I = 1 TO NOBAD  <
      IF NPLOTL(NPLOT).GE.BAD LEFT(I) .AND. NPLOTR(NPLOT).LE.BAD RIGHT(I)  < 
         RETURN;
      >
   >
   PLOT WINDOW IS IN SPECTRUM = .TRUE.;
>

RETURN;
END;


SUBROUTINE LEAF THROUGH SPECTRUM(START,FINISH,IPLOT);

IMPLICIT REAL*8(A-H,O-Z);

INTEGER IEND,START,FINISH,IPLOT,ISHIFT,J;
LOGICAL EMPTY;

J = IPLOT;
LOOP   <
   IF FINISH-START .GT. 110   <
      IEND = START + 100;
      PLOT SPECTRUM ON SCREEN(START,IEND,EMPTY);
      IF EMPTY  <
                START = IEND + 100;
                NEXT;
      >
      DISPLAY LINES TO USER(ISHIFT);
      MARK LINES;
      INTERACT WITH USER(J,ISHIFT);
      IF J .NE. IPLOT   <
         IPLOT = J;
         EXIT;   >
      IF  IEND+ISHIFT .GE. 1   <
         START = IEND + ISHIFT;   >
      ELSE   <  START = 1;  >
      >
   ELSEIF FINISH-START .GE. 10   <
      PLOT SPECTRUM ON SCREEN(START,FINISH,EMPTY);
      IF EMPTY  <
                START = IEND + 100;
                NEXT;
      >
      DISPLAY LINES TO USER(ISHIFT);
      MARK LINES;
      INTERACT WITH USER(IPLOT,ISHIFT);
      START = START + ISHIFT + 100;
      IF ISHIFT .EQ. 0   <  EXIT;  >
      >
   ELSE   <
      RETURN;   >
   >REPEAT;
RETURN;
END;


SUBROUTINE PLOT SPECTRUM ON SCREEN(ISTART,IEND,EMPTY);

IMPLICIT REAL*8(A-H,O-Z);
LOGICAL EMPTY;

EMPTY = .FALSE.;
SET TERMINAL WINDOW;
SET DATA WINDOW(ISTART,IEND,XMIN,XMAX,YMIN,YMAX);
IF YMAX.LE.0.0  <                            " if nothing on page don't plot "
   EMPTY = .TRUE.;
   RETURN;  >
ERASE SCREEN;
PLOT DATA ARRAY(ISTART,IEND);
PLOT CONTINUUM(ISTART,IEND);
/TEK_CODE/;
PLOT AXES(XMIN,XMAX,YMIN,YMAX);
DRAW TICKMARKS(XMIN,XMAX,YMIN,YMAX);
LABEL AXES;
/TEK_END/;
/PGP_CODE/;
DRAW PGPLOT BOX(XMIN,XMAX,YMIN,YMAX); 
/PGP_END/;
RETURN;
END;


SUBROUTINE SET TERMINAL WINDOW;

IMPLICIT REAL*8(A-H,O-Z);

IXMIN = 100;
IXMAX = 900;
IYMIN = 275;
IYMAX = 750;
SET SCREEN BOUNDS(IXMIN,IXMAX,IYMIN,IYMAX);
RETURN;
END;


SUBROUTINE SET DATA WINDOW(ISTART,IEND,XMIN,XMAX,YMIN,YMAX);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-PLOTS;

SCREEN LEFT = ISTART;
SCREEN RIGHT= IEND;
XMIN = WAV(DBLE(ISTART));
XMAX = WAV(DBLE(IEND));
FIND MINIMUM(ISTART,IEND,YMIN);
FIND MAXIMUM DATA(ISTART,IEND,YMAX);
FIND MAXIMUM CONTINUUM(ISTART,IEND,CMAX);
IF CMAX .GT. YMAX  <  YMAX = CMAX;  >
YRANGE = YMAX - YMIN;
YMAX = YMAX + 0.05*YRANGE;
YMIN = YMIN - 0.05*YRANGE;
IF YRANGE .EQ. 0.0   <
   YMAX = 1.05*YMAX;
   YMIN = 0.95*YMIN;  >
IF YMIN .LT. 0.0   <  YMIN = 0.0;  >
SET USER WINDOW(XMIN,XMAX,YMIN,YMAX);
RETURN;
END;


/IRAF_CODE/;  "This version makes use of IRAF's linear dispersion"
REAL*8 FUNCTION WAV(POSN);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 POSN;
COMMON-BLOCK-LINES;
COMMON-BLOCK-SPECTRUM;

WAV = OFFSET + DISP*(POSN-PIX_OFFSET);   
WAV = WAV / (1.0+RV/3.0D+05);

RETURN;
END;
/IRAF_END/;


/FIGARO_CODE/; "This version makes use of an explicit LAMBDA array"
REAL*8 FUNCTION WAV(XPOSN);

IMPLICIT REAL*8(A-H,O-Z);

INTEGER IPOSN;
REAL*8  XPOSN,DLAMBDA;
COMMON-BLOCK-LINES;
COMMON-BLOCK-SPECTRUM;

IPOSN = DINT(XPOSN);
IF (IPOSN.EQ.NUMBER OF DIODES) <
   DLAMBDA=LAMBDA(NUMBER OF DIODES)-LAMBDA(NUMBER OF DIODES-1); >
ELSE <
   DLAMBDA=LAMBDA(IPOSN+1)-LAMBDA(IPOSN);
>
WAV = LAMBDA(IPOSN) + (XPOSN-DBLE(IPOSN))*DLAMBDA;
WAV = WAV / (1.0+RV/3.0D+05);

RETURN;
END;
/FIGARO_END/;


/IRAF_CODE/;  "This version makes use of IRAF's linear dispersion"
REAL*8 FUNCTION CHANNEL(W);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-SPECTRUM;

W0 = W * (1.0+RV/3.0D+05);
CHANNEL = PIX_OFFSET + (W0-OFFSET)/DISP;

RETURN;
END;
/IRAF_END/;


/FIGARO_CODE/; "This version makes use of an explicit LAMBDA array"
REAL*8 FUNCTION CHANNEL(W);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8  W0;
INTEGER GEN_DSEARCH;
INTEGER ICHAN;
REAL*8  WSTEP;
COMMON-BLOCK-LINES;
COMMON-BLOCK-SPECTRUM;

W0 = W * (1.0+RV/3.0D+05);
ICHAN = GEN_DSEARCH(LAMBDA,NUMBER OF DIODES,W0);
IF (ICHAN.EQ.0) <
   CHANNEL = 0.0D00;
   RETURN;
>
IF (ICHAN.EQ.NUMBER OF DIODES) <
   WSTEP = LAMBDA(NUMBER OF DIODES) - LAMBDA(NUMBER OF DIODES-1); >
ELSEIF (ICHAN.EQ.1) <
   WSTEP = LAMBDA(2) - LAMBDA(1); >
ELSEIF (W0.LT.LAMBDA(ICHAN)) <
   WSTEP = LAMBDA(ICHAN) - LAMBDA(ICHAN-1); >
ELSE <
   WSTEP = LAMBDA(ICHAN+1) - LAMBDA(ICHAN);
>
CHANNEL = DFLOAT(ICHAN) + (W0-LAMBDA(ICHAN))/WSTEP;

RETURN;
END;
/FIGARO_END/;


SUBROUTINE FIND MINIMUM(ISTART,IEND,YMIN);

IMPLICIT REAL*8(A-H,O-Z);

LOGICAL BAD DIODE;
INTEGER ISTART,IEND;
REAL*8 YMIN;

YMIN = SPEC(ISTART);
FOR I = ISTART TO IEND   <
   IF SPEC(I) .LT. YMIN .AND. .NOT.BAD DIODE(I)   < 
      YMIN = SPEC(I);   >
   >
YMIN = YMIN;
RETURN;
END;


SUBROUTINE FIND MAXIMUM DATA(ISTART,IEND,YMAX);

IMPLICIT REAL*8(A-H,O-Z);

LOGICAL BAD DIODE;
INTEGER ISTART,IEND;
REAL*8 YMAX;

YMAX = SPEC(ISTART);
FOR I = ISTART TO IEND   <
   IF SPEC(I) .GT. YMAX .AND. .NOT.BAD DIODE(I)  <
      YMAX = SPEC(I);   >
   >
YMAX = YMAX;
RETURN;
END;


SUBROUTINE FIND MAXIMUM CONTINUUM(ISTART,IEND,YMAX);

IMPLICIT REAL*8(A-H,O-Z);

INTEGER ISTART,IEND;
REAL*8 YMAX;

YMAX = CONTINUUM(DBLE(ISTART));
FOR I = ISTART TO IEND   <
   IF CONTINUUM(DBLE(I)) .GT. YMAX   <
      YMAX = CONTINUUM(DBLE(I));   >
   >
RETURN;
END;


/TEK_CODE/; " Original Tektronix plotting version"
SUBROUTINE PLOT DATA ARRAY(ISTART,IEND);

IMPLICIT REAL*8(A-H,O-Z);

FIND USER WINDOW BOUNDS(XMIN,XMAX,YMIN,YMAX);
FOR I = ISTART TO IEND   <
   Y = SPEC(I);
   IF Y .LE. YMAX  .AND.  Y .GE. YMIN   <
      PLOT PLUS(WAV(DBLE(I)),Y);   >
   >
RETURN;
END;
/TEK_END/;


/PGP_CODE/; " PGPLOT replacement for original Tek version "
SUBROUTINE PLOT DATA ARRAY(ISTART,IEND);

IMPLICIT REAL*8(A-H,O-Z);
INTEGER N,I;

REAL*4 XPLOT(MAX DIODE),YPLOT(MAX DIODE);

N = IEND-ISTART+1;
FOR I = 1 TO N <
   YPLOT(I) = REAL(SPEC(I+ISTART-1));
   XPLOT(I) = REAL(WAV(DBLE(I+ISTART-1)));
>
"
write(23,'(15h istart,iend,n ,3i16)')istart,iend,n;
write(23,'(13h xplot,yplot ,2f10.4)')(xplot(ii),yplot(ii),ii=1,n);
"
CALL PGPT(N,XPLOT,YPLOT,2);   
RETURN;
END;
/PGP_END/;


/TEK_CODE/;
SUBROUTINE OVERPLOT DATA;

IMPLICIT REAL*8(A-H,O-Z);

FIND USER WINDOW BOUNDS(XMIN,XMAX,YMIN,YMAX);
ISTART = NINT(CHANNEL(XMIN));
IEND = NINT(CHANNEL(XMAX));
FOR I = ISTART TO IEND   <
   Y = SPEC(I);
   IF Y .LE. YMAX  .AND.  Y .GE. YMIN   <
      PLOT SMALL PLUS(WAV(DBLE(I)),Y);   >
   >
RETURN;
END;
/TEK_END/;


/PGP_CODE/;
SUBROUTINE OVERPLOT DATA;

IMPLICIT REAL*8(A-H,O-Z);

INTEGER ISTART,IEND,I,II;
REAL*8 XMIN,XMAX,YMIN,YMAX;
REAL*4 XPLOT(MAX DIODE),YPLOT(MAX DIODE);

FIND USER WINDOW BOUNDS(XMIN,XMAX,YMIN,YMAX);
ISTART = NINT(CHANNEL(XMIN));
IEND = NINT(CHANNEL(XMAX));
FOR I = ISTART TO IEND   <
   II = I-ISTART+1;
   YPLOT(II) = REAL(SPEC(I));
   XPLOT(II) = WAV(DBLE(I));
>
CALL PGPT(IEND-ISTART+1,XPLOT,YPLOT,1);   
RETURN;
END;
/PGP_END/;


/TEK_CODE/;
SUBROUTINE PLOT SMALL PLUS(X,Y);

IMPLICIT REAL*8(A-H,O-Z);

MOVE PEN TO USER(X,Y);
CALL MOVREL(0,1);
CALL DRWREL(0,-2);
CALL MOVREL(-1,1);
CALL DRWREL(2,0);
RETURN;
END;
/TEK_END/;


/TEK_CODE/;
SUBROUTINE PLOT PLUS(X,Y);

IMPLICIT REAL*8(A-H,O-Z);

MOVE PEN TO USER(X,Y);
CALL MOVREL(0,6);
CALL DRWREL(0,-12);
CALL MOVREL(-6,6);
CALL DRWREL(12,0);
RETURN;
END;
/TEK_END/;


/TEK_CODE/;
SUBROUTINE PLOT BIG PLUS(X,Y);

IMPLICIT REAL*8(A-H,O-Z);

MOVE PEN TO USER(X,Y);
CALL MOVREL(0,18);
CALL DRWREL(0,-36);
CALL MOVREL(-18,18);
CALL DRWREL(36,0);
RETURN;
END;
/TEK_END/;


SUBROUTINE PLOT CONTINUUM(ISTART,IEND);

IMPLICIT REAL*8(A-H,O-Z);

MOVE PEN TO USER(WAV(DBLE(ISTART)),CONTINUUM(DBLE(ISTART)));
FOR I = ISTART TO IEND   <
   DRAW TO USER(WAV(DBLE(I)),CONTINUUM(DBLE(I)));   >
RETURN;
END;


/TEK_CODE/;
SUBROUTINE PLOT AXES(XMIN,XMAX,YMIN,YMAX);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 XMIN,XMAX,YMIN,YMAX;

MOVE PEN TO USER(XMAX,YMIN);
DRAW TO USER(XMAX,YMAX);
DRAW TO USER(XMIN,YMAX);
DRAW TO USER(XMIN,YMIN);
DRAW TO USER(XMAX,YMIN);
RETURN;
END;
/TEK_END/;


/TEK_CODE/;
SUBROUTINE DRAW TICKMARKS(XMIN,XMAX,YMIN,YMAX);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 INCR,INCRD2,XMIN,XMAX,YMIN,YMAX;

"
  THIS ROUTINE WAS COPIED FROM COUDMAN WITHOUT ATTEMPTING TO UNDERSTAND
  IT.  THEREFORE THE CODE LOOKS SLOPPY FOR MORTRAN.
"
XLOW = XMIN;  YLOW = YMIN;
XRANGE = DABS(XMAX-XMIN);  YRANGE = DABS(YMAX-YMIN);
INCR = TICSTEP(XRANGE/10.0);
IF INCR .LE. 0.05   <  INCR = 2.0*INCR;  >
NSTEP = INT(XRANGE/INCR);
IF NSTEP .GT. 7  .OR. (NSTEP .GT. 5  .AND.  XMAX .GT. 10000.0) <
   INCR = 2.0*INCR;   >
TICVAL = FLOAT( INT(XMIN/INCR)-1 )*INCR;
INCRD2 = INCR/2.0;
FOR I = 1 TO 11   <
   TICVAL = TICVAL + INCR;
   IF TICVAL .LT. XMIN <
      NEXT; >
   ELSEIF TICVAL .GT. XMAX  <
      EXIT;   >
   IF DABS(TICVAL) .LT. INCRD2 <
      TICVAL = 0.0;   >
   MOVE PEN TO USER(TICVAL,YLOW);
   CALL DRWREL(0,-15);
   CALL MOVREL(-36,-25);
   CALL ANMODE;
   WRITE(6,'(F7.1)')TICVAL;   >
"
DRAW Y TICKS
"
INCR = TICSTEP(YRANGE/10.0);
IF INCR .LE. 0.005   <  INCR = 2.0*INCR;  >
TICVAL = FLOAT( INT(YMIN/INCR)-1 )*INCR;
INCRD2 = INCR/2.0;
FOR I = 1 TO 12   <
   TICVAL = TICVAL + INCR;
   IF TICVAL .LT. YMIN   <
      NEXT;   >
   ELSEIF TICVAL .GT. YMAX   <
      EXIT;   >
   IF DABS(TICVAL) .LT. INCRD2   <
      TICVAL = 0.0;   >
   MOVE PEN TO USER(XLOW,TICVAL);
   CALL DRWREL(-15,0);
   CALL MOVREL(-130,-8);
   CALL ANMODE;
   WRITE(6,'(F6.2)')TICVAL;   >
RETURN;
END;
/TEK_END/;


/TEK_CODE/;
REAL*8 FUNCTION TICSTEP(DF);

IMPLICIT REAL*8(A-H,O-Z);
"
  TAKEN FROM COUDMAN.
"
REAL*8 DF;
T2 = DLOG10(2.0D+00);
T5 = DLOG10(5.0D+00);
P1 = DLOG10(DF);
P2 = FLOAT( INT(P1) );
P3 = P1 - P2;
IF P3 .LT. 0.0  <
   P3 = P3 + 1.0;
   P2 = P2 - 1.0;   >
IF P3 .LT. FPMINVAL  <
   TICSTEP = 10.0**(P2);   >
IF P3 .GT. 0.0  .AND.  P3 .LE. T2  <
   TICSTEP = 10.0**(P2+T2);   >
IF P3 .GT. T2  .AND.  P3 .LT. T5   <
   TICSTEP = 10.0**(P2+T5);   >
IF P3 .GT. T5  .AND.  P3 .LT. 1.0  <
   TICSTEP = 10.0**(P2+1.0);  >
RETURN;
END;
/TEK_END/;


/TEK_CODE/;
SUBROUTINE LABEL AXES;

IMPLICIT REAL*8(A-H,O-Z);

CALL MOVABS(20,780);
CALL ANMODE;
OUTPUT(6);(' RELATIVE FLUX ');
CALL MOVABS(430,200);
CALL ANMODE;
OUTPUT(6);(' WAVELENGTH (A) ');
RETURN;
END;
/TEK_END/;


/PGP_CODE/;
SUBROUTINE DRAW PGPLOT BOX(XMIN,XMAX,YMIN,YMAX);

" P G P _ B O X "

REAL*8 XMIN,XMAX,YMIN,YMAX;
REAL*4 X1,X2,Y1,Y2;

X1 = XMIN; X2 = XMAX;
Y1 = YMIN; Y2 = YMAX;

CALL PGBOX('BCNTS',0.0,0,'BCNTS',0.0,0);
CALL PGLAB('WAVELENGTH (A)','RELATIVE FLUX',' ');
RETURN;
END;
/PGP_END/;


SUBROUTINE DISPLAY LINES TO USER(ISHIFT);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
LOGICAL LINE IS OUT OF BOUNDS;
INTEGER ISHIFT,LINE;
REAL*8 LEFT,RIGHT,LEFT1,RIGHT1;

LEFT = 0.0;
RIGHT = 0.0;
ISHIFT = 0;
POSN = 0.0;
FOR LINE = 1 TO NUMBER OF LINES   <
   INEXT = LINE + 1;  ILAST = LINE - 1;
   GET LINE BOUNDS(LINE,LEFT,RIGHT);
   GET LINE BOUNDS(INEXT,LEFT1,RIGHT1);
   IF LEFT1 .EQ. LEFT   <
      LEFT1 = RIGHT;   >
   IF POSN .LT. LEFT   <
      POSN = LEFT;   >
   IF INEXT .GT. NUMBER OF LINES   <
      LEFT1 = RIGHT;   >
   IF LINE IS OUT OF BOUNDS(LEFT,RIGHT,ISHIFT)   <
      NEXT;   >
   OUTPUT CURRENT LINE FLUX(LINE,POSN,BLEND(LINE),LEFT1,RIGHT);
   >
RETURN;
END;



SUBROUTINE PLOT NEXT LINE(ISHIFT);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-PLOTS;
CHARACTER*1 ANS;


IF CONTINUUM PLOTTING  <
   RETURN;
   >

FOR LINE = 1 TO NUMBER OF LINES  <
   IF CENTRE(LINE) .GT. DBLE(SCREEN RIGHT) <
      MID = (SCREEN LEFT + SCREEN RIGHT)/2;
      ISHIFT  = NINT(CENTRE(LINE)) - MID - 100;
      RETURN;
      >
   >

WRITE(6,'(A)')'No more lines; skip to next order/spectrum?';
READ(5,'(A)')ANS;
IF ANS .EQ. 'Y' .OR. ANS .EQ. 'y'   <
   ISHIFT = 10000;
   >
ELSE  <
   ISHIFT = -100;
   >
      
RETURN;
END;




SUBROUTINE PLOT LAST LINE(ISHIFT);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-PLOTS;


IF CONTINUUM PLOTTING  <
   RETURN;
   >

FOR LINE = NUMBER OF LINES TO 1 BY -1  <
   IF CENTRE(LINE) .LT. DBLE(SCREEN LEFT) <
      MID = (SCREEN LEFT + SCREEN RIGHT)/2;
      ISHIFT  = NINT(CENTRE(LINE)) - MID - 100;
      RETURN;
      >
   >

WRITE(6,'(A)')'This is the first line';
ISHIFT = -100;
      
RETURN;
END;




SUBROUTINE INTERACT WITH USER(IPLOT,ISHIFT);

IMPLICIT REAL*8(A-H,O-Z);

CHARACTER*2 COMM;
INTEGER ISHIFT,IPLOT;
LOGICAL PAPER,FOUND;
COMMON-BLOCK-PLOTS;
COMMON-BLOCK-COMMANDS;
COMMON-BLOCK-SYNTHESIS;

INITIALISE COMMAND AREA;
NFILE = 0;   PAPER = .FALSE.;  
LOOP   <
   DISPLAY PROMPT;
   READ(5,'(A2)')COMM;
   IF COMM .EQ. 'a '   <
      AGAIN;   >
   ELSEIF COMM .EQ. 'ac'   <
      ADD CONTINUUM;   >
   ELSEIF COMM .EQ. 'b '   <
      BLOWUP SCREEN;   >
   ELSEIF COMM .EQ. 'z '   <
      ZERO PLOT;   >
   ELSEIF COMM .EQ. 'cc'   <
      DELETE CONTINUUM(FOUND);
      IF FOUND   <  ADD CONTINUUM;  >
      "REPLACE CONTINUUM;"   >
   ELSEIF COMM .EQ. 'dc'   <
      DELETE CONTINUUM(FOUND);   >
   ELSEIF COMM .EQ. 'cp'   <
      CONTINUUM PLOT;   >
   ELSEIF COMM .EQ. 'fc'   <
      CONTINUUM FIT; >
   ELSEIF COMM .EQ. 'nf'   <
      DOT TO DOT;   >
   ELSEIF COMM .EQ. 'ml'   <
      MARK LINES;   >
   ELSEIF COMM .EQ. 'op'   <
      OVERPLOT DATA;   >
   ELSEIF COMM .EQ. 'ds'   <
      CONTINUUM PLOTTING = .FALSE.;
      ISHIFT = -100;
      RETURN;   >
   ELSEIF COMM .EQ. 'ew'   <
      MEASURE FEATURE;   >
   ELSEIF COMM .EQ. 'fl'   <
      PLOT FULL SPECTRUM;   >
   ELSEIF COMM .EQ. 'ha'   <
      PAPER COPY;   >
   ELSEIF COMM .EQ. 'r '   <
      REJECT LINE;   >
   ELSEIF COMM .EQ. 'rm'   <
      REMEASURE LINES;   >
   ELSEIF COMM .EQ. 'p '   <
      POINT DIODE;   >
   ELSEIF COMM .EQ. 'pb'   <
      ISHIFT = - 200;
      RETURN;   >
   ELSEIF COMM .EQ. 'pl'   <
      OPEN SYNTHESIS FILE(W0,WSTEP);
      PLOT SYNTHESIS(W0,WSTEP,PAPER);
      CLOSE(UNIT=13);   >
   ELSEIF COMM .EQ. 'nn'   <
      ISHIFT = 10000;
      RETURN;   >
   ELSEIF COMM .EQ. 'n '   <
      PLOT NEXT LINE(ISHIFT);
      RETURN;   >
   ELSEIF COMM .EQ. 'l '   <
      PLOT LAST LINE(ISHIFT);
      RETURN;   >
   ELSEIF COMM .EQ. 'll'   <
      IF IPLOT .EQ. 0   < NEXT; >
      IPLOT = IPLOT - 2;
      IF IPLOT .LT. 0   <
         IPLOT = 0;  >
      RETURN;   >
   ELSEIF COMM .EQ. 'c '   <
      RETURN;   >
   ELSEIF COMM .EQ. 'q '   <
      IPLOT = 100;
      RETURN;   >
   ELSEIF COMM .EQ. 'sg'   <
      NGAUSS = 1;
      INTERACTIVE MULTIPLE GAUSSIAN(NGAUSS);   >
   ELSEIF COMM .EQ. 'dg'   <
      NGAUSS = 2;
      INTERACTIVE MULTIPLE GAUSSIAN(NGAUSS);   >
   ELSEIF COMM .EQ. 'tg'   <
      NGAUSS = 3;
      INTERACTIVE MULTIPLE GAUSSIAN(NGAUSS);   >
   ELSEIF COMM .EQ. 'sl'   <
      DISPLAY LINES TO USER(I);   >
   ELSEIF COMM .EQ. 'v '   <
      SET VSINI;   >
   ELSEIF COMM .EQ. 'ab'   <
      STOP;   >
   >REPEAT;
RETURN;
END;


SUBROUTINE AGAIN;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-COMMANDS;
COMMON-BLOCK-PLOTS;
LOGICAL PAPER;

PAPER = .FALSE.;
FIND USER WINDOW BOUNDS(XMIN,XMAX,YMIN,YMAX);
ERASE SCREEN;
ISTART = NINT(CHANNEL(XMIN));
IEND   = NINT(CHANNEL(XMAX));
IF CONTINUUM PLOTTING   <
   REPLOT CONTINUUM;
   DISPLAY CONTINUUM REGIONS ON PAGE;   >
ELSE   <
   PLOT DATA ARRAY(ISTART,IEND);
   PLOT CONTINUUM(ISTART,IEND); 
   REPLOT SYNTHESES(PAPER);   >
/TEK_CODE/;
PLOT AXES(XMIN,XMAX,YMIN,YMAX);
DRAW TICKMARKS(XMIN,XMAX,YMIN,YMAX);
LABEL AXES;
/TEK_END/;
/PGP_CODE/;
DRAW PGPLOT BOX(XMIN,XMAX,YMIN,YMAX); 
/PGP_END/;

INITIALISE COMMAND AREA;
RETURN;
END;





SUBROUTINE MARK LINES;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-COMMANDS;
COMMON-BLOCK-LINES;

LOGICAL PAPER;
REAL*8 TOP,BOTTOM,YTEXT;

PAPER = .FALSE.;
FIND USER WINDOW BOUNDS(XMIN,XMAX,YMIN,YMAX);

TOP     = 0.4  * (YMAX - YMIN) + YMIN;
BOTTOM  = 0.3  * (YMAX - YMIN) + YMIN;
YTEXT   = 0.25 * (YMAX - YMIN) + YMIN;

FOR I = 1 TO NUMBER OF LINES  <
    IF WAVELENGTH(I).GE.XMIN .AND. WAVELENGTH(I).LE.XMAX   <
       MOVE PEN TO USER(WAVELENGTH(I),BOTTOM);
       DRAW TO USER(WAVELENGTH(I),TOP);
       PUT LINE LABEL(WAVELENGTH(I),YTEXT,LINEID(I));   >
    >
RETURN;
END;




SUBROUTINE PUT LINE LABEL(X,Y,LABEL);

REAL*8 X,Y;
REAL*4 XL,YL;
CHARACTER*10 LABEL;

XL = X;
YL = Y;

CALL PGTEXT(XL,YL,LABEL);

RETURN;
END;





SUBROUTINE ZERO PLOT;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-COMMANDS;
COMMON-BLOCK-PLOTS;
LOGICAL PAPER;

PAPER = .FALSE.;
FIND USER WINDOW BOUNDS(XMIN,XMAX,YMIN,YMAX);
YMIN = 0.0;
ISTART = NINT(CHANNEL(XMIN));
IEND   = NINT(CHANNEL(XMAX));
ERASE SCREEN;
SET USER WINDOW(XMIN,XMAX,YMIN,YMAX);
PLOT CONTINUUM(ISTART,IEND);
/TEK_CODE/;
PLOT AXES(XMIN,XMAX,YMIN,YMAX);
DRAW TICKMARKS(XMIN,XMAX,YMIN,YMAX);
LABEL AXES;
/TEK_END/;
/PGP_CODE/;
DRAW PGPLOT BOX(XMIN,XMAX,YMIN,YMAX); 
/PGP_END/;
IF CONTINUUM PLOTTING   <
   DISPLAY CONTINUUM REGIONS ON PAGE;   >
ELSE   <
    PLOT DATA ARRAY(ISTART,IEND);   
    REPLOT SYNTHESES(PAPER);   >
INITIALISE COMMAND AREA;
RETURN;
END;


/TEK_CODE/;
SUBROUTINE INITIALISE COMMAND AREA;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-COMMANDS;

LINENO = 0;
ICOL = 1;
CALL SETMRG(0,1023);
RETURN;
END;
/TEK_END/;


"
THE ROUTINE BELOW ONLY WORKS ON TEKTRONIXS SYSTEMS WHERE SETMRG WORKS PROPERLY.
IT HAS BEEN REPLACED WITH ANOTHER ROUTINE WHICH DOES NOT USE THE SETMRG
SUBROUTINE.

SUBROUTINE DISPLAY PROMPT;

IMPLICIT REAL*8(A-H,O-Z);

IF LINENO .GE. 32   <
   LINENO = -1;   >
LINENO = LINENO + 1;
LFEED = MOD(LINENO,8) + 1;
IF LFEED .EQ. 1   <
   CALL SETMRG(256*LINENO/8,1023);   >
CALL HOME;
CALL MOVREL(0,-580);
FOR I = 1 TO LFEED   <
   CALL LINEF;   >
CALL ANCHO(62);
CALL ANMODE;
RETURN;
END;

"

/TEK_CODE/;
"
THIS ROUTINE ADDED IN BY A.MCWILLIAM 12 JUNE 1989 FOR SUN TERMINALS.
actually it worked for a sun gterm window

SUBROUTINE DISPLAY PROMPT;

IMPLICIT REAL*8(A-H,O-Z);


COMMON-BLOCK-COMMANDS;

IF LINENO.GT.6 <
   LINENO = 0;
   ICOL = ICOL + 1;
   >
CALL HOME;
CALL MOVREL(0,-550);
LINENO = LINENO + 1;
IF LINENO.GT.1   <
   FOR I = 1 TO LINENO-1   <
      CALL NEWLIN;  >   
   >
IF ICOL.GT.4   <  ICOL = 1;   >
NSPACE = (ICOL-1)*18;
FOR J = 1 TO NSPACE   <
   CALL ANCHO(32);   >
CALL ANCHO(62);
CALL ANMODE;
RETURN;
END;

"
"
  The following written by A.McWilliam 3 April 1996 for sun xgterm Tek
  window
"
SUBROUTINE DISPLAY PROMPT;

COMMON-BLOCK-COMMANDS;

IF LINENO.GT.8 <
   LINENO = 0;
   ICOL = ICOL + 1;
   IF ICOL.GT.4   <  ICOL = 1;   >
   >
CALL HOME;
CALL MOVREL(0,-590);
LINENO = LINENO + 1;
IF LINENO.GT.1   <
   FOR I = 1 TO LINENO-1   <
      CALL MOVREL(0,-21);  >  
   >
IF ICOL.GT.1   <
   FOR I = 1 TO ICOL-1   <
      CALL MOVREL(256,0);  >  
   >
CALL ANCHO(62);
CALL ANMODE;
RETURN;
END;

/TEK_END/;



/PGP_CODE/;
SUBROUTINE DISPLAY PROMPT;

WRITE(6,'(1H>$)');
RETURN;
END;
/PGP_END/;


SUBROUTINE BLOWUP SCREEN;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-COMMANDS;
COMMON-BLOCK-PLOTS;

INTEGER ICHAR;
LOGICAL PAPER;


PAPER = .FALSE.;
FIND USER WINDOW BOUNDS(XMIN,XMAX,YMIN,YMAX);
MARK CURSOR POSITION(ICHAR,X1,Y1);
IF ICHAR .EQ. 121   <
   "  121 IS A Y CHARACTER "
   MARK CURSOR POSITION(ICHAR,X2,Y2);
   IF Y1 .GT. Y2   <
      YMIN = Y2;  YMAX = Y1;   >
   ELSEIF Y2 .GT. Y1  <
      YMIN = Y1;  YMAX = Y2;   >
   ELSE < RETURN; >
   >
ELSEIF ICHAR .EQ. 120   <
   "  120 IS THE X CHARACTER  "
   MARK CURSOR POSITION(ICHAR,X2,Y2);
   IF X1 .GT. X2   <
      XMIN = X2;  XMAX = X1;   >
   ELSEIF X2 .GT. X1   <
      XMIN = X1;  XMAX = X2;   >
   ELSE < RETURN; >
   >
ELSEIF ICHAR .EQ. 101   <
   "  101 IS THE e CHARACTER  "
   MARK CURSOR POSITION(ICHAR,X2,Y2);
   IF X1 .GT. X2   <
      XMIN = X2;  XMAX = X1;   >
   ELSEIF X2 .GT. X1   <
      XMIN = X1;  XMAX = X2;   >
   IF Y1 .GT. Y2   <
      YMIN = Y2;  YMAX = Y1;   >
   ELSEIF Y2 .GT. Y1  <
      YMIN = Y1;  YMAX = Y2;   >
   IF X1.EQ.X2 .AND. Y1.EQ.Y2  <
      RETURN; >
   >
ELSE   <
   DISPLAY PROMPT;
   OUTPUT(6);('MUST ENTER x OR y OR e');
   RETURN;   >
ERASE SCREEN;
ISTART = NINT(CHANNEL(XMIN));  XMIN = WAV(DBLE(ISTART));
IEND   = NINT(CHANNEL(XMAX));  XMAX = WAV(DBLE(IEND));
SCREEN LEFT = ISTART;
SCREEN RIGHT= IEND;
SET USER WINDOW(XMIN,XMAX,YMIN,YMAX);
PLOT CONTINUUM(ISTART,IEND);
/TEK_CODE/;
PLOT AXES(XMIN,XMAX,YMIN,YMAX);
DRAW TICKMARKS(XMIN,XMAX,YMIN,YMAX);
LABEL AXES;
/TEK_END/;
/PGP_CODE/;
DRAW PGPLOT BOX(XMIN,XMAX,YMIN,YMAX); 
/PGP_END/;
IF CONTINUUM PLOTTING   <
   DISPLAY CONTINUUM REGIONS ON PAGE;   >
ELSE   <
    PLOT DATA ARRAY(ISTART,IEND);   
    REPLOT SYNTHESES(PAPER);   >
INITIALISE COMMAND AREA;
RETURN;
END;


SUBROUTINE REPLACE CONTINUUM;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-COMMANDS;
COMMON-BLOCK-CONTINUUM;
LOGICAL FOUND,CONTINUUM IS OUT OF ORDER,CONTINUUM IS BAD;

DISPLAY CONTINUUM REGIONS ON PAGE;
MARK CURSOR POSITION(ICHAR,X,Y);
X = CHANNEL(X);
FIND CONTINUUM(X,ICONT,FOUND);
IF .NOT.FOUND   <
   DISPLAY PROMPT;
   OUTPUT(6);('NO CONTINUUM FOUND');
   RETURN;   >
DISPLAY PROMPT;
OUTPUT(6);('ENTER BOUNDS');
MARK CURSOR POSITION(ICHAR,X1,Y1);
MARK CURSOR POSITION(ICHAR,X2,Y2);
IF X2 .LT. X1   <
   XTEMP = X2;
   X2 = X1;
   X1 = XTEMP;   >
X1 = NINT(CHANNEL(X1));
X2 = NINT(CHANNEL(X2));
IF CONTINUUM IS OUT OF ORDER(X1,X2,ICONT)   <
   DISPLAY PROMPT;
   OUTPUT(6);('BAD CONTINUUM ORDER');
   RETURN;   >
OLEFT = CONTINUUM LEFT(ICONT);
ORIGHT = CONTINUUM RIGHT(ICONT);
OSIZE = CONTINUUM SIZE(ICONT);
CONTINUUM LEFT(ICONT) = X1;
CONTINUUM RIGHT(ICONT) = X2;
CONTINUUM SIZE(ICONT) = X2-X1+1.0;
IF CONTINUUM IS BAD(ICONT)   <
   DISPLAY PROMPT;
   OUTPUT(6);('BAD DIODES IN RANGE');
   CONTINUUM LEFT(ICONT) = OLEFT;
   CONTINUUM RIGHT(ICONT) = ORIGHT;
   CONTINUUM SIZE(ICONT) = OSIZE;
   RETURN;   >
FIT CONTINUUM;
REPLOT CONTINUUM;
RETURN;
END;




SUBROUTINE ADD CONTINUUM;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-COMMANDS;
COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-SPECTRUM;
LOGICAL CONTINUUM IS BAD;

DISPLAY CONTINUUM REGIONS ON PAGE;
DISPLAY PROMPT;
OUTPUT(6);('ENTER BOUNDS');
MARK CURSOR POSITION(ICHAR,X1,Y1);
MARK CURSOR POSITION(ICHAR,X2,Y2);
IF X2 .LT. X1   <
   XTEMP = X2;
   X2 = X1;
   X1 = XTEMP;   >
IX1 = NINT(CHANNEL(X1));
IX2 = NINT(CHANNEL(X2));
IF IX1.LT.1  <  IX1 = 1;  >
IF IX2.GT.NUMBER OF DIODES  <  IX2 = NUMBER OF DIODES;  >
IF IX2.LT.1  .OR. IX1.GT.NUMBER OF DIODES  <
   DISPLAY PROMPT;
   OUTPUT(6);('WARNING: OUT OF BOUNDS; NO CONTINUUM ADDED ');   
   RETURN;
   >
NOCONT = NOCONT + 1;
CONTINUUM LEFT(NOCONT)  = IX1;
CONTINUUM RIGHT(NOCONT) = IX2;
CONTINUUM SIZE(NOCONT)  = IX2-IX1+1;
IF CONTINUUM IS BAD(NOCONT)   <
   DISPLAY PROMPT;
   OUTPUT(6);('WARNING: TOO MANY BAD DIODES; NO CONTINUUM ADDED');
   NOCONT = NOCONT - 1;
   RETURN;   >
SINGLE CONTINUUM FLUX(NOCONT);
SORT CONTINUUM;
PERFORM FIT;
REPLOT CONTINUUM;
DISPLAY CONTINUUM REGIONS ON PAGE;
RETURN;
END;






SUBROUTINE SINGLE CONTINUUM FLUX(ICONT);
"
 A routine to compute the flux, sigma, and center of a specified
 region of the spectrum (in pixels).     AMcW 3/2000
"
IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-SPECTRUM;

REAL*8 AVG,SNSIG,SNR;
LOGICAL CONTINUUM IS BAD,BAD DIODE;
INTEGER K,MIDDLE;

SXI    = 0.0; SXIWI = 0.0; SXI2 = 0.0; SNSIG = 0.0;
MIDDLE = 0;   ANUM  = 0.0;

FOR K = CONTINUUM LEFT(ICONT) TO CONTINUUM RIGHT(ICONT)   <
   IF .NOT. BAD DIODE(K)   <
      SXIWI = SXIWI + SPEC(K)*SNR(K)**2;
      SXI  = SXI + SPEC(K);
      SXI2 = SXI2 + SPEC(K)**2;
      SNSIG = SNSIG + SNR(K)**2;
      ANUM = ANUM + 1.0;
      >
   >
AVG = SXIWI/SNSIG;
SNSIG = 1.D0/DSQRT(SNSIG);
IF CONTINUUM SIZE(ICONT) .GT. 1   <
   CSIG = DMYSQ( ( SXI2 - (SXI**2)/ANUM )/(ANUM-1.0) );
   CSIG = CSIG/DMYSQ(ANUM);
   >

CONTINUUM FLUX(ICONT) = AVG;
SIGMA FLUX(ICONT) = CSIG;
IF CSIG.LT. AVG*SNSIG  < 
   SIGMA FLUX(ICONT) = AVG*SNSIG; >

CONTINUUM CENTRE(ICONT) = 
                 0.5D0*DBLE(CONTINUUM LEFT(ICONT)+CONTINUUM RIGHT(ICONT));
RETURN;
END;






SUBROUTINE FIND CONTINUUM(X,ICONT,FOUND);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-CONTINUUM;
LOGICAL FOUND;

FOUND = .FALSE.;
FOR I = 1 TO NOCONT   <
   DX = DBLE(CONTINUUM SIZE(I))/2.0D0;
   IF CONTINUUM CENTRE(I) + DX .GE. X   <
      IF CONTINUUM CENTRE(I) - DX .LE. X   <
         ICONT = I;
         FOUND = .TRUE.;>
      RETURN;   >
   >
RETURN;
END;


/TEK_CODE/; " Original Tektronix plotting version "
SUBROUTINE DISPLAY CONTINUUM REGIONS ON PAGE;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-CONTINUUM;

FIND USER WINDOW BOUNDS(XMIN,XMAX,YMIN,YMAX);
FOR I = 1 TO NOCONT   <
   X = CONTINUUM CENTRE(I);
   IF WAV(X) .GE. XMIN   <
      IF WAV(X) .LE. XMAX   <
         PLOT BIG PLUS(WAV(X),CONTINUUM FLUX(I));   >
      ELSE   <
         RETURN;   >
      >
   >
RETURN;
END;
/TEK_END/;


/PGP_CODE/; " PGPLOT replacement for original Tek version "
SUBROUTINE DISPLAY CONTINUUM REGIONS ON PAGE;

IMPLICIT REAL*8(A-H,O-Z);
REAL*4 XLOWER(MAX CONT),XUPPER(MAX CONT),YPLOT(MAX CONT);

COMMON-BLOCK-CONTINUUM;

FOR I = 1 TO NOCONT   <
   DX = DBLE(CONTINUUM SIZE(I))/2.0D0;
   XLOWER(I) = WAV(CONTINUUM CENTRE(I)-DX);
   XUPPER(I) = WAV(CONTINUUM CENTRE(I)+DX);
   YPLOT(I)  = CONTINUUM FLUX(I);
   >
CALL PGERRX(NOCONT,XLOWER,XUPPER,YPLOT,3.0);
RETURN;
END;
/PGP_END/;


LOGICAL FUNCTION CONTINUUM IS OUT OF ORDER(X1,X2,ICONT);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-CONTINUUM;

CONTINUUM IS OUT OF ORDER = .FALSE.;
XAVG = (X1+X2)/2.0;
IF ICONT .EQ. 1   <
   IF NOCONT .EQ. 1   <
      RETURN;   >
   IF XAVG .GT. CONTINUUM CENTRE(ICONT+1)   <
      CONTINUUM IS OUT OF ORDER = .TRUE.;   >
   RETURN;   >
IF ICONT .EQ. NOCONT   <
   IF XAVG .LT. CONTINUUM CENTRE(ICONT-1)   <
      CONTINUUM IS OUT OF ORDER = .TRUE.;   >
   RETURN;   >
IF XAVG .LT. CONTINUUM CENTRE(ICONT-1)  .OR.
   XAVG .GT. CONTINUUM CENTRE(ICONT+1)       <
   CONTINUUM IS OUT OF ORDER = .TRUE.;   >
RETURN;
END;


SUBROUTINE REPLOT CONTINUUM;

IMPLICIT REAL*8(A-H,O-Z);

FIND USER WINDOW BOUNDS(XMIN,XMAX,YMIN,YMAX);
ISTART = NINT(CHANNEL(XMIN));
IEND   = NINT(CHANNEL(XMAX));
PLOT CONTINUUM(ISTART,IEND);
RETURN;
END;


SUBROUTINE DELETE CONTINUUM(FOUND);

IMPLICIT REAL*8(A-H,O-Z);

LOGICAL FOUND;
COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-COMMANDS;

DISPLAY CONTINUUM REGIONS ON PAGE;
MARK CURSOR POSITION(ICHAR,X,Y);
X = CHANNEL(X);
FIND CONTINUUM(X,ICONT,FOUND);
IF .NOT.FOUND   <
   DISPLAY PROMPT;
   OUTPUT(6);('NO CONTINUUM FOUND');
   RETURN;   >
REMOVE CONTINUUM POINT(ICONT);
PERFORM FIT;
AGAIN;
"
AMcW 3/2000
REPLOT CONTINUUM;
DISPLAY CONTINUUM REGIONS ON PAGE;
"
RETURN;
END;


SUBROUTINE CONTINUUM PLOT;
"
This routine will plot the continuum flux points and continuum fit only
"
IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-SPECTRUM;
COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-PLOTS;

CONTINUUM PLOTTING = .TRUE.;
" first find plot bounds "
ISTART = 1;
IEND = NPTS;
XMIN = WAV(DBLE(ISTART));
XMAX = WAV(DBLE(IEND));
IF NOCONT.GE.1   <
   YMIN = CONTINUUM FLUX(1);
   YMAX = CONTINUUM FLUX(1);
   IF NOCONT.GE.2   <
      FOR I = 2 TO NOCONT   <
         IF CONTINUUM FLUX(I).GT.YMAX   <
            YMAX = CONTINUUM FLUX(I);   >
         ELSEIF CONTINUUM FLUX(I).LT.YMIN   <
            YMIN = CONTINUUM FLUX(I);   >
         >
      >
   YMIN = YMIN  - 0.03;
   YMAX = YMAX  + 0.03;
   >
ELSE   <
   YMIN = 0.93;
   YMAX = 1.07;   >
" now make the plot "
ERASE SCREEN;
SET USER WINDOW(XMIN,XMAX,YMIN,YMAX);
PLOT CONTINUUM(ISTART,IEND);
DISPLAY CONTINUUM REGIONS ON PAGE;
/TEK_CODE/;
PLOT AXES(XMIN,XMAX,YMIN,YMAX);
DRAW TICKMARKS(XMIN,XMAX,YMIN,YMAX);
LABEL AXES;
/TEK_END/;
/PGP_CODE/;
DRAW PGPLOT BOX(XMIN,XMAX,YMIN,YMAX); 
/PGP_END/;
INITIALISE COMMAND AREA;
RETURN;
END;


SUBROUTINE PLOT FULL SPECTRUM;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-SPECTRUM;
COMMON-BLOCK-COMMANDS;

ERASE SCREEN;
ISTART = 1;
IEND = NPTS;
SET DATA WINDOW(ISTART,IEND,XMIN,XMAX,YMIN,YMAX);
PLOT DATA ARRAY(ISTART,IEND);
PLOT CONTINUUM(ISTART,IEND);
/TEK_CODE/;
PLOT AXES(XMIN,XMAX,YMIN,YMAX);
DRAW TICKMARKS(XMIN,XMAX,YMIN,YMAX);
LABEL AXES;
/TEK_END/;
/PGP_CODE/;
DRAW PGPLOT BOX(XMIN,XMAX,YMIN,YMAX); 
/PGP_END/;
INITIALISE COMMAND AREA;
RETURN;
END;






" removed AMcW 4/96
XMIN = WAV(DBLE(ISTART));
XMAX = WAV(DBLE(IEND));
YMIN = 0.0;
YMAX = 1.05;
ERASE SCREEN;
SET USER WINDOW(XMIN,XMAX,YMIN,YMAX);
PLOT DATA ARRAY(ISTART,IEND);
PLOT CONTINUUM(ISTART,IEND);
/TEK_CODE/;
PLOT AXES(XMIN,XMAX,YMIN,YMAX);
DRAW TICKMARKS(XMIN,XMAX,YMIN,YMAX);
LABEL AXES;
/TEK_END/;
/PGP_CODE/;
DRAW PGPLOT BOX(XMIN,XMAX,YMIN,YMAX); 
/PGP_END/;
INITIALISE COMMAND AREA;
RETURN;
END;

"

SUBROUTINE OPEN SYNTHESIS FILE(W0,WSTEP);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-SYNTHESIS;
COMMON-BLOCK-COMMANDS;

IF NFILE .GE. 7   <
   DISPLAY PROMPT;
   OUTPUT(6);('ONLY 7 SYNTHESIS FILES ALLOWED');
   RETURN;   >
DISPLAY PROMPT;
OUTPUT(6);('ENTER FILENAME');
DISPLAY PROMPT;
NFILE = NFILE + 1;
READ(5,'(A7)')FILES(NFILE);
DISPLAY PROMPT;
OUTPUT(6);('ENTER WAVE ZERO & STEP');
DISPLAY PROMPT;
READ(5,*)WZERO(NFILE),WINC(NFILE);
W0 = WZERO(NFILE);
WSTEP = WINC(NFILE);
OPEN(UNIT=13,FILE=FILES(NFILE),STATUS='OLD');
REWIND 13;
RETURN;
END;


SUBROUTINE PAPER COPY;

IMPLICIT REAL*8(A-H,O-Z);

CHARACTER*80 TITLE;
LOGICAL PAPER;

TITLE = '     ';
XLENGTH = 35.0;
PAPER = .TRUE.;
FIND USER WINDOW BOUNDS(XMIN,XMAX,YMIN,YMAX);
PRINT HEADER INFO FOR PLOT(TITLE,XMIN,XMAX,YMIN,YMAX,XLENGTH);
PRINT FLUXS(INT(CHANNEL(XMIN)),NINT(CHANNEL(XMAX)));
PRINT CONTINUUM(INT(CHANNEL(XMIN)),NINT(CHANNEL(XMAX)));
REPLOT SYNTHESES(PAPER);
RETURN;
END;


SUBROUTINE PLOT SYNTHESIS(W0,WSTEP,PAPER);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 FLUX(10),XMIN,XMAX,YMIN,YMAX,W0,WSTEP;
LOGICAL FIRST,PAPER;

FIRST = .TRUE.;
FIND USER WINDOW BOUNDS(XMIN,XMAX,YMIN,YMAX);
IF W0 .LE. XMAX   <
   W = W0;
   READ(13,*,END=:LAST:)(FLUX(J),J=1,10);
   LOOP   <
      FOR I = 1 TO 10   <
         IF W .LE. XMAX  .AND.  W .GE. XMIN   <
            Y = (1.0-FLUX(I))*CONTINUUM(CHANNEL(W));
            IF FIRST   <
               IF PAPER   <
                  OUTPUT(11);('COLOR BLACK');
                  OUTPUT(11);('NOMARKER');
                  OUTPUT(11);('DASHEDLINE 4');   >
               ELSE   <
                  MOVE PEN TO USER(W,Y);   >
               FIRST = .FALSE.;
               >
            ELSE   <
               IF PAPER   <
                  OUTPUT(11)W,Y;  (F10.3,2X,F10.6);   >
               ELSE   <
                  DRAW TO USER(W,Y);   >
               >
            >
         W = W + WSTEP;
         >
      READ(13,*,END=:LAST:)(FLUX(J),J=1,10);
    >UNTIL W .GT. XMAX;
   RETURN;
   :LAST:  IMAX = J - 1;
        FOR I = 1 TO IMAX   <
           IF W .LE. XMAX  .AND.  W .GE. XMIN   <
              Y = (1.0-FLUX(I))*CONTINUUM(CHANNEL(W));
              IF FIRST   <
               IF PAPER   <
                  OUTPUT(11);('COLOR BLACK');
                  OUTPUT(11);('NOMARKER');
                  OUTPUT(11);('DASHEDLINE 4');   >
               ELSE   <
                  MOVE PEN TO USER(W,Y);
                  FIRST = .FALSE.;   >
               >
              ELSE   <
                 IF PAPER   <
                    OUTPUT(11)W,Y;  (F10.3,2X,F10.6);   >
                 ELSE   <
                    DRAW TO USER(W,Y);   >
                 >
              >
           W = W + WSTEP;
           >
   >
RETURN;
END;


SUBROUTINE REPLOT SYNTHESES(PAPER);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-SYNTHESIS;
LOGICAL PAPER;

IF NFILE .LE. 0   <  RETURN;  >
FOR I = 1 TO NFILE   <
   OPEN(UNIT=13,FILE=FILES(I),STATUS='OLD');
   REWIND 13;
   PLOT SYNTHESIS(WZERO(I),WINC(I),PAPER);
   CLOSE(UNIT=13);
   >
PAPER = .FALSE.;
RETURN;
END;


SUBROUTINE MEASURE FEATURE;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-COMMANDS;

REAL*8 PI,COV(9,9),SW(9);
PI = 3.141592654;

FIND USER WINDOW BOUNDS(XMIN,XMAX,YMIN,YMAX);
MARK CURSOR POSITION(ICHAR,X1,Y1);
MARK CURSOR POSITION(ICHAR,X2,Y2);
IF X1 .LT. X2   < XLEFT = X1;  XRIGHT = X2;   >
ELSE   <  XLEFT = X2;  XRIGHT = X1;   >
IF XLEFT .LT. XMIN   < XLEFT = XMIN;   >
IF XRIGHT .GT. XMAX   < XRIGHT = XMAX;   >
INTEGRATE(XLEFT,XRIGHT,AREA);
A1 = SPEC(NINT(XLEFT));  A2 = DNINT(XLEFT);
FOR I = NINT(XLEFT)+1 TO INT(XRIGHT)   <
   IF SPEC(I) .LT. A1   <
      A1 = SPEC(I);
      A2 = DBLE(I);   >
   >
A1 = 1.0 - SPEC(INT(A2))/CONTINUUM(A2);
A3 = AREA/(A1*DMYSQ(PI));
"
 set up dummy covariance matrix 
"
FOR I = 1 TO 9 <
   FOR J = 1 TO 9  <
      COV(I,J) = 0.0D0;
   >
   COV(I,I) = 1.0D0;
   SW(I)    = 0.0D0;
>
SW(1)    = 1.0D0; SW(2)    = 1.0D0; SW(3)    = 1.0D0;
N = 1;
REPLACE EW(A1,A2,A3,COV,SW,N);
RETURN;
END;


SUBROUTINE INTEGRATE(XMIN,XMAX,WIDTH);

IMPLICIT REAL*8(A-H,O-Z);

FRAC1 = 0.0; FRAC2 = 0.0; SUM = 0.0; SUM1 = 0.0; SUM2 = 0.0; SUM3 = 0.0;
SUM4 = 0.0;  SUM5 = 0.0;  IZERO = 0;
XMIN = CHANNEL(XMIN);  XMAX = CHANNEL(XMAX);
ISTART = INT(XMIN);  IEND = INT(XMAX);
IF DBLE(ISTART) .NE. XMIN   <
   ISTART = ISTART + 1;
   FRAC1  = DBLE(ISTART) - XMIN;   >
FRAC2 = XMAX - DBLE(IEND);
N = IEND - ISTART + 1;
"
  NOW BRANCH ACCORDING TO THE NUMBER OF POINTS TO BE INTEGRATED
"
IF N .LE. 1   <
   SUM = 0.0;   >
ELSEIF N .EQ. 2   <
   I = ISTART;
   SUM = 1.0-(SPEC(I)/CONTUM(DBLE(I))+SPEC(IEND)/CONTUM(DBLE(IEND)))/2.0; >
ELSE   <
   SUM5 = 2.0-SPEC(ISTART)/CONTUM(DBLE(ISTART))-SPEC(IEND)/CONTUM(DBLE(IEND));
   HALF = DBLE(N)/2.0;
   IF HALF .EQ. DBLE(N/2)   <
      I = ISTART;
      SUM1 = SPEC(I)/CONTUM(DBLE(I)) +
             3.0*(SPEC(I+1)/CONTUM(DBLE(I+1)) + SPEC(I+2)/CONTUM(DBLE(I+2))) +
             SPEC(I+3)/CONTUM(DBLE(I+3));
      SUM1 = 3.0 - SUM1*0.375;
      IF N .EQ. 4   < SUM5 = 0.0;  >
      ELSE   <
         SUM5=2.0-SPEC(I+3)/CONTUM(DBLE(I+3))-SPEC(IEND)/CONTUM(DBLE(IEND));>
      IZERO = 3;   >
   FOR I = ISTART+IZERO+1 TO IEND-1 BY 2   <
      SUM2 = SUM2 + 4.0*(1.0-SPEC(I)/CONTINUUM(DBLE(I)));   >
   FOR I = ISTART+IZERO+2 TO IEND-2 BY 2   <
      SUM3 = SUM3 + 2.0*(1.0-SPEC(I)/CONTINUUM(DBLE(I)));   >
   SUM = SUM1 + (SUM2 + SUM3 + SUM5)/3.0;   >
"
  NOW ADD ON THE END BITS
"
IF FRAC1 .NE. 0.0  <
   I = ISTART;
   SUM4 = FRAC1* (1.0-SPEC(I)/CONTUM(DBLE(I))) +
     FRAC1**2*(SPEC(I)/CONTUM(DBLE(I)) - SPEC(I-1)/CONTUM(DBLE(I-1)))/2.0; >
IF FRAC2 .NE. 0.0   <
   I = IEND;
   SUM4 = SUM4 +  FRAC2*(1.0-SPEC(I)/CONTUM(DBLE(I))) -
     FRAC2**2*(SPEC(I+1)/CONTUM(DBLE(I+1))-SPEC(I)/CONTUM(DBLE(I)))/2.0; >
IF N .LE. 0   <
   I = ISTART;
   SUM4 = -1.0+(SPEC(I)/CONTUM(DBLE(I))+SPEC(IEND)/CONTUM(DBLE(IEND)))/2.0 +
         SUM4;   >
WIDTH = SUM + SUM4;
RETURN;
END;


SUBROUTINE REJECT LINE;

IMPLICIT REAL*8(A-H,O-Z);
COMMON-BLOCK-COMMANDS;
CHARACTER*1 CHAR;
INTEGER ICENTRE,ICHAR,LINE;

MARK CURSOR POSITION(ICHAR,X,Y);
DISPLAY PROMPT;
OUTPUT(6);(' REJECT LINE. ARE YOU SURE?');
DISPLAY PROMPT;
READ(5,'(A1)')CHAR;
IF CHAR.NE.'Y' .AND. CHAR.NE.'y'   <
   RETURN;   >
FIND LINE(CHANNEL(X),LINE);
IF LINE .EQ. 0   <  RETURN;  >
REMOVE FROM LIST(LINE);
RETURN;
END;


SUBROUTINE POINT DIODE;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-COMMANDS;

MARK CURSOR POSITION(ICHAR,X,Y);
XCHAN = CHANNEL(X);
LINENO = LINENO - 1;
DISPLAY PROMPT;
OUTPUT(6)XCHAN;('   DIODE ',F7.2);
DISPLAY PROMPT;
OUTPUT(6)X;('   WAVE ',F8.3);
RETURN;
END;


SUBROUTINE FIND LINE(CENT,LINE);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;

FOR LINE = 1 TO NUMBER OF LINES   <
   WAVE = WAV(CENT);
   IF DABS(WAVELENGTH(LINE)-WAVE) .LE. 2.0*DISP  .OR.
      DABS(WAVELENGTH(LINE)-WAVE) .LE. 0.04   <
      IF LINE .LT. NUMBER OF LINES   <
         IF DABS(WAVELENGTH(LINE)-WAVE) .LE. DABS(WAVELENGTH(LINE+1)-WAVE)   <
            RETURN;   >
         >
      ELSE   <  RETURN;  >
      >
   >
LINE = 0;
RETURN;
END;


SUBROUTINE CONTINUUM FIT;
"
   a routine to interactively fit the continuum points
"
IMPLICIT REAL*8(A-H,O-Z);
 
REAL*8 X(1000),Y(1000),SIGMA(1000),ADUM(50),COVAR(50,50);
REAL ACHISQ,SMEAN,PDEV;

COMMON-BLOCK-FLAGS;
COMMON-BLOCK-IMAGE;
COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-CONT-FIT;
COMMON-BLOCK-COMMANDS;

" first ask user for order "

DISPLAY PROMPT;
OUTPUT(6);('   ENTER ORDER OF POLYNOMIAL');
LINENO = LINENO - 1;
DISPLAY PROMPT;
READ(5,'(I2)')IORD;
IF NOCONT.LT.IORD   <
   DISPLAY PROMPT;
   OUTPUT(6);('ORDER TOO BIG');
   RETURN;   >

FITCON = .TRUE.;

"  set up continuum points into arrays "

IF NOCONT.GE.1   <
   SMEAN = 0.0;
   FOR J = 1 TO NOCONT   <
      Y(J) = CONTINUUM FLUX(J);
      X(J) = CONTINUUM CENTRE(J);
      SIGMA(J) = SIGMA FLUX(J);
      SMEAN = SMEAN + 1.0/SIGMA(J)**2;
      >
   POLYNOMIAL FIT(X,Y,SIGMA,IORD,ADUM,COVAR,CHISQ,NOCONT);
   CONT ORDER(CURRENT_IMAGE_ROW) = IORD;
   FOR ITERM = 1 TO IORD   <
      ACON(ITERM,CURRENT_IMAGE_ROW) = ADUM(ITERM);   >
   REPLOT CONTINUUM;
   ACHISQ = REAL(CHISQ/DBLE(NOCONT-IORD));
   PDEV = 100.0 * (SQRT(ACHISQ) / SQRT(SMEAN))/CONTINUUM FLUX(NOCONT/2);
   DISPLAY PROMPT;
   OUTPUT(6)ACHISQ;('Chi2/Ndf = ',F8.3);
   DISPLAY PROMPT;
   OUTPUT(6)PDEV;('wrms dev.% =',F7.3);
    >
ELSE   <
   CONT ORDER(CURRENT_IMAGE_ROW) = 1;
   ACON(1,CURRENT_IMAGE_ROW) = 1.0;   >
RETURN;
END;


SUBROUTINE DOT TO DOT;

IMPLICIT REAL*8 (A-H,O-Z);

COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-CONT-FIT;
COMMON-BLOCK-IMAGE;

CONT ORDER(CURRENT_IMAGE_ROW) = 0;
FIND USER WINDOW BOUNDS(XMIN,XMAX,YMIN,YMAX);
ISTART = NINT(CHANNEL(XMIN));
IEND   = NINT(CHANNEL(XMAX));
PLOT CONTINUUM(ISTART,IEND);
RETURN;
END;


SUBROUTINE INTERACTIVE MULTIPLE GAUSSIAN(NGAUSS);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-ROTATION;

REAL*8 SWITCH(9),A(9),COV(9,9),X(200),PHOTONS,VWIDTH,SWDUMMY(9);
INTEGER NGAUSS,I,LEFT,RIGHT,N,ICENT;

FOR I = 1 TO 9   <
   A(I) = 0.0D0;
   IF I .LE. 3*NGAUSS   <
      SWITCH(I) = 1.0;   
      SWDUMMY(I) = 1.0;  >
   ELSE   <
      SWITCH(I) = 0.0;   
      SWDUMMY(I) = 0.0;  >
   >
FOR I = 1 TO NGAUSS   <
   PROMPT FOR CENTRE AND DEPTH(A(3*I-1),A(3*I-2),SWITCH,I);   >
PROMPT FOR BOUNDS(LEFT,RIGHT,SWITCH,NGAUSS);
IF LEFT .EQ. 0  .AND.  RIGHT .EQ. 0   <  RETURN;  >
SET UP POINTS(X,LEFT,RIGHT,N);
FOR I = 1 TO NGAUSS   <
   W = WAV(A(3*I-1));
   FIND SIGMA(W,A(3*I-2),A(3*I),SWITCH(3*I));
   IF SWITCH(3*I) .EQ. 1.0   <
      A(3*I) = 0.5*( X(2*N-1) - X(1) )/3.0;   >
   IF SWITCH(3*I) .EQ. 1.0  .AND.  A(3*I) .LT. 2.0   <
      A(3*I) = 2.0;   >
   >
ICENT = NINT(A(2));
PHOTONS = SNR(ICENT)**2 * CONTINUUM(DBLE(ICENT))/SPEC(ICENT);
GAUSS FIT(X,A,N,PHOTONS,COV,SWITCH,CHISQ);
VWIDTH = (VSINI/3.0D5)*(WAV(A(2))/DISP);
START = A(2) - 1.5*DABS(A(3))/0.60056 - VWIDTH;
END   = A(3*NGAUSS-1) + 1.5*DABS(A(3*NGAUSS))/0.60056 + VWIDTH;
POSN  = START;
FLUX = 0.0;
"
 *****   commented out A.McWilliam, March 1996: vsini changes
FOR I = 1 TO NGAUSS   <
   FLUX = FLUX + A(3*I-2)*EXP( - ((POSN-A(3*I-1))/A(3*I))**2 );   >
 *****
"
FLUX = PROFILE(POSN, A, SWDUMMY, VSINI);  

FLUX = (1.0-FLUX)*CONTINUUM(POSN);
MOVE PEN TO USER(WAV(POSN),FLUX);
FOR POSN = START + 0.25 TO END BY 0.25   <
   FLUX = 0.0;
   " *****  commented out A.McW. 3/96 for vsini changes
   FOR I = 1 TO NGAUSS   <
      FLUX = FLUX + A(3*I-2)*EXP( - ((POSN-A(3*I-1))/A(3*I))**2 );   >
     *****
   "
   FLUX = PROFILE(POSN, A, SWDUMMY, VSINI);  
   FLUX = (1.0-FLUX)*CONTINUUM(POSN);
   DRAW TO USER(WAV(POSN),FLUX);   >
FOR I = 1 TO NGAUSS   <
   REPLACE EW(A(3*I-2),A(3*I-1),A(3*I),COV,SWITCH,I);   >
RETURN;
END;


SUBROUTINE PROMPT FOR BOUNDS(LEFT,RIGHT,SWITCH,NGAUSS);

IMPLICIT REAL*8(A-H,O-Z);
COMMON-BLOCK-COMMANDS;
REAL*8 SWITCH(9);
INTEGER LEFT,RIGHT,NGAUSS,NPOINT;
CHARACTER*1 ANS;
DISPLAY PROMPT;
OUTPUT(6);(12HENTER BOUNDS);
MARK CURSOR POSITION(ICHAR1,X1,Y1);
MARK CURSOR POSITION(ICHAR2,X2,Y2);
IF X1 .GT. X2   <
   LEFT = NINT(CHANNEL(X2));
   RIGHT= NINT(CHANNEL(X1));   >
ELSE  <
   RIGHT = NINT(CHANNEL(X2));
   LEFT  = NINT(CHANNEL(X1));  >
NPOINT = 0;
FOR I = 1 TO 3*NGAUSS   <
   NPOINT = INT(SWITCH(I)) + NPOINT;   >
IF RIGHT - LEFT + 1  .LT. NPOINT   <
   DISPLAY PROMPT;
   OUTPUT(6);(19HINSUFFICIENT POINTS);
   LEFT = 0;  RIGHT = 0;   >
RETURN;
END;


SUBROUTINE PROMPT FOR CENTRE AND DEPTH(CENTRE,DEPTH,SWITCH,NGAUSS);

IMPLICIT REAL*8(A-H,O-Z);
COMMON-BLOCK-COMMANDS;
REAL*8 CENTRE,DEPTH,SWITCH(9);
INTEGER NGAUSS;
CHARACTER*1 ANS;

DISPLAY PROMPT;
OUTPUT(6);(13HSET LINE APEX);
MARK CURSOR POSITION(ICHAR,X,Y);
CENTRE = CHANNEL(X);
DEPTH  = 1.0 - Y/CONTINUUM(CENTRE);
   "  ASK IF CENTRE , DEPTH OR FWHM ARE FIRM. (102 IS AN F)  "
IF ICHAR .EQ. 102   <
   DISPLAY PROMPT;
   OUTPUT(6);('   FIX DEPTH ?');
   LINENO = LINENO - 1;
   DISPLAY PROMPT;
   READ(5,'(A1)')ANS;
   IF ANS .EQ. 'y'   <
      SWITCH(3*NGAUSS-2) = 0.0;   >
   DISPLAY PROMPT;
   OUTPUT(6);('   FIX CENTRE?');
   LINENO = LINENO - 1;
   DISPLAY PROMPT;
   READ(5,'(A1)')ANS;
   IF ANS .EQ. 'y'   <
      SWITCH(3*NGAUSS-1) = 0.0;   >
   DISPLAY PROMPT;OUTPUT(6);('   FIX FWHM  ?');
   LINENO = LINENO - 1;
   DISPLAY PROMPT;READ(5,'(A1)')ANS;
   IF ANS .EQ. 'y'   <
      SWITCH(3*NGAUSS) = 0.0;   >
   >
RETURN;
END;




SUBROUTINE SET VSINI;   

IMPLICIT REAL*8 (A-H,O-Z);

COMMON-BLOCK-ROTATION;

DISPLAY PROMPT;
OUTPUT(6);('ENTER VSINI:');
DISPLAY PROMPT;
READ(5,'(F10.3)')VSINI;
RETURN;
END;



SUBROUTINE FIND SIGMA(W,ADEPTH,SIGMA,SWITCH);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-COMMANDS;
COMMON-BLOCK-FLAGS;
COMMON-BLOCK-IMAGE;
REAL*8 ADEPTH,SIGMA,SWITCH;

IF SWITCH .EQ. 0.0   <
   GET BEST FWHM(W,ADEPTH,WIDTH,SIGWIDTH);
   IF NUMBER OF GOOD LINES .EQ. 0 .AND. .NOT. FIXFWHM .OR. WIDTH .EQ. 0.0 <
      DISPLAY PROMPT;
      OUTPUT(6);(19HNO MEAN FWHM EXISTS);
      SWITCH = 1.0;   >
   SIGMA = WIDTH*0.60056121;
   >
RETURN;
END;


SUBROUTINE REPLACE EW(A1,A2,A3,COV,SWITCH,N);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-COMMANDS;
CHARACTER*1 ANS;
REAL*8 COV(9,9),SWITCH(9),PI;
INTEGER N,N0;

PI = 3.141592654D0;

WAVE = WAV(A2);
FIND LINE(A2,LINE);
AREA = A1*DABS(A3)*DMYSQ(PI)*DISP*1000.0;
IF LINE .EQ. 0   <
   DISPLAY PROMPT;OUTPUT(6);
   (16HLINE NOT ON LIST);
   DISPLAY PROMPT;
   OUTPUT(6)AREA;(4HEW =,F7.2,2HMA);
   DISPLAY PROMPT;
   OUTPUT(6)WAVE;(7HWAVE = ,F8.2,1HA);   >
ELSE   <
"
 print out the EW data
"
   WAVE2 = WAV(CENTRE(LINE));
   DISPLAY PROMPT;
   OUTPUT(6)AREA;(8HNEW EW =,F7.2,2HMA);
   DISPLAY PROMPT;
   OUTPUT(6)WAVE;(7HWAVE = ,F8.2,1HA);
   DISPLAY PROMPT;
   OUTPUT(6)EW(LINE);(8HOLD EW =,F7.2,2HMA);
   DISPLAY PROMPT;
   OUTPUT(6)WAVE2;(7HWAVE = ,F8.2,1HA);
   DISPLAY PROMPT;
   OUTPUT(6);(15HREPLACE OLD EW?);
   DISPLAY PROMPT;
   READ(5,'(A1)')ANS;
   IF ANS .EQ. 'Y' .OR. ANS .EQ. 'y'  <
      EW(LINE) = AREA;
      DEPTH(LINE) = A1;
      CENTRE(LINE)= A2;
      COMPUTE DELTA EW(A1,A3,COV,SWITCH,N,LINE);
      DELTA_EW(LINE) = DELTA_EW(LINE) * EW(LINE);
      DISPLAY PROMPT;
      OUTPUT(6)DELTA_EW(LINE);(7HD_EW = ,F7.2,2HMA);
      FWHM(LINE)  = DABS(A3)/0.60056121;   >
   >
RETURN;
END;


SUBROUTINE COMPUTE DELTA EW(A1,A3,COV,SWITCH,N,LINE);
"
  At this stage DELTA_EW is the fractional EW uncertainty; i.e. dEW/EW

  A1 and A3 are the gaussian coefficients; COV is the 9X9 covariance matrix,
  SWITCH provides the info. on what coefficients were fit, and N is the
  number of the gaussian (ie 1, 2 or 3).
"
IMPLICIT REAL*8 (A-H,O-Z);

COMMON-BLOCK-LINES;

REAL*8 COV(9,9),SWITCH(9),A1,A3;
INTEGER N,LINE,ND,NDEPTH,NW,NWIDTH,I;

ND = (N-1)*3 + 1;
NW = (N-1)*3 + 3;
GET BEST FWHM(WAVELENGTH(LINE),A1,WIDTH,SIGWIDTH);
IF (SWITCH(ND).EQ.1.0)  <
   IF (SWITCH(NW).EQ.1.0)  <
"find position of depth and width stuff in covariance matrix"
      DELTA = COV(NW,NW)/A3**2 + COV(ND,ND)/A1**2 + 
                           2.0*COV(ND,NW)/(A3*A1);   >
   ELSE  <
      DELTA = COV(ND,ND)/A1**2;
      DELTA = DELTA + (0.60056121*SIGWIDTH/A3)**2;   >
   >
ELSEIF (SWITCH(NW).EQ.1.0)  <
   DELTA = COV(NW,NW)/A3**2 ;   >
ELSE   <
   DELTA = (0.60056121*SIGWIDTH/A3)**2;   >
DELTA_EW(LINE) = DSQRT(DELTA);
RETURN;
END;


SUBROUTINE PLOT LINE FLUX(POSN,FLUX);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 POSN,FLUX,XMIN,XMAX,YMIN,YMAX;

FIND USER WINDOW BOUNDS(XMIN,XMAX,YMIN,YMAX);
IF FLUX .GE. YMIN  .AND.  FLUX .LE. YMAX   <
   DRAW TO USER(WAV(POSN),FLUX);   >
ELSEIF FLUX .LT. YMIN   <
   DRAW TO USER(WAV(POSN),YMIN);   >
ELSE   <
   DRAW TO USER(WAV(POSN),YMAX);   >
RETURN;
END;


REAL*8 FUNCTION SPEC(I);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-SPECTRUM;

INTEGER I;
IF I.LE.0 .OR. I.GT.NUMBER OF DIODES  <
   SPEC = 0.0;   >
ELSE  <
   SPEC = SPECTRUM(I) ;   >
RETURN;
END;



REAL*8 FUNCTION SNR(I);

"
  A function which returns the value of the local S/N for pixel I, by
  taking the square root of the flux from the variance spectrum.

  -Argument must be an integer between 1 and number of diodes
"

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-SPECTRUM;
COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-IMAGE;

INTEGER I;
IF .NOT.VARIANCE_FILE   <
   IF SPEC(I)/CONTINUUM(DBLE(I)) .GT. 0.0   <
      SNR = SN * DSQRT( SPEC(I)/CONTINUUM(DBLE(I)) );   >
   ELSE < SNR = 0.0;  >
   >
ELSEIF I.LE.0 .OR. I.GT.NUMBER OF DIODES  <
   SNR = 0.0;   >
ELSEIF VARSPEC(I) .LE. 0.0  <
   SNR = 0.0;   >
ELSE  <
   SNR = DSQRT( VARSPEC(I) )  ;   >
RETURN;
END;


REAL*8 FUNCTION CONTINUUM(DIODE);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-FLAGS;
COMMON-BLOCK-IMAGE;
COMMON-BLOCK-CONT-FIT;
COMMON-BLOCK-TELLURIC;

INTEGER RED,BLUE;
REAL*8 DIODE;

"  NOCONT IS THE NUMBER OF CONTINUUM REGIONS USED  "

IF NORMALISED <
   CONTINUUM = 1.0;
   RETURN;  
   >
IF TELLURIC SET UP   <
   CONTINUUM = 1.0;
   RETURN;   >
X=DIODE;
IF DIODE.GE.CONTINUUM CENTRE(1) .AND.
   DIODE.LE.CONTINUUM CENTRE(NOCONT) .OR. OLD_CONTINUUM <
   IF CONT ORDER(CURRENT_IMAGE_ROW) .GT. 0   <
      C = 0.0;
      FOR I = 1 TO CONT ORDER(CURRENT_IMAGE_ROW)   <
         C = C + ACON(I,CURRENT_IMAGE_ROW)*X**(I-1);   >
      CONTINUUM = C;   >
   ELSEIF CFLAG.EQ.1   <
      CONTINUUM = A*X*X + B*X +C;  >
   ELSEIF CFLAG.EQ.2   <
      CONTINUUM = A*X + B;   >
   ELSEIF CFLAG.EQ.3   <
      CONTINUUM = A;   >
   ELSEIF CFLAG.EQ.4   <
      FIND NEAREST CONTINUA(DIODE,BLUE,RED);
      INTERPOLATE(BLUE,RED,DIODE,VALUE);
      CONTINUUM = VALUE;   >
   ELSEIF CFLAG.EQ.5   <
      FIND NEAREST CONTINUA(DIODE,BLUE,RED);
      CONTINUUM = (CONTINUUM FLUX(BLUE)+CONTINUUM FLUX(RED))/2.0;>
   RETURN;
   >

" extrapolation  "

IF CONT ORDER(CURRENT_IMAGE_ROW) .GT. 0   <
   IF DIODE.LT.CONTINUUM CENTRE(1)   <
      X = CONTINUUM CENTRE(1);
      C = 0.0;
         FOR I = 1 TO CONT ORDER(CURRENT_IMAGE_ROW)   <
            C = C + ACON(I,CURRENT_IMAGE_ROW)*X**(I-1);   >
         CONTINUUM = C;   >
   ELSEIF DIODE.GT.CONTINUUM CENTRE(NOCONT)   <
      X = CONTINUUM CENTRE(NOCONT);
      C = 0.0;
         FOR I = 1 TO CONT ORDER(CURRENT_IMAGE_ROW)   <
            C = C + ACON(I,CURRENT_IMAGE_ROW)*X**(I-1);   >
         CONTINUUM = C;   >
   RETURN;
   >

" old extrapolation stuff "

IF DIODE.LT.CONTINUUM CENTRE(1)   <
   I1=1;I2=2;  >
ELSEIF DIODE.GT.CONTINUUM CENTRE(NOCONT)   <
   I1=NOCONT-1; I2=NOCONT;   >
IF EFLAG.EQ.1   <
   EXTRAPOLATE(I1,I2,DIODE,CONTINUUM);   >
ELSEIF EFLAG.EQ.2 .AND. I1.EQ.1    <
   CONTINUUM = CONTINUUM FLUX(I1);   >
ELSEIF EFLAG.EQ.2   <
   CONTINUUM = CONTINUUM FLUX(I2);   >
ELSEIF EFLAG.EQ.3   <
   CONTINUUM = A*X + B;   >
RETURN;END;


SUBROUTINE FIND NEAREST CONTINUA(DIODE,BLUE,RED);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-CONTINUUM;

INTEGER BLUE,RED;
REAL*8 DIODE;

BLUE=0;RED=0;
FOR I = 1 TO NOCONT-1   <
   IF DIODE.GE.CONTINUUM CENTRE(I) .AND.
      DIODE.LE.CONTINUUM CENTRE(I+1)   <
      BLUE=I;
      RED=I+1;  EXIT;   >
   >
RETURN;
END;


SUBROUTINE EXTRAPOLATE(I1,I2,DIODE,VALUE);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-FLAGS;

INTEGER I1,I2;
REAL*8 VALUE,DIODE;

VALUE = (CONTINUUM CENTRE(I1)-DIODE)*(CONTINUUM FLUX(I1)-
         CONTINUUM FLUX(I2)) /
        (CONTINUUM CENTRE(I2)-CONTINUUM CENTRE(I1)) +
         CONTINUUM FLUX(I1);
RETURN;
END;


SUBROUTINE FINISH UP;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-LINES;
COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-SPECTRUM;
COMMON-BLOCK-IMAGE;

OUTPUT(1)CURRENT SPECTRUM,CURRENT ORDER;
         (/,'RESULTS FOR SPECTRUM ',I3,' ORDER ',I3,1H:);
OUTPUT(1)CURRENT_IMAGE_ROW;
         ('CURRENT IMAGE ROW ',I3,/);
IF .NOT.NORMALISED   <
   OUTPUT(1);(' CONTINUUM FLUX VALUES ',/);
   OUTPUT(1)(CONTINUUM FLUX(I),I=1,NOCONT);(8F10.6);
   OUTPUT(1);(//,' CONTINUUM WAVELENGTHS ',/);
   OUTPUT(1)(WAV(CONTINUUM CENTRE(I)),I=1,NOCONT);(8F10.2);   

   OUTPUT(1)CONT ORDER(CURRENT_IMAGE_ROW);(//,'ORDER OF POLYNOMIAL FIT = ',I4);
   OUTPUT(1);(/,'POLYNOMIAL COEFFICIENTS: ');
   OUTPUT(1)
      ( ACON(ITERM,CURRENT_IMAGE_ROW),ITERM=1,CONT ORDER(CURRENT_IMAGE_ROW));
      (5(G16.9,1X));
   >
ELSE   <
   OUTPUT(1);('NORMALISED CONTINUUM AT 1.00 USED THROUGHOUT');   >
FOR IPAGE = 1 TO 100   <
   N = (IPAGE-1)*50;
   OUTPUT(1);
 (///,
 '  LINE ID  WAVELENGTH  LEFT  RIGHT  DEPTH  CENTRE  FWHM   EW(MA)  +/-EW'//);
   FOR I= N+1 TO N+50  <
      IF I .GT. NUMBER OF LINES  <
         RETURN;  >
      OUTPUT(1)LINE ID(I),WAVELENGTH(I),LEFT DIODE(I),RIGHT DIODE(I),DEPTH(I),
               CENTRE(I),FWHM(I),EW(I),DELTA_EW(I);
      (1X,A10,1X,F8.3,2X,F5.0,2X,F5.0,2X,F6.4,1X,F7.2,1X,F6.3,1X,F6.2,1X,F5.1);
      >UNTIL I .GE. NUMBER OF LINES;
   OUTPUT(1);(1H1);   >UNTIL I .GE. NUMBER OF LINES;
RETURN;
END;




SUBROUTINE CLOSE FILES;

COMMON-BLOCK-IMAGE;

INTEGER IER;

IER = 0;
CALL FTCLOS(IM,IER);
CALL FTCLOS(IVM,IER);
CLOSE(UNIT=11);
CLOSE(UNIT=10);
CLOSE(UNIT=12);
CLOSE(UNIT=15);
CLOSE(UNIT=9);
CLOSE(UNIT=8);
CLOSE(UNIT=4);
CLOSE(UNIT=1);
RETURN;
END;

"

  THE FOLLOWING ROUTINES ARE STRICTLY UTILITY TYPE

"
SUBROUTINE GAUSS FIT(X,AOLD,N,PHOTONS,COV,SWITCH,CHISQ);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-ROTATION;

REAL*8 X(200),AOLD(9),ANEW(9),XBEST(200),V(200),F(100),DELTA(9),FA(200,9);
REAL*8 FX(100,200),W(100),PHI(100),SIGMA(200),PHOTONS,COV(9,9),FACTOR,NU;
REAL*8 SWITCH(9),CHISQ,COVOLD(9,9),WOLD(100),PHIOLD(100);
INTEGER N,I,J,NITER,NPARAM,NZERO,NRUN;
LOGICAL CONVERGENCE,GAUSSIANS SWITCHED;

NRUN = 0;
:900: CONTINUE;
NITER = 1;  NZERO = 0;
NU = 1000.0;
FOR J = 1 TO 9   <  ANEW(J) = AOLD(J);  >
INITIALISE PARAMETERS(V,X,XBEST,N,AOLD,F,SIGMA,PHOTONS,SWITCH,COV,NPARAM);
"
 commented out A.McW Jan. 1992
FIND NUMBER OF ZEROS(X,N,NZERO);
"
IF N-NZERO .LT. NPARAM   <
   IF N .EQ. 1   <
      IF SWITCH(1) .EQ. 1.0   < AOLD(1) = 0.0; >
      ELSEIF SWITCH(4) .EQ. 1.0   < AOLD(4) = 0.0; >
      ELSEIF SWITCH(7) .EQ. 1.0   < AOLD(7) = 0.0; >
      RETURN;   >
   OUTPUT(8);
   (' INSUFFICIENT NUMBER OF POINTS IN GAUSS FIT ');
   OUTPUT(8)SWITCH,X;
   (' SWITCH ',9F3.0,/,' X VALUES ',20(8E15.6,/),/);
   RETURN;   >
FIND DERIVATIVES(XBEST,FA,FX,W,SIGMA,N,AOLD,SWITCH);
DETERMINE PHI(PHI,F,V,FX,N);
FIND X CORRECTIONS(V,N,FA,FX,PHI,W,SIGMA,DELTA,AOLD,X);
COMPUTE RESIDUALS(PHI,W,SOLD,N);
LOOP  <
   FIND PARAMETER CORRECTIONS(DELTA,N,NU,W,FA,PHI,COV,NPARAM,IER);
   CHECK FOR IMSL ERROR(IER,N,AOLD,X);
   CORRECT PARAMETERS(X,XBEST,V,N,ANEW,DELTA,F,SWITCH);
   FIND DERIVATIVES(XBEST,FA,FX,W,SIGMA,N,ANEW,SWITCH);
   DETERMINE PHI(PHI,F,V,FX,N);
   FIND X CORRECTIONS(V,N,FA,FX,PHI,W,SIGMA,DELTA,ANEW,X);
   COMPUTE RESIDUALS(PHI,W,SNEW,N);
   IF SNEW .GE. SOLD   <
      NU = NU/10.0;   >
   ELSE   <
      NU = 10.0*NU;
      " keep current parameters "
      FOR J = 1 TO 9   <  
          AOLD(J) = ANEW(J);
          FOR JJ = 1 TO 9  <
             COVOLD(J,JJ) = COV(J,JJ);
          >
      >
      FOR JJ = 1 TO N   <
         WOLD(JJ) = W(JJ);
         PHIOLD(JJ) = PHI(JJ);   >
      " continue "
      FIND X CORRECTIONS(V,N,FA,FX,PHI,W,SIGMA,DELTA,AOLD,X);
      DETERMINE PHI(PHI,F,V,FX,N);
      FIND PARAMETER CORRECTIONS(DELTA,N,NU,W,FA,PHI,COV,NPARAM,IER);
      CHECK FOR IMSL ERROR(IER,N,AOLD,X);
      COMPUTE RESIDUALS(PHI,W,SOLD,N);   >
   NITER = NITER + 1;
>UNTIL CONVERGENCE(AOLD,ANEW,DELTA,SWITCH) .OR. NITER .GT. 16;
"
IF GAUSSIANS SWITCHED(AOLD,SWITCH) .AND. NRUN.EQ.0  <   
   NRUN = 1;
   GOTO :900:;  >
"
IF N .GT. NPARAM   <  
   FACTOR = 0.0;
   FOR I = 1 TO N   <
      FACTOR = FACTOR + WOLD(I)*PHIOLD(I)**2;  >
   FACTOR = FACTOR/DBLE(N-NPARAM);
>
" setting factor = 1 gives a better estimate of covariance matrix 
  because a) we biased the selection of input pixels, and b) we used
  the correct method for evaluating the uncertainty on the flux.
" 
FACTOR = 1.00;
FINAL COVARIANCE MATRIX(COV,COVOLD,FACTOR,SWITCH);
COMPUTE CHISQ(X,N,AOLD,SIGMA,SWITCH,CHISQ);
RETURN;
END;


SUBROUTINE INITIALISE PARAMETERS(V,X,XBEST,N,A,F,SIGMA,PHOTONS,SW,COV,NPARAM);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-ROTATION;

REAL*8 V(200),X(200),XBEST(200),A(9),F(100),SIGMA(200),PHOTONS,DELTA,SW(9);
REAL*8 MYEXP,COV(9,9),PROFILE;
INTEGER N,I,NPARAM;

FOR I = 1 TO 9  <
   FOR II = 1 TO 9  <
      COV(I,II) = 0.0;  >
   >
FOR I = 1 TO 2*N  <
   V(I) = 0.0;
   XBEST(I) = X(I);   >
" FIND NUMBER OF PARAMETERS TO BE FIT "
NPARAM = 0;
FOR J = 1 TO 9   <
   IF SW(J) .EQ. 1.0   <
      NPARAM = NPARAM + 1;   >
   >
" SET UP RESIDUAL VECTOR F "

FOR I = 1 TO N  <
   F(I) = PROFILE(X(2*I-1),A,SW,VSINI) - X(2*I);
   >
IF N .GT. 1   <
   DELTA = X(3) - X(1);   >
ELSE   <
   DELTA = 1.0;   >
IF PHOTONS.EQ.0.0   < PHOTONS = 1.0;   >
FOR J = 1 TO 2*N-1 BY 2   <
   SIGMA(J) = DELTA**2/(12.0*(1.0-X(J+1))*PHOTONS);
   "
    old sigma's based on thesis stuff
    SIGMA(J+1) = ( 1.5-2.0*X(J+1)+0.5*X(J+1)**2 )/PHOTONS;   
   "
    SIGMA(J+1) = ( 1.0 - X(J+1) )/PHOTONS;   >
RETURN;
END;


SUBROUTINE FIND NUMBER OF ZEROS(X,N,NZERO);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 X(200);
INTEGER N,NZERO,I;

NZERO = 0;
FOR I = 2 TO 2*N BY 2  <
   IF X(I) .LE. 0.0   <
      NZERO = NZERO + 1;   >
   >
RETURN;
END;


SUBROUTINE FIND DERIVATIVES(XBEST,FA,FX,W,SIGMA,N,A,SW);
"
 This routine uses a forward difference method to get derivatives,
 and utilizes the step sizes given in COMMON-BLOCK-ITERATE.
 For non-gaussian profiles this routine will be used frequently.
"

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-ROTATION;
COMMON-BLOCK-ITERATE;

REAL*8 XBEST(200),FA(200,9),FX(100,200),W(100),A(9),SIGMA(200),SW(9);
REAL*8 ADUM(9),VAL1,VAL2,PROFILE;
INTEGER I,J,N,K,IPAR,ISW;

IF VSINI .GT. 0.1D0  <
   FOR IPAR = 1 TO 9  <
      ADUM(IPAR) = A(IPAR);  >
   FOR I = 1 TO N   <
      K = 1;
      FOR ISW = 1 TO 9   <
         IF SW(ISW) .EQ. 1.0  <
            VAL1 = PROFILE(XBEST(2*I-1),ADUM,SW,VSINI);
            ADUM(ISW) = ADUM(ISW) + DA(ISW);
            VAL2 = PROFILE(XBEST(2*I-1),ADUM,SW,VSINI);
            FA(I,K) = (VAL2-VAL1)/DA(ISW);
            K = K + 1;
            ADUM(ISW) = A(ISW);  >
      >
   >
   J = 1;
   FOR I = 1 TO N   <
      VAL1 = PROFILE(XBEST(2*I-1),A,SW,VSINI);
      VAL2 = PROFILE(XBEST(2*I-1)+DX,A,SW,VSINI);
      FX(I,J) = (VAL2-VAL1)/DX;
      W(I)  =  1.0/( FX(I,J)**2*SIGMA(J)+SIGMA(J+1) );
      J = J+1;
      FX(I,J) = -1.0;
      J = J+1;   >
   >

ELSE  <
   GET EXPLICIT DERIVATIVES(XBEST,FA,FX,W,SIGMA,N,A,SW);   >

RETURN;
END;




SUBROUTINE GET EXPLICIT DERIVATIVES(XBEST,FA,FX,W,SIGMA,N,A,SW);   
"
 This routine computes the derivatives for a a gaussian fit to
 up to 3 lines, by use of analytic expressions.  In the case where
 analytic expressions are not possible, then the FIND DERIVATIVES
 routine is used to compute gradients by a forward difference method.
"
IMPLICIT REAL*8(A-H,O-Z);

REAL*8 XBEST(200),FA(200,9),FX(100,200),W(100),A(9),SIGMA(200),SW(9);
REAL*8 MYEXP;
INTEGER I,J,N,K;

FOR I = 1 TO N   <
   K = 1;
   IF SW(1) .EQ. 1.0   <
      FA(I,K) = MYEXP(-((XBEST(2*I-1)-A(2))/A(3))**2);
      K = K + 1;   >
   IF SW(2) .EQ. 1.0   <
      FA(I,K) = (2.0*(XBEST(2*I-1)-A(2))/A(3)**2)*A(1)
                * MYEXP( -((XBEST(2*I-1)-A(2))/A(3))**2);
      K = K + 1;   >
   IF SW(3) .EQ. 1.0   <
      FA(I,K) = 2.0*( ( XBEST(2*I-1)-A(2) )/A(3) )**2 *A(1)/A(3) *
                MYEXP( -((XBEST(2*I-1)-A(2))/A(3))**2);
      K = K + 1;   >
"  NOW FOR THE SECOND GAUSSIAN  "
   IF SW(4) .EQ. 1.0   <
      FA(I,K) = MYEXP(-((XBEST(2*I-1)-A(5))/A(6))**2);
      K = K + 1;   >
   IF SW(5) .EQ. 1.0   <
      FA(I,K) = (2.0*(XBEST(2*I-1)-A(5))/A(6)**2)*A(4)
                * MYEXP( -((XBEST(2*I-1)-A(5))/A(6))**2);
      K = K + 1;   >
   IF SW(6) .EQ. 1.0   <
      FA(I,K) = 2.0*( ( XBEST(2*I-1)-A(5) )/A(6) )**2 *A(4)/A(6) *
                MYEXP( -((XBEST(2*I-1)-A(5))/A(6))**2);
      K = K + 1;   >
"  AND NOW THE THIRD GAUSSIAN  "
   IF SW(7) .EQ. 1.0   <
      FA(I,K) = MYEXP(-((XBEST(2*I-1)-A(8))/A(9))**2);
      K = K + 1;   >
   IF SW(8) .EQ. 1.0   <
      FA(I,K) = (2.0*(XBEST(2*I-1)-A(8))/A(9)**2)*A(7)
                * MYEXP( -((XBEST(2*I-1)-A(8))/A(9))**2);
      K = K + 1;   >
   IF SW(9) .EQ. 1.0   <
      FA(I,K) = 2.0*( ( XBEST(2*I-1)-A(8) )/A(9) )**2 *A(7)/A(9) *
                MYEXP( -((XBEST(2*I-1)-A(8))/A(9))**2);
      K = K + 1;   >
   >
FOR I = 1 TO N   <
   FOR J = 1 TO 2*N   <
      FX(I,J) = 0.0;   >
   >
J=1;
FOR I = 1 TO N   <
   FX(I,J) = - 2.0*( ( XBEST(2*I-1)-A(2) )/A(3) ) *A(1)/A(3) *
                   MYEXP( -((XBEST(2*I-1)-A(2))/A(3))**2);
   IF SW(4).EQ.1.0  .OR.  SW(5).EQ.1.0  .OR.  SW(6).EQ.1.0   <
      FX(I,J) = FX(I,J) - 2.0*( ( XBEST(2*I-1)-A(5) )/A(6) ) *A(4)/A(6) *
                              MYEXP( -((XBEST(2*I-1)-A(5))/A(6))**2);   >
   IF SW(7).EQ.1.0  .OR.  SW(8).EQ.1.0  .OR.  SW(9).EQ.1.0   <
      FX(I,J) = FX(I,J) - 2.0*( ( XBEST(2*I-1)-A(8) )/A(9) ) *A(7)/A(9) *
                              MYEXP( -((XBEST(2*I-1)-A(8))/A(9))**2);   >
   W(I)  =  1.0/( FX(I,J)**2*SIGMA(J)+SIGMA(J+1) );
   J = J+1;
   FX(I,J) = -1.0;
   J = J+1;
   >
RETURN;END;




REAL*8 FUNCTION PROFILE(X, A, SW, VSINI);
"
 A routine which computes the profile for fitting, including possible
 rotationally broadened lines, and up to 3 blended lines.
"
IMPLICIT REAL*8 (A-H,O-Z);
REAL*8 DUMMY, X, A(9), SW(9), VSINI, GAUSS_PROF, ROT_PROF;
INTEGER I, NGAUSS;

DUMMY = 0.0D0;

FOR I = 1 TO NGAUSS(SW)  <
   IF VSINI .LT. 0.1D0  <
      DUMMY = DUMMY + GAUSS_PROF(X, A, I);   >
   ELSE  <
      DUMMY = DUMMY + ROT_PROF(X, A, I, VSINI);   >
   >
PROFILE = DUMMY;
RETURN;
END;



INTEGER FUNCTION NGAUSS(SW);
"
A routine to count the number of gaussians being fitted.
"

REAL*8 SW(9);

NGAUSS = 0;
IF SW(1)+SW(2)+SW(3) .GE. 1.0  <  NGAUSS = 1;   >
IF SW(4)+SW(5)+SW(6) .GE. 1.0  <  NGAUSS = 2;   >
IF SW(7)+SW(8)+SW(9) .GE. 1.0  <  NGAUSS = 3;   >
RETURN;
END;




REAL*8 FUNCTION GAUSS_PROF(X, A, ILINE);
IMPLICIT REAL*8 (A-H,O-Z);
"
A routine to compute the gaussian function at X for gaussian ILINE
"

REAL*8 A1,A2,A3,A(9),X,MYEXP;
INTEGER ILINE;

A1 = A(3*(ILINE-1)+1);
A2 = A(3*(ILINE-1)+2);
A3 = A(3*(ILINE-1)+3);

GAUSS_PROF = A1 * MYEXP( -((X-A2)/A3)**2 );
RETURN;
END;




REAL*8 FUNCTION ROT_PROF(PIX, A, ILINE, VSINI );
"

  A routine to compute the convolution of rotational and gaussian
  line profiles, given:
 
  pix   = pixel position
  a     = gaussian parameters
  iline = number of the line to be fitted in a blend
  vsini = vsini in Km/s

Note that the convolution step size may become important, because in
the fit the gradient found by forward differencing must be dominated
by the real parameter sensitivity, not the step size used in the
convolution.

"

IMPLICIT REAL*8 (A-H,O-Z);
REAL*8 PIX, A(9), VSINI, C, COEFF(3), LAMC,LAM, DLAML, DPIXL, XSTEPR;
REAL*8 XSTEPG, XSTEP, DPIX, X(5000), F(5000), SUM(5000);
REAL*8 H, G, HELENA, WAVE, DIODE;
INTEGER I,ILINE,NLAM;

C = 2.9979250D+5;

COEFF(1) = A(3*(ILINE-1)+1);
COEFF(2) = A(3*(ILINE-1)+2);
COEFF(3) = A(3*(ILINE-1)+3);


" The following is a debugging test A.McW. 3/96 not for normal operation
   ROT_PROF = H(PIX,COEFF);
   RETURN;
  remove the above after checking is done ***** "



LAMC = WAV(COEFF(2));
LAM  = WAV(PIX);

DLAML  = LAMC*VSINI/C;
DPIXL  = 0.5D0 * ( CHANNEL(LAMC+DLAML) - CHANNEL(LAMC-DLAML) );

XSTEPR = DPIXL/30.D0;
XSTEPG = COEFF(3)/10.D0;

XSTEP = XSTEPG;
IF XSTEPR .LT. XSTEPG  <  XSTEP = XSTEPR;  >   " ***old** lstep = 0.002d0 "
XSTEP = 0.05;  " just set the step size to 1/20 of a pixel"
NLAM = 2*INT(DPIXL/XSTEP) + 1;
DPIX = -DPIXL;

   
" now try the new bounds and step size code to try to spped it up  

   ****DOESN'T WORK!!
   
DPIXG = 5.0D0 * COEFF(3);
XSTEPG = COEFF(3)/40.0D0;
XSTEPR = DPIXL/60.D0;
XSTEP = XSTEPG;
IF XSTEPR .LT. XSTEPG  <  XSTEP = XSTEPR;  >   
XSTEP = 0.05;  
IF DPIXG .LT. DPIXL   <
   NLAM = 2*INT(DPIXG/XSTEP) + 1;
   DPIX = -DPIXG;   >
ELSE  <
   NLAM = 2*INT(DPIXL/XSTEP) + 1;
   DPIX = -DPIXL;   >
"


"  Convolution is performed in this loop  "

FOR I = 1 TO NLAM  <
   F(I) = H(PIX-DPIX,COEFF)*G(DPIX,DPIXL,DLAML,LAMC);
   X(I) = DPIX;
   DPIX = -DPIXL + DBLE(I)*XSTEP;
   >
ROT_PROF = HELENA(X,F,SUM,NLAM);
RETURN;
END;





REAL*8 FUNCTION H(X,COEFF);
"
  a routine to compute the gaussian line profile, H.  Input parameters are:
 
   x         pixel wavelength 
   coeff(1)  central depth
   coeff(2)  central pixel wavelength in pixels
   coeff(3)  gaussian sigma in pixels

"
IMPLICIT REAL*8 (A-H,O-Z);
REAL*8 X, COEFF(3),MYEXP;

H = COEFF(1)*MYEXP(- ((X-COEFF(2))/COEFF(3))**2 );

RETURN;
END;



REAL*8 FUNCTION G(DPIX,DPIXL,DLAML,LAMC);
"
   a little routine to compute the rotational profile fn. G
 
   dpix is the pixel shift from line center
   dpixl is the maximum pixel shift for non-zero rotational profile.
   eps   is the limb-darkening coefficient -- should be a fn. of wavelength
   lamc  is the line central wavelength

   I input the wavelength, LAMC, because the limb darkening coefficient is
   wavelength dependent and should ultimately include a LAMC term.
"

IMPLICIT REAL*8 (A-H,O-Z);
REAL*8 LAMC,DPIX,DPIXL,DLAML,C1,C2,EPS,PI;

PI = 3.141592654D+0;
EPS = 0.6D+0;

IF DABS(DPIX) .GT. DABS(DPIXL)  <
   G = 0.0D0;   >
ELSE  <
"
this original was almost certainly wrong: see what happens with pixels...
   C1 = 2.0D0*(1.D0 - EPS)/(PI*DLAML*(1.D0-EPS/3.D0));
   C2 = EPS/(2.D0*DLAML*(1.D0-EPS/3.D0));
"
   C1 = 2.0D0*(1.D0 - EPS)/(PI*DPIXL*(1.D0-EPS/3.D0));
   C2 = EPS/(2.D0*DPIXL*(1.D0-EPS/3.D0));
   G = C1*(1.D0-(DPIX/DPIXL)**2)**0.5+C2*(1.D0-(DPIX/DPIXL)**2);   >

RETURN;
END;





REAL*8 FUNCTION MYEXP(ARG);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 ARG;

IF ARG .LT. -150.D0   <
   MYEXP = 0.0D0;   >
ELSE   <
   MYEXP = DEXP(ARG);   >
RETURN;
END;


SUBROUTINE DETERMINE PHI(PHI,F,V,FX,N);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 PHI(100),F(100),V(200),FX(100,200);
INTEGER N;

FOR J = 1 TO N  <
   PHI(J) = 0.0;
   FOR I = 1 TO 2*N-1 BY 2   <
      PHI(J) = PHI(J) - FX(J,I)*V(I);   >
   PHI(J) = PHI(J) + F(J);   >
RETURN;
END;


SUBROUTINE COMPUTE RESIDUALS(PHI,W,S,N);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 PHI(100),W(100),S;
INTEGER I,N;

S = 0.0;
FOR I = 1 TO N   <
   S = S + PHI(I)**2 * W(I);   >
S = 0.5*S;
RETURN;
END;


SUBROUTINE FIND PARAMETER CORRECTIONS(DELTA,N,NU,W,FA,PHI,MINV,NPARAM,IER);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 DELTA(9),M(9,9),MINV(9,9),COL(9),W(100),PHI(100),FA(200,9),NU;
REAL*8 WKAREA(108);
INTEGER NPARAM,NINE,IDIGIT,IER;

IDIGIT = 9;
IER = 0;
NINE = 9;
FOR I = 1 TO 9   <
   FOR J = 1 TO 9   <
      MINV(I,J) = 0.0;   >
   >
FOR I = 1 TO NPARAM   <
   FOR J = 1 TO NPARAM   <
      M(I,J) = 0.0;
      FOR K = 1 TO N   <
         M(I,J) = M(I,J) + W(K)*FA(K,I)*FA(K,J);   >
     >
   >
FOR I = 1 TO NPARAM   <
   M(I,I) = M(I,I)*(1.0+1.0/NU);   >
CALL LINV2F(M,NPARAM,NINE,MINV,IDIGIT,WKAREA,IER);
FOR J = 1 TO NPARAM   <
   COL(J) = 0.0;
   FOR I = 1 TO N <
      COL(J) = COL(J) + W(I)*PHI(I)*FA(I,J);   >
   >
FOR J = 1 TO NPARAM   <
   DELTA(J) = 0.0;
   FOR I = 1 TO NPARAM   <
      DELTA(J) = DELTA(J) - MINV(J,I)*COL(I);   >
   >
RETURN;
END;


SUBROUTINE CHECK FOR IMSL ERROR(IER,N,A,X);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 A(9),X(200);
INTEGER IER,N,I;

IF IER .NE. 0   <
   OUTPUT(8)IER;  (/' IMSL ERROR NUMBER ',I3);
   OUTPUT(8)A;    (' A VALUES: ',/,3(3E15.6,/));
   OUTPUT(8)(X(I),I=1,2*N);(' X VALUES: ',/,25(8E15.6,/));
   >
RETURN;
END;


SUBROUTINE FIND X CORRECTIONS(V,N,FA,FX,PHI,W,SIGMA,DELTA,A,X);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 V(200),FA(200,9),PHI(100),W(100),DELTA(9),X(200),A(9),SIGMA(200);
REAL*8 FX(100,200),COL(100);
INTEGER N;

FOR I = 1 TO N   <
   V(2*I-1) = - W(I)*PHI(I)*FX(I,2*I-1)*SIGMA(2*I-1);
   V(2*I)   =   W(I)*PHI(I)*SIGMA(2*I);  >
RETURN;
END;


SUBROUTINE CORRECT PARAMETERS(X,XBEST,V,N,A,DELTA,F,SW);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-ROTATION;

REAL*8 X(200),XBEST(200),V(200),F(100),A(9),DELTA(9),SW(9),PROFILE;
INTEGER N,I;

FOR I = 1 TO 2*N    <
   XBEST(I) = X(I) + V(I);   >
J = 0;
FOR I = 1 TO 9   <
   IF SW(I) .EQ. 1.0   <
      J = J + 1;
      A(I) = A(I) + DELTA(J);   >
   >

FOR I = 1 TO N   <
   F(I) = PROFILE(X(2*I-1),A,SW,VSINI) - X(2*I);
   >

RETURN;
END;


LOGICAL FUNCTION CONVERGENCE(AOLD,ANEW,DELTA,SWITCH);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 AOLD(9),ANEW(9),DELTA(9),SWITCH(9);

CONVERGENCE = .FALSE.;
K = 0;
FOR I = 1 TO 9   <
   IF SWITCH(I) .EQ. 1.0   <
      K = K + 1;
      IF DLOG10(DABS(DELTA(K))) .LT. -60.0   <
         CONVERGENCE = .TRUE.;   >
      ELSEIF DABS( ANEW(I) ) .GT. 30000.0   <
          CONVERGENCE = .TRUE.;
          OUTPUT(8);(' GAUSSIAN FIT DIVERGING, ITERATIONS ABANDONED ');
          EXIT;   >
      ELSEIF DABS( AOLD(I)/DELTA(K) ) .GT. 10000.0   <
         CONVERGENCE = .TRUE.;   >
      ELSE   <
          CONVERGENCE = .FALSE.;
          EXIT;   >
      >
   >
RETURN;
END;


LOGICAL FUNCTION GAUSSIANS SWITCHED(AOLD,SWITCH);
"
   This routine checks to see if the fit has switched the order of the
   gaussians; if so it switches to the correct order and returns .true.
"
IMPLICIT REAL*8 (A-H,O-Z);
REAL*8 AOLD(9),SWITCH(9),ADUM(3);
INTEGER I,NGAUSS;

GAUSSIANS SWITCHED = .FALSE.; 

IF NGAUSS(SWITCH).EQ.1  < RETURN;  >
:900: CONTINUE;
FOR I = 1 TO NGAUSS(SWITCH)-1   <
   IF AOLD(3*(I-1)+2) .GT. AOLD(3*I+2)   <
      ADUM(1) = AOLD(3*(I-1)+1);
      ADUM(2) = AOLD(3*(I-1)+2);
      ADUM(3) = AOLD(3*(I-1)+3);
      AOLD(3*(I-1)+1) = AOLD(3*I+1);
      AOLD(3*(I-1)+2) = AOLD(3*I+2);
      AOLD(3*(I-1)+3) = AOLD(3*I+3);
      AOLD(3*I+1) = ADUM(1);
      AOLD(3*I+2) = ADUM(2);
      AOLD(3*I+3) = ADUM(3);
      GAUSSIANS SWITCHED = .TRUE.;   >
   >
IF AOLD(2).GT.AOLD(5)  <  GOTO :900:;  >
RETURN;
END;


SUBROUTINE COMPUTE CHISQ(X,N,A,SIGMA,SW,CHISQ);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-ROTATION;

REAL*8 X(200),A(9),SIGMA(200),PROFILE,CHISQ,SW(9);
INTEGER N,I;

CHISQ = 0.0;
FOR I = 1 TO N   <
   YRES = PROFILE(X(2*I-1),A,SW,VSINI) - X(2*I);
   CHISQ = CHISQ + YRES**2/SIGMA(2*I);   >
RETURN;
END;




SUBROUTINE FINAL COVARIANCE MATRIX(COV,COVOLD,FACTOR,SWITCH);

IMPLICIT REAL*8(A-H,O-Z);

REAL*8 COV(9,9),COVOLD(9,9),SWITCH(9),FACTOR;
INTEGER IPARAM(9),IC,I,J;

" first set-up iparam array for parameter positions "

IC = 0;
FOR I = 1 TO 9   <
   IPARAM(I) = 0;
   IF SWITCH(I).EQ.1.0   <
      IC = IC + 1;
      IPARAM(I) = IC;   >
>


" now set COV elements corresponding to the input parameters "

FOR I = 1 TO 9   <
   FOR J = 1 TO 9   <
      IF SWITCH(I).EQ.1.0 .AND. SWITCH(J).EQ.1.0   <
         COV(I,J) = FACTOR * COVOLD( IPARAM(I),IPARAM(J) ); >
      ELSE   <
         COV(I,J) = 0.0;   >
   >
>

RETURN;
END;



SUBROUTINE FIND RV;

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-SPECTRUM;
COMMON-BLOCK-IMAGE;

INTEGER JREF,J,I,WRONG;
INTEGER NREF,IEND,ISTART,STDORDER;
REAL*8 FMIN,WREF(100),NSIG,PMIN,RVI(100);
REAL*8 RVT,AN,RVT2,SIG,WEND,CENTER,SHIFTSTD,WSTD,RV_FAC;
"
C  A ROUTINE TO COMPUTE THE RADIAL VELOCITY OF THE STAR, BASED ON THE
C  PRESENCE OF STANDARD LINES IN THE rvlist.dat FILE.
"

OUTPUT(6);(47H Enter approximate RV and search range in Km/s );
READ(*,*)RV_EST,RV_SRCH;

RV_FZERO = 1.0D+00 + RV_EST / 3.0D+05;

OPEN(UNIT=14,FILE='rvlist.dat',STATUS='OLD');
"
 First read the wavelength of a strong standard line which appears in 
 the spectrum.  For best results this should not be a line near the edge
 of an order, and should not be close to another, stronger line.
"
READ(14,*)WSTD;
WJUNK = WSTD * RV_FZERO;
FIND ORDER(WJUNK,STDORDER);
IF STDORDER.EQ.0  <
   OUTPUT(6)WSTD;(32H Cannot locate standard line at ,F10.3);
   STOP;
>
READ SPECTRUM(STDORDER);

WEND   = W1(STDORDER) + DW(STDORDER)*(DBLE(NUMBER OF DIODES)-PIX1(STDORDER));
WSTART = W1(STDORDER) + DW(STDORDER)*(1.0d0-PIX1(STDORDER));

RV_FAC = 1.0D+00 + 350. / 3.0D+05 ;

IF WSTART.GT.WSTD/RV_FAC .OR. WEND.LT.WSTD*RV_FAC   <
   WRITE(6,'(55H WARNING: Standard line within 350 Km/s of spectrum end)');   >
ELSEIF WSTART.LE.WSTD-0.7 .AND. WEND.GE.WSTD+0.7  <
   "   choose points within RV_SRCH Km/s of rest wavelength   "

   RV_FZERO = 1.0D+00 + RV_EST / 3.0D+05;
   RV_FAC   = 1.0D+00 + RV_SRCH / 3.0D+05;

   ISTART = NINT( (WSTD*RV_FZERO/RV_FAC - WSTART)/DW(STDORDER) + 1.0 );
   IEND   = NINT( (WSTD*RV_FZERO*RV_FAC - WSTART)/DW(STDORDER) + 1.0 );

   IF ISTART.LT.1   <  ISTART=1;  >
   IF IEND.GT.NUMBER OF DIODES   <  IEND=NUMBER OF DIODES;   >
   FMIN = 1.0;
   FOR I = ISTART TO IEND  <
      IF (SPEC(I).LT.FMIN)  <
         FMIN = SPEC(I);
         PMIN = DBLE(I);
      >
   >
>
ELSE  <
   WRITE(6,'(43H end of spectrum too close to standard line)');
   STOP;
   >
"
C  APPROX STD LINE RADIAL VELOCITY IN PIXELS
"
GET STD LINE MINIMUM(PMIN,FMIN,CENTER);
SHIFTSTD  =  ( WSTART + (CENTER-1.0)*DW(STDORDER) ) / WSTD;
FOR J = 1 TO 100  <
   READ(14,*,END=:900:)WREF(J);
   >
:900:   REWIND(UNIT=14); CLOSE(UNIT=14);

NREF = J - 1;
WRONG = 0;
RVT = 0.0;
RVT2 = 0.0;
FOR J = 1 TO NREF  <
   FIND ORDER(WREF(J),NEW ORDER);
   IF NEW ORDER .EQ. 0  < 
      REMOVE RV REF(WREF,J,NREF);
      J = J - 1;
      NEXT;
      >
   IF NEW ORDER .NE. CURRENT ORDER   <
      READ SPECTRUM(NEW ORDER);   >

   WEND   = W1(NEW ORDER) + DW(NEW ORDER) *
            (DBLE(NUMBER OF DIODES)-PIX1(NEW ORDER));
   WSTART = W1(NEW ORDER) + DW(NEW ORDER)*(1.0d0-PIX1(NEW ORDER));

   JREF = NINT((WREF(J)*SHIFTSTD - WSTART) / DW(NEW ORDER) + 1.0D+00);
   GET MINIMUM(JREF,CENTER,NUMBER OF DIODES);
   WCENT = WSTART + DW(NEW ORDER)*(CENTER-1.0D+00);
   RVI(J) = 3.0D+05*(  WCENT/WREF(J) - 1.0D+00 );
   >
GET MEDIAN2(RVI,WREF,NREF,RVMED);
"
 now use only RV's within 1 focus FWHM of the median
"
FOR J = 1 TO NREF   <
   DVLIMIT = 25.0;
   IF DABS(RVI(J)-RVMED).GT.DVLIMIT   <
      IF J.LT.NREF   <
         FOR JJ = J TO NREF-1  <
            WREF(JJ) = WREF(JJ+1);
            RVI(JJ)  = RVI(JJ+1);   >
         >
      NREF = NREF - 1;   
      J    = J - 1;  
      NEXT;   >
   ELSE   <
      RVT = RVT + RVI(J);
      RVT2 = RVT2 + RVI(J)**2;  
      WRITE(6,'(7h wav = ,F10.3,2X,6h RV = ,F10.3)')WREF(J),RVI(J);   >
   > UNTIL J.GE.NREF;

" compute mean RV and sigma "

AN = DBLE(NREF);
RV = RVT/AN;
SIGRV = DMYSQ(  (RVT2 - RVT**2/AN )/(AN-1.0) );
WRITE(6,'(19H RADIAL VELOCITY = ,F10.3,5H +/- ,F6.2)')RV,SIGRV;
WRITE(6,'(15H MEDIAN R.V. = ,F10.3)')RVMED;
DV = 2.0 * 3.0D+05*DW(NREF/2)/WREF(NREF/2);
" see what happens if median is always used 
RV = RVMED;
"
IF DABS(RV-RVMED).GT.DV   <
   RV = RVMED;
   WRITE(6,'(16H MEDIAN RV USED )');
>
RETURN;
END;



SUBROUTINE REMOVE RV REF(WREF,J,NREF);

REAL*8 WREF(100);
INTEGER NREF,J,I;

FOR I = J TO NREF-1  <
   WREF(I) = WREF(I+1);   >
NREF = NREF - 1;
RETURN;
END;
   

SUBROUTINE GET STD LINE MINIMUM(PMIN,FMIN,CENTER);
IMPLICIT REAL*8 (A-H,O-Z);
REAL*8 X(100),Y(100);

ICENT = INT(PMIN);
ILEFT = 0;
IRIGHT = 0;
FOR I = 1 TO 50  <
   IF( 1.0 - SPEC(ICENT-I) .LT. 0.5*(1.0-FMIN)  .AND. ILEFT.EQ.0 )   <
      ILEFT = ICENT - I;   >
   IF( 1.0 - SPEC(ICENT+I) .LT. 0.5*(1.0-FMIN)  .AND. IRIGHT.EQ.0)   <
      IRIGHT = ICENT + I;   >
   >
IF ILEFT.EQ.0  .OR.  IRIGHT.EQ.0 <  
   OUTPUT(6);(67H CANNOT DEFINE STD LINE - half depth not within 50 
              pixels of center);
   STOP;  >
II = 0;
FOR I = ILEFT TO IRIGHT <
   II = II + 1;
   X(II) = DBLE(I);
   Y(II) =  SPEC(I);   >
N = IRIGHT - ILEFT + 1;
CALL PARABOL(X,Y,N,A,B,C);
CENTER = -B/(2.0*A);
RETURN;
END;


SUBROUTINE GET MINIMUM(J,CENTER,NUMBER OF DIODES);

IMPLICIT REAL*8 (A-H,O-Z);

INTEGER J,JMIN,N,ILEFT,IRIGHT,NUMBER OF DIODES;
LOGICAL RIGHT,LEFT;
REAL*8 DFMIN,DFL,DFR,FMIN,NSIG,SNR;
REAL*8 A(9),COV(9,9),X(200),PHOTONS,SINGLE(9),CENTER;

FOR I = 1 TO 3   <
   SINGLE(I) = 1.0;  >
FOR I = 4 TO 9   <
   SINGLE(I) = 0.0;  >

"
C  A ROUTINE TO FIND THE CENTER OF A LINE
C
C  FIRST FIND MINIMUM WITHIN 2 PIXELS OF ESTIMATED CENTER
"
NSIG = 1.8;
JMIN = J-2;
FMIN = SPEC(JMIN);
FOR I = J-2 TO J+2  <
   IF SPEC(I).LT.FMIN  <
      FMIN = SPEC(I);
      JMIN = I;
   >
>
DFMIN = NSIG * DMYSQ(FMIN)/SNR(NINT(CENTER));
RIGHT = .FALSE.;
LEFT = .FALSE.;
"
C  TEST EACH PIXEL, ON LEFT AND RIGHT, FOR SIGNIFICANT DISTANCE FROM MINIMUM
"
FOR I = 1 TO 15  <
   IF .NOT.RIGHT .AND. JMIN+I.LE.NUMBER OF DIODES  <
"
  I dont like this
      IF SPEC(JMIN+I).LT.FMIN  <
         FMIN = SPEC(JMIN+I);
         DFMIN = NSIG * DMYSQ(FMIN)/SN;
         >
"
      DFR = NSIG * DMYSQ(SPEC(JMIN+I))/SNR(JMIN+I);
      IF SPEC(JMIN+I).GT. FMIN+DFMIN+DFR  <
         RIGHT = .TRUE.;
         IRIGHT = I + JMIN;
         >
      >
   IF .NOT.LEFT .AND. JMIN-I.GE.1  <
"
  I still don't like it
      IF SPEC(JMIN-I).LT.FMIN  <
         DFMIN = NSIG * DMYSQ(FMIN)/SN;
         FMIN = SPEC(JMIN-I);
      >
"
      DFL = NSIG * DMYSQ(SPEC(JMIN-I))/SNR(JMIN-I);
      IF SPEC(JMIN-I).GT.FMIN+DFMIN+DFR  < 
         LEFT = .TRUE.;
         ILEFT = JMIN-I;  
      >
   >
   IF LEFT.AND.RIGHT  < GOTO :300:; >
>
WRITE(6,'(44H COULD NOT FIND MINIMUM FOR LINE NEAR PIXEL ,I6)')J;
CENTER = DBLE(J);
RETURN;
:300:   CONTINUE;
"
   Fit points around the minimum with a Gaussian, and find center
"
N =  IRIGHT - ILEFT + 1;
INDEX = ILEFT;
FOR I = 1 TO 2*N-1 BY 2   <
   X(I) = DBLE(INDEX);
   X(I+1) = 1.0 - SPEC(INDEX);
   INDEX = INDEX + 1;
   >
A(1) = 1.0 - FMIN;
A(2) = DBLE(JMIN);
A(3) = 0.5*( X(2*N-1) - X(1) );

IF FMIN .GE. 0.0D0  <
   PHOTONS = SNR(JMIN)**2/FMIN;  >
ELSE  <
   PHOTONS = 0.0D0;  >

GAUSS FIT(X,A,N,PHOTONS,COV,SINGLE,CHISQ);
IF A(2)-DBLE(J) .LT. 8   <
   CENTER = A(2);   >
ELSE   <
   CENTER = DBLE(J);  >
RETURN;
END;


SUBROUTINE GET MEDIAN2(RVI,WREF,N,RVMED);

REAL*8 RVI(100),WREF(100),RVMED,DUMMY;
INTEGER N;

"
  Get the median value of an array of (100) numbers
"
FOR J = 1 TO N-1  <
   K = N - J;
   FOR I = 1 TO K   <
      IF  RVI(I) .LT. RVI(I+1)     <
         DUMMY = RVI(I+1);
         RVI(I+1) = RVI(I);
         RVI(I) = DUMMY;   
         DUMMY = WREF(I+1);
         WREF(I+1) = WREF(I);
         WREF(I) = DUMMY;   
      >
   >
>
N2 = N/2;
IODD = N - 2*N2;
IF (IODD.EQ.0)  <
   RVMED = RVI(N2);
>
ELSEIF N.GT.1   <
   RVMED = ( RVI(N2) + RVI(N2+1) )/2.0;
>
ELSE   <
   RVMED = RVI(1);
>
RETURN;
END;


SUBROUTINE GET MEDIAN(RVI,N,RVMED);

REAL*8 RVI(100),RVMED,DUMMY;
INTEGER N;

"
  Get the median value of an array of (100) numbers
"
FOR J = 1 TO N-1  <
   K = N - J;
   FOR I = 1 TO K   <
      IF  RVI(I) .LT. RVI(I+1)     <
         DUMMY = RVI(I+1);
         RVI(I+1) = RVI(I);
         RVI(I) = DUMMY;   
      >
   >
>
N2 = N/2;
IODD = N - 2*N2;
IF (IODD.EQ.0)  <
   RVMED = RVI(N2);
>
ELSEIF N.GT.1   <
   RVMED = ( RVI(N2) + RVI(N2+1) )/2.0;
>
ELSE   <
   RVMED = RVI(1);
>
RETURN;
END;


SUBROUTINE FIND ORDER(W,IORDER);
"  A routine which returns the order number with the feature wavelength
   closest to the order center.  
   If wavelength not covered IORDER = 0 is returned.
"
IMPLICIT REAL*8 (A-H,O-Z);

COMMON-BLOCK-IMAGE;
INTEGER IORDER;

IORDER = 0;
NUMBER OF DIODES = AXLEN(1);
FOR I = 1 TO NUMBER OF ORDERS   <
   WEND   = W1(I) + DW(I)*(DBLE(NUMBER OF DIODES)-PIX1(I));
   WSTART = W1(I) + DW(I)*(1.0d0-PIX1(I));
   IF WEND.GE.W  .AND.  WSTART.LT.W   <
      X1 = 1.0 + (W-WSTART)/DW(I);
      IORDER = I;
      EXIT;   >
   >
IF I.LT.NUMBER OF ORDERS   <
   WEND   = W1(I+1) + DW(I+1)*(DBLE(NUMBER OF DIODES)-PIX1(I+1));
   WSTART = W1(I+1) + DW(I+1)*(1.0d0-PIX1(I+1));
   IF WEND.GE.W  .AND. WSTART.LE.W   <
      X2 = 1.0 + (W-WSTART)/DW(I+1);
      IF DABS(X1-DBLE(NUMBER OF DIODES)/2.0) .GT.
         DABS(X2-DBLE(NUMBER OF DIODES)/2.0)      <
         IORDER = I + 1;   >
   >
>

RETURN;
END;


SUBROUTINE READ CURRENT CONTINUUM(RV);

"  A routine to read continuum keywords for each order  "

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-BADDIODE;
COMMON-BLOCK-PLOTS;
COMMON-BLOCK-IMAGE;

CHARACTER*10 ID,LINE*80;
REAL*8 WAV1,WAV2,NPX;
INTEGER SEARCH,ISIZE;

"  NOCONT IS THE NUMBER OF CONTINUUM REGIONS USED  "

"  Reset variables from previous orders  "

I=0;   NOCONT = 0;   NOBAD = 0;
NUMBER OF DIODES = AXLEN(1);
WSTART = WAV(1.0D+00);
WEND = WAV(DBLE(NUMBER OF DIODES));
LOOP  <
   I=I+1;
   READ(4,'(A80)',END=:END:)LINE;
   IF ID.EQ.'CONTINUUM '   <
      READ(LINE,'(A10,3D10.3))',END=:END:)ID,WAV1,WAV2,NPX;
      I = I - 1;
      WAV1 = WAV1;
      WAV2 = WAV2;
      IF WAV1.LT.WEND .AND. WAV2.GT.WSTART   <
         NOCONT = NOCONT + 1;
         CONTINUUM LEFT(NOCONT)  = NINT(CHANNEL(WAV1));
         CONTINUUM RIGHT(NOCONT) = NINT(CHANNEL(WAV2));
         IF CONTINUUM LEFT(NOCONT) .LT. 1  <   CONTINUUM LEFT(NOCONT) = 1;  >
         IF CONTINUUM RIGHT(NOCONT) .GT. NUMBER OF DIODES  <
            CONTINUUM RIGHT(NOCONT) = NUMBER OF DIODES;  >
         ISIZE = CONTINUUM RIGHT(NOCONT) - CONTINUUM LEFT(NOCONT) + 1;
         IF NPX.EQ.0.0   <
            CONTINUUM SIZE(NOCONT) = ISIZE;
            >
         ELSE  <
            CONTINUUM SIZE(NOCONT)  = NINT(NPX);
            >
         IF CONTINUUM SIZE(NOCONT).GT.ISIZE   <
            CONTINUUM SIZE(NOCONT) = ISIZE;   >
         >
      NEXT;   >
   ELSEIF ID.EQ.'FITCONTIN'   <
      FITCON = .TRUE.;
      I = I - 1;
      NEXT;   >
   ELSEIF ID.EQ.'AUTOCONTIN'   <
      AUTO CONTINUUM = .TRUE.;
"     NOCONT = 1;  removed AMcW 3/2000"   
      I = I - 1;
      CONTINUUM RIGHT(1) = INT(WAV1);
      CONTINUUM LEFT(1) = 1;
      CONTINUUM SIZE(1) = INT(WAV2);
      NEXT;    >
   ELSEIF ID .EQ. 'NORMALISED'   <
      NORMALISED = .TRUE.;   
      I = I - 1;
      NEXT;   >
   ELSEIF ID .EQ. 'BADDIODE  '   <
      IF INT(NPX).EQ.CURRENT_IMAGE_ROW   <
         IF NOBAD .EQ. 300   <
            OUTPUT(8);('MAXIMUM NUMBER OF BAD DIODE REGIONS EXCEEDED');
            RETURN;   >
         NOBAD = NOBAD + 1;
         I = I - 1;
         BAD LEFT(NOBAD) = INT( WAV1 );
         BAD RIGHT(NOBAD)= INT( WAV2 );
         >
      NEXT;   >
   >
:END: REWIND(UNIT=4);
SORT CONTINUUM;
RETURN;
END;


SUBROUTINE READ GOOD LINES ONLY(RV);

IMPLICIT REAL*8(A-H,O-Z);

COMMON-BLOCK-FLAGS;
COMMON-BLOCK-WIDE;
COMMON-BLOCK-LINES;
COMMON-BLOCK-CONTINUUM;
COMMON-BLOCK-BADDIODE;
COMMON-BLOCK-PLOTS;
COMMON-BLOCK-TELLURIC;
COMMON-BLOCK-FOCUS;
COMMON-BLOCK-IMAGE;

CHARACTER*80 LINE;
INTEGER SEARCH;

"  NOCONT IS THE NUMBER OF CONTINUUM REGIONS USED  "

"  Reset variables from previous orders  "

I=0;   NUMBER OF GOOD LINES = 0;   NUMBER OF LINES = 0;  NOBAD = 0;
NUMBER OF DIODES = AXLEN(1);
WSTART = WAV(1.0D+00);
WEND   = WAV(DBLE(NUMBER OF DIODES));
LOOP  <
   READ(4,'(A80)',END=:END:)LINE;
   IF LINE(:9).EQ.'OLDCONTIN'   <
      NEXT;   >
   READ(LINE,'(A10,4D10.3,3(2X,I3))')LINE ID(I+1),WAVELENGTH(I+1),
       ATOM(I+1),EPLOW(I+1),GF(I+1),IGOOD,ILEFT(I+1),IRIGHT(I+1);
   IF LINE ID(I).EQ.'CONTINUUM '   <
         NEXT;   >
   ELSEIF LINE ID(I+1).EQ.'FITCONTIN'   <
      NEXT;   >
   ELSEIF LINE ID(I+1).EQ.'AUTOCONTIN'   <
      NEXT;   >
   ELSEIF LINE ID(I+1) .EQ. 'NORMALISED'   <
      NEXT;   >
   ELSEIF LINE ID(I+1)(:5) .EQ. 'FOCUS'   <
      READ(LINE(6:10),'(F5.1)')XROW;
      IROW = NINT(XROW);
      IF IROW.GT.0   <
         FOCUS_PARS(IROW) = .TRUE.;
         READ(LINE(11:),'(7F10.5)')WFC(IROW),(A_FOCUS(IROW,IPAR),IPAR=1,6);   >
      ELSE   <
         GLOBAL_FOCUS = .TRUE.;   
         READ(LINE(11:),'(7F10.5)')GLOBAL_WFC,(GLOBAL_A(IPAR),IPAR=1,6);   >
      NEXT;   >
   ELSEIF LINE ID(I+1) .EQ. 'INST_PROF '   <
      INST_PROF = .TRUE.;
      NEXT;   >
   ELSEIF LINE ID(I+1) .EQ. 'BOUNDS    '   <
      NEXT;   >
   ELSEIF LINE ID(I+1) .EQ. 'PLOT      '   <
      NEXT;   >
   ELSEIF LINE ID(I+1) .EQ. 'PLOTALL   '   <
      NEXT;   >
   ELSEIF LINE ID(I+1).EQ.'PLOTCONTIN'   <
      NEXT;   >
   ELSEIF LINE ID(I+1) .EQ. 'BADDIODE  '   <
      IF INT(EPLOW(I+1)).EQ.CURRENT_IMAGE_ROW   <
         IF NOBAD .EQ. 300   <
            OUTPUT(8);('MAXIMUM NUMBER OF BAD DIODE REGIONS EXCEEDED');
            RETURN;   >
         NOBAD = NOBAD + 1;
         BAD LEFT(NOBAD) = INT( WAVELENGTH(I+1) );
         BAD RIGHT(NOBAD)= INT( ATOM(I+1) );   
         >
      NEXT;   >
   ELSEIF LINE ID(I+1) .EQ. 'LLIMIT    '   <
      NEXT;   >
   ELSEIF LINE ID(I+1) .EQ. 'ULIMIT    '   <
      NEXT;   >
   ELSEIF LINE ID(I+1) .EQ. 'FWHM      '   <
      NEXT;   >
   IF IGOOD .EQ. 999    <
      I = I + 1;
      NUMBER OF GOOD LINES = NUMBER OF GOOD LINES + 1;
      GOOD(NUMBER OF GOOD LINES) = I;
      IGOOD = 0;   >
"
   IF GF(I+1) .EQ. 0.0   <   GF(I+1) = 1.0;   >
"
   >UNTIL I.GE.MAX LINES .OR. NOCONT.GE.MAX CONT;
OUTPUT(8);(' LINE OR CONTINUUM BUFFER MAXIMUM REACHED');
OUTPUT(8)I,MAX LINES;(I3,1X,27H LINES USED, MAX ALLOWED IS,1X,I3);
OUTPUT(8)NOCONT,MAX CONT;
   (I3,1X,30H CONTINUA USED, MAX ALLOWED IS,1X,I3);
:END:
   NUMBER OF LINES=I;
   REWIND(UNIT=4);
   RETURN;
   END;


REAL*8 FUNCTION DMYSQ(X);

" A routine to stop zero or -ve numbers entering the dsqrt function  "

IMPLICIT REAL*8 (A-H,O-Z);

IF X.LE.0.0   <
   DMYSQ = 0.0;   >
ELSE   <
   DMYSQ = DSQRT(X);   >
RETURN;
END;



"

     THE FOLLOWING ROUTINES CALL PGPLOT TO EMULATE GETJOB'S TEKTRONIX
        PLOTTING FUNCTIONS.
                                       -- A.McW & J.McC  19 Nov. 1993

"
/PGP_CODE/;
SUBROUTINE SET SCREEN BOUNDS(IXMIN,IXMAX,IYMIN,IYMAX);

" P G P _ T W I N D O "

INTEGER IXMIN,IXMAX,IYMIN,IYMAX;
REAL*4  X1,X2,Y1,Y2;

X1 = FLOAT(IXMIN)/FLOAT(NTEKPTS);
X2 = FLOAT(IXMAX)/FLOAT(NTEKPTS);
Y1 = FLOAT(IYMIN)/(0.75*FLOAT(NTEKPTS));
Y2 = FLOAT(IYMAX)/(0.75*FLOAT(NTEKPTS));

CALL PGSVP(X1,X2,Y1,Y2);

RETURN;
END;
/PGP_END/;


/PGP_CODE/;
SUBROUTINE SET USER WINDOW(XMIN,XMAX,YMIN,YMAX);

" P G P _ D W I N D O "

REAL*8 XMIN,XMAX,YMIN,YMAX;
REAL*4 X1,X2,Y1,Y2;

X1 = XMIN; X2 = XMAX;
Y1 = YMIN; Y2 = YMAX;

CALL PGSWIN(X1,X2,Y1,Y2);

RETURN;
END;
/PGP_END/;



/PGP_CODE/;
SUBROUTINE MOVE PEN TO USER(X,Y);

" P G P _ M O V E A "

REAL*8 X,Y;
REAL*4 FX,FY;

FX=X; FY=Y;
CALL PGMOVE(FX,FY);

RETURN;
END;
/PGP_END/;


/PGP_CODE/;
SUBROUTINE DRAW TO USER(X,Y);

" P G P _ D R A W A "

REAL*8 X,Y;
REAL*4 FX,FY;

FX=X; FY=Y;
CALL PGDRAW(FX,FY);

RETURN;
END;
/PGP_END/;


/PGP_CODE/;
SUBROUTINE FIND USER WINDOW BOUNDS(XMIN,XMAX,YMIN,YMAX);

" P G P _ S E E D W "

REAL*8 XMIN,XMAX,YMIN,YMAX;
REAL*4 X1,X2,Y1,Y2;

CALL PGQWIN(X1,X2,Y1,Y2);
XMIN=X1; XMAX=X2;
YMIN=Y1; YMAX=Y2;

RETURN;
END;
/PGP_END/;


/PGP_CODE/;
SUBROUTINE MARK CURSOR POSITION(ICH,X,Y);

" P G P _ V C U R S R "

INTEGER ICH;
REAL*8 X,Y;
REAL*4 FX,FY;
CHARACTER KEY;

CALL PGCURSE(FX,FY,KEY);

X=FX; Y=FY;
ICH=ICHAR(KEY);

RETURN;
END;
/PGP_END/;

