C MORTRAN 2.0 (VERSION OF 6/24/75) PROGRAM GETJOB IMPLICIT LOGICAL (A-Z) COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF 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/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON/ITRCOM/ DA(9),DX,PROF_TOL REAL*8 DA,DX,PROF_TOL COMMON/ROTCOM/ VSINI REAL*8 VSINI INTEGER I CALL INITPG(RV) CALL RDHDIF 10010 CURSPC=SPEC_START GOTO 10013 10011 CURSPC=CURSPC+(SPEC_STEP) 10013 IF((SPEC_STEP)*((CURSPC)-(NSPEC)).GT.0)GOTO 10012 CALL RADIALV CALL MKCNFTS(RV) CALL MEGDLN(RV) CALL CMNRVAS CALL DETWTD CALL WRHDRS 10020 I=1 GOTO 10023 10021 I=I+1 10023 IF((I).GT.(NORD))GOTO 10022 CALL RDSPEC(I) CALL RDLNCL(RV) CALL AD2BADLST CALL MEASALN GOTO 10021 10022 CONTINUE GOTO 10011 10012 CONTINUE CALL CLSFILS STOP END SUBROUTINE CKFRBL COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK 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/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON/ROTCOM/ VSINI REAL*8 VSINI REAL*8 DMYSQ,RFOCUS,SIGV,SIGF,DLAM INTEGER I 10030 I=1 GOTO 10033 10031 I=I+1 10033 IF((I).GT.(NOLINES - 1))GOTO 10032 SIGV = 0.8D0 * WAVELN(I) * (VSINI / 3.0D+5) IF((.NOT.(GLOBAL_FOCUS)) .AND. (.NOT.(FOCUS_PARS(CURIMR))))GOTO 10 *051 SIGF = WAVELN(I) / RFOCUS(WAVELN(I)) 10051 CONTINUE DLAM = DMYSQ( SIGV**2 + SIGF**2) IF(WAVELN(I+1)-WAVELN(I) .GE. 1.5D0*DLAM)GOTO 10071 ILEFT(I+1) = -1 IRIGHT(I) = -1 10071 CONTINUE IF(ILEFT(I) .GE. 0 .OR. IRIGHT(I) .GE. 0)GOTO 10091 ILEFT(I) = -2 IRIGHT(I) = -2 10091 CONTINUE GOTO 10031 10032 CONTINUE RETURN END SUBROUTINE INITPG(RV) IMPLICIT REAL*8(A-H,O-Z) COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/DNONLIN/PIXMIN,PIXMAX,PMIDDLE,PRANGE,C REAL*8 PIXMIN,PIXMAX,PMIDDLE,PRANGE,C(50) COMMON/LNONLIN/NON_LINEAR LOGICAL NON_LINEAR COMMON/NNONLIN/NTERMS INTEGER NTERMS COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) COMMON/LTELL/TELSET,TELPRES LOGICAL TELSET,TELPRES COMMON/ITELL/LBOUND(100),RBOUND(100),NBOUNDS,NH2O INTEGER LBOUND,RBOUND,NBOUNDS,NH2O COMMON/RTELL/H2OCENT(100),H2OFWHM(100),H2ODEEP(100), H2OSLOP,H2OIN *T,H2OMIN REAL*8 H2OCENT,H2OFWHM,H2ODEEP,H2OSLOP,H2OINT,H2OMIN COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM 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/ITRCOM/ DA(9),DX,PROF_TOL REAL*8 DA,DX,PROF_TOL COMMON/ROTCOM/ VSINI REAL*8 VSINI COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL CHARACTER*80 IMAGE,VARIANCE,ERRMSG,ANSWER*1 INTEGER RWMODE,BLOCKSIZE DATA BLEND/1000*0/ DATA ILEFT/1000*0/ DATA IRIGHT/1000*0/ DATA DA,DX/9*1.0D-8,1.0D-8/ DATA FOCUS_PARS,GLOBAL_FOCUS/101*.FALSE./ DATA CONORD/1000*0/ VSINI = 0.0D0 PROF_TOL = 0.0D0 RV = 0.0 PLOTALL = .FALSE. CONNECT = .FALSE. BINNED = .FALSE. SCREEN = .TRUE. NPLOTS = 0 NSPEC = 1 LINE_COLOR = 4 SOFT_DEVICE=' ' HARD_DEVICE=' ' DEFAULT=.TRUE. NON_LINEAR = .FALSE. NRMLSD = .FALSE. AUTOCON = .FALSE. OLD_CONTUM = .FALSE. SCALED_CONTUM=.FALSE. FITCON = .FALSE. PLOTCON=.FALSE. TELSET = .FALSE. TELPRES= .FALSE. FIXFWHM = .FALSE. INST_PROF = .FALSE. IGROW = 0 INCPT = 0.0 SLOPE = 0.0 LLIMIT = 0.15 ULIMIT = 0.50 EFLAG=0 CFLAG=0 WIDFLG=1 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') 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 WRITE(*,'(18H ENTER IMAGE NAME )') READ(*,'(A80)')IMAGE IER = 0 RWMODE = 0 CALL FTGIOU(IM,IER) CALL FTOPEN(IM,IMAGE,RWMODE,BLOCKSIZE,IER) IF(IER .EQ. 0)GOTO 10111 CALL FTPMSG(ERRMSG) WRITE(*,'(A80)')ERRMSG STOP 10111 CONTINUE WRITE(*,'(27H IS THERE A VARIANCE FILE? )') READ(*,'(A1)')ANSWER IF((ANSWER .NE. 'Y') .AND. (ANSWER .NE. 'y'))GOTO 10131 VARFIL = .TRUE. WRITE(*,'(26H ENTER VARIANCE FILE NAME )') READ(*,'(A80)')VARIANCE CALL FTGIOU(IVM,IER) CALL FTOPEN(IVM,VARIANCE,RWMODE,BLOCKSIZE,IER) GOTO 10141 10131 CONTINUE VARFIL = .FALSE. 10141 CONTINUE 10121 CONTINUE IF(IER .EQ. 0)GOTO 10161 CALL FTPMSG(ERRMSG) WRITE(*,'(A80)')ERRMSG STOP 10161 CONTINUE RETURN END SUBROUTINE RDHDIF COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS CHARACTER*68 VALSTR,COMMENT,ERRMSG*80 INTEGER STATUS STATUS = 0 CALL FTGKYJ(IM,'NAXIS',NAXIS,COMMENT,STATUS) CALL FTGKYJ(IM,'NAXIS1',AXLEN(1),COMMENT,STATUS) IF(NAXIS .LT. 2)GOTO 10181 CALL FTGKYJ(IM,'NAXIS2',AXLEN(2),COMMENT,STATUS) 10181 CONTINUE NPTS = AXLEN(1) NORD = AXLEN(2) IF(NAXIS .LT. 3)GOTO 10201 WRITE(*,'(46H NOTE: 3-D PROCESSING NOT YET FULLY FUNCTIONAL)') 10201 CONTINUE CALL FTGKYS(IM,'WCSDIM',VALSTR,COMMENT,STATUS) IF(STATUS .NE. 0)GOTO 10221 CALL FTGKYS(IM,'WAT0_001',VALSTR,COMMENT,STATUS) IF(VALSTR(:15) .NE. 'system=equispec')GOTO 10241 NSPEC = NORD NORD = 1 CALL RDEQWV(NORD) CALL PTSSAS(SPEC_START,SPEC_STEP,NAXIS) GOTO 10231 10241 IF(VALSTR(:16) .NE. 'system=multispec')GOTO 10251 CALL RDWCSWV(IM,W1,DW,PIX1,NORD) GOTO 10231 10251 IF(STATUS .EQ. 0)GOTO 10261 WRITE(6,10270) 10270 FORMAT ('ERROR: No WCS system card present') STOP 10261 CONTINUE 10231 CONTINUE GOTO 10281 10221 CONTINUE WRITE(6,10290) 10290 FORMAT(37H ERROR: Spectrum is not in WCS format) STOP 10281 CONTINUE 10211 CONTINUE CALL FTGKYS(IM,'title',SPTITLE,COMMENT,STATUS) STATUS = 0 IF(.NOT.(.NOT.VARFIL))GOTO 10311 CALL FTGKYD(IM,'S/N',SN,COMMENT,STATUS) IF(STATUS .EQ. 0)GOTO 10331 WRITE(6,10340) 10340 FORMAT(38H No variance file and no S/N in header) STOP 10331 CONTINUE 10311 CONTINUE WRITE(10,*)SPTITLE WRITE(1,10350)SPTITLE 10350 FORMAT(' THE INPUT SPECTRUM TITLE IS: ',/,A80) CALL FTCMSG RETURN END SUBROUTINE PTSSAS(SPEC_START,SPEC_STEP,NAXIS) INTEGER SPEC_START,SPEC_STEP,NAXIS IF(NAXIS .LE. 1)GOTO 10371 WRITE(6,10380) 10380 FORMAT ('equispec file: Enter first spectrum number and step ') READ(5,*)SPEC_START,SPEC_STEP GOTO 10391 10371 CONTINUE SPEC_START = 1 SPEC_STEP = 1 10391 CONTINUE 10361 CONTINUE RETURN END SUBROUTINE RDEQWV(NROWS) IMPLICIT REAL*8 (A-H,O-Z) COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL INTEGER IERR(3),NROWS 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) .EQ. 0) .AND. ((IERR(2) .EQ. 0) .AND. (IERR(3) .EQ. 0) *))GOTO 10411 WRITE(6,10420) 10420 FORMAT(46H CRVAL1, CDELT1, or CRPIX1 missing from header) CALL FTCMSG STOP 10411 CONTINUE 10430 I=1 GOTO 10433 10431 I=I+1 10433 IF((I).GT.(NROWS))GOTO 10432 W1(I) = W1R DW(I) = DWR PIX1(I) = PXR GOTO 10431 10432 CONTINUE RETURN END SUBROUTINE RDWCSWV(IM,W1,DW,PIX1,NORD) CHARACTER*68 WAT2(1000),COMMENT INTEGER NWAT2,NORD,IM REAL*8 W1(1000),DW(1000),PIX1(1000) CALL GTWATC(IM,NWAT2,WAT2) CALL GETWVP(WAT2,NWAT2,W1,DW,PIX1) CALL CKWVP(W1,DW,NORD) RETURN END SUBROUTINE GTWATC(UNIT,NWAT2,WAT2) INTEGER UNIT,NWAT2,STATUS,I CHARACTER*68 WAT2(1000),KEYWD*8,COMMENT STATUS = 0 KEYWD = 'WAT2_001' 10440 I=1 GOTO 10443 10441 I=I+1 10443 IF((I).GT.(1000))GOTO 10442 IF(I .GE. 10)GOTO 10461 WRITE(KEYWD(8:8),'(I1)')I GOTO 10451 10461 IF(I .GE. 100)GOTO 10471 WRITE(KEYWD(7:8),'(I2)')I GOTO 10451 10471 IF(I .GE. 1000)GOTO 10481 WRITE(KEYWD(6:8),'(I3)')I 10481 CONTINUE 10451 CONTINUE CALL FTGKYS(UNIT,KEYWD,WAT2(I),COMMENT,STATUS) IF(STATUS .EQ. 0)GOTO 10501 CALL FTCMSG NWAT2 = I - 1 RETURN 10501 CONTINUE GOTO 10441 10442 CONTINUE RETURN END SUBROUTINE GETWVP(WAT2,NWAT2,W1,DW,PIX1) IMPLICIT REAL*8 (A-H,O-Z) COMMON/DNONLIN/PIXMIN,PIXMAX,PMIDDLE,PRANGE,C REAL*8 PIXMIN,PIXMAX,PMIDDLE,PRANGE,C(50) COMMON/LNONLIN/NON_LINEAR LOGICAL NON_LINEAR COMMON/NNONLIN/NTERMS INTEGER NTERMS INTEGER NWAT2,I,IORD,NORD,IC CHARACTER*68 WAT2(1000),STRING*1000,SPECID*12 REAL*8 W1(1000),DW(1000),PIX1(1000),WAV1,DWAV LOGICAL IN_STRING IN_STRING = .FALSE. NORD = 0 IC = 0 10510 I=1 GOTO 10513 10511 I=I+1 10513 IF((I).GT.(1000))GOTO 10512 W1(I) = 0.0 DW(I) = 0.0 PIX1(I) = 0.0 GOTO 10511 10512 CONTINUE IORD = 1 CALL SETSPECID(SPECID,IORD,IS) 10520 I=1 GOTO 10523 10521 I=I+1 10523 IF((I).GT.(NWAT2))GOTO 10522 10530 J=1 GOTO 10533 10531 J=J+1 10533 IF((J).GT.(68))GOTO 10532 IC = IC + 1 STRING(IC:IC)=WAT2(I)(J:J) IF((IC .LT. IS) .AND. (.NOT.(IN_STRING)))GOTO 10551 IF(.NOT.(.NOT. IN_STRING) .OR. STRING(IC-IS+1:IC) .NE. SPECID(:IS) *)GOTO 10571 IN_STRING = .TRUE. IC = 0 GOTO 10561 10571 IF(WAT2(I)(J:J) .NE. '"')GOTO 10581 IN_STRING = .FALSE. READ(STRING(1:IC),*)IDUM0,IDUM1,IDTYPE,WAV1,DWAV,INUM IF(IDTYPE .NE. 2.)GOTO 10601 NON_LINEAR = .TRUE. READ(STRING(1:IC),*)IDUM0,IDUM1,IDTYPE,WAV1,DWAV,INUM, ADUM1,ADUM *2,ADUM3,IDUM2,IDUM3,IDUM4,NTERMS,PIXMIN,PIXMAX READ(STRING(1:IC),*)IDUM0,IDUM1,IDTYPE,WAV1,DWAV,INUM, ADUM1,ADUM *2,ADUM3,IDUM2,IDUM3,IDUM4,IDUM5,PIXMIN,PIXMAX, (C(IKK),IKK=1,NTER *MS) PMIDDLE = (PIXMIN+PIXMAX)/2.0d0 PRANGE = PIXMAX - PIXMIN 10601 CONTINUE W1(IORD) = WAV1 DW(IORD) = DWAV PIX1(IORD) = 1.0 IC = 0 IORD=IORD+1 CALL SETSPECID(SPECID,IORD,IS) 10581 CONTINUE 10561 CONTINUE 10551 CONTINUE GOTO 10531 10532 CONTINUE GOTO 10521 10522 CONTINUE RETURN END SUBROUTINE SETSPECID(SPECID,IORD,IS) INTEGER IORD,IS CHARACTER*12 SPECID SPECID(:4) = 'spec' IF(IORD .GE. 10)GOTO 10621 WRITE(SPECID(5:5),'(I1)')IORD SPECID(6:9) = ' = "' IS = 9 GOTO 10611 10621 IF(IORD .GE. 100)GOTO 10631 WRITE(SPECID(5:6),'(I2)')IORD SPECID(7:10) = ' = "' IS = 10 GOTO 10611 10631 IF(IORD .GE. 1000)GOTO 10641 WRITE(SPECID(4:6),'(I3)')IORD SPECID(8:11) = ' = "' IS = 11 GOTO 10651 10641 CONTINUE WRITE(SPECID(5:7),'(I4)')IORD SPECID(9:12) = ' = "' IS = 12 10651 CONTINUE 10611 CONTINUE RETURN END SUBROUTINE CKWVP(W1,DW,NORD) REAL*8 W1(1000),DW(1000) INTEGER I,NORD COMMON/DNONLIN/PIXMIN,PIXMAX,PMIDDLE,PRANGE,C REAL*8 PIXMIN,PIXMAX,PMIDDLE,PRANGE,C(50) COMMON/LNONLIN/NON_LINEAR LOGICAL NON_LINEAR COMMON/NNONLIN/NTERMS INTEGER NTERMS IF(.NOT.(.NOT.NON_LINEAR))GOTO 10671 10680 I=1 GOTO 10683 10681 I=I+1 10683 IF((I).GT.(NORD))GOTO 10682 IF((W1(I) .NE. 0.0D0) .AND. (DW(I) .NE. 0.0D0))GOTO 10701 WRITE(6,10710)I 10710 FORMAT ('ERROR: Could not find wavelength solution for order',I3) STOP 10701 CONTINUE GOTO 10681 10682 CONTINUE 10671 CONTINUE RETURN END SUBROUTINE QKCNFT(RV) IMPLICIT REAL*8 (A-H,O-Z) COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) INTEGER IORD,IDUM1,IDUM2 REAL*8 RV CALL RDLNCL(RV) IF(.NOT.(FITCON))GOTO 10731 10740 IORD=1 GOTO 10743 10741 IORD=IORD+1 10743 IF((IORD).GT.(NORD))GOTO 10742 CALL RDSPEC(IORD) CALL RDCUCT(RV) IF(.NOT.(FITCON))GOTO 10761 CALL FITCONT 10761 CONTINUE GOTO 10741 10742 CONTINUE 10731 CONTINUE RETURN END SUBROUTINE MKCNFTS(RV) IMPLICIT REAL*8 (A-H,O-Z) COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) INTEGER IORD,IDUM1,IDUM2,LPG REAL*8 RV CALL RDLNCL(RV) IF(.NOT.(PLOTCON))GOTO 10781 SOFT_DEVICE = '/GTERM' CALL PGBEG(14,SOFT_DEVICE,1,1) CALL PGASK(.FALSE.) CALL SETWIN 10781 CONTINUE IF((.NOT.(PLOTCON)) .AND. (.NOT.(FITCON)))GOTO 10801 10810 IORD=1 GOTO 10813 10811 IORD=IORD+1 10813 IF((IORD).GT.(NORD))GOTO 10812 CALL RDSPEC(IORD) CALL RDCUCT(RV) IF(.NOT.(FITCON))GOTO 10831 CALL FITCONT 10831 CONTINUE IF(.NOT.(PLOTCON))GOTO 10851 CALL CONPLT CALL INTUSR(IDUM1,IDUM2) 10851 CONTINUE GOTO 10811 10812 CONTINUE 10801 CONTINUE IF(.NOT.(PLOTCON))GOTO 10871 CALL PGEND 10871 CONTINUE RETURN END SUBROUTINE MEGDLN(RV) IMPLICIT REAL*8(A-H,O-Z) COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER LMIN,LMAX,I,IORDER LOGICAL ZERO LMIN = 1 ZERO=.FALSE. CALL RDGDLO(RV) 10880 LMIN=1 GOTO 10883 10881 LMIN=LMIN+1 10883 IF((LMIN).GT.(NOLINES))GOTO 10882 CALL FNDORD(WAVELN(LMIN),IORDER) IF(IORDER .EQ. 0)GOTO 10901 CALL RDSPEC(IORDER) GOTO 10882 10901 CONTINUE GOTO 10881 10882 CONTINUE ILOW = LMIN 10910 I=ILOW GOTO 10913 10911 I=I+1 10913 IF((I).GT.(NOLINES))GOTO 10912 CALL FNDORD(WAVELN(I),IORDER) IF(IORDER .EQ. CURORD .OR. .NOT.(.NOT.ZERO))GOTO 10931 LMAX = I - 1 CALL RDCUCT(RV) CALL MLICUO(LMIN,LMAX) IF(IORDER .EQ. 0)GOTO 10951 CALL RDSPEC(IORDER) GOTO 10961 10951 CONTINUE ZERO = .TRUE. 10961 CONTINUE 10941 CONTINUE LMIN = I GOTO 10921 10931 IF(.NOT.(ZERO) .OR. IORDER .EQ. 0)GOTO 10971 ZERO = .FALSE. CALL RDSPEC(IORDER) 10971 CONTINUE 10921 CONTINUE GOTO 10911 10912 CONTINUE IF(IORDER .EQ. 0)GOTO 10991 LMAX = NOLINES CALL RDSPEC(IORDER) CALL RDCUCT(RV) CALL MLICUO(LMIN,LMAX) 10991 CONTINUE RETURN END SUBROUTINE QKMSALL IMPLICIT REAL*8(A-H,O-Z) COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS INTEGER LMIN,LMAX,I,IORDER LOGICAL ZERO LMIN = 1 ZERO=.FALSE. CALL QKRDALL(RV) 11000 LMIN=1 GOTO 11003 11001 LMIN=LMIN+1 11003 IF((LMIN).GT.(NOLINES))GOTO 11002 CALL FNDORD(WAVELN(LMIN),IORDER) IF(IORDER .EQ. 0)GOTO 11021 CALL RDSPEC(IORDER) GOTO 11002 11021 CONTINUE GOTO 11001 11002 CONTINUE ILOW = LMIN 11030 I=ILOW GOTO 11033 11031 I=I+1 11033 IF((I).GT.(NOLINES))GOTO 11032 CALL FNDORD(WAVELN(I),IORDER) IF(IORDER .EQ. CURORD .OR. .NOT.(.NOT.ZERO))GOTO 11051 LMAX = I - 1 CALL RDCUCT(RV) CALL MLICUO(LMIN,LMAX) IF(IORDER .EQ. 0)GOTO 11071 CALL RDSPEC(IORDER) GOTO 11081 11071 CONTINUE ZERO = .TRUE. 11081 CONTINUE 11061 CONTINUE LMIN = I GOTO 11041 11051 IF(.NOT.(ZERO) .OR. IORDER .EQ. 0)GOTO 11091 ZERO = .FALSE. CALL RDSPEC(IORDER) 11091 CONTINUE 11041 CONTINUE GOTO 11031 11032 CONTINUE IF(IORDER .EQ. 0)GOTO 11111 LMAX = NOLINES CALL RDSPEC(IORDER) CALL RDCUCT(RV) CALL MLICUO(LMIN,LMAX) 11111 CONTINUE RETURN END SUBROUTINE MLICUO(LMIN,LMAX) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM INTEGER LINE,LMIN,LMAX REAL*8 A(9),COV(9,9) LOGICAL DELETED NPTS = AXLEN(1) CALL ESLNCT(LMIN,LMAX) IF(CONORD(CURIMR) .NE. 0)GOTO 11131 CALL FITCONT 11131 CONTINUE 11140 LINE=LMIN GOTO 11143 11141 LINE=LINE+1 11143 IF((LINE).GT.(LMAX))GOTO 11142 CALL FCDNAD(LINE,A,COV,DELETED) IF(.NOT.(DELETED))GOTO 11161 LINE = LINE - 1 GOTO 11141 11161 CONTINUE CALL OBFWHML (LINE,A,COV,NPTS) CALL FT1GAUS(LINE) CALL CMLINRV(LINE) GOTO 11141 11142 CONTINUE RETURN END SUBROUTINE CMLINRV(LINE) IMPLICIT REAL*8 (A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK W = WAV(CENTRE(LINE)) DELTRV(LINE) = 3.0D+05 * ( W/WAVELN(LINE) - 1.0D+00 ) RETURN END SUBROUTINE CMNRVAS IMPLICIT REAL*8 (A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS DV = 0.0 DV2 = 0.0 NZERO = 0 11170 I=1 GOTO 11173 11171 I=I+1 11173 IF((I).GT.(NOGDLN))GOTO 11172 IF(CHANNEL(WAVELN(GOOD(I))) .NE. CENTRE(GOOD(I)))GOTO 11191 NZERO = NZERO + 1 11191 CONTINUE DV = DV + DELTRV(GOOD(I)) DV2 = DV2 + DELTRV(GOOD(I))**2 GOTO 11171 11172 CONTINUE IF(NOGDLN-NZERO .LE. 2)GOTO 11211 AN = DBLE(NOGDLN - 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 11211 CONTINUE WRITE(6,'(19H RADIAL VELOCITY = ,F10.3,5H +/- ,F6.2)')ROT,RVERR WRITE(6,'(12H SIGMA RV = ,F10.3)')SIGROT WRITE(1,11220)RV 11220 FORMAT('RADIAL VELOCITY = ',F10.4,' KM/S') WRITE(1,11230)SIGROT 11230 FORMAT('SIGMA RV = ',F10.3,' KM/S') RETURN END SUBROUTINE MEASALN COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL INTEGER LINE,SEARCH,IDUMMY REAL*8 A(9),COV(9,9) LOGICAL DELETED CALL EACKLC(NPTS) IF(NOLINES .LT. 1)GOTO 11251 CALL FITCONT 11260 LINE=1 GOTO 11263 11261 LINE=LINE+1 11263 IF((LINE).GT.(NOLINES))GOTO 11262 CALL FCDNAD(LINE,A,COV,DELETED) IF(.NOT.(DELETED))GOTO 11281 LINE = LINE - 1 GOTO 11261 11281 CONTINUE CALL OBFWHML (LINE,A,COV,NPTS) CALL FT1GAUS(LINE) GOTO 11261 11262 CONTINUE CALL FITWKL 11290 LINE=1 GOTO 11293 11291 LINE=LINE+1 11293 IF((LINE).GT.(NOLINES))GOTO 11292 CALL SFTBLS(LINE) GOTO 11291 11292 CONTINUE CALL FNBRDLN CALL FTBLIN(NOLINES) 11300 LINE=1 GOTO 11303 11301 LINE=LINE+1 11303 IF((LINE).GT.(NOLINES))GOTO 11302 CALL MEASEW(LINE) GOTO 11301 11302 CONTINUE IF(NOLINES .LT. 1)GOTO 11321 CALL PTSCPL(NPTS) CALL PRDMIF(RV,SPTITLE) CALL FINSH 11321 CONTINUE 11251 CONTINUE RETURN END SUBROUTINE RMEASLN COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL INTEGER LINE,SEARCH,IDUMMY REAL*8 A(9),COV(9,9) LOGICAL DELETED CALL EACKLC(NPTS) IF(NOLINES .LT. 1)GOTO 11341 11350 LINE=1 GOTO 11353 11351 LINE=LINE+1 11353 IF((LINE).GT.(NOLINES))GOTO 11352 CALL FCDNAD(LINE,A,COV,DELETED) IF(.NOT.(DELETED))GOTO 11371 LINE = LINE - 1 GOTO 11351 11371 CONTINUE CALL OBFWHML (LINE,A,COV,NPTS) CALL FT1GAUS(LINE) GOTO 11351 11352 CONTINUE CALL FITWKL 11380 LINE=1 GOTO 11383 11381 LINE=LINE+1 11383 IF((LINE).GT.(NOLINES))GOTO 11382 CALL SFTBLS(LINE) GOTO 11381 11382 CONTINUE CALL FNBRDLN CALL FTBLIN(NOLINES) 11390 LINE=1 GOTO 11393 11391 LINE=LINE+1 11393 IF((LINE).GT.(NOLINES))GOTO 11392 CALL MEASEW(LINE) GOTO 11391 11392 CONTINUE 11341 CONTINUE RETURN END SUBROUTINE RDSPEC(IROW) IMPLICIT REAL*8(A-H,O-Z) COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK CHARACTER*80 ERRMSG INTEGER I,IROW,FPIX(2),LPIX(2),NAXES(2),INCS(2),NULLVAL,IER,GROUP LOGICAL ANYF CURIMR = (CURSPC - 1)*NORD + IROW NAXES(1) = NPTS NAXES(2) = NORD*NSPEC FPIX(1) = 1 FPIX(2) = CURIMR LPIX(1) = NPTS LPIX(2) = CURIMR INCS(1) = 1 INCS(2) = 1 NULLVAL = 0 GROUP = 1 IER = 0 CALL FTGSVD(IM,GROUP,NAXIS,NAXES,FPIX,LPIX,INCS,NULLVAL,SPCTRUM,AN *YF,IER) IF(IER .EQ. 0)GOTO 11411 CALL FTGMSG(ERRMSG) WRITE(*,'(8H Error: ,A80)')ERRMSG STOP 11411 CONTINUE DISP = DW(IROW) OFFSET = W1(IROW) PIX_OFFSET = PIX1(IROW) CURORD = IROW IF(.NOT.(VARFIL))GOTO 11431 CALL FTGSVD(IVM,1,NAXIS,NAXES,FPIX,LPIX,INCS,NULLVAL,VARSPEC, ANYF *,IER) IF(IER .EQ. 0)GOTO 11451 CALL FTGMSG(ERRMSG) WRITE(*,'(8H Error: ,A80)')ERRMSG STOP 11451 CONTINUE 11431 CONTINUE 11460 I=1 GOTO 11463 11461 I=I+1 11463 IF((I).GT.(NPTS))GOTO 11462 LAMBDA(I) = OFFSET + (I-1)*DISP GOTO 11461 11462 CONTINUE RETURN END SUBROUTINE CORTELB(ISHIFT,NPTS) IMPLICIT REAL*8(A-H,O-Z) INTEGER ISHIFT,NPTS,I,J COMMON/LTELL/TELSET,TELPRES LOGICAL TELSET,TELPRES COMMON/ITELL/LBOUND(100),RBOUND(100),NBOUNDS,NH2O INTEGER LBOUND,RBOUND,NBOUNDS,NH2O COMMON/RTELL/H2OCENT(100),H2OFWHM(100),H2ODEEP(100), H2OSLOP,H2OIN *T,H2OMIN REAL*8 H2OCENT,H2OFWHM,H2ODEEP,H2OSLOP,H2OINT,H2OMIN 11470 I=1 GOTO 11473 11471 I=I+1 11473 IF((I).GT.(NBOUNDS))GOTO 11472 LBOUND(I) = LBOUND(I) + ISHIFT RBOUND(I) = RBOUND(I) + ISHIFT GOTO 11471 11472 CONTINUE 11480 I=1 GOTO 11483 11481 I=I+1 11483 IF((I).GT.(NBOUNDS))GOTO 11482 IF(LBOUND(I) .GE. 1)GOTO 11501 IF(RBOUND(I) .GE. 1)GOTO 11521 11530 J=I GOTO 11533 11531 J=J+1 11533 IF((J).GT.(NBOUNDS - 1))GOTO 11532 LBOUND(J) = LBOUND(J+1) RBOUND(J) = RBOUND(J+1) GOTO 11531 11532 CONTINUE NBOUNDS = NBOUNDS - 1 I = I - 1 GOTO 11541 11521 CONTINUE LBOUND(I) = 1 11541 CONTINUE 11511 CONTINUE GOTO 11491 11501 IF(RBOUND(I) .LE. NPTS)GOTO 11551 IF(LBOUND(I) .LE. NPTS)GOTO 11571 11580 J=I GOTO 11583 11581 J=J+1 11583 IF((J).GT.(NBOUNDS - 1))GOTO 11582 LBOUND(J) = LBOUND(J+1) RBOUND(J) = RBOUND(J+1) GOTO 11581 11582 CONTINUE NBOUNDS = NBOUNDS - 1 I = I - 1 GOTO 11591 11571 CONTINUE RBOUND(I) = NPTS 11591 CONTINUE 11561 CONTINUE 11551 CONTINUE 11491 CONTINUE GOTO 11481 11482 CONTINUE RETURN END SUBROUTINE NORTEL(SPCTRUM,NPTS) IMPLICIT REAL*8(A-H,O-Z) COMMON/LTELL/TELSET,TELPRES LOGICAL TELSET,TELPRES COMMON/ITELL/LBOUND(100),RBOUND(100),NBOUNDS,NH2O INTEGER LBOUND,RBOUND,NBOUNDS,NH2O COMMON/RTELL/H2OCENT(100),H2OFWHM(100),H2ODEEP(100), H2OSLOP,H2OIN *T,H2OMIN REAL*8 H2OCENT,H2OFWHM,H2ODEEP,H2OSLOP,H2OINT,H2OMIN INTEGER DIODE REAL*8 SPCTRUM(1000000) LOGICAL TELDIOD 11600 I=1 GOTO 11603 11601 I=I+1 11603 IF((I).GT.(NBOUNDS))GOTO 11602 IF(LBOUND(I) .EQ. 1 .OR. RBOUND(I) .EQ. NPTS)GOTO 11621 GRAD = (SPCTRUM(RBOUND(I)+1)-SPCTRUM(LBOUND(I)-1))/ DBLE( RBOUND(I *) - LBOUND(I) + 2 ) 11630 J=LBOUND(I) GOTO 11633 11631 J=J+1 11633 IF((J).GT.(RBOUND(I)))GOTO 11632 CONT = GRAD*DBLE( J - LBOUND(I) + 1 ) + SPCTRUM(LBOUND(I)-1) SPCTRUM(J) = SPCTRUM(J)/CONT IF(SPCTRUM(J) .LE. 1.0)GOTO 11651 SPCTRUM(J) = 1.0 11651 CONTINUE GOTO 11631 11632 CONTINUE GOTO 11661 11621 CONTINUE IF(LBOUND(I) .NE. 1)GOTO 11681 DIODE = RBOUND(I) + 1 GOTO 11671 11681 IF(RBOUND(I) .NE. NPTS)GOTO 11691 DIODE = LBOUND(I) - 1 11691 CONTINUE 11671 CONTINUE 11700 J=LBOUND(I) GOTO 11703 11701 J=J+1 11703 IF((J).GT.(RBOUND(I)))GOTO 11702 SPCTRUM(J) = SPCTRUM(J)*1.0/SPCTRUM(DIODE) GOTO 11701 11702 CONTINUE 11661 CONTINUE 11611 CONTINUE GOTO 11601 11602 CONTINUE 11710 I=1 GOTO 11713 11711 I=I+1 11713 IF((I).GT.(NPTS))GOTO 11712 IF(.NOT.(.NOT. TELDIOD(I)))GOTO 11731 SPCTRUM(I) = 1.0 11731 CONTINUE GOTO 11711 11712 CONTINUE RETURN END LOGICAL FUNCTION TELDIOD(I) IMPLICIT REAL*8(A-H,O-Z) INTEGER I COMMON/LTELL/TELSET,TELPRES LOGICAL TELSET,TELPRES COMMON/ITELL/LBOUND(100),RBOUND(100),NBOUNDS,NH2O INTEGER LBOUND,RBOUND,NBOUNDS,NH2O COMMON/RTELL/H2OCENT(100),H2OFWHM(100),H2ODEEP(100), H2OSLOP,H2OIN *T,H2OMIN REAL*8 H2OCENT,H2OFWHM,H2ODEEP,H2OSLOP,H2OINT,H2OMIN TELDIOD = .FALSE. 11740 J=1 GOTO 11743 11741 J=J+1 11743 IF((J).GT.(NBOUNDS))GOTO 11742 IF(I .GE. LBOUND(J))GOTO 11761 RETURN GOTO 11751 11761 IF(I .GT. RBOUND(J))GOTO 11771 TELDIOD = .TRUE. RETURN 11771 CONTINUE 11751 CONTINUE GOTO 11741 11742 CONTINUE RETURN END SUBROUTINE SUCCPF(TITLE) IMPLICIT REAL*8(A-H,O-Z) CHARACTER*80 TITLE WRITE(8,11780)TITLE(1:45) 11780 FORMAT(' TITLE $',A45,'$') WRITE(8,11790) 11790 FORMAT(' XLABEL $DIODE SHIFT$') WRITE(8,11800) 11800 FORMAT(' YLABEL $CROSS PRODUCT$') WRITE(8,11810) 11810 FORMAT(' XFORMAT I5') WRITE(8,11820) 11820 FORMAT(' YFORMAT F6.2') WRITE(8,11830) 11830 FORMAT(' NOMARKER ') WRITE(8,11840) 11840 FORMAT(' LINE ') RETURN END SUBROUTINE RDLNCL(RV) IMPLICIT REAL*8(A-H,O-Z) COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF COMMON/WIDLIN/WIDE(50) REAL*8 WIDE COMMON/IWIDLI/IWIDE INTEGER IWIDE COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/IBADD/ NOBAD,IBADL(1000),IBADR(1000), IGROW INTEGER NOBAD,IBADL,IBADR,IGROW COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) COMMON/LTELL/TELSET,TELPRES LOGICAL TELSET,TELPRES COMMON/ITELL/LBOUND(100),RBOUND(100),NBOUNDS,NH2O INTEGER LBOUND,RBOUND,NBOUNDS,NH2O COMMON/RTELL/H2OCENT(100),H2OFWHM(100),H2ODEEP(100), H2OSLOP,H2OIN *T,H2OMIN REAL*8 H2OCENT,H2OFWHM,H2ODEEP,H2OSLOP,H2OINT,H2OMIN COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL 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/ROTCOM/ VSINI REAL*8 VSINI COMMON/ITRCOM/ DA(9),DX,PROF_TOL REAL*8 DA,DX,PROF_TOL INTEGER SEARCH,IBADOR CHARACTER*80 LINE,OLDCFILE*70 I=0 NOCONT = 0 NOBAD = 0 NOGDLN = 0 NBOUNDS = 0 IWIDE = 0 NPLOTS = 0 NOLINES = 0 IBADOR = 0 NPTS = AXLEN(1) WSTART = WAV(1.0D+00) WEND = WAV(DBLE(NPTS)) 11850 CONTINUE 11851 CONTINUE READ(4,'(A80)',END=11860)LINE IF(LINE(:9) .NE. 'OLDCONTIN')GOTO 11881 READ(LINE(11:),'(A70)')OLDCFILE OLD_CONTUM = .TRUE. CALL GRABCOF(OLDCFILE,ACON,CONORD) READ(4,'(A80)',END=11860)LINE 11881 CONTINUE I=I+1 READ(LINE,'(A10,4D10.3,3(2X,I3))')LINEID(I),WAVELN(I),ATOM(I), EP %LOW(I),GF(I),IGOOD,ILEFT(I),IRIGHT(I) IF(LINEID(I) .NE. 'CONTINUUM ')GOTO 11901 I = I - 1 WAV1 = WAVELN(I+1) WAV2 = ATOM(I+1) IF(WAV1 .GE. WEND .OR. WAV2 .LE. WSTART)GOTO 11921 NOCONT = NOCONT + 1 CONLFT(NOCONT) = NINT(CHANNEL(WAV1)+0.5) CONRHT(NOCONT) = NINT(CHANNEL(WAV2)-0.5) IF(CONLFT(NOCONT) .GE. 1)GOTO 11941 CONLFT(NOCONT) = 1 11941 CONTINUE IF(CONRHT(NOCONT) .LE. NPTS)GOTO 11961 CONRHT(NOCONT) = NPTS 11961 CONTINUE ISIZE = CONRHT(NOCONT) - CONLFT(NOCONT) + 1 IF(EPLOW(I+1) .NE. 0.0)GOTO 11981 CONSIZE(NOCONT) = ISIZE GOTO 11991 11981 CONTINUE CONSIZE(NOCONT) = NINT(EPLOW(I+1)) 11991 CONTINUE 11971 CONTINUE IF(CONSIZE(NOCONT) .LE. ISIZE)GOTO 12011 CONSIZE(NOCONT) = ISIZE 12011 CONTINUE CFACTOR(NOCONT) = 1.00000 IF(GF(I+1) .LE. 0.00000)GOTO 12031 CFACTOR(NOCONT) = GF(I+1) SCALED_CONTUM = .TRUE. 12031 CONTINUE 11921 CONTINUE GOTO 11851 GOTO 11891 11901 IF(LINEID(I) .NE. 'FITCONTIN')GOTO 12041 FITCON = .TRUE. I = I - 1 GOTO 11851 GOTO 11891 12041 IF(LINEID(I) .NE. 'AUTOCONTIN')GOTO 12051 AUTOCON = .TRUE. I = I - 1 CONRHT(1) = INT(WAVELN(I+1)) CONLFT(1) = 1 CONSIZE(1) = INT(ATOM(I+1)) CFACTOR(1) = 1.00000 GOTO 11851 GOTO 11891 12051 IF(LINEID(I) .NE. 'NORMALISED')GOTO 12061 NRMLSD = .TRUE. I = I - 1 GOTO 11851 GOTO 11891 12061 IF(LINEID(I)(:5) .NE. 'FOCUS')GOTO 12071 READ(LINE(6:10),'(F5.1)')XROW IROW = NINT(XROW) IF(IROW .LE. 0)GOTO 12091 FOCUS_PARS(IROW) = .TRUE. READ(LINE(11:),'(7F10.5)')WFC(IROW),(A_FOCUS(IROW,IPAR),IPAR=1,6) GOTO 12101 12091 CONTINUE GLOBAL_FOCUS = .TRUE. READ(LINE(11:),'(7F10.5)')GLOBAL_WFC,(GLOBAL_A(IPAR),IPAR=1,6) 12101 CONTINUE 12081 CONTINUE I = I - 1 GOTO 11851 GOTO 11891 12071 IF(LINEID(I) .NE. 'INST_PROF ')GOTO 12111 INST_PROF = .TRUE. I = I - 1 GOTO 11851 GOTO 11891 12111 IF(LINEID(I) .NE. 'PROF_TOL ')GOTO 12121 PROF_TOL = WAVELN(I+1) I = I - 1 GOTO 11851 GOTO 11891 12121 IF(LINEID(I) .NE. 'BOUNDS ')GOTO 12131 NBOUNDS = NBOUNDS + 1 I = I - 1 LBOUND(NBOUNDS) = INT( WAVELN(I+1) ) RBOUND(NBOUNDS) = INT( ATOM(I+1) ) GOTO 11851 GOTO 11891 12131 IF(LINEID(I) .NE. 'PLOT ')GOTO 12141 I = I - 1 IF((NPLOTS .LT. 500) .AND. (.NOT.(PLOTALL)))GOTO 12161 GOTO 11851 12161 CONTINUE NPLOTS = NPLOTS + 1 WPLOTL(NPLOTS) = WAVELN(I+1) WPLOTR(NPLOTS) = ATOM(I+1) GOTO 11851 GOTO 11891 12141 IF(LINEID(I) .NE. 'PLOTALL ')GOTO 12171 I = I - 1 PLOTALL = .TRUE. NPLOTS = 0 GOTO 11851 GOTO 11891 12171 IF(LINEID(I) .NE. 'PLOTCONTIN')GOTO 12181 PLOTCON = .TRUE. I = I - 1 GOTO 11851 GOTO 11891 12181 IF(LINEID(I) .NE. 'BADGROW ')GOTO 12191 IGROW = NINT( WAVELN(I+1) ) GOTO 11851 GOTO 11891 12191 IF(LINEID(I) .NE. 'BADDIODE ')GOTO 12201 I = I - 1 IF(NINT(EPLOW(I+1)) .NE. CURIMR)GOTO 12221 IF(NOBAD .NE. 1000)GOTO 12241 WRITE(8,12250) 12250 FORMAT('MAXIMUM NUMBER OF BAD DIODE REGIONS EXCEEDED') RETURN 12241 CONTINUE NOBAD = NOBAD + 1 IBADL(NOBAD) = NINT( WAVELN(I+1) ) IBADR(NOBAD)= NINT( ATOM(I+1) ) 12221 CONTINUE GOTO 11851 GOTO 11891 12201 IF(LINEID(I) .NE. 'LLIMIT ')GOTO 12261 LLIMIT = WAVELN(I) I = I - 1 GOTO 11851 GOTO 11891 12261 IF(LINEID(I) .NE. 'ULIMIT ')GOTO 12271 ULIMIT = WAVELN(I) I = I - 1 GOTO 11851 GOTO 11891 12271 IF(LINEID(I) .NE. 'FWHM ')GOTO 12281 FIXFWHM = .TRUE. INCPT = WAVELN(I) SLOPE = ATOM(I) MINIDP = EPLOW(I) SIGFRAC = GF(I) I = I - 1 GOTO 11851 GOTO 11891 12281 IF(LINEID(I) .NE. 'VSINI ')GOTO 12291 WRITE(1,'(9h VSINI = ,f10.2,5h Km/s)')VSINI WRITE(1,'(32h VSINI option does not work yet )') VSINI = WAVELN(I) I = I - 1 GOTO 11851 12291 CONTINUE 11891 CONTINUE IF((ILEFT(I) .GE. 0) .AND. (IRIGHT(I) .GE. 0))GOTO 12311 IF(IGOOD .NE. 999)GOTO 12331 WRITE(8,12340)I 12340 FORMAT (' CANNOT USE LINE ',I3,' AS A GOOD LINE SINCE ONLY DEPTH', % ' IS TO BE USED FOR ITS EW ') IGOOD = 0 12331 CONTINUE 12311 CONTINUE IF(IGOOD .NE. 999)GOTO 12361 NOGDLN = NOGDLN + 1 GOOD(NOGDLN) = I IGOOD = 0 12361 CONTINUE IF(IGOOD .NE. 100)GOTO 12381 IF(IWIDE .GE. 50)GOTO 12401 IWIDE = IWIDE + 1 WIDE(IWIDE) = WAVELN(I) GOTO 12411 12401 CONTINUE WRITE(8,12420) 12420 FORMAT(' WARNING: ONLY THE FIRST 50 WIDE LINES USED ') 12411 CONTINUE 12391 CONTINUE IGOOD = 0 12381 CONTINUE WEAK(I) = .FALSE. BLEND(I) = 0 IF(I.GE.1000 .OR. NOCONT.GE.10000)GOTO 11852 GOTO 11851 11852 CONTINUE WRITE(8,12430) 12430 FORMAT(' LINE OR CONTINUUM BUFFER MAXIMUM REACHED') WRITE(8,12440)I,1000 12440 FORMAT(I3,1X,27H LINES USED, MAX ALLOWED IS,1X,I3) WRITE(8,12450)NOCONT,10000 12450 FORMAT (I3,1X,30H CONTINUA USED, MAX ALLOWED IS,1X,I3) 11860 CONTINUE CALL SORTCON NOLINES=I-1 REWIND(UNIT=4) RETURN END SUBROUTINE AD2BADLST IMPLICIT REAL*8(A-H,O-Z) INTEGER I COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON/IBADD/ NOBAD,IBADL(1000),IBADR(1000), IGROW INTEGER NOBAD,IBADL,IBADR,IGROW 12460 I=1 GOTO 12463 12461 I=I+1 12463 IF((I).GT.(NPTS))GOTO 12462 IF(SPCTRUM(I) .GT. -0.50)GOTO 12481 IF(NOBAD .GE. 1000)GOTO 12501 NOBAD = NOBAD + 1 IBADL(NOBAD) = I - IGROW IBADR(NOBAD)= I + IGROW GOTO 12511 12501 CONTINUE WRITE(8,12520) 12520 FORMAT('MAXIMUM NUMBER OF BAD DIODE REGIONS EXCEEDED') RETURN 12511 CONTINUE 12491 CONTINUE 12481 CONTINUE GOTO 12461 12462 CONTINUE RETURN END SUBROUTINE SORTCON IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM INTEGER I,J,CLDUM,CRDUM,CSDUM REAL*8 CFDUM,SFDUM,CCDUM,CFACDUM 12530 J=1 GOTO 12533 12531 J=J+1 12533 IF((J).GT.(NOCONT-1))GOTO 12532 12540 I=1 GOTO 12543 12541 I=I+1 12543 IF((I).GT.(NOCONT-J))GOTO 12542 IF(CONLFT(I) .LE. CONLFT(I+1))GOTO 12561 CLDUM = CONLFT(I+1) CONLFT(I+1) = CONLFT(I) CONLFT(I) = CLDUM CRDUM = CONRHT(I+1) CONRHT(I+1) = CONRHT(I) CONRHT(I) = CRDUM CSDUM = CONSIZE(I+1) CONSIZE(I+1) = CONSIZE(I) CONSIZE(I) = CSDUM CFDUM = CONFLUX(I+1) CONFLUX(I+1) = CONFLUX(I) CONFLUX(I) = CFDUM SFDUM = SIGFLUX(I+1) SIGFLUX(I+1) = SIGFLUX(I) SIGFLUX(I) = SFDUM CCDUM = CONCENT(I+1) CONCENT(I+1) = CONCENT(I) CONCENT(I) = CCDUM CFACDUM = CFACTOR(I+1) CFACTOR(I+1) = CFACTOR(I) CFACTOR(I) = CFACDUM 12561 CONTINUE GOTO 12541 12542 CONTINUE GOTO 12531 12532 CONTINUE RETURN END SUBROUTINE GRABCOF(FILE,A,CONORD) IMPLICIT REAL*8 (A-H,O-Z) REAL*8 A(50,100) INTEGER CONORD(1000),IROW(1000),NROW CHARACTER*70 FILE,LINE*120 LOGICAL FOUND OPEN(UNIT=30,FILE=FILE,STATUS='OLD') FOUND = .FALSE. NROW = 0 12570 CONTINUE 12571 CONTINUE READ(30,'(A80)',END=12580)LINE IF(LINE(:18) .NE. 'CURRENT IMAGE ROW ')GOTO 12601 NROW = NROW + 1 READ(LINE(19:),*)IROW(NROW) 12610 CONTINUE 12611 CONTINUE READ(30,'(A80)',END=12580)LINE IF(LINE(:25) .NE. 'ORDER OF POLYNOMIAL FIT =')GOTO 12631 READ(LINE(26:),*)CONORD(IROW(NROW)) READ(30,'(A80)')LINE READ(30,'(A80)')LINE READ(30,'(5(G16.9,1X))') (A(I,IROW(NROW)),I=1,CONORD(IROW(NROW))) FOUND = .TRUE. 12631 CONTINUE IF(FOUND)GOTO 12612 GOTO 12611 12612 CONTINUE 12601 CONTINUE FOUND = .FALSE. GOTO 12571 12572 CONTINUE 12580 CONTINUE CLOSE(UNIT=30) RETURN END SUBROUTINE READTP IMPLICIT REAL*8(A-H,O-Z) COMMON/LTELL/TELSET,TELPRES LOGICAL TELSET,TELPRES COMMON/ITELL/LBOUND(100),RBOUND(100),NBOUNDS,NH2O INTEGER LBOUND,RBOUND,NBOUNDS,NH2O COMMON/RTELL/H2OCENT(100),H2OFWHM(100),H2ODEEP(100), H2OSLOP,H2OIN *T,H2OMIN REAL*8 H2OCENT,H2OFWHM,H2ODEEP,H2OSLOP,H2OINT,H2OMIN OPEN(UNIT=12,FILE='H2OLIST',STATUS='OLD') REWIND 12 READ(12,*)H2OSLOP,H2OINT,H2OMIN 12640 I=1 GOTO 12643 12641 I=I+1 12643 IF((I).GT.(100))GOTO 12642 READ(12,*,END=12650)H2OCENT(I),H2OFWHM(I),H2ODEEP(I) GOTO 12641 12642 CONTINUE WRITE(8,12660) 12660 FORMAT(/,'WARNING: ONLY THE FIRST 100 TELLURIC LINES WILL BE USED' %,/) NH2O = 100 RETURN 12650 CONTINUE NH2O = I - 1 RETURN END SUBROUTINE CORCNL(ISHIFT,NPTS) IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM INTEGER I,ISHIFT,NPTS 12670 I=1 GOTO 12673 12671 I=I+1 12673 IF((I).GT.(NOCONT))GOTO 12672 CONRHT(I) = CONRHT(I) + ISHIFT CONLFT(I) = CONLFT(I) + ISHIFT IF(CONLFT(I) .GE. 1)GOTO 12691 IF(CONRHT(I) .GE. 1)GOTO 12711 CALL REMCTP(I) GOTO 12721 12711 CONTINUE CONLFT(I) = 1 12721 CONTINUE 12701 CONTINUE GOTO 12681 12691 IF(CONRHT(I) .LE. NPTS)GOTO 12731 IF(CONLFT(I) .LE. NPTS)GOTO 12751 CALL REMCTP(I) GOTO 12761 12751 CONTINUE CONRHT(I) = NPTS 12761 CONTINUE 12741 CONTINUE 12731 CONTINUE 12681 CONTINUE GOTO 12671 12672 CONTINUE RETURN END SUBROUTINE REMCTP(ICONT) IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM INTEGER ICONT,I IF(ICONT .NE. NOCONT)GOTO 12781 ICONT = ICONT - 1 NOCONT = NOCONT - 1 RETURN 12781 CONTINUE 12790 I=ICONT GOTO 12793 12791 I=I+1 12793 IF((I).GT.(NOCONT - 1))GOTO 12792 CONRHT(I) = CONRHT(I+1) CONLFT(I) = CONLFT(I+1) CONSIZE(I) = CONSIZE(I+1) CONCENT(I)= CONCENT(I+1) CONFLUX(I) = CONFLUX(I+1) CFACTOR(I) = CFACTOR(I+1) SIGFLUX(I) = SIGFLUX(I+1) GOTO 12791 12792 CONTINUE ICONT = ICONT - 1 NOCONT = NOCONT - 1 RETURN END SUBROUTINE ESLNCT(LMIN,LMAX) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER I,LMIN,LMAX 12800 I=LMIN GOTO 12803 12801 I=I+1 12803 IF((I).GT.(LMAX))GOTO 12802 CENTRE(I) = CHANNEL(WAVELN(I)) GOTO 12801 12802 CONTINUE RETURN END SUBROUTINE EACKLC(NPTS) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER I,NPTS 12810 I=1 GOTO 12813 12811 I=I+1 12813 IF((I).GT.(NOLINES))GOTO 12812 CENTRE(I) = CHANNEL(WAVELN(I)) IF((INT(CENTRE(I)) .GE. 3) .AND. (INT(CENTRE(I)) .LE. NPTS - 2))GO *TO 12831 CALL REMFLS(I) I = I - 1 12831 CONTINUE GOTO 12811 12812 CONTINUE RETURN END SUBROUTINE MLTILL IMPLICIT REAL*8(A-H,O-Z) INTEGER I,K CHARACTER*10 ID COMMON/LTELL/TELSET,TELPRES LOGICAL TELSET,TELPRES COMMON/ITELL/LBOUND(100),RBOUND(100),NBOUNDS,NH2O INTEGER LBOUND,RBOUND,NBOUNDS,NH2O COMMON/RTELL/H2OCENT(100),H2OFWHM(100),H2ODEEP(100), H2OSLOP,H2OIN *T,H2OMIN REAL*8 H2OCENT,H2OFWHM,H2ODEEP,H2OSLOP,H2OINT,H2OMIN COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK K = 1 ID = 'TELLURIC ' 12840 I=1 GOTO 12843 12841 I=I+1 12843 IF((I).GT.(NOLINES + NH2O - 1))GOTO 12842 IF(H2OCENT(K) .GT. CENTRE(I))GOTO 12861 WAVE = WAV(H2OCENT(K)) CALL INSBFL(I,ID,WAVE,H2OCENT(K),H2OFWHM(K),H2ODEEP(K)) K = K + 1 GOTO 12851 12861 IF(I .LT. NOLINES + K - 1)GOTO 12871 GOTO 12842 12871 CONTINUE 12851 CONTINUE IF(K .GT. NH2O)GOTO 12842 GOTO 12841 12842 CONTINUE IF(K .LE. NH2O)GOTO 12891 RETURN 12891 CONTINUE 12900 N=K GOTO 12903 12901 N=N+1 12903 IF((N).GT.(NH2O))GOTO 12902 I = I + 1 WAVE = WAV(H2OCENT(N)) CALL INSBFL(I,ID,WAVE,H2OCENT(N),H2OFWHM(N),H2ODEEP(N)) GOTO 12901 12902 CONTINUE RETURN END SUBROUTINE INSBFL(I,ID,WAVE,CENT,WIDTH,DEEP) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK REAL*8 PI CHARACTER*10 ID INTEGER I,J,K IF(NOLINES .NE. 1000)GOTO 12921 WRITE(8,12930)ID,WAVE 12930 FORMAT ('ERROR: COULD NOT INSERT LINE WITH ID ',A10,' AT ',F9.3,' %A.') RETURN 12921 CONTINUE 12940 J=NOLINES GOTO 12943 12941 J=J+(-1) 12943 IF((-1)*((J)-(I)).GT.0)GOTO 12942 LINEID(J+1) = LINEID(J) WAVELN(J+1) = WAVELN(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) LFTDIO(J+1) = LFTDIO(J) RHTDIO(J+1) = RHTDIO(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) DELTEW(J+1) = DELTEW(J) DELTRV(J+1) = DELTRV(J) GOTO 12941 12942 CONTINUE LINEID(I) = ID WAVELN(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 LFTDIO(I) = 0.0 RHTDIO(I) = 0.0 PI = 3.141592654D+0 EW(I) = DEPTH(I)*FWHM(I)*DISP*1000.0*0.60056121*DMYSQ(PI) DELTRV(I) = 0.0 DELTEW(I) = 0.0 NOLINES = NOLINES + 1 12950 J=1 GOTO 12953 12951 J=J+1 12953 IF((J).GT.(NOGDLN))GOTO 12952 IF(GOOD(J) .LT. I)GOTO 12971 12980 K=J GOTO 12983 12981 K=K+1 12983 IF((K).GT.(NOGDLN))GOTO 12982 GOOD(K) = GOOD(K) + 1 GOTO 12981 12982 CONTINUE GOTO 12952 12971 CONTINUE GOTO 12951 12952 CONTINUE WEAK(I) = .FALSE. BLEND(I) = 0 RETURN END SUBROUTINE REMFLS(LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON/LTELL/TELSET,TELPRES LOGICAL TELSET,TELPRES COMMON/ITELL/LBOUND(100),RBOUND(100),NBOUNDS,NH2O INTEGER LBOUND,RBOUND,NBOUNDS,NH2O COMMON/RTELL/H2OCENT(100),H2OFWHM(100),H2ODEEP(100), H2OSLOP,H2OIN *T,H2OMIN REAL*8 H2OCENT,H2OFWHM,H2ODEEP,H2OSLOP,H2OINT,H2OMIN COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER LINE,I IF(LINE .EQ. 1)GOTO 13001 IF(BLEND(LINE-1) .NE. 2)GOTO 13021 BLEND(LINE-1) = -1 GOTO 13011 13021 IF(BLEND(LINE-1) .NE. 1)GOTO 13031 BLEND(LINE-1) = 0 13031 CONTINUE 13011 CONTINUE 13001 CONTINUE IF(LINE .EQ. NOLINES)GOTO 13051 IF(BLEND(LINE+1) .NE. 2)GOTO 13071 BLEND(LINE+1) = 1 GOTO 13061 13071 IF(BLEND(LINE+1) .NE. -1)GOTO 13081 BLEND(LINE+1) = 0 13081 CONTINUE 13061 CONTINUE 13051 CONTINUE IF(.NOT.(TELPRES) .OR. LINEID(LINE) .NE. 'TELLURIC ')GOTO 13101 INDEX = 1 13110 I=1 GOTO 13113 13111 I=I+1 13113 IF((I).GT.(LINE - 1))GOTO 13112 IF(LINEID(I) .NE. 'TELLURIC ')GOTO 13131 INDEX = INDEX + 1 13131 CONTINUE GOTO 13111 13112 CONTINUE 13140 I=INDEX GOTO 13143 13141 I=I+1 13143 IF((I).GT.(NH2O - 1))GOTO 13142 H2OCENT(I) = H2OCENT(I+1) H2OFWHM(I) = H2OFWHM(I+1) H2ODEEP(I) = H2ODEEP(I+1) GOTO 13141 13142 CONTINUE NH2O = NH2O - 1 13101 CONTINUE 13150 I=LINE GOTO 13153 13151 I=I+1 13153 IF((I).GT.(NOLINES))GOTO 13152 CENTRE(I) = CENTRE(I+1) FWHM(I) = FWHM(I+1) DEPTH(I) = DEPTH(I+1) WAVELN(I) = WAVELN(I+1) LINEID(I) = LINEID(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) LFTDIO(I) = LFTDIO(I+1) RHTDIO(I)= RHTDIO(I+1) EW(I) = EW(I+1) DELTEW(I) = DELTEW(I+1) DELTRV(I) = DELTRV(I+1) ILEFT(I) = ILEFT(I+1) IRIGHT(I) = IRIGHT(I+1) IF(I .GE. NOLINES - 1)GOTO 13152 GOTO 13151 13152 CONTINUE NOLINES = NOLINES - 1 13160 I=1 GOTO 13163 13161 I=I+1 13163 IF((I).GT.(NOGDLN))GOTO 13162 IF(GOOD(I) .NE. LINE)GOTO 13181 CALL RMLFGL(LINE) RETURN GOTO 13171 13181 IF(GOOD(I) .LE. LINE)GOTO 13191 RETURN 13191 CONTINUE 13171 CONTINUE GOTO 13161 13162 CONTINUE RETURN END SUBROUTINE RMLFGL(LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER I,J,LINE 13200 I=1 GOTO 13203 13201 I=I+1 13203 IF((I).GT.(NOGDLN))GOTO 13202 IF(GOOD(I) .NE. LINE)GOTO 13221 NOGDLN = NOGDLN - 1 13230 J=I GOTO 13233 13231 J=J+1 13233 IF((J).GT.(NOGDLN))GOTO 13232 GOOD(J) = GOOD(J+1) DELTRV(J) = DELTRV(J+1) GOTO 13231 13232 CONTINUE RETURN 13221 CONTINUE GOTO 13201 13202 CONTINUE RETURN END SUBROUTINE FITCONT IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL IF(.NOT.(OLD_CONTUM) .OR. CONORD(CURIMR) .EQ. 0)GOTO 13251 RETURN GOTO 13261 13251 CONTINUE CALL CCCAFV CALL PERFIT 13261 CONTINUE 13241 CONTINUE RETURN END SUBROUTINE CCCAFV IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS REAL*8 AVG,SNSIG,SNR LOGICAL CNTBAD,BADIOD INTEGER I,J,K,MIDDLE IF(.NOT.(AUTOCON))GOTO 13281 ISTEP = CONRHT(1) NOCONT = NPTS/CONRHT(1) IF(NOCONT .LE. 10000)GOTO 13301 WRITE(8,13310) 13310 FORMAT(' CONTINUUM BUFFER MAXIMUM REACHED') WRITE(8,13320)NOCONT,10000 13320 FORMAT (I5,1X,30H CONTINUA USED, MAX ALLOWED IS,1X,I6) NOCONT = 10000 13301 CONTINUE 13330 I=2 GOTO 13333 13331 I=I+1 13333 IF((I).GT.(NOCONT))GOTO 13332 CONLFT(I) = CONRHT(I-1) - CONSIZE(1) + 1 CONRHT(I) = CONRHT(I-1) + ISTEP CONSIZE(I) = CONSIZE(1) CFACTOR(I) = CFACTOR(1) GOTO 13331 13332 CONTINUE CONRHT(NOCONT) = NPTS 13281 CONTINUE 13340 J=1 GOTO 13343 13341 J=J+1 13343 IF((J).GT.(NOCONT))GOTO 13342 IF(.NOT.(CNTBAD(J)))GOTO 13361 WRITE(8,13370)J 13370 FORMAT('CONTINUUM NO. ',I3,' REMOVED DUE TO BAD DIODES') CALL REMCTP(J) GOTO 13341 13361 CONTINUE CONFLUX(J) = 0.0 13380 I=CONLFT(J) GOTO 13383 13381 I=I+1 13383 IF((I).GT.(CONRHT(J)-CONSIZE(J)+1))GOTO 13382 SXI = 0.0 SXIWI = 0.0 SXI2 = 0.0 SNSIG = 0.0 MIDDLE = 0 ANUM = 0.0 13390 K=1 GOTO 13393 13391 K=K+1 13393 IF((K).GT.(CONSIZE(J)))GOTO 13392 IF(.NOT.(.NOT. BADIOD(I+K-1)))GOTO 13411 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 13411 CONTINUE GOTO 13391 13392 CONTINUE AVG = SXIWI/SNSIG SNSIG = 1.D0/DSQRT(SNSIG) IF(CONSIZE(J) .LE. 1)GOTO 13431 CSIG = DMYSQ( ( SXI2 - (SXI**2)/ANUM )/(ANUM-1.0) ) CSIG = CSIG/DMYSQ(ANUM) 13431 CONTINUE IF(AVG .LT. CONFLUX(J))GOTO 13451 CONFLUX(J) = AVG SIGFLUX(J) = CSIG IF(CSIG .GE. AVG*SNSIG)GOTO 13471 SIGFLUX(J) = AVG*SNSIG 13471 CONTINUE CONCENT(J) = DBLE(MIDDLE)/ANUM 13451 CONTINUE GOTO 13381 13382 CONTINUE IF(CONFLUX(J) .GT. 0.0)GOTO 13491 WRITE(8,13500)J 13500 FORMAT('CONTINUUM NO. ',I3,' REMOVED: ZERO OR NEGATIVE FLUX') CALL REMCTP(J) GOTO 13341 13491 CONTINUE GOTO 13341 13342 CONTINUE IF(.NOT.(AUTOCON))GOTO 13521 13530 J=1 GOTO 13533 13531 J=J+1 13533 IF((J).GT.(NOCONT))GOTO 13532 CONLFT(J) = CONCENT(J)-0.5*DBLE(CONSIZE(J)) + 0.5 CONRHT(J) = CONCENT(J)+0.5*DBLE(CONSIZE(J)) -0.5 GOTO 13531 13532 CONTINUE 13521 CONTINUE RETURN END LOGICAL FUNCTION CNTBAD(ICONT) IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/IBADD/ NOBAD,IBADL(1000),IBADR(1000), IGROW INTEGER NOBAD,IBADL,IBADR,IGROW LOGICAL BADIOD INTEGER I,J,NBAD_PIX,ICONT CNTBAD = .FALSE. IF(NOBAD .NE. 0)GOTO 13551 RETURN 13551 CONTINUE 13560 I=CONLFT(ICONT) GOTO 13563 13561 I=I+1 13563 IF((I).GT.(CONRHT(ICONT)-CONSIZE(ICONT)+1))GOTO 13562 NBAD_PIX = 0 13570 J=1 GOTO 13573 13571 J=J+1 13573 IF((J).GT.(CONSIZE(ICONT)))GOTO 13572 IF(.NOT.(BADIOD(I+J-1)))GOTO 13591 NBAD_PIX = NBAD_PIX + 1 13591 CONTINUE GOTO 13571 13572 CONTINUE IF(NBAD_PIX .LE. CONSIZE(ICONT)-NBAD_PIX)GOTO 13611 CNTBAD = .TRUE. RETURN 13611 CONTINUE GOTO 13561 13562 CONTINUE RETURN END LOGICAL FUNCTION BADIOD(IPOINT) IMPLICIT REAL*8(A-H,O-Z) COMMON/IBADD/ NOBAD,IBADL(1000),IBADR(1000), IGROW INTEGER NOBAD,IBADL,IBADR,IGROW INTEGER I,IPOINT BADIOD = .FALSE. IF(NOBAD .NE. 0)GOTO 13631 RETURN 13631 CONTINUE 13640 I=1 GOTO 13643 13641 I=I+1 13643 IF((I).GT.(NOBAD))GOTO 13642 IF(IPOINT .LT. IBADL(I) .OR. IPOINT .GT. IBADR(I))GOTO 13661 BADIOD = .TRUE. RETURN 13661 CONTINUE GOTO 13641 13642 CONTINUE RETURN END SUBROUTINE PERFIT IMPLICIT REAL*8(A-H,O-Z) REAL*8 X(10000),Y(10000),SIGMA(10000),ADUM(50),COVAR(50,50) COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/CPARMS/A,B,C REAL*8 A,B,C COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL IF(.NOT.(DEFAULT))GOTO 13681 CALL SETFLG(NOCONT) 13681 CONTINUE IF(.NOT.(FITCON))GOTO 13701 CONORD(CURIMR) = 0 IF(NOCONT .LT. 1)GOTO 13721 13730 J=1 GOTO 13733 13731 J=J+1 13733 IF((J).GT.(NOCONT))GOTO 13732 Y(J) = CONFLUX(J)*CFACTOR(J) X(J) = CONCENT(J) SIGMA(J) = SIGFLUX(J) GOTO 13731 13732 CONTINUE IORD = 1 CALL POLYLIN(X,Y,SIGMA,IORD,ADUM,COVAR,CHISQ,NOCONT) 13740 ITERM=1 GOTO 13743 13741 ITERM=ITERM+1 13743 IF((ITERM).GT.(IORD))GOTO 13742 ACON(ITERM,CURIMR) = ADUM(ITERM) GOTO 13741 13742 CONTINUE NFREE = NOCONT-IORD CALL G3SIGCH(NFREE,CHI3SIG) OCHIRAT = CHISQ / CHI3SIG CONORD(CURIMR) = IORD 13750 IORD=2 GOTO 13753 13751 IORD=IORD+1 13753 IF((IORD).GT.(5))GOTO 13752 IF(3*(IORD+1) .LE. NOCONT)GOTO 13771 GOTO 13752 13771 CONTINUE CALL POLYLIN(X,Y,SIGMA,IORD,ADUM,COVAR,CHISQ,NOCONT) NFREE = NOCONT-IORD CALL G3SIGCH(NFREE,CHI3SIG) CHIRAT = CHISQ / CHI3SIG IF(CHIRAT .GE. OCHIRAT*0.80)GOTO 13791 13800 ITERM=1 GOTO 13803 13801 ITERM=ITERM+1 13803 IF((ITERM).GT.(IORD))GOTO 13802 ACON(ITERM,CURIMR) = ADUM(ITERM) GOTO 13801 13802 CONTINUE OCHIRAT = CHIRAT CONORD(CURIMR) = IORD GOTO 13781 13791 IF(CHIRAT .LE. OCHIRAT)GOTO 13811 GOTO 13752 13811 CONTINUE 13781 CONTINUE GOTO 13751 13752 CONTINUE GOTO 13821 13721 CONTINUE CONORD(CURIMR) = 1 ACON(1,CURIMR) = 1.0 13821 CONTINUE 13711 CONTINUE 13701 CONTINUE CHI_SCALE = OCHIRAT IF(CFLAG .NE. 1 .OR. NOCONT .LT. 3)GOTO 13841 CALL PARABOL(CONCENT,CONFLUX,NOCONT,A,B,C) GOTO 13831 13841 IF(CFLAG .NE. 2 .OR. NOCONT .LT. 2)GOTO 13851 CALL FITLINE(CONCENT,CONFLUX,NOCONT,A,B) GOTO 13831 13851 IF(CFLAG .NE. 3 .OR. NOCONT .LT. 1)GOTO 13861 CALL AVRGE(CONFLUX,NOCONT,A) 13861 CONTINUE 13831 CONTINUE RETURN END SUBROUTINE LOWRCNT(NPTS) IMPLICIT REAL*8 (A-H,O-Z) REAL*8 SNR INTEGER MIDDLE LOGICAL BADIOD COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM CWINDOW = DBLE( CONRHT(1) ) CBIN = DBLE( CONSIZE(1) ) ILOW = 0 NBAD = 0 PROB = ( 0.5/(CWINDOW-CBIN+1.0) )**(1.0/CBIN) CALL GETNSIG(PROB,ANSIG) 13870 I=101 GOTO 13873 13871 I=I+1 13873 IF((I).GT.(NPTS - 100))GOTO 13872 CUTOFF = (ANSIG+1.0)/SNR(I) DIODE = DBLE(I) IF(.NOT.(.NOT.BADIOD(I)))GOTO 13891 IF(SPEC(I) .GT. CONTUM(DIODE)-CUTOFF)GOTO 13911 ILOW = ILOW + 1 13911 CONTINUE GOTO 13921 13891 CONTINUE NBAD = NBAD + 1 13921 CONTINUE 13881 CONTINUE GOTO 13871 13872 CONTINUE FC = 1.0 - DBLE(ILOW)/DBLE(NPTS - NBAD - 200) FC = FC/0.84 NLIN = CWINDOW*(1.0-FC)/6.0 IF(NLIN .GE. 1)GOTO 13941 NLIN = 0 13941 CONTINUE CSIZE = (CWINDOW-CBIN+1.0)*FC/(NLIN+1) IF(CSIZE .LT. CBIN)GOTO 13961 NBINS = (CWINDOW-CBIN+1.0)*FC/CBIN PROB = ( 0.5/NBINS )**(1.0/CBIN) GOTO 13971 13961 CONTINUE PROB = ( 0.5/((CWINDOW-CBIN+1.0)*(2.0*FC)**(CBIN-1.0)) )**(1.0/CBI *N) 13971 CONTINUE 13951 CONTINUE CALL GETNSIG(PROB,ANSIG) MIDDLE = NINT( CONCENT(NOCONT) - CONCENT(1) ) HEIGHT = (ANSIG)/SNR(MIDDLE) PERCNT = HEIGHT*100.0 IF(PROB .GT. 0.50)GOTO 13991 WRITE(6,'(28H Shifting continuum down by ,F5.2,8H percent)')PERCNT GOTO 14001 13991 CONTINUE WRITE(6,'(26H Shifting continuum up by ,F5.2,8H percent)')PERCNT 14001 CONTINUE 13981 CONTINUE 14010 I=1 GOTO 14013 14011 I=I+1 14013 IF((I).GT.(NOCONT))GOTO 14012 HEIGHT = (ANSIG)/SNR(NINT(CONCENT(I))) FACTOR = 1.0-HEIGHT CONFLUX(I) = CONFLUX(I)*FACTOR GOTO 14011 14012 CONTINUE RETURN END SUBROUTINE GETNSIG(PROB,ANSIG) IMPLICIT REAL*8 (A-H,O-Z) INTEGER I IF(PROB .LE. 0.50)GOTO 14031 P = 1.0 - PROB GOTO 14041 14031 CONTINUE P = PROB 14041 CONTINUE 14021 CONTINUE ANSIG = 0.0 STEP = 1.0 PROB1 = ERFCC(ANSIG)/2.0 14050 I=1 GOTO 14053 14051 I=I+1 14053 IF((I).GT.(10000))GOTO 14052 ANSIG = ANSIG + STEP PROB2 = ERFCC(ANSIG)/2.0 IF(PROB1 .LT. P .OR. PROB2 .GT. P)GOTO 14071 ANSIG = ANSIG - STEP STEP = STEP/10.0 GOTO 14081 14071 CONTINUE PROB1 = PROB2 14081 CONTINUE 14061 CONTINUE IF(STEP.LE.0.0001)GOTO 14052 GOTO 14051 14052 CONTINUE ANSIG = DMYSQ(2.0D+00)*(ANSIG + STEP/2.0) IF(PROB .LE. 0.5)GOTO 14101 ANSIG = -ANSIG 14101 CONTINUE RETURN END REAL*8 FUNCTION ERFCC(ANSIG) 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.09 *678418+ T*(-0.18628806+T*(0.27886807+T*(-1.13520398+T*(1.48851587+ * T*(-0.82215223+T*0.17087277))))))))) IF(ANSIG .GE. 0.0)GOTO 14121 ERFCC=2.0-ERFCC 14121 CONTINUE RETURN END SUBROUTINE AVRGE(VALUE,I,A) IMPLICIT REAL*8(A-H,O-Z) REAL*8 VALUE(100),A INTEGER I A = 0.0 14130 J=1 GOTO 14133 14131 J=J+1 14133 IF((J).GT.(I))GOTO 14132 A = VALUE(J)/DBLE(I) + A GOTO 14131 14132 CONTINUE RETURN END SUBROUTINE SETFLG(NOCONT) IMPLICIT REAL*8(A-H,O-Z) COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF INTEGER NOCONT IF(NOCONT .LT. 6)GOTO 14151 CFLAG = 4 EFLAG = 2 GOTO 14141 14151 IF(NOCONT .LT. 3)GOTO 14161 CFLAG = 2 EFLAG = 2 GOTO 14171 14161 CONTINUE CFLAG = 3 EFLAG = 2 14171 CONTINUE 14141 CONTINUE RETURN END SUBROUTINE FCDNAD(LINE,A,COV,DELETED) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS INTEGER LINE,START,END,I,ICENTRE,INDEX,STEP REAL*8 A(9),COV(9,9),X(200),PHOTONS,SINGLE(9),SNR LOGICAL FIRST,BADIOD,DELETED DATA SINGLE/3*1.0,6*0.0/ DELETED = .FALSE. FIRST = .TRUE. SINGLE(1) = 1.0 SINGLE(2) = 1.0 SINGLE(3) = 1.0 IF(.NOT.(INST_PROF))GOTO 14191 SINGLE(3) = 0.0 14191 CONTINUE CENTRE(LINE) = CHANNEL(WAVELN(LINE)) ICENTRE=NINT(CENTRE(LINE)) START = ICENTRE - 1 END = ICENTRE + 1 IF((ILEFT(LINE) .NE. 1) .AND. (ILEFT(LINE) .NE. -1))GOTO 14211 START = ICENTRE - 1 GOTO 14201 14211 IF(ILEFT(LINE) .GT. -2)GOTO 14221 START = ICENTRE 14221 CONTINUE 14201 CONTINUE IF((IRIGHT(LINE) .NE. 1) .AND. (IRIGHT(LINE) .NE. -1))GOTO 14241 END = ICENTRE + 1 GOTO 14231 14241 IF(IRIGHT(LINE) .GT. -2)GOTO 14251 END = ICENTRE 14251 CONTINUE 14231 CONTINUE 14260 I=START GOTO 14263 14261 I=I+1 14263 IF((I).GT.(END))GOTO 14262 IF(SPEC(I) .GE. SPEC(ICENTRE) .OR. .NOT.(.NOT. BADIOD(I)))GOTO 142 *81 ICENTRE = I 14281 CONTINUE GOTO 14261 14262 CONTINUE IF(.NOT.(BADIOD(ICENTRE)))GOTO 14301 ILEFT(LINE) = -1 IRIGHT(LINE)= -1 CALL REMFLS(LINE) DELETED = .TRUE. RETURN 14301 CONTINUE IF(SPEC(ICENTRE) .LE. 0.0)GOTO 14321 CFLUX = SNR(ICENTRE)**2 * CONTUM(DBLE(ICENTRE))/SPEC(ICENTRE) DFLUX = DMYSQ( CFLUX + CNTUNC(ICENTRE)**2 ) GOTO 14331 14321 CONTINUE CFLUX = SN**2 DFLUX = 0.0 14331 CONTINUE 14311 CONTINUE IF(SNR(ICENTRE)**2 .LE. CFLUX-2.5*DFLUX)GOTO 14351 WRITE(8,14360)WAVELN(LINE),LINEID(LINE) 14360 FORMAT (' LINE AT ',F9.3,' A WITH ID ',A10,' IS TOO WEAK TO BE MEA %SURED PROPERLY',/ ,' THE LINE HAS BEEN REMOVED FROM THE LIST. ',/) CALL REMFLS(LINE) DELETED = .TRUE. RETURN 14351 CONTINUE IF(SNR(ICENTRE)**2 .LE. CFLUX-5.0*DFLUX)GOTO 14381 WEAK(LINE) = .TRUE. WRITE(8,14390)WAVELN(LINE),LINEID(LINE) 14390 FORMAT (' LINE AT ',F9.3,' A WITH ID ',A10,' IS TOO WEAK TO BE MEA %SURED PROPERLY',/ ,' THE EQUIVALENT WIDTH WILL BE AN ESTIMATE ONLY %. ',/) CALL RMLFGL(LINE) RETURN 14381 CONTINUE IF(SNR(ICENTRE)**2 .LE. CFLUX-7.0*DFLUX)GOTO 14411 CALL RMLFGL(LINE) 14411 CONTINUE IF(ILEFT(LINE) .GE. 0)GOTO 14431 IF(IRIGHT(LINE) .GE. 0)GOTO 14451 RHTDIO(LINE) = DBLE(ICENTRE) RETURN 14451 CONTINUE LFTDIO(LINE) = DBLE(ICENTRE) 14431 CONTINUE IF(IRIGHT(LINE) .GE. 0)GOTO 14471 RHTDIO(LINE) = DBLE(ICENTRE) 14471 CONTINUE LAST = 0 NEXT = 0 IF(LINE .LE. 1)GOTO 14491 LAST = NINT( CHANNEL(WAVELN(LINE-1)) ) 14491 CONTINUE IF(LINE .GE. NOLINES)GOTO 14511 NEXT = NINT( CHANNEL(WAVELN(LINE+1)) ) 14511 CONTINUE STEP = -1 CALL DETLIM(ICENTRE,STEP,LFTDIO(LINE),NPTS,LAST, WAVELN(LINE),LINE *ID(LINE)) STEP = 1 CALL DETLIM(ICENTRE,STEP,RHTDIO(LINE),NPTS,NEXT, WAVELN(LINE),LINE *ID(LINE)) IF((LFTDIO(LINE) .NE. DBLE(ICENTRE)) .AND. (RHTDIO(LINE) .NE. DBLE *(ICENTRE)))GOTO 14531 IF(LFTDIO(LINE) .NE. DBLE(ICENTRE))GOTO 14551 LFTDIO(LINE) = DNINT(CENTRE(LINE)) ILEFT(LINE) = -1 14551 CONTINUE IF(RHTDIO(LINE) .NE. DBLE(ICENTRE))GOTO 14571 RHTDIO(LINE) = DNINT(CENTRE(LINE)) IRIGHT(LINE) = -1 14571 CONTINUE CALL RMLFGL(LINE) RETURN 14531 CONTINUE CALL TSETLM(ICENTRE,LFTDIO(LINE),ILEFT(LINE),WAVELN(LINE)) CALL TSETLM(ICENTRE,RHTDIO(LINE),IRIGHT(LINE),WAVELN(LINE)) INDEX = INT(LFTDIO(LINE)) IEND = INT(RHTDIO(LINE)) CALL SETUPTS(X,INDEX,IEND,N) CALL FRGUAV(X,N,A,CENTRE(LINE),ICENTRE) PHOTONS = SNR(ICENTRE)**2 * CONTUM(DBLE(ICENTRE))/SPEC(ICENTRE) CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) CENTRE(LINE) = A(2) DXVEL = 1.0000 * SIGRV*WAVELN(LINE)/(DISP*3.0D+05) DXFIT = DMYSQ(COV(2,2)) DIFF = DABS(CHANNEL(WAVELN(LINE)) - A(2)) IF(((DXFIT .LE. 1.20*DXVEL) .AND. (DIFF .LE. 3.0*DXVEL .OR. DIFF . *LE. 3.0*DXFIT) .OR. DIFF*DISP .LE. 0.02) .AND. (DIFF .LE. 6.0D+00) *)GOTO 14591 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 14600 I=1 GOTO 14603 14601 I=I+1 14603 IF((I).GT.(3))GOTO 14602 14610 J=1 GOTO 14613 14611 J=J+1 14613 IF((J).GT.(3))GOTO 14612 COV(I,J) = 0.0 GOTO 14611 14612 CONTINUE GOTO 14601 14602 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) 14591 CONTINUE DEPTH(LINE) = A(1) CENTRE(LINE) = A(2) A1 = A(1) A3 = A(3) NG=1 CALL CPDELE(A1,A3,COV,SINGLE,NG,LINE) SINGLE(2) = 1.0 IF(DEPTH(LINE) .LE. 1.0)GOTO 14631 DEPTH(LINE) = 1.0 14631 CONTINUE RETURN END REAL*8 FUNCTION CNTUNC(ICENTRE) IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL INTEGER ICENTRE IF(NOCONT .NE. 1)GOTO 14651 CNTUNC = SIGFLUX(1) RETURN GOTO 14641 14651 IF(NOCONT .NE. 0)GOTO 14661 CNTUNC = 0.0D0 RETURN 14661 CONTINUE 14641 CONTINUE IF(DBLE(ICENTRE) .GT. CONCENT(1))GOTO 14681 CNTUNC = SIGFLUX(1) GOTO 14671 14681 IF(DBLE(ICENTRE) .LT. CONCENT(NOCONT))GOTO 14691 CNTUNC = SIGFLUX(NOCONT) GOTO 14701 14691 CONTINUE 14710 I=1 GOTO 14713 14711 I=I+1 14713 IF((I).GT.(NOCONT))GOTO 14712 IF(DBLE(ICENTRE) .LT. CONCENT(I) .OR. DBLE(ICENTRE) .GT. CONCENT(I *+1))GOTO 14731 CNTUNC = 0.5D0*(SIGFLUX(I)+SIGFLUX(I+1)) 14731 CONTINUE GOTO 14711 14712 CONTINUE 14701 CONTINUE 14671 CONTINUE FACTOR = CHI_SCALE /DMYSQ(DBLE(NOCONT-CONORD(CURIMR))) CNTUNC = CNTUNC * FACTOR RETURN END SUBROUTINE FRGUAV(X,N,A,CENT,ICENT) IMPLICIT REAL*8 (A-H,O-Z) COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF REAL*8 X(200),A(9) INTEGER N,ICENT A(1) = 1.0 - SPEC(ICENT)/CONTUM(DBLE(ICENT)) A(2) = CENT DEEP = A(1) WAVE = WAV(CENT) IF((.NOT.(FIXFWHM)) .AND. (.NOT.(INST_PROF)))GOTO 14751 CALL GTBSFW(WAVE,DEEP,WIDTH,SIGWDTH,SIG_AV_WIDTH) A(3) = WIDTH*0.60056121 GOTO 14761 14751 CONTINUE DX1 = DABS(X(1)-CENT) DXN = DABS(X(2*N-1)-CENT) Y1 = 1.0 - SPEC(INT(X(1)))/CONTUM(X(1)) YN = 1.0 - SPEC(INT(X(2*N-1)))/CONTUM(X(2*N-1)) IF(DX1 .LE. DXN)GOTO 14781 A(3) = DX1/DSQRT(-DLOG(Y1/A(1))) GOTO 14791 14781 CONTINUE A(3) = DXN/DSQRT(-DLOG(YN/A(1))) 14791 CONTINUE 14771 CONTINUE 14761 CONTINUE 14741 CONTINUE IF(A(3) .GE. 1.20)GOTO 14811 A(3) = 1.20 14811 CONTINUE RETURN END SUBROUTINE GUESLC(LINE,CENT,FIRST) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER LINE LOGICAL FIRST REAL*8 CENT,CENT1,CENT2,WAVE1,WAVE2 CENT = CHANNEL(WAVELN(LINE)) RETURN CENT1 = 0.0 IF(LINE .EQ. NOLINES .OR. .NOT.(.NOT. FIRST))GOTO 14831 14840 NEXT=LINE+1 GOTO 14843 14841 NEXT=NEXT+1 14843 IF((NEXT).GT.(NOLINES))GOTO 14842 IF(ILEFT(NEXT) .LT. 0 .OR. IRIGHT(NEXT) .LT. 0 .OR. LINEID(NEXT) . *EQ. 'TELLURIC ')GOTO 14861 CENT1 = CHANNEL(WAVELN(LINE)) - CHANNEL(WAVELN(NEXT)) CENT1 = CENT1 + CENTRE(NEXT) WAVE1 = WAVELN(NEXT) GOTO 14842 14861 CONTINUE GOTO 14841 14842 CONTINUE 14831 CONTINUE CENT2 = 0.0 IF(LINE .EQ. 1)GOTO 14881 14890 LAST=LINE-1 GOTO 14893 14891 LAST=LAST+(-1) 14893 IF((-1)*((LAST)-(1)).GT.0)GOTO 14892 IF(ILEFT(LAST) .LT. 0 .OR. IRIGHT(LAST) .LT. 0 .OR. LINEID(LAST) . *EQ. 'TELLURIC ')GOTO 14911 CENT2 = CHANNEL(WAVELN(LINE)) - CHANNEL(WAVELN(LAST)) CENT2 = CENT2 + CENTRE(LAST) WAVE2 = WAVELN(LAST) GOTO 14892 14911 CONTINUE GOTO 14891 14892 CONTINUE 14881 CONTINUE IF(CENT1 .EQ. 0.0 .OR. DABS( CENT1-CHANNEL(WAVELN(LINE)) ) .GE. 1. *5)GOTO 14931 IF(CENT2 .EQ. 0.0 .OR. DABS( CENT2-CHANNEL(WAVELN(LINE)) ) .GE. 1. *5)GOTO 14951 CENT = ( CENT1*(WAVELN(LINE)-WAVE2) + CENT2*(WAVE1-WAVELN(LINE)) ) * / (WAVE1-WAVE2) GOTO 14961 14951 CONTINUE CENT = CENT1 14961 CONTINUE 14941 CONTINUE GOTO 14921 14931 IF(CENT2 .EQ. 0.0 .OR. DABS( CENT2-CHANNEL(WAVELN(LINE)) ) .GE. 1. *5)GOTO 14971 CENT = CENT2 GOTO 14981 14971 CONTINUE CENT = CHANNEL( WAVELN(LINE) ) 14981 CONTINUE 14921 CONTINUE RETURN END SUBROUTINE TSETLM(ICENTRE,LIMIT,ILIMIT,WAVE) IMPLICIT REAL*8(A-H,O-Z) INTEGER ICENTRE,ILIMIT REAL*8 LIMIT,WAVE IF(IABS( ICENTRE-INT(LIMIT) ) .LE. ILIMIT .OR. ILIMIT .EQ. 0)GOTO *15001 IF(INT(LIMIT) .GE. ICENTRE)GOTO 15021 WRITE(8,15030)WAVE 15030 FORMAT (' WARNING FOR LINE AT ',F9.3,' ILL DEFINED GAUSSIAN MAY RE %SULT FROM ', 'USE OF LEFT LIMIT') LIMIT = DBLE(ICENTRE-ILIMIT) GOTO 15041 15021 CONTINUE WRITE(8,15050)WAVE 15050 FORMAT (' WARNING FOR LINE AT ',F9.3,' ILL DEFINED GAUSSIAN MAY RE %SULT FROM', ' USE OF RIGHT LIMIT') LIMIT = DBLE(ICENTRE+ILIMIT) 15041 CONTINUE 15011 CONTINUE 15001 CONTINUE RETURN END SUBROUTINE DETLIM(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 BADIOD YCEN = SPEC(ICENTRE)/CONTUM(DBLE(ICENTRE)) IF(YCEN .LE. 0.0)GOTO 15071 DYCEN = YCEN/SNR(ICENTRE) GOTO 15081 15071 CONTINUE DYCEN = 0.0 15081 CONTINUE 15061 CONTINUE 15090 INDEX=ICENTRE + STEP GOTO 15093 15091 INDEX=INDEX+(STEP) 15093 IF((STEP)*((INDEX)-(ICENTRE + STEP * 40)).GT.0)GOTO 15092 IF((INDEX .GE. 1) .AND. (INDEX .LE. NUMBER))GOTO 15111 GOTO 15092 15111 CONTINUE Y = SPEC(INDEX)/CONTUM(DBLE(INDEX)) IF(Y .LE. 0.0)GOTO 15131 DY = Y/SNR(INDEX) GOTO 15141 15131 CONTINUE DY = 0.0 15141 CONTINUE 15121 CONTINUE IF(STEP .NE. -1 .OR. NEXT .EQ. 0)GOTO 15161 IF(INDEX .GT. NEXT)GOTO 15181 GOTO 15092 15181 CONTINUE GOTO 15151 15161 IF(STEP .NE. 1 .OR. NEXT .EQ. 0)GOTO 15191 IF(INDEX .LT. NEXT)GOTO 15211 GOTO 15092 15211 CONTINUE 15191 CONTINUE 15151 CONTINUE IF(.NOT.(BADIOD(INDEX)))GOTO 15231 WRITE(8,15240)INDEX,WAVE 15240 FORMAT (' BAD DIODE NO. ',I4,' RUINS HALF OF LINE AT ',F9.3,' A') LIMIT = DBLE(ICENTRE) RETURN 15231 CONTINUE IF(Y-2.0*DY .LE. YCEN+2.0*DYCEN)GOTO 15261 LIMIT = DBLE(INDEX) RETURN 15261 CONTINUE IF(YCEN-2.0*DYCEN .LE. Y+2.0*DY)GOTO 15281 GOTO 15092 15281 CONTINUE IF(Y + DY .LE. 1.00)GOTO 15301 LIMIT = DBLE(ICENTRE) WRITE(8,15310)WAVE,ID 15310 FORMAT (' LINE AT ',F9.3,' A WITH ID ',A10,' IS TOO WEAK TO BE MEA %SURED PROPERLY', /,' THE EQUIVALENT WIDTH WILL BE AN ESTIMATE ONLY %.',/) RETURN 15301 CONTINUE GOTO 15091 15092 CONTINUE LIMIT = DBLE(ICENTRE) WRITE(8,15320)WAVE,ID 15320 FORMAT (' 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 OBFWHML (LINE,A,COV,NPTS) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF INTEGER STEP,LINE,N,I,J,NPTS REAL*8 A(9),COV(9,9),SINGLE(9),SIGMAR,SIGMAL,DELTAR,DELTAL,RIGHT,L *EFT DATA SINGLE/9*0.0/ IF((ILEFT(LINE) .GE. 0) .AND. ((IRIGHT(LINE) .GE. 0) .AND. (.NOT.( *WEAK(LINE)))))GOTO 15341 FWHM(LINE) = 0.0 RETURN 15341 CONTINUE SINGLE(1) = 1.0 SINGLE(2) = 1.0 SINGLE(3) = 1.0 IF(.NOT.(INST_PROF))GOTO 15361 SINGLE(3) = 0.0 15361 CONTINUE STEP = 1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,RIGHT) SIGMAR = DABS(A(3)) DELTAR = DMYSQ( COV(3,3) ) STEP = -1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,LEFT) SIGMAL = DABS(A(3)) DELTAL = DMYSQ( COV(3,3) ) IF(SIGMAL + 2.0*DELTAL .GE. SIGMAR - 2.0*DELTAR)GOTO 15381 LFTDIO(LINE) = LEFT STEP = 1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,RIGHT) FWHM(LINE) = DABS(A(3))*1.66510921 GOTO 15371 15381 IF(SIGMAR + 2.0*DELTAR .GE. SIGMAL - 2.0*DELTAL)GOTO 15391 RHTDIO(LINE) = RIGHT STEP = -1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,LEFT) FWHM(LINE) = DABS(A(3))*1.66510921 GOTO 15401 15391 CONTINUE FWHM(LINE) = ( SIGMAR+SIGMAL )*0.83255460 15401 CONTINUE 15371 CONTINUE IF(A(2)-LEFT .LE. 2.0*FWHM(LINE))GOTO 15421 LEFT = A(2) - 2.0*FWHM(LINE) 15421 CONTINUE IF(RIGHT-A(2) .LE. 2.0*FWHM(LINE))GOTO 15441 RIGHT = A(2) + 2.0*FWHM(LINE) 15441 CONTINUE RHTDIO(LINE) = RIGHT LFTDIO(LINE) = LEFT RETURN END SUBROUTINE FNBRDLN IMPLICIT REAL*8(A-H,O-Z) REAL*8 WIDTH,DEEP INTEGER LINE,ICENTRE COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL IF(.NOT.(INST_PROF))GOTO 15461 RETURN 15461 CONTINUE IF((NOGDLN .LT. 2 .OR. INCPT .LE. 0.0) .AND. (.NOT.(FIXFWHM)))GOTO * 15481 15490 I=1 GOTO 15493 15491 I=I+1 15493 IF((I).GT.(NOLINES))GOTO 15492 ICENTRE = NINT(CHANNEL(WAVELN(I))) DEEP = 1.0 - SPEC(ICENTRE)/CONTUM(DBLE(ICENTRE)) CALL GTBSFW(WAVELN(I),DEEP,WIDTH,SIGWDTH,SIG_AV_WIDTH) IF((DABS(1.0-FWHM(I)/WIDTH) .LE. 3.0*SIGWDTH/WIDTH) .AND. ((FWHM(I *) .GT. 0.0) .AND. (FWHM(I) .LT. DBLE(40))) .OR. DEPTH(I) .GT. 0.50 *)GOTO 15511 CALL RBLWFF(I) 15511 CONTINUE GOTO 15491 15492 CONTINUE 15481 CONTINUE RETURN END SUBROUTINE RBLWFF(LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS REAL*8 A(9),COV(9,9),X(200),PHOTONS,SINGLE(9) INTEGER NPX,ICENTRE,LEFT,RIGHT SINGLE(1) = 1.0 15520 I=2 GOTO 15523 15521 I=I+1 15523 IF((I).GT.(9))GOTO 15522 SINGLE(I) = 0.0 GOTO 15521 15522 CONTINUE CENTRE(LINE) = CHANNEL(WAVELN(LINE)) ICENTRE = NINT(CENTRE(LINE)) DEEP = 1.0 - SPEC(ICENTRE)/CONTUM(DBLE(ICENTRE)) CALL GTBSFW(WAVELN(LINE),DEEP,WIDTH,SIGWDTH,SIG_AV_WIDTH) FWHM(LINE) = WIDTH NPX = 1 CALL SETUPTS(X,ICENTRE,ICENTRE,NPX) PHOTONS = SNR(ICENTRE)**2 * CONTUM(DBLE(ICENTRE))/SPEC(ICENTRE) A(2) = CENTRE(LINE) A(3) = FWHM(LINE)*0.60056121 CALL GAUSFT(X,A,NPX,PHOTONS,COV,SINGLE,CHISQ) DXVEL = 1.0000 * SIGRV*WAVELN(LINE)/(DISP*3.0D+05) DXFIT = DMYSQ(COV(2,2)) DIFF = DABS(CHANNEL(WAVELN(LINE)) - A(2)) IF(((DXFIT .LE. 1.20*DXVEL) .AND. (DIFF .LE. 3.0*DXVEL .OR. DIFF . *LE. 3.0*DXFIT) .OR. DIFF*DISP .LE. 0.02) .AND. (DIFF .LE. 6.0D+00) *)GOTO 15541 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 15550 I=1 GOTO 15553 15551 I=I+1 15553 IF((I).GT.(3))GOTO 15552 15560 J=1 GOTO 15563 15561 J=J+1 15563 IF((J).GT.(3))GOTO 15562 COV(I,J) = 0.0 GOTO 15561 15562 CONTINUE GOTO 15551 15552 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) SINGLE(2) = 1.0 15541 CONTINUE CALL OBFFWBS(LINE,A,COV,NPTS) LEFT = INT(LFTDIO(LINE)) RIGHT = INT(RHTDIO(LINE)) NPX = RIGHT - LEFT + 1 CALL SETUPTS(X,LEFT,RIGHT,NPX) CALL GAUSFT(X,A,NPX,PHOTONS,COV,SINGLE,CHISQ) DXFIT = DMYSQ(COV(2,2)) DIFF = DABS(CHANNEL(WAVELN(LINE)) - A(2)) WRITE(26,'(34H REFIT BROAD LINE WITH FIXED FWHM )') WRITE(26,'(25h Wav, DXvel, DXfit, Diff ,2f10.3,3f14.9)')WAVELN(LIN %E),A(1), DXVEL,DXFIT,DIFF IF(((DXFIT .LE. 1.20*DXVEL) .AND. (DIFF .LE. 3.0*DXVEL .OR. DIFF . *LE. 3.0*DXFIT) .OR. DIFF*DISP .LE. 0.02) .AND. (DIFF .LE. 6.0D+00) *)GOTO 15581 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 15590 I=1 GOTO 15593 15591 I=I+1 15593 IF((I).GT.(3))GOTO 15592 15600 J=1 GOTO 15603 15601 J=J+1 15603 IF((J).GT.(3))GOTO 15602 COV(I,J) = 0.0 GOTO 15601 15602 CONTINUE GOTO 15591 15592 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) 15581 CONTINUE DEPTH(LINE) = A(1) CENTRE(LINE) = A(2) A1 = A(1) A3 = A(3) NG=1 CALL CPDELE(A1,A3,COV,SINGLE,NG,LINE) SINGLE(2) = 1.0 RETURN END SUBROUTINE OBFFWBS(LINE,A,COV,NPTS) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER STEP,LINE,N,I,J,NPTS REAL*8 A(9),COV(9,9),SINGLE(9),SIGMAR,SIGMAL,DELTAR,DELTAL,RIGHT,L *EFT DATA SINGLE/9*0.0/ SINGLE(1) = 1.0 SINGLE(2) = 0.0 SINGLE(3) = 0.0 STEP = 1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,RIGHT) A1R = A(1) STEP = -1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,LEFT) A1L = A(1) IF(A1L .GE. A1R)GOTO 15621 LFTDIO(LINE) = LEFT STEP = 1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,RIGHT) GOTO 15611 15621 IF(A1R .GE. A1L)GOTO 15631 RHTDIO(LINE) = RIGHT STEP = -1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,LEFT) 15631 CONTINUE 15611 CONTINUE RHTDIO(LINE) = RIGHT LFTDIO(LINE) = LEFT RETURN END SUBROUTINE DETSAE(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 TSTHLN(A,COV,SINGLE,STEP,LINE,DIODE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS 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 DEPTOL,BADIOD 15640 II=1 GOTO 15643 15641 II=II+1 15643 IF((II).GT.(3))GOTO 15642 ANEW(II) = A(II) GOTO 15641 15642 CONTINUE IF(STEP .LE. 0)GOTO 15661 START = INT(LFTDIO(LINE)) GOTO 15671 15661 CONTINUE START = INT(RHTDIO(LINE)) 15671 CONTINUE 15651 CONTINUE IF(IRIGHT(LINE) .LE. 0 .OR. STEP .LE. 0)GOTO 15691 END = NINT(CENTRE(LINE)) + IRIGHT(LINE) GOTO 15681 15691 IF(ILEFT(LINE) .LE. 0 .OR. STEP .GE. 0)GOTO 15701 END = NINT(CENTRE(LINE)) - ILEFT(LINE) GOTO 15711 15701 CONTINUE END = NINT(CENTRE(LINE)) + STEP * 40 15711 CONTINUE 15681 CONTINUE IF(END .GE. 1)GOTO 15731 END = 1 GOTO 15721 15731 IF(END .LE. NPTS)GOTO 15741 END = NPTS 15741 CONTINUE 15721 CONTINUE N = INT( RHTDIO(LINE) - LFTDIO(LINE) ) + 1 INDEX = START 15750 I=1 GOTO 15753 15751 I=I+(2) 15753 IF((2)*((I)-(2*N-1)).GT.0)GOTO 15752 X(I) = DBLE(INDEX) X(I+1) = 1.0 - SPEC(INDEX)/CONTUM(DBLE(INDEX)) INDEX = INDEX + STEP GOTO 15751 15752 CONTINUE ICENTRE = NINT(CENTRE(LINE)) PHOTONS = SNR(ICENTRE)**2 * CONTUM(DBLE(ICENTRE))/SPEC(ICENTRE) 15760 I=2*N+1 GOTO 15763 15761 I=I+(2) 15763 IF((2)*((I)-(2*IABS(START - END) + 1)).GT.0)GOTO 15762 Y = 1.0 - SPEC(INDEX)/CONTUM(DBLE(INDEX)) DY = SPEC(INDEX) / ( SNR(INDEX)*CONTUM(DBLE(INDEX)) ) XVAL = DBLE(INDEX) IF((.NOT.(DEPTOL(A,SINGLE,COV,Y,DY,XVAL))) .AND. ((.NOT.(BADIOD(IN *DEX))) .AND. (DY/Y .GE. 0.5)))GOTO 15781 GOTO 15762 15781 CONTINUE IF(DABS( A(2)-CHANNEL(WAVELN(LINE)) ) .LE. 6.0D+00)GOTO 15801 GOTO 15762 15801 CONTINUE 15810 J=INDEX + STEP GOTO 15813 15811 J=J+(STEP) 15813 IF((STEP)*((J)-(END)).GT.0)GOTO 15812 XVAL = DBLE(J) Y = 1.0 - SPEC(J)/CONTUM(DBLE(J)) DY = SPEC(J) / ( SNR(J)*CONTUM(CENTRE(LINE)) ) IF((.NOT.(DEPTOL(A,SINGLE,COV,Y,DY,XVAL))) .AND. ((.NOT.(BADIOD(J) *)) .AND. (DY/Y .GE. 0.5)))GOTO 15831 END = J - STEP GOTO 15812 15831 CONTINUE GOTO 15811 15812 CONTINUE X(I) = DBLE(INDEX) X(I+1) = Y NPX = IABS(INDEX - START) + 1 CALL GAUSFT(X,ANEW,NPX,PHOTONS,COV,SINGLE,CHISQ) CALL COMDGFR(NPX,SINGLE,NFREE) CALL G3SIGCH(NFREE,CHI3SIG) IF(CHISQ .LE. CHI3SIG .OR. CHI3SIG .LE. 0.0)GOTO 15851 WRITE(24,'(9H LINE AT ,F10.3)')WAVELN(LINE) GOTO 15762 15851 CONTINUE DXVEL = 1.0000 * SIGRV*WAVELN(LINE)/(DISP*3.0D+05) DXFIT = DMYSQ(COV(2,2)) DIFF = DABS(CHANNEL(WAVELN(LINE)) - ANEW(2)) IF(((DXFIT .LE. 1.20*DXVEL) .AND. (DIFF .LE. 3.0*DXVEL .OR. DIFF . *LE. 3.0*DXFIT) .OR. DIFF*DISP .LE. 0.02) .AND. (DIFF .LE. 6.0D+00) *)GOTO 15871 GOTO 15762 15871 CONTINUE 15880 J=START+N*STEP GOTO 15883 15881 J=J+(STEP) 15883 IF((STEP)*((J)-(INDEX)).GT.0)GOTO 15882 XVAL = DBLE(J) Y = 1.0 - SPEC(J)/CONTUM(DBLE(J)) DY = SPEC(J) / ( SNR(J)*CONTUM(CENTRE(LINE)) ) IF((.NOT.(DEPTOL(ANEW,SINGLE,COV,Y,DY,XVAL))) .AND. (.NOT.(BADIOD( *J))))GOTO 15901 DIODE = DBLE(INDEX-STEP) RETURN 15901 CONTINUE GOTO 15881 15882 CONTINUE 15910 II=1 GOTO 15913 15911 II=II+1 15913 IF((II).GT.(3))GOTO 15912 A(II) = ANEW(II) GOTO 15911 15912 CONTINUE INDEX = INDEX + STEP IF(2*N+1 .GE. 2*IABS(START-END)+1)GOTO 15762 GOTO 15761 15762 CONTINUE DIODE = DBLE(INDEX-STEP) RETURN END SUBROUTINE COMDGFR(NPX,SINGLE,NFREE) IMPLICIT REAL*8(A-H,O-Z) REAL*8 SINGLE(9) INTEGER NPX,NFREE,I,NPARAMS 15920 I=1 GOTO 15923 15921 I=I+1 15923 IF((I).GT.(9))GOTO 15922 NPARAMS = NPARAMS + DBLE(SINGLE(I)) GOTO 15921 15922 CONTINUE NFREE = NPX - NPARAMS RETURN END SUBROUTINE G3SIGCH(NFREE,CHI3SIG) IMPLICIT REAL*8(A-H,O-Z) REAL*8 CHIRAY(20) INTEGER NFREE DATA CHIRAY/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 .GT. 0)GOTO 15941 CHI3SIG = 0.0 GOTO 15931 15941 IF(NFREE .GT. 20)GOTO 15951 CHI3SIG = CHIRAY(NFREE) GOTO 15931 15951 IF(NFREE .LE. 20)GOTO 15961 CHI3SIG = CHIRAY(20) + 1.4d0 * DBLE(NFREE-20) 15961 CONTINUE 15931 CONTINUE RETURN END LOGICAL FUNCTION DEPTOL(A,SW,COV,Y,DY,X) IMPLICIT REAL*8(A-H,O-Z) COMMON/ROTCOM/ VSINI REAL*8 VSINI COMMON/ITRCOM/ DA(9),DX,PROF_TOL REAL*8 DA,DX,PROF_TOL REAL*8 A(9),AOLD(9),SW(9),COV(9,9),Y,DY,YEST,DYEST,DYEST2,DMYSQ,PR *OFILE REAL*8 GRAD(9),DELTA DEPTOL = .FALSE. 15970 I=1 GOTO 15973 15971 I=I+1 15973 IF((I).GT.(9))GOTO 15972 AOLD(I) = A(I) GOTO 15971 15972 CONTINUE YEST = PROFILE(X, A, SW, VSINI) 15980 I=1 GOTO 15983 15981 I=I+1 15983 IF((I).GT.(9))GOTO 15982 IF(SW(I) .NE. 1.D0)GOTO 16001 A(I) = A(I) + DA(I) GRAD(I) = ( PROFILE(X, A, SW, VSINI) - YEST ) / DA(I) A(I) = AOLD(I) GOTO 16011 16001 CONTINUE GRAD(I) = 0.0D0 16011 CONTINUE 15991 CONTINUE GOTO 15981 15982 CONTINUE DYEST2 = 0.0D0 16020 I=1 GOTO 16023 16021 I=I+1 16023 IF((I).GT.(9))GOTO 16022 IF(SW(I) .NE. 1.0D0)GOTO 16041 16050 J=1 GOTO 16053 16051 J=J+1 16053 IF((J).GT.(9))GOTO 16052 IF(SW(J) .NE. 1.0D0)GOTO 16071 DYEST2 = DYEST2 + GRAD(I)*GRAD(J)*COV(I,J) 16071 CONTINUE GOTO 16051 16052 CONTINUE 16041 CONTINUE GOTO 16021 16022 CONTINUE DYEST = DMYSQ(DYEST2) DELTA = Y-YEST IF((DELTA .LE. 2.0*DY + 2.0*DYEST .OR. DELTA .LE. A(1)*PROF_TOL) . *AND. (Y - 2.0*DY .LT. A(1)))GOTO 16091 DEPTOL = .TRUE. 16091 CONTINUE RETURN END SUBROUTINE FT1GAUS(LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS 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(.NOT.(INST_PROF))GOTO 16111 SINGLE(3) = 0.0 16111 CONTINUE IF((ILEFT(LINE) .GE. 0) .AND. ((IRIGHT(LINE) .GE. 0) .AND. (.NOT.( *WEAK(LINE)))))GOTO 16131 RETURN 16131 CONTINUE N = INT( RHTDIO(LINE) - LFTDIO(LINE) ) + 1 INDEX = INT( LFTDIO(LINE) ) IEND = INT( RHTDIO(LINE) ) CALL SETUPTS(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 * CONTUM(DBLE(ICENTRE))/SPEC(ICENTRE) CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) DXVEL = 1.0000 * SIGRV*WAVELN(LINE)/(DISP*3.0D+05) DXFIT = DMYSQ(COV(2,2)) DIFF = DABS(CHANNEL(WAVELN(LINE)) - A(2)) IF(((DXFIT .LE. 1.20*DXVEL) .AND. (DIFF .LE. 3.0*DXVEL .OR. DIFF . *LE. 3.0*DXFIT) .OR. DIFF*DISP .LE. 0.02) .AND. (DIFF .LE. 6.0D+00) *)GOTO 16151 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 16160 I=1 GOTO 16163 16161 I=I+1 16163 IF((I).GT.(3))GOTO 16162 16170 J=1 GOTO 16173 16171 J=J+1 16173 IF((J).GT.(3))GOTO 16172 COV(I,J) = 0.0 GOTO 16171 16172 CONTINUE GOTO 16161 16162 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) 16151 CONTINUE DEPTH(LINE) = A(1) CENTRE(LINE) = A(2) FWHM(LINE) = DABS(A(3))/0.60056121 A1 = A(1) A3 = A(3) NG=1 CALL CPDELE(A1,A3,COV,SINGLE,NG,LINE) SINGLE(2) = 1.0 RETURN END SUBROUTINE DETWTD IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF INTEGER NUSED REAL*8 X(1000),Y(1000),YMIN,YMAX IF(.NOT.(INST_PROF))GOTO 16191 RETURN 16191 CONTINUE IF(.NOT.(FIXFWHM))GOTO 16211 SLOPE = 0.0 RETURN 16211 CONTINUE MINIDP = 1.0 IF(NOGDLN .LT. 2)GOTO 16231 CALL AMINWTDF(X,Y,NUSED) GOTO 16241 16231 CONTINUE CALL QKMSALL CALL LDALLN(X,Y,N) WRITE(6,*)'LESS THAN 2 ON GOOD LINE LIST: NO W-D FIT PERFORMED' 16241 CONTINUE 16221 CONTINUE CALL FDMNMX(1,NUSED,Y,YMIN,YMAX) YMAX = YMAX * 1.05d0 XMIN = 0.0d0 XMAX = 1.0d0 CALL PLWD(X,Y,NUSED,XMIN,XMAX,YMIN,YMAX) CALL WTDUI(X,Y,NUSED) RETURN END SUBROUTINE RLGLN(X,Y,N) IMPLICIT REAL*8 (A-H,O-Z) COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON/DNONLIN/PIXMIN,PIXMAX,PMIDDLE,PRANGE,C REAL*8 PIXMIN,PIXMAX,PMIDDLE,PRANGE,C(50) COMMON/LNONLIN/NON_LINEAR LOGICAL NON_LINEAR COMMON/NNONLIN/NTERMS INTEGER NTERMS COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL 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) REAL*8 X(1000),Y(1000) REAL*8 X1,Y1,YMIN,YMAX,Y8(1000) INTEGER N CALL MEGDLN(RV) 16250 I=1 GOTO 16253 16251 I=I+1 16253 IF((I).GT.(NOGDLN))GOTO 16252 CALL FNDORD(WAVELN(GOOD(I)),IORDER) IF(.NOT.(NON_LINEAR))GOTO 16271 DWAV = WAV(CHANNEL( WAVELN(GOOD(I)) )) - WAV(CHANNEL( WAVELN(GOOD *(I)) )-1.0d0) GOTO 16281 16271 CONTINUE DWAV = DW(IORDER) 16281 CONTINUE 16261 CONTINUE R = WAVELN(GOOD(I))/(FWHM(GOOD(I))*DWAV) RW = DLOG10( 1.065*DWAV*FWHM(GOOD(I))*DEPTH(GOOD(I))/ WAVELN(GOOD( *I)) ) X(I) = DEPTH(GOOD(I)) IF((.NOT.(GLOBAL_FOCUS)) .AND. (.NOT.(FOCUS_PARS(CURIMR))))GOTO 16 *301 Y(I) = 1.0/R**2 - 1.0/RFOCUS(WAVELN(GOOD(I)))**2 Y8(I) = Y(I) GOTO 16311 16301 CONTINUE Y(I) = 1.0/R**2 Y8(I) = Y(I) 16311 CONTINUE 16291 CONTINUE GOTO 16251 16252 CONTINUE N = NOGDLN CALL FDMNMX(1,N,Y,YMIN,YMAX) YMAX = YMAX * 1.05d0 XMIN = 0.0d0 XMAX = 1.0d0 CALL PLWD(X,Y,N,XMIN,XMAX,YMIN,YMAX) RETURN END SUBROUTINE LDALLN(X,Y,N) IMPLICIT REAL*8 (A-H,O-Z) COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON/DNONLIN/PIXMIN,PIXMAX,PMIDDLE,PRANGE,C REAL*8 PIXMIN,PIXMAX,PMIDDLE,PRANGE,C(50) COMMON/LNONLIN/NON_LINEAR LOGICAL NON_LINEAR COMMON/NNONLIN/NTERMS INTEGER NTERMS COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL 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) REAL*8 X(1000),Y(1000),X1 REAL*8 Y0,YMIN,YMAX,Y8(1000) INTEGER I,N,KK N = 0 16320 I=1 GOTO 16323 16321 I=I+1 16323 IF((I).GT.(NOLINES))GOTO 16322 CALL FNDORD(WAVELN(I),IORDER) IF(.NOT.(NON_LINEAR))GOTO 16341 DWAV = WAV(CHANNEL( WAVELN(I) )) - WAV(CHANNEL( WAVELN(I) )-1.0d0 *) GOTO 16351 16341 CONTINUE DWAV = DW(IORDER) 16351 CONTINUE 16331 CONTINUE IF(FWHM(I) .LE. 0.0d0)GOTO 16371 N = N + 1 R = WAVELN(I)/(FWHM(I)*DWAV) RW = DLOG10( 1.065*DWAV*FWHM(I)*DEPTH(I)/ WAVELN(I) ) X(N) = DEPTH(I) IF((.NOT.(GLOBAL_FOCUS)) .AND. (.NOT.(FOCUS_PARS(CURIMR))))GOTO 16 *391 Y(N) = 1.0/R**2 - 1.0/RFOCUS(WAVELN(I))**2 Y8(N) = Y(N) GOTO 16401 16391 CONTINUE Y(N) = 1.0/R**2 Y8(N) = Y(N) 16401 CONTINUE 16381 CONTINUE 16371 CONTINUE GOTO 16321 16322 CONTINUE RETURN END SUBROUTINE WTDUI(X,Y,N) IMPLICIT REAL*8 (A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK CHARACTER*2 CMD INTEGER IORD,N REAL*8 X(1000),Y(1000),XMIN,XMAX,YMIN,YMAX REAL*8 XW(2),YW(2),XS(2),YS(2) REAL*8 ADUM(50) CALL PRWDHLP CALL DISPRM 16410 CONTINUE 16411 CONTINUE READ(5,'(a2)')CMD IF((CMD .NE. 'q ') .AND. (CMD .NE. 'Q '))GOTO 16431 RETURN GOTO 16421 16431 IF((CMD .NE. 'rg') .AND. (CMD .NE. 'RG'))GOTO 16441 CALL RLGLN(X,Y,N) GOTO 16421 16441 IF((CMD .NE. 'al') .AND. (CMD .NE. 'AL'))GOTO 16451 CALL QKMSALL CALL LDALLN(X,Y,N) CALL FLSCWDPL(X,Y,N) GOTO 16421 16451 IF((CMD .NE. 'if') .AND. (CMD .NE. 'IF'))GOTO 16461 CALL SELWDDAT(XW,YW,XS,YS) CALL INTWDFIT(XW,YW,XS,YS,X,Y,N) CALL REFRWDPL(X,Y,N) CALL DRDTBXS(XW,YW,XS,YS) GOTO 16421 16461 IF((CMD .NE. 'fs') .AND. (CMD .NE. 'FS'))GOTO 16471 CALL FLSCWDPL(X,Y,N) CALL DRDTBXS(XW,YW,XS,YS) GOTO 16421 16471 IF((CMD .NE. 'r ') .AND. (CMD .NE. 'R '))GOTO 16481 CALL REJWDPT(X,Y,N) CALL REFRWDPL(X,Y,N) CALL DRDTBXS(XW,YW,XS,YS) GOTO 16421 16481 IF((CMD .NE. 'b ') .AND. (CMD .NE. 'B '))GOTO 16491 CALL GETNSCB(XMIN,XMAX,YMIN,YMAX) CALL PLWD(X,Y,N,XMIN,XMAX,YMIN,YMAX) CALL DRDTBXS(XW,YW,XS,YS) GOTO 16421 16491 IF((CMD .NE. '? ') .AND. (CMD .NE. '??'))GOTO 16501 CALL PRWDHLP 16501 CONTINUE 16421 CONTINUE CALL DISPRM GOTO 16411 16412 CONTINUE RETURN END SUBROUTINE PRWDHLP IMPLICIT REAL*8 (A-H,O-Z) WRITE(6,*)' ' WRITE(6,*)'ENTER COMMANDS FOR WIDTH-DEPTH RELATION:' WRITE(6,*)'q QUIT' WRITE(6,*)'b BLOWUP PLOT' WRITE(6,*)'rg RELOAD GOOD LINES ONLY' WRITE(6,*)'al LOAD ALL LINES FOR WIDTH-DEPTH RELATION' WRITE(6,*)'fs FULL SCALE PLOT' WRITE(6,*)'if INTERACTIVE FIT WIDTH TO DEPTH RELATION' WRITE(6,*)'r REJECT LINE FROM FIT' WRITE(6,*)' ' RETURN END SUBROUTINE SELWDDAT(XW,YW,XS,YS) CHARACTER*80 STRING REAL*8 XW(2),YW(2),XS(2),YS(2) STRING = 'SET DEPTH RANGE FOR WEAK LINES' CALL GTDTCUR(STRING,XW,YW) STRING = 'SET DEPTH RANGE FOR STRONG LINES' CALL GTDTCUR(STRING,XS,YS) CALL DRDTBXS(XW,YW,XS,YS) RETURN END SUBROUTINE DRDTBXS(XW,YW,XS,YS) REAL*8 XW(2),YW(2),XS(2),YS(2) INTEGER ICOL ICOL = 2 CALL DRWBOX(XW,YW,ICOL) ICOL = 3 CALL DRWBOX(XS,YS,ICOL) RETURN END SUBROUTINE DRWBOX(X,Y,ICOL) IMPLICIT REAL*8 (A-H,O-Z) REAL*8 X(2),Y(2) REAL*4 XDAT(5),YDAT(5) INTEGER ICOL,N N=5 XDAT(1) = X(1) YDAT(1) = Y(1) XDAT(2) = X(2) YDAT(2) = Y(1) XDAT(3) = X(2) YDAT(3) = Y(2) XDAT(4) = X(1) YDAT(4) = Y(2) XDAT(5) = X(1) YDAT(5) = Y(1) CALL PGSCI(ICOL) CALL PGLINE(N,XDAT,YDAT) RETURN END SUBROUTINE INTWDFIT(XW,YW,XS,YS,X,Y,N) IMPLICIT REAL*8 (A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK CHARACTER*80 STRING,ANS*1 INTEGER N REAL*8 X(1000),Y(1000),A(50),YLOW,VAR REAL*8 XW(2),YW(2),XS(2),YS(2) 16510 CONTINUE 16511 CONTINUE CALL DISPRM WRITE(6,16520) 16520 FORMAT(' Average or Median for weak line FWHM?') CALL DISPRM READ(5,'(a1)')ANS IF((ANS .NE. 'a') .AND. (ANS .NE. 'A'))GOTO 16541 CALL CAVGWK(XW,YW,X,Y,N,YLOW) GOTO 16512 GOTO 16531 16541 IF((ANS .NE. 'm') .AND. (ANS .NE. 'M'))GOTO 16551 CALL CMEDWK(XW,YW,X,Y,N,YLOW) GOTO 16512 16551 CONTINUE 16531 CONTINUE GOTO 16511 16512 CONTINUE 16560 CONTINUE 16561 CONTINUE CALL DISPRM WRITE(6,16570) 16570 FORMAT(' Least Squares or Robust estimator for fit?') CALL DISPRM READ(5,'(a1)')ANS IF((ANS .NE. 'l') .AND. (ANS .NE. 'L'))GOTO 16591 IORD = 2 CALL LSQWIDDEPFIT(X,Y,N,XS,YS,A,IORD,VAR) INCPT = A(1) SLOPE = A(2) SIGFWHM = DMYSQ(VAR) SIG_AV_FWHM = DMYSQ(VAR/DBLE(N-IORD)) GOTO 16562 GOTO 16581 16591 IF((ANS .NE. 'r') .AND. (ANS .NE. 'R'))GOTO 16601 CALL MWDFIT(XS,YS,X,Y,N) GOTO 16562 16601 CONTINUE 16581 CONTINUE GOTO 16561 16562 CONTINUE MINIWD = YLOW MINIDP = (YLOW - INCPT)/SLOPE RETURN END SUBROUTINE LSQWIDDEPFIT(XDUM,YDUM,NDUM,XS,YS,ADUM,IORD,VAR) IMPLICIT REAL*8(A-H,O-Z) INTEGER NDUM,IORD,INUM REAL*8 XDUM(1000),YDUM(1000),XS1,XS2,MINIDP REAL*8 X(1000),Y(1000),SIGMA(1000),ADUM(50),COVAR(50,50) REAL*8 XS(2),YS(2),VAR INUM = 0 16610 I=1 GOTO 16613 16611 I=I+1 16613 IF((I).GT.(NDUM))GOTO 16612 IF(XDUM(I) .LT. XS(1) .OR. XDUM(I) .GT. XS(2))GOTO 16631 IF(YDUM(I) .LT. YS(1) .OR. YDUM(I) .GT. YS(2))GOTO 16651 INUM = INUM + 1 X(INUM) = XDUM(I) Y(INUM) = YDUM(I) SIGMA(INUM) = 1.0d0 16651 CONTINUE 16631 CONTINUE GOTO 16611 16612 CONTINUE IF(INUM .GE. 2)GOTO 16671 WRITE(6,16680) 16680 FORMAT('INSUFFICIENT NUMBER OF POINTS FOR LSQ FIT') RETURN 16671 CONTINUE CALL POLYLIN(X,Y,SIGMA,IORD,ADUM,COVAR,CHISQ,INUM) IF(ADUM(2) .GE. 0.0D0)GOTO 16701 ADUM(2) = 0.0D0 IORD = 1 CALL POLYLIN(X,Y,SIGMA,IORD,ADUM,COVAR,CHISQ,INUM) 16701 CONTINUE VAR = CHISQ/DBLE(INUM-IORD) RETURN END SUBROUTINE CAVGWK(XW,YW,X,Y,N,YAVG) IMPLICIT REAL*8 (A-H,O-Z) REAL*8 X(1000),Y(1000),YAVG,YSUM REAL*8 XW(2),YW(2) INTEGER N,NY NY = 0 YSUM = 0.0 16710 I=1 GOTO 16713 16711 I=I+1 16713 IF((I).GT.(N))GOTO 16712 IF(X(I) .GT. XW(2) .OR. X(I) .LT. XW(1))GOTO 16731 IF(Y(I) .GT. YW(2) .OR. Y(I) .LT. YW(1))GOTO 16751 YSUM = YSUM + Y(I) NY = NY + 1 16751 CONTINUE 16731 CONTINUE GOTO 16711 16712 CONTINUE IF(NY .LE. 0)GOTO 16771 YAVG = YSUM/NY GOTO 16781 16771 CONTINUE YAVG = 0.0 16781 CONTINUE 16761 CONTINUE RETURN END SUBROUTINE CMEDWK(XW,YW,X,Y,N,YMED) IMPLICIT REAL*8 (A-H,O-Z) REAL*8 X(1000),Y(1000),YM(1000),YMED REAL*8 XW(2),YW(2) INTEGER I,J,N,NY,NMED NY = 0 16790 I=1 GOTO 16793 16791 I=I+1 16793 IF((I).GT.(N))GOTO 16792 IF(X(I) .GT. XW(2) .OR. X(I) .LT. XW(1))GOTO 16811 IF(Y(I) .GT. YW(2) .OR. Y(I) .LT. YW(1))GOTO 16831 NY = NY + 1 YM(NY) = Y(I) 16831 CONTINUE 16811 CONTINUE GOTO 16791 16792 CONTINUE 16840 I=NY GOTO 16843 16841 I=I+(-1) 16843 IF((-1)*((I)-(2)).GT.0)GOTO 16842 16850 J=1 GOTO 16853 16851 J=J+1 16853 IF((J).GT.(I-1))GOTO 16852 IF(YM(J+1) .GE. YM(J))GOTO 16871 YDUM = YM(J) YM(J) = YM(J+1) YM(J+1) = YDUM 16871 CONTINUE GOTO 16851 16852 CONTINUE GOTO 16841 16842 CONTINUE NMED = NY / 2 IF(NMED .LT. 1)GOTO 16891 IF(2*NMED .GE. NY)GOTO 16911 YMED = YM(NMED+1) GOTO 16921 16911 CONTINUE YMED = 0.5 * (YM(NMED)+YM(NMED+1)) 16921 CONTINUE 16901 CONTINUE 16891 CONTINUE RETURN END SUBROUTINE GTDTCUR(STRING,XS,YS) IMPLICIT REAL*8(A-H,O-Z) INTEGER ICHAR CHARACTER*80 STRING REAL*8 XS(2),YS(2),XDUM,YDUM CALL DISPRM WRITE(6,'(A)')STRING CALL DISPRM CALL PGP_VCURSR(ICHAR,X,Y) XS(1) = X YS(1) = Y CALL PGP_VCURSR(ICHAR,X,Y) XS(2) = X YS(2) = Y IF(XS(2) .GE. XS(1))GOTO 16941 XDUM = XS(2) XS(2) = XS(1) XS(1) = XDUM 16941 CONTINUE IF(YS(2) .GE. YS(1))GOTO 16961 YDUM = YS(2) YS(2) = YS(1) YS(1) = YDUM 16961 CONTINUE IF((XS(1) .GE. 0.0) .AND. (XS(2) .LE. 1.0))GOTO 16981 CALL DISPRM WRITE(6,16990) 16990 FORMAT(' DEPTH MUST BE IN RANGE 0.0 TO 1.0') 16981 CONTINUE RETURN END SUBROUTINE REFRWDPL(X,Y,N) IMPLICIT REAL*8 (A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK REAL*8 X(1000),Y(1000),YMIN,YMAX,XMIN,XMAX INTEGER N CALL PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) CALL PLWD(X,Y,N,XMIN,XMAX,YMIN,YMAX) RETURN END SUBROUTINE FLSCWDPL(X,Y,N) IMPLICIT REAL*8 (A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK REAL*8 X(1000),Y(1000),YMIN,YMAX,XMIN,XMAX INTEGER N CALL FDMNMX(1,N,Y,YMIN,YMAX) YMAX = YMAX * 1.05d0 XMIN = 0.0d0 XMAX = 1.0d0 CALL PLWD(X,Y,N,XMIN,XMAX,YMIN,YMAX) RETURN END SUBROUTINE GETNSCB(XMIN,XMAX,YMIN,YMAX) IMPLICIT REAL*8(A-H,O-Z) COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) INTEGER ICHAR LOGICAL PAPER PAPER = .FALSE. CALL PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) CALL PGP_VCURSR(ICHAR,X1,Y1) IF(ICHAR .NE. 121)GOTO 17011 CALL PGP_VCURSR(ICHAR,X2,Y2) IF(Y1 .LE. Y2)GOTO 17031 YMIN = Y2 YMAX = Y1 GOTO 17021 17031 IF(Y2 .LE. Y1)GOTO 17041 YMIN = Y1 YMAX = Y2 GOTO 17051 17041 CONTINUE RETURN 17051 CONTINUE 17021 CONTINUE GOTO 17001 17011 IF(ICHAR .NE. 120)GOTO 17061 CALL PGP_VCURSR(ICHAR,X2,Y2) IF(X1 .LE. X2)GOTO 17081 XMIN = X2 XMAX = X1 GOTO 17071 17081 IF(X2 .LE. X1)GOTO 17091 XMIN = X1 XMAX = X2 GOTO 17101 17091 CONTINUE RETURN 17101 CONTINUE 17071 CONTINUE GOTO 17001 17061 IF(ICHAR .NE. 101)GOTO 17111 CALL PGP_VCURSR(ICHAR,X2,Y2) IF(X1 .LE. X2)GOTO 17131 XMIN = X2 XMAX = X1 GOTO 17121 17131 IF(X2 .LE. X1)GOTO 17141 XMIN = X1 XMAX = X2 17141 CONTINUE 17121 CONTINUE IF(Y1 .LE. Y2)GOTO 17161 YMIN = Y2 YMAX = Y1 GOTO 17151 17161 IF(Y2 .LE. Y1)GOTO 17171 YMIN = Y1 YMAX = Y2 17171 CONTINUE 17151 CONTINUE IF(X1 .NE. X2 .OR. Y1 .NE. Y2)GOTO 17191 RETURN 17191 CONTINUE GOTO 17201 17111 CONTINUE CALL DISPRM WRITE(6,17210) 17210 FORMAT('MUST ENTER x OR y OR e') RETURN 17201 CONTINUE 17001 CONTINUE CALL PGPAGE CONTINUE RETURN END SUBROUTINE REJWDPT(XARRAY,YARRAY,N) IMPLICIT REAL*8(A-H,O-Z) CHARACTER*1 CHAR INTEGER ICENTRE,ICHAR,N,NLINE REAL*8 XARRAY(1000),YARRAY(1000) CALL PGP_VCURSR(ICHAR,X,Y) CALL DISPRM CALL FNDWDEN(XARRAY,YARRAY,N,X,Y,NLINE) IF(NLINE .NE. 0)GOTO 17231 RETURN 17231 CONTINUE CALL RMWDLST(XARRAY,YARRAY,N,NLINE) RETURN END SUBROUTINE FNDWDEN(XARRAY,YARRAY,N,X,Y,NLINE) IMPLICIT REAL*8(A-H,O-Z) REAL*8 XARRAY(1000),YARRAY(1000),X,Y,D,DMIN,XMIN,XMAX,YMIN,YMAX,DX *,DY INTEGER I,N,NLINE CALL PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) DX = XMAX - XMIN DY = YMAX - YMIN DMIN = DSQRT( ((X-XARRAY(1))/DX)**2 + ((Y-YARRAY(1))/DY)**2) NLINE = 1 17240 I=2 GOTO 17243 17241 I=I+1 17243 IF((I).GT.(N))GOTO 17242 D = DSQRT( ((X-XARRAY(I))/DX)**2 + ((Y-YARRAY(I))/DY)**2) IF(D .GE. DMIN)GOTO 17261 DMIN = D NLINE = I 17261 CONTINUE GOTO 17241 17242 CONTINUE RETURN END SUBROUTINE RMWDLST(XARRAY,YARRAY,N,NLINE) IMPLICIT REAL*8(A-H,O-Z) REAL*8 XARRAY(1000),YARRAY(1000) INTEGER N,NLINE 17270 I=NLINE GOTO 17273 17271 I=I+1 17273 IF((I).GT.(N-1))GOTO 17272 XARRAY(I) = XARRAY(I+1) YARRAY(I) = YARRAY(I+1) GOTO 17271 17272 CONTINUE N = N - 1 RETURN END SUBROUTINE MWDFIT(XS,YS,XDUM,YDUM,K) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL 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) REAL*8 TOLER,ERROR,Q(1003,4),X(4),RES(1001),CU(2,1003),RDUMMY(1000 *),SL,Y0,Y1 REAL*8 XDUM(1000),YDUM(1000),YWEAK(1000),YMEDIAN REAL*8 XS(2),YS(2) INTEGER K,L,M,N,KLMD,KLM2D,NKLMD,N2D,IU(2,1003),S(1001),ITER,KODE, *IORDER INTEGER IAVG,INUM L = 0 M = 1 N = 2 KLMD = 1001 KLM2D = 1003 N2D = 4 KODE = 0 TOLER = 0.002 ITER = 1010 NKLMD = 1003 IAVG = 0 INUM = 0 DMIN = 0.10 17280 I=1 GOTO 17283 17281 I=I+1 17283 IF((I).GT.(K))GOTO 17282 IF(XDUM(I) .LT. XS(1) .OR. XDUM(I) .GT. XS(2))GOTO 17301 IF(YDUM(I) .LT. YS(1) .OR. YDUM(I) .GT. YS(2))GOTO 17321 INUM = INUM + 1 Q(INUM,1) = XDUM(I) Q(INUM,2) = 1.0 Q(INUM,3) = YDUM(I) Q(INUM,4) = 0.0 17321 CONTINUE 17301 CONTINUE GOTO 17281 17282 CONTINUE IF(INUM .GE. 2)GOTO 17341 WRITE(6,17350) 17350 FORMAT('INSUFFICIENT NUMBER OF POINTS FOR MINSUM FIT') RETURN 17341 CONTINUE 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(INUM,L,M,N,KLMD,KLM2D,NKLMD,N2D,Q,KODE,TOLER,ITER,X,RES,E *RROR, CU,IU,S) IF(KODE .LE. 0)GOTO 17371 WRITE(8,17380)KODE 17380 FORMAT (29H MINSUM ROUTINE ABORTED CODE ,I2) RETURN 17371 CONTINUE IF(INUM .LE. 1)GOTO 17401 SIGFWHM = DMYSQ( 1.25*ERROR/DBLE(INUM-2) ) SIG_AV_FWHM = DMYSQ( 1.25*ERROR)/DBLE(INUM-2) GOTO 17411 17401 CONTINUE SIGFWHM = 0.0 17411 CONTINUE 17391 CONTINUE SLOPE = X(1) INCPT = X(2) RETURN END SUBROUTINE DMNFWH IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON/LTELL/TELSET,TELPRES LOGICAL TELSET,TELPRES COMMON/ITELL/LBOUND(100),RBOUND(100),NBOUNDS,NH2O INTEGER LBOUND,RBOUND,NBOUNDS,NH2O COMMON/RTELL/H2OCENT(100),H2OFWHM(100),H2ODEEP(100), H2OSLOP,H2OIN *T,H2OMIN REAL*8 H2OCENT,H2OFWHM,H2ODEEP,H2OSLOP,H2OINT,H2OMIN REAL*8 MEAN,VAR INTEGER EXCLUDE,LINE,IORDER MEAN = 0.0 VAR = 0.0 EXCLUDE = 0 17420 I=1 GOTO 17423 17421 I=I+1 17423 IF((I).GT.(NOGDLN))GOTO 17422 IF((DEPTH(GOOD(I)) .LT. LLIMIT .OR. DEPTH(GOOD(I)) .GT. ULIMIT) .A *ND. (.NOT.(TELSET)))GOTO 17441 CALL FNDORD(WAVELN(GOOD(I)),IORDER) MEAN = MEAN + WAVELN(GOOD(I))/(FWHM(GOOD(I))*DW(IORDER)) GOTO 17451 17441 CONTINUE EXCLUDE = EXCLUDE + 1 17451 CONTINUE 17431 CONTINUE GOTO 17421 17422 CONTINUE IF(NOGDLN .LE. EXCLUDE)GOTO 17471 INCPT = MEAN/DBLE(NOGDLN - EXCLUDE) GOTO 17481 17471 CONTINUE INCPT = 0.0 WRITE(8,17490) 17490 FORMAT ('ERROR: NO GOOD LINES WITHIN DEPTH LIMITS FOR FWHM TO DEP %TH RELATION') 17481 CONTINUE 17461 CONTINUE SLOPE = 0.0 17500 I=1 GOTO 17503 17501 I=I+1 17503 IF((I).GT.(NOGDLN))GOTO 17502 FAC = WAVELN(GOOD(I))/DW(IORDER) IF((DEPTH(GOOD(I)) .GE. 0.10 .OR. DEPTH(GOOD(I)) .GE. 0.50) .AND. *(.NOT.(TELSET)))GOTO 17521 VAR = VAR + (FAC/FWHM(GOOD(I))-INCPT)**2 17521 CONTINUE GOTO 17501 17502 CONTINUE SIGFWHM = DMYSQ( VAR )/DBLE(NOGDLN -2 - EXCLUDE) RETURN END SUBROUTINE AMINWTDF(XDUM,YDUM,K) IMPLICIT REAL*8(A-H,O-Z) COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON/DNONLIN/PIXMIN,PIXMAX,PMIDDLE,PRANGE,C REAL*8 PIXMIN,PIXMAX,PMIDDLE,PRANGE,C(50) COMMON/LNONLIN/NON_LINEAR LOGICAL NON_LINEAR COMMON/NNONLIN/NTERMS INTEGER NTERMS COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL 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) REAL*8 TOLER,ERROR,Q(1003,4),X(4),RES(1001),CU(2,1003),RDUMMY(1000 *),SL,Y0,Y1 REAL*8 XDUM(1000),YDUM(1000) INTEGER K,L,M,N,KLMD,KLM2D,NKLMD,N2D,IU(2,1003),S(1001),ITER,KODE, *IORDER INTEGER IAVG,INUM K = NOGDLN L = 0 M = 1 N = 2 KLMD = 1001 KLM2D = 1003 N2D = 4 KODE = 0 TOLER = 0.002 ITER = 1010 NKLMD = 1003 IAVG = 0 INUM = 0 DMIN = 0.10 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 )') 17530 I=1 GOTO 17533 17531 I=I+1 17533 IF((I).GT.(NOGDLN))GOTO 17532 IF(DEPTH(GOOD(I)) .LT. DMIN)GOTO 17551 CALL FNDORD(WAVELN(GOOD(I)),IORDER) IF(.NOT.(NON_LINEAR))GOTO 17571 DWAV = WAV(CHANNEL( WAVELN(GOOD(I)) )) - WAV(CHANNEL( WAVELN(GOOD *(I)) )-1.0d0) GOTO 17581 17571 CONTINUE DWAV = DW(IORDER) 17581 CONTINUE 17561 CONTINUE R = WAVELN(GOOD(I))/(FWHM(GOOD(I))*DWAV) RW = DLOG10( 1.065*DWAV*FWHM(GOOD(I))*DEPTH(GOOD(I))/ WAVELN(GOOD( *I)) ) IF(RW .LT. -5.22)GOTO 17601 INUM = INUM + 1 Q(INUM,1) = DEPTH(GOOD(I)) Q(INUM,2) = 1.0 IF((.NOT.(GLOBAL_FOCUS)) .AND. (.NOT.(FOCUS_PARS(CURIMR))))GOTO 17 *621 Q(INUM,3) = 1.0/R**2 - 1.0/RFOCUS(WAVELN(GOOD(I)))**2 GOTO 17631 17621 CONTINUE Q(INUM,3) = 1.0/R**2 17631 CONTINUE 17611 CONTINUE WRITE(9,*)DEPTH(GOOD(I)),Q(INUM,3),WAVELN(GOOD(I)) XDUM(INUM) = DEPTH(GOOD(I)) YDUM(INUM) = Q(INUM,3) Q(INUM,4) = 0.0 17601 CONTINUE IF(RW .GE. -4.85)GOTO 17651 IAVG = IAVG + 1 IF((.NOT.(GLOBAL_FOCUS)) .AND. (.NOT.(FOCUS_PARS(CURIMR))))GOTO 17 *671 RDUMMY(IAVG) = 1.0/R**2 - 1.0/RFOCUS(WAVELN(GOOD(I)))**2 GOTO 17681 17671 CONTINUE RDUMMY(IAVG) = 1.0/R**2 17681 CONTINUE 17661 CONTINUE 17651 CONTINUE 17551 CONTINUE GOTO 17531 17532 CONTINUE K = INUM 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,ERRO *R, CU,IU,S) IF(KODE .LE. 0)GOTO 17701 WRITE(8,17710)KODE 17710 FORMAT (29H MINSUM ROUTINE ABORTED CODE ,I2) RETURN 17701 CONTINUE IF(INUM .LE. 1)GOTO 17731 SIGFWHM = DMYSQ( 1.25*ERROR/DBLE(NOGDLN-2) ) SIG_AV_FWHM = DMYSQ( 1.25*ERROR)/DBLE(NOGDLN-2) GOTO 17741 17731 CONTINUE SIGFWHM = 0.0 17741 CONTINUE 17721 CONTINUE SLOPE = X(1) INCPT = X(2) IF(IAVG .LT. 1 .OR. SLOPE .LE. 0.0)GOTO 17761 CALL GTMEDN(RDUMMY,IAVG,RMEDIAN) IF(RMEDIAN .GE. 2.5D-11)GOTO 17781 RW = 1.41D-05 CALL GETWIDTH(RW,SLOPE,INCPT,MINIWD) GOTO 17791 17781 CONTINUE MINIWD = RMEDIAN 17791 CONTINUE 17771 CONTINUE GOTO 17801 17761 CONTINUE RW = 1.41D-05 CALL GETWIDTH(RW,SLOPE,INCPT,MINIWD) 17801 CONTINUE 17751 CONTINUE MINIDP = (MINIWD - INCPT)/SLOPE RETURN END REAL*8 FUNCTION RFOCUS(W) IMPLICIT REAL*8 (A-H,O-Z) 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/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL REAL*8 R,W,X INTEGER IROW,I R = 0.0 IROW = CURIMR IF(.NOT.(FOCUS_PARS(IROW)))GOTO 17821 X = W - WFC(IROW) 17830 I=1 GOTO 17833 17831 I=I+1 17833 IF((I).GT.(6))GOTO 17832 R = R + A_FOCUS(IROW,I)*X**(I-1) GOTO 17831 17832 CONTINUE GOTO 17811 17821 IF(.NOT.(GLOBAL_FOCUS))GOTO 17841 X = W - GLOBAL_WFC 17850 I=1 GOTO 17853 17851 I=I+1 17853 IF((I).GT.(6))GOTO 17852 R = R + GLOBAL_A(I)*X**(I-1) GOTO 17851 17852 CONTINUE 17841 CONTINUE 17811 CONTINUE RFOCUS = R RETURN END SUBROUTINE GETDEPT(RW,SLOPE,INCPT,MINIDP) IMPLICIT REAL*8(A-H,O-Z) REAL*8 RMIN,R,RW,RWCALC,SLOPE,INCPT,MINIDP,D,DELTAD,DMYSQ INTEGER I,ICOUNT DELTAD = 0.1 RMIN = 200000.0 D = 1.0 ICOUNT = 0 17860 I=1 GOTO 17863 17861 I=I+1 17863 IF((I).GT.(100000))GOTO 17862 R = 1.0/(INCPT + SLOPE*D) R = DMYSQ(R) RWCALC = 1.067*D/R IF(RWCALC .GE. RW)GOTO 17881 D = D + DELTAD DELTAD = DELTAD/10.0 ICOUNT = ICOUNT + 1 GOTO 17891 17881 CONTINUE D = D - DELTAD 17891 CONTINUE 17871 CONTINUE IF(ICOUNT .LT. 6)GOTO 17911 IF(R .LE. RMIN)GOTO 17931 WRITE(8,17940) 17940 FORMAT('ERROR: WIDTH TO DEPTH RELATION TOO NARROW') 17931 CONTINUE GOTO 17862 17911 CONTINUE GOTO 17861 17862 CONTINUE MINIDP = D RETURN END SUBROUTINE GETWIDTH(RW,SLOPE,INCPT,WIDTH) IMPLICIT REAL*8(A-H,O-Z) REAL*8 RW,REW,W,W2,SLOPE,INCPT,WIDTH,TOL INTEGER I TOL = 0.0001 REW = 10.00**RW W = INCPT + SLOPE 17950 I=1 GOTO 17953 17951 I=I+1 17953 IF((I).GT.(100))GOTO 17952 W2 = (REW*SLOPE/1.067)/DMYSQ(W) + INCPT IF(DABS((W-W2)/W) .GT. TOL)GOTO 17971 WIDTH = W2 RETURN 17971 CONTINUE W = W2 GOTO 17951 17952 CONTINUE WRITE(8,17980) 17980 FORMAT('ERROR: PROBLEM CONVERGING IN ROUTINE GET WIDTH') RETURN END SUBROUTINE FITWKL IMPLICIT REAL*8 (A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS REAL*8 SINGLE(9),X(200),A(9),COV(9,9) INTEGER LINE,N SINGLE(1) = 1.0 SINGLE(2) = 1.0 17990 I=3 GOTO 17993 17991 I=I+1 17993 IF((I).GT.(9))GOTO 17992 A(I) = 0.0 SINGLE(I) = 0.0 GOTO 17991 17992 CONTINUE 18000 LINE=1 GOTO 18003 18001 LINE=LINE+1 18003 IF((LINE).GT.(NOLINES))GOTO 18002 IF(.NOT.(WEAK(LINE)))GOTO 18021 CENTRE(LINE) = CHANNEL(WAVELN(LINE)) ICENTRE = NINT(CENTRE(LINE)) DEPTH(LINE) = 1.0 - SPEC(ICENTRE)/CONTUM(DBLE(ICENTRE)) DEEP = DEPTH(LINE) W = WAVELN(LINE) CALL GTBSFW(W,DEEP,WIDTH,SIGWDTH,SIG_AV_WIDTH) IF(WIDTH .NE. 0.0)GOTO 18041 RETURN 18041 CONTINUE FWHM(LINE) = WIDTH RHTDIO(LINE) = DNINT(CENTRE(LINE) + 0.5*WIDTH) LFTDIO(LINE) = DNINT(CENTRE(LINE) - 0.5*WIDTH) IF(LINE .GE. NOLINES)GOTO 18061 IF(RHTDIO(LINE) .LT. CHANNEL(WAVELN(LINE+1)))GOTO 18081 GOTO 18001 18081 CONTINUE 18061 CONTINUE IF(LINE .LE. 1)GOTO 18101 IF(LFTDIO(LINE) .GT. CHANNEL(WAVELN(LINE-1)))GOTO 18121 GOTO 18001 18121 CONTINUE 18101 CONTINUE ISTART = INT( LFTDIO(LINE) ) IEND = INT( RHTDIO(LINE)) CALL SETUPTS(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 * CONTUM(DBLE(ICENT))/SPEC(ICENT) 18130 I=1 GOTO 18133 18131 I=I+1 18133 IF((I).GT.(3))GOTO 18132 18140 J=1 GOTO 18143 18141 J=J+1 18143 IF((J).GT.(3))GOTO 18142 COV(I,J) = 0.0 GOTO 18141 18142 CONTINUE GOTO 18131 18132 CONTINUE SINGLE(2) = 1.0 CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) DXVEL = 1.0000 * SIGRV*WAVELN(LINE)/(DISP*3.0D+05) DXFIT = DMYSQ(COV(2,2)) DIFF = DABS(CHANNEL(WAVELN(LINE)) - A(2)) IF(((DXFIT .LE. 1.20*DXVEL) .AND. (DIFF .LE. 3.0*DXVEL .OR. DIFF . *LE. 3.0*DXFIT) .OR. DIFF*DISP .LE. 0.02) .AND. (DIFF .LE. 6.0D+00) *)GOTO 18161 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 18170 I=1 GOTO 18173 18171 I=I+1 18173 IF((I).GT.(3))GOTO 18172 18180 J=1 GOTO 18183 18181 J=J+1 18183 IF((J).GT.(3))GOTO 18182 COV(I,J) = 0.0 GOTO 18181 18182 CONTINUE GOTO 18171 18172 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) SINGLE(2) = 1.0 18161 CONTINUE DEPTH(LINE) = A(1) CENTRE(LINE) = A(2) A1 = A(1) A3 = A(3) NG = 1 CALL CPDELE(A1,A3,COV,SINGLE,NG,LINE) 18021 CONTINUE GOTO 18001 18002 CONTINUE RETURN END SUBROUTINE SFTBLS(LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS REAL*8 SINGLE(9),X(200),A(3),COV(9,9) INTEGER STEP,LINE LOGICAL FIRST,BADIOD,LNABST DATA SINGLE/9*0.0/ FIRST = .FALSE. IF(ILEFT(LINE) .LT. 0 .OR. IRIGHT(LINE) .LT. 0)GOTO 18201 RETURN 18201 CONTINUE CALL GUESLC(LINE,CENTRE(LINE),FIRST) ICENTRE = NINT(CENTRE(LINE)) IF(.NOT.(BADIOD(ICENTRE)))GOTO 18221 WRITE(8,18230)WAVELN(LINE) 18230 FORMAT (' REMOVED LINE AT ',F9.3,' A DUE TO BAD DIODES') WRITE(6,18240)WAVELN(LINE) 18240 FORMAT (' REMOVED LINE AT ',F9.3,' A DUE TO BAD DIODES') CALL REMFLS(LINE) LINE = LINE - 1 RETURN 18221 CONTINUE IF(.NOT.(LNABST(CENTRE(LINE))) .OR. LINEID(LINE) .EQ. 'TELLURIC ' %)GOTO 18261 WRITE(8,18270)LINEID(LINE),WAVELN(LINE) 18270 FORMAT (' LINE WITH ID ',A10,' AT ',F9.3,' WAS REMOVED - TOO WEAK %TO MEASURE.') WRITE(6,18280)LINEID(LINE),WAVELN(LINE) 18280 FORMAT (' LINE WITH ID ',A10,' AT ',F9.3,' WAS REMOVED - TOO WEAK %TO MEASURE.') CALL REMFLS(LINE) LINE = LINE - 1 RETURN 18261 CONTINUE DEPTH(LINE) = 1.0 - SPEC(ICENTRE)/CONTUM(DBLE(ICENTRE)) CALL CHKLQY(LINE,ICENTRE,NPTS) CALL STBDGS(SINGLE,LINE,NPTS) CALL GTBSFW(WAVELN(LINE),DEPTH(LINE),FWHM(LINE),SIGWDTH,SIG_AV_WID *TH) IF(ILEFT(LINE) .GE. 0 .OR. IRIGHT(LINE) .GE. 0 .OR. FWHM(LINE) .NE *. 0.0)GOTO 18301 RETURN GOTO 18291 18301 IF(FWHM(LINE) .NE. 0.0)GOTO 18311 FWHM(LINE) = 4.5 18311 CONTINUE 18291 CONTINUE ISTART = INT( LFTDIO(LINE) ) IEND = INT( RHTDIO(LINE)) CALL SETUPTS(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 * CONTUM(DBLE(ICENT))/SPEC(ICENT) 18320 I=1 GOTO 18323 18321 I=I+1 18323 IF((I).GT.(3))GOTO 18322 18330 J=1 GOTO 18333 18331 J=J+1 18333 IF((J).GT.(3))GOTO 18332 COV(I,J) = 0.0 GOTO 18331 18332 CONTINUE GOTO 18321 18322 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) DXVEL = 1.0000 * SIGRV*WAVELN(LINE)/(DISP*3.0D+05) DXFIT = DMYSQ(COV(2,2)) DIFF = DABS(CHANNEL(WAVELN(LINE)) - A(2)) IF(((DXFIT .LE. 1.20*DXVEL) .AND. (DIFF .LE. 3.0*DXVEL .OR. DIFF . *LE. 3.0*DXFIT) .OR. DIFF*DISP .LE. 0.02) .AND. (DIFF .LE. 6.0D+00) *)GOTO 18351 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 18360 I=1 GOTO 18363 18361 I=I+1 18363 IF((I).GT.(3))GOTO 18362 18370 J=1 GOTO 18373 18371 J=J+1 18373 IF((J).GT.(3))GOTO 18372 COV(I,J) = 0.0 GOTO 18371 18372 CONTINUE GOTO 18361 18362 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) 18351 CONTINUE IF(ILEFT(LINE) .GE. 0 .OR. IRIGHT(LINE) .LT. 0)GOTO 18391 STEP = 1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,RHTDIO(LINE)) GOTO 18381 18391 IF(IRIGHT(LINE) .GE. 0 .OR. ILEFT(LINE) .LT. 0)GOTO 18401 STEP = -1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,LFTDIO(LINE)) 18401 CONTINUE 18381 CONTINUE DEPTH(LINE) = A(1) CENTRE(LINE) = A(2) FWHM(LINE) = DABS(A(3))/0.60056121 A1 = A(1) A3 = A(3) N = 1 CALL CPDELE(A1,A3,COV,SINGLE,N,LINE) RETURN END LOGICAL FUNCTION LNABST(CENTRE) IMPLICIT REAL*8(A-H,O-Z) REAL*8 CENTRE INTEGER ICENTRE LNABST = .FALSE. ICENTRE = NINT(CENTRE) DEPTH = 1.0 - SPEC(ICENTRE)/CONTUM(DBLE(ICENTRE)) SIGMA = ( SPEC(ICENTRE)/CONTUM(DBLE(ICENTRE)) ) / SNR(ICENTRE) IF(DEPTH .GT. SIGMA)GOTO 18421 LNABST = .TRUE. 18421 CONTINUE RETURN END SUBROUTINE CHKLQY(LINE,ICENTRE,NPTS) IMPLICIT REAL*8(A-H,O-Z) INTEGER LINE,ICENTRE,NPTS,STEP,NEXT,LAST COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK NEXT = 0 LAST = 0 IF(LINE .GE. NOLINES)GOTO 18441 NEXT = NINT( CHANNEL(WAVELN(LINE+1)) ) 18441 CONTINUE STEP = 1 CALL DETLIM(ICENTRE,STEP,RHTDIO(LINE),NPTS,NEXT, WAVELN(LINE),LINE *ID(LINE)) IF(LINE .LE. 1)GOTO 18461 LAST = NINT( CHANNEL(WAVELN(LINE-1)) ) 18461 CONTINUE STEP = -1 CALL DETLIM(ICENTRE,STEP,LFTDIO(LINE),NPTS,LAST, WAVELN(LINE),LINE *ID(LINE)) IF(RHTDIO(LINE) .NE. DBLE(ICENTRE))GOTO 18481 IRIGHT(LINE) = -1 18481 CONTINUE IF(LFTDIO(LINE) .NE. DBLE(ICENTRE))GOTO 18501 ILEFT(LINE) = -1 18501 CONTINUE RETURN END SUBROUTINE STBDGS(SINGLE,LINE,NPTS) IMPLICIT REAL*8(A-H,O-Z) REAL*8 SINGLE(9) INTEGER LINE,NPTS,STEP,NEXT,LAST,ILIMIT LOGICAL NOTURN COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF IF(ILEFT(LINE) .GE. 0 .OR. IRIGHT(LINE) .GE. 0)GOTO 18521 SINGLE(1) = 1.0 SINGLE(2) = 0.0 SINGLE(3) = 0.0 GOTO 18531 18521 CONTINUE IF(ILEFT(LINE) .GE. 0)GOTO 18551 NEXT = 0 ILIMIT = INT(RHTDIO(LINE)) STEP = 1 IF(LINE .GE. NOLINES)GOTO 18571 NEXT = NINT( CHANNEL(WAVELN(LINE+1)) ) 18571 CONTINUE CALL DETLIM(ILIMIT,STEP,RHTDIO(LINE),NPTS, NEXT,WAVELN(LINE),LINEI *D(LINE)) GOTO 18541 18551 IF(IRIGHT(LINE) .GE. 0)GOTO 18581 LAST = 0 ILIMIT = INT(LFTDIO(LINE)) STEP = -1 IF(LINE .LE. 1)GOTO 18601 LAST = NINT( CHANNEL(WAVELN(LINE-1)) ) 18601 CONTINUE CALL DETLIM(ILIMIT,STEP,LFTDIO(LINE),NPTS, LAST,WAVELN(LINE),LINEI *D(LINE)) 18581 CONTINUE 18541 CONTINUE SINGLE(1) = 1.0 SINGLE(2) = 0.0 SINGLE(3) = 1.0 IF(.NOT.(INST_PROF))GOTO 18621 SINGLE(3) = 0.0 18621 CONTINUE IF((RHTDIO(LINE) .NE. DBLE(ILIMIT)) .AND. ((LFTDIO(LINE) .NE. DBLE *(ILIMIT)) .AND. (.NOT.(NOTURN(LINE,CENTRE(LINE),NPTS,NOLINES)))))G *OTO 18641 SINGLE(3) = 0.0 ILEFT(LINE) = -1 IRIGHT(LINE) = -1 18641 CONTINUE 18531 CONTINUE 18511 CONTINUE RETURN END LOGICAL FUNCTION NOTURN(LINE,CENT,NPTS,NOLINES) IMPLICIT REAL*8(A-H,O-Z) INTEGER LINE,NPTS,NOLINES,ICENT REAL*8 CENT,CNEXT,CLAST LOGICAL FIRST FIRST = .FALSE. NOTURN = .TRUE. CLAST = 1.0 CNEXT = DBLE(NPTS) CALL GUESLC(LINE,CENT,FIRST) ICENT = NINT(CENT) IF((ICENT .GT. 2) .AND. (ICENT .LT. NPTS - 1))GOTO 18661 RETURN GOTO 18651 18661 IF(SPEC(ICENT+1) .LT. SPEC(ICENT) .OR. SPEC(ICENT) .LT. SPEC(ICENT *-1))GOTO 18671 RETURN GOTO 18651 18671 IF(SPEC(ICENT+1) .GT. SPEC(ICENT) .OR. SPEC(ICENT) .GT. SPEC(ICENT *-1))GOTO 18681 RETURN 18681 CONTINUE 18651 CONTINUE IF(LINE .GE. NOLINES)GOTO 18701 CALL GUESLC(LINE+1,CNEXT,FIRST) 18701 CONTINUE IF(LINE .LE. 1)GOTO 18721 CALL GUESLC(LINE-1,CLAST,FIRST) 18721 CONTINUE IF((DBLE(ICENT-1) .GT. CLAST) .AND. (DBLE(ICENT+1) .LT. CNEXT))GOT *O 18741 RETURN 18741 CONTINUE NOTURN = .FALSE. RETURN END SUBROUTINE GTBSFW(WAVE,DEEP,WIDTH,SIGWDTH,SIG_AV_WIDTH) IMPLICIT REAL*8(A-H,O-Z) COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL 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 /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF REAL*8 D,DEEP,WIDTH,WAVE,SIGWDTH,SIG_AV_WIDTH WIDTH = 0.0 D = DEEP RILIN2 = INCPT + D*SLOPE IF(RILIN2 .GE. MINIWD)GOTO 18761 RILIN2 = MINIWD 18761 CONTINUE IF((.NOT.(FOCUS_PARS(CURIMR))) .AND. (.NOT.(GLOBAL_FOCUS)))GOTO 18 *781 RIOBS2 = 1.0/RFOCUS(WAVE)**2 + RILIN2 GOTO 18791 18781 CONTINUE RIOBS2 = RILIN2 18791 CONTINUE 18771 CONTINUE DELTA_W = DABS( WAVE - WAV(CHANNEL(WAVE)+1.0D+00) ) WIDTH = DMYSQ(RIOBS2) * WAVE / DELTA_W SIGWDTH = SIGFWHM * WAVE /DELTA_W SIG_AV_WIDTH = SIG_AV_FWHM * WAVE /DELTA_W IF(.NOT.(INST_PROF))GOTO 18811 SIGWDTH = WIDTH * 0.05 18811 CONTINUE RETURN END SUBROUTINE FTBLIN(NOLINES) IMPLICIT REAL*8(A-H,O-Z) INTEGER LINE,NOLINES 18820 LINE=1 GOTO 18823 18821 LINE=LINE+1 18823 IF((LINE).GT.(NOLINES))GOTO 18822 CALL FTBLND(LINE) GOTO 18821 18822 CONTINUE RETURN END SUBROUTINE FTBLND(LINE) IMPLICIT REAL*8(A-H,O-Z) INTEGER LINE LOGICAL RHTWGB IF(.NOT.(RHTWGB(LINE)))GOTO 18841 IF(.NOT.(RHTWGB(LINE-1)))GOTO 18861 CALL FT3GAUS(LINE) GOTO 18871 18861 CONTINUE CALL FT2GAUS(LINE) 18871 CONTINUE 18851 CONTINUE 18841 CONTINUE RETURN END LOGICAL FUNCTION RHTWGB(LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/ROTCOM/ VSINI REAL*8 VSINI REAL*8 DEPTH1,DEPTH2,LIMIT1,LIMIT2,FWHM1,FWHM2,VWIDTH RHTWGB = .FALSE. W = WAVELN(LINE) VWIDTH = W * VSINI / (DISP * 3.0D+05) IF((LINE .LT. NOLINES) .AND. (LINE .GT. 0))GOTO 18891 RETURN 18891 CONTINUE FWHM1 = FWHM(LINE) DEEP = DEPTH(LINE) IF(FWHM1 .NE. 0.0)GOTO 18911 CALL GTBSFW(W,DEEP,FWHM1,SIGWDTH,SIG_AV_WIDTH) 18911 CONTINUE FWHM2 = FWHM(LINE+1) DEEP = DEPTH(LINE+1) IF(FWHM2 .NE. 0.0)GOTO 18931 CALL GTBSFW(W,DEEP,FWHM2,SIGWDTH,SIG_AV_WIDTH) 18931 CONTINUE ICENTRE = NINT(CENTRE(LINE)) DEPTH1 = 3.0D0 * DMYSQ(SPEC(ICENTRE)/CONTUM(DBLE(ICENTRE))) / SNR( *ICENTRE) ICENTRE = NINT(CENTRE(LINE+1)) DEPTH2 = 3.0D0 * DMYSQ(SPEC(ICENTRE)/CONTUM(DBLE(ICENTRE))) / SNR( *ICENTRE) IF(DEPTH(LINE) .LE. DEPTH1)GOTO 18951 LIMIT1 = CENTRE(LINE) + FWHM1*0.60056121*DMYSQ( DLOG(DEPTH(LINE)/D *EPTH1) ) GOTO 18961 18951 CONTINUE LIMIT1 = CENTRE(LINE) 18961 CONTINUE 18941 CONTINUE IF(DEPTH(LINE+1) .LE. DEPTH2)GOTO 18981 LIMIT2 = CENTRE(LINE+1)-FWHM2*0.60056121*DMYSQ(DLOG(DEPTH(LINE+1)/ *DEPTH2)) GOTO 18991 18981 CONTINUE LIMIT2 = CENTRE(LINE+1) 18991 CONTINUE 18971 CONTINUE IF((LIMIT2 .GE. LIMIT1) .AND. (CENTRE(LINE+1)-CENTRE(LINE) .GE. FW *HM1+FWHM2+1.8D0*VWIDTH))GOTO 19011 RHTWGB = .TRUE. 19011 CONTINUE RETURN END SUBROUTINE FT3GAUS(LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL 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/ 19020 I=1 GOTO 19023 19021 I=I+1 19023 IF((I).GT.(9))GOTO 19022 TRIPLE(I) = 1.0 GOTO 19021 19022 CONTINUE BLEND(LINE) = 2 BLEND(LINE+1) = -1 19030 INDEX=1 GOTO 19033 19031 INDEX=INDEX+1 19033 IF((INDEX).GT.(3))GOTO 19032 L = LINE - 2 + INDEX CALL SMGSWI(TRIPLE,L,INDEX,ILEFT(L),IRIGHT(L)) IF(BLEND(LINE-1) .NE. 2)GOTO 19051 TRIPLE(1) = 0.0 TRIPLE(2) = 0.0 TRIPLE(3) = 0.0 19051 CONTINUE GOTO 19031 19032 CONTINUE CALL FN3LBD(LINE,LEFT,RIGHT,LFTDIO,RHTDIO) CALL SETUPTS(X,LEFT,RIGHT,N) ICENT = NINT(CENTRE(LINE)) PHOTONS = SNR(ICENT)**2 * CONTUM(DBLE(ICENT))/SPEC(ICENT) 19060 I=1 GOTO 19063 19061 I=I+1 19063 IF((I).GT.(3))GOTO 19062 A( (I-1)*3+1 ) = DEPTH(LINE-2+I) A( (I-1)*3+2 ) = CHANNEL(WAVELN(LINE-2+I)) A( (I-1)*3+3 ) = FWHM(LINE-2+I)*0.60056121 IF(FWHM(LINE-2+I) .NE. 0.0)GOTO 19081 WAVE = WAV(A((I-1)*3+2)) CALL GTBSFW(WAVE,DEPTH(LINE-2+I),WIDTH,SIGWDTH,SIG_AV_WIDTH) A( (I-1)*3+3 ) = WIDTH*0.60056121 TRIPLE((I-1)*3+3) = 0.00 19081 CONTINUE GOTO 19061 19062 CONTINUE IF(DABS(CHANNEL(WAVELN(LINE+1))-CHANNEL(WAVELN(LINE))) .GT. 2.0D+0 *0)GOTO 19101 TRIPLE(5) = 0.0 A(5) = CHANNEL(WAVELN(LINE)) TRIPLE(8) = 0.0 A(8) = CHANNEL(WAVELN(LINE+1)) 19101 CONTINUE IF(DABS(CHANNEL(WAVELN(LINE-1))-CHANNEL(WAVELN(LINE))) .GT. 2.0D+0 *0)GOTO 19121 TRIPLE(2) = 0.0 A(2) = CHANNEL(WAVELN(LINE-1)) TRIPLE(5) = 0.0 A(5) = CHANNEL(WAVELN(LINE)) 19121 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,TRIPLE,CHISQ) 19130 I=1 GOTO 19133 19131 I=I+1 19133 IF((I).GT.(3))GOTO 19132 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) CALL CPDELE(A1,A3,COV,TRIPLE,I,LINE-2+I) IF(FWHM(LINE-2+I) .EQ. 0.0)GOTO 19151 FWHM(LINE-2+I) = DABS(A( (I-1)*3+3 ))/0.60056121 19151 CONTINUE GOTO 19131 19132 CONTINUE RETURN END SUBROUTINE FT2GAUS(LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL 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/ 19160 I=1 GOTO 19163 19161 I=I+1 19163 IF((I).GT.(6))GOTO 19162 DOUBLE(I) = 1.0 GOTO 19161 19162 CONTINUE 19170 I=7 GOTO 19173 19171 I=I+1 19173 IF((I).GT.(9))GOTO 19172 DOUBLE(I) = 0.0 GOTO 19171 19172 CONTINUE BLEND(LINE) = 1 BLEND(LINE+1) = -1 19180 INDEX=1 GOTO 19183 19181 INDEX=INDEX+1 19183 IF((INDEX).GT.(2))GOTO 19182 L = LINE -1 + INDEX CALL SMGSWI(DOUBLE,L,INDEX,ILEFT(L),IRIGHT(L)) GOTO 19181 19182 CONTINUE CALL FN2LBD(LINE,LEFT,RIGHT,LFTDIO,RHTDIO) CALL SETUPTS(X,LEFT,RIGHT,N) ICENT = NINT(CENTRE(LINE)) PHOTONS = SNR(ICENT)**2 * CONTUM(DBLE(ICENT))/SPEC(ICENT) 19190 I=1 GOTO 19193 19191 I=I+1 19193 IF((I).GT.(2))GOTO 19192 A( (I-1)*3+1 ) = DEPTH(LINE-1+I) A( (I-1)*3+2 ) = CHANNEL(WAVELN(LINE-1+I)) A( (I-1)*3+3 ) = FWHM(LINE-1+I)*0.60056121 IF(FWHM(LINE-1+I) .NE. 0.0)GOTO 19211 WAVE = WAV(A((I-1)*3+2)) CALL GTBSFW(WAVE,DEPTH(LINE-1+I),WIDTH,SIGWDTH,SIG_AV_WIDTH) A( (I-1)*3+3 ) = WIDTH*0.60056121 DOUBLE((I-1)*3+3) = 0.0 19211 CONTINUE GOTO 19191 19192 CONTINUE IF(DABS(CHANNEL(WAVELN(LINE+1))-CHANNEL(WAVELN(LINE))) .GT. 2.0D+0 *0)GOTO 19231 DOUBLE(2) = 0.0 A(2) = CHANNEL(WAVELN(LINE)) DOUBLE(5) = 0.0 A(5) = CHANNEL(WAVELN(LINE+1)) 19231 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,DOUBLE,CHISQ) 19240 I=1 GOTO 19243 19241 I=I+1 19243 IF((I).GT.(2))GOTO 19242 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) CALL CPDELE(A1,A3,COV,DOUBLE,I,LINE-1+I) IF(FWHM(LINE-1+I) .EQ. 0.0)GOTO 19261 FWHM(LINE-1+I) = DABS(A( (I-1)*3+3 ))/0.60056121 19261 CONTINUE GOTO 19241 19242 CONTINUE RETURN END SUBROUTINE SMGSWI(SWITCH,LINE,INDEX,ILEFT,IRIGHT) IMPLICIT REAL*8(A-H,O-Z) COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF REAL*8 SWITCH(9) INTEGER LINE,INDEX,ILEFT,IRIGHT SWITCH(3*(INDEX-1)+1) = 1.0 SWITCH(3*(INDEX-1)+2) = 0.0 SWITCH(3*(INDEX-1)+3) = 1.0 IF(.NOT.(INST_PROF))GOTO 19281 SWITCH(3*(INDEX-1)+3) = 0.0 19281 CONTINUE IF(ILEFT .GE. 0 .OR. IRIGHT .GE. 0)GOTO 19301 SWITCH(3*(INDEX-1)+3) = 0.0 19301 CONTINUE RETURN END SUBROUTINE FN3LBD(LINE,LEFT,RIGHT,LFTDIO,RHTDIO) IMPLICIT REAL*8(A-H,O-Z) REAL*8 LFTDIO(1000),RHTDIO(1000) INTEGER LINE,LEFT,RIGHT LEFT = INT( LFTDIO(LINE-1) ) IF(INT( LFTDIO(LINE) ) .GE. LEFT)GOTO 19321 LEFT = INT( LFTDIO(LINE) ) 19321 CONTINUE IF(INT( LFTDIO(LINE+1) ) .GE. LEFT)GOTO 19341 LEFT = INT( LFTDIO(LINE+1) ) 19341 CONTINUE RIGHT = INT( RHTDIO(LINE+1) ) IF(INT( RHTDIO(LINE) ) .LE. RIGHT)GOTO 19361 RIGHT = INT( RHTDIO(LINE) ) 19361 CONTINUE IF(INT( RHTDIO(LINE-1) ) .LE. RIGHT)GOTO 19381 RIGHT = INT( RHTDIO(LINE-1) ) 19381 CONTINUE RETURN END SUBROUTINE FN2LBD(LINE,LEFT,RIGHT,LFTDIO,RHTDIO) IMPLICIT REAL*8(A-H,O-Z) REAL*8 LFTDIO(1000),RHTDIO(1000) INTEGER LINE,LEFT,RIGHT LEFT = INT( LFTDIO(LINE) ) RIGHT= INT( RHTDIO(LINE+1) ) IF(INT( LFTDIO(LINE+1) ) .GE. LEFT)GOTO 19401 LEFT = INT( LFTDIO(LINE+1) ) 19401 CONTINUE IF(INT( RHTDIO(LINE) ) .LE. RIGHT)GOTO 19421 RIGHT = INT( RHTDIO(LINE) ) 19421 CONTINUE RETURN END SUBROUTINE SETUPTS(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 19430 I=1 GOTO 19433 19431 I=I+(2) 19433 IF((2)*((I)-(2*N-1)).GT.0)GOTO 19432 X(I) = DBLE(INDEX) X(I+1) = 1.0 - SPEC(INDEX)/CONTUM(DBLE(INDEX)) INDEX = INDEX + 1 GOTO 19431 19432 CONTINUE RETURN END SUBROUTINE RDOLIN(NPTS) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER NPTS REAL*8 A(9),COV(9,9) LOGICAL RHTWGB,DELETED 19440 I=1 GOTO 19443 19441 I=I+1 19443 IF((I).GT.(NREDO))GOTO 19442 CALL FNDRDL(REDO(I),LINE,WAVELN,NOLINES) LFTDIO(LINE) = 0.0 RHTDIO(LINE)= 0.0 ILEFT(LINE) = 0 IRIGHT(LINE)= 0 BLEND(LINE) = 0 CALL FCDNAD(LINE,A,COV,DELETED) IF(.NOT.(DELETED))GOTO 19461 NREDO = NREDO - 1 19470 J=I GOTO 19473 19471 J=J+1 19473 IF((J).GT.(NREDO))GOTO 19472 REDO(J) = REDO(J+1) GOTO 19471 19472 CONTINUE I = I - 1 GOTO 19441 19461 CONTINUE CALL OBFWHML(LINE,A,COV,NPTS) CALL FT1GAUS(LINE) CALL SFTBLS(LINE) GOTO 19441 19442 CONTINUE 19480 I=1 GOTO 19483 19481 I=I+1 19483 IF((I).GT.(NREDO))GOTO 19482 CALL FNDRDL(REDO(I),LINE,WAVELN,NOLINES) IF((.NOT.(RHTWGB(LINE))) .AND. (.NOT.(RHTWGB(LINE-1))))GOTO 19501 CALL FNDSAE(LINE,ISTART,IEND,I) 19510 J=ISTART GOTO 19513 19511 J=J+1 19513 IF((J).GT.(IEND))GOTO 19512 CALL FTBLND(J) GOTO 19511 19512 CONTINUE 19501 CONTINUE GOTO 19481 19482 CONTINUE RETURN END SUBROUTINE FNDSAE(LINE,ISTART,IEND,IREDO) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER LINE,ISTART,IEND,IREDO LOGICAL RHTWGB 19520 IEND=LINE GOTO 19523 19521 IEND=IEND+1 19523 IF((IEND).GT.(NOLINES))GOTO 19522 IF(.NOT.(.NOT. RHTWGB(IEND)))GOTO 19541 GOTO 19522 19541 CONTINUE IF(REDO(IREDO+1) .NE. WAVELN(IEND) .OR. IREDO .GE. NREDO)GOTO 1956 *1 IREDO = IREDO + 1 19561 CONTINUE GOTO 19521 19522 CONTINUE 19570 ISTART=LINE GOTO 19573 19571 ISTART=ISTART+(-1) 19573 IF((-1)*((ISTART)-(1)).GT.0)GOTO 19572 IF(.NOT.(.NOT. RHTWGB(ISTART-1)))GOTO 19591 GOTO 19572 19591 CONTINUE GOTO 19571 19572 CONTINUE RETURN END SUBROUTINE FNDRDL(WAVE,LINE,WAVELN,N) IMPLICIT REAL*8(A-H,O-Z) REAL*8 WAVE,WAVELN(1000) INTEGER LINE,N 19600 LINE=1 GOTO 19603 19601 LINE=LINE+1 19603 IF((LINE).GT.(N))GOTO 19602 IF(WAVE .NE. WAVELN(LINE))GOTO 19621 RETURN 19621 CONTINUE GOTO 19601 19602 CONTINUE RETURN END LOGICAL FUNCTION TLINWS(IDUMMY) IMPLICIT REAL*8(A-H,O-Z) LOGICAL RHTWGB COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER I,IDUMMY REAL*8 LAST NREDO = 0 LAST = 0.0 TLINWS = .FALSE. 19630 I=1 GOTO 19633 19631 I=I+1 19633 IF((I).GT.(NOLINES))GOTO 19632 IF(.NOT.(RHTWGB(I)))GOTO 19651 IF((LINEID(I) .NE. 'TELLURIC ' .OR. LINEID(I+1) .EQ. 'TELLURIC ' %) .AND. (LINEID(I+1) .NE. 'TELLURIC ' .OR. LINEID(I) .EQ. 'TELLUR %IC '))GOTO 19671 TLINWS = .TRUE. IF(NREDO .LT. 100)GOTO 19691 WRITE(8,19700) 19700 FORMAT('MAXIMUM NUMBER OF REDO LINES REACHED') GOTO 19632 19691 CONTINUE IF(LINEID(I+1) .NE. 'TELLURIC ' .OR. WAVELN(I) .EQ. LAST)GOTO 197 %21 NREDO = NREDO + 1 REDO(NREDO) = WAVELN(I) GOTO 19711 19721 IF(LINEID(I) .NE. 'TELLURIC ')GOTO 19731 NREDO = NREDO + 1 REDO(NREDO) = WAVELN(I+1) LAST = REDO(NREDO) 19731 CONTINUE 19711 CONTINUE 19671 CONTINUE 19651 CONTINUE GOTO 19631 19632 CONTINUE RETURN END SUBROUTINE REMBDF(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 19740 I=1 GOTO 19743 19741 I=I+1 19743 IF((I).GT.(NH2O))GOTO 19742 IF(WEIGHT(I) .LT. 0.0)GOTO 19761 FACTOR(COUNT) = FACTOR(I) ERROR(COUNT) = ERROR(I) WEIGHT(COUNT) = WEIGHT(I) SHIFT(COUNT) = SHIFT(I) COUNT = COUNT + 1 19761 CONTINUE GOTO 19741 19742 CONTINUE RETURN END SUBROUTINE SRTFCL(FACTOR,ERROR,WEIGHT,SHIFT,NFAC) IMPLICIT REAL*8(A-H,O-Z) REAL*8 FACTOR(100),ERROR(100),WEIGHT(100),TFACTOR,TWEIGHT,TERROR,S *HIFT(100) REAL*8 TSHIFT INTEGER NFAC,I,J 19770 I=1 GOTO 19773 19771 I=I+1 19773 IF((I).GT.(NFAC - 1))GOTO 19772 19780 J=1 GOTO 19783 19781 J=J+1 19783 IF((J).GT.(NFAC - 1))GOTO 19782 IF(FACTOR(J) .LE. FACTOR(J+1))GOTO 19801 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 19801 CONTINUE GOTO 19781 19782 CONTINUE GOTO 19771 19772 CONTINUE RETURN END SUBROUTINE REMFAC(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 19810 I=J GOTO 19813 19811 I=I+1 19813 IF((I).GT.(NFAC-1))GOTO 19812 FACTOR(I) = FACTOR(I+1) ERROR(I) = ERROR(I+1) WEIGHT(I) = WEIGHT(I+1) SHIFT(I) = SHIFT(I+1) GOTO 19811 19812 CONTINUE RETURN END SUBROUTINE DIVTEL(SPCTRUM,NPTS) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK REAL*8 SPCTRUM(1000000) INTEGER NPTS,I,J 19820 I=1 GOTO 19823 19821 I=I+1 19823 IF((I).GT.(NOLINES))GOTO 19822 IF(LINEID(I) .NE. 'TELLURIC ')GOTO 19841 LIMIT1 = NINT(CENTRE(I)-2.0*FWHM(I)) LIMIT2 = NINT(CENTRE(I)+2.0*FWHM(I)) IF(LIMIT1 .GE. 1)GOTO 19861 LIMIT1 = 1 GOTO 19851 19861 IF(LIMIT2 .LE. NPTS)GOTO 19871 LIMIT2 = NPTS 19871 CONTINUE 19851 CONTINUE A1 = DEPTH(I) A2 = CENTRE(I) A3 = FWHM(I)*0.60056121 19880 J=LIMIT1 GOTO 19883 19881 J=J+1 19883 IF((J).GT.(LIMIT2))GOTO 19882 FACTOR = 1.0 - A1*EXP(-( (A2-DBLE(J))/A3 )**2) SPCTRUM(J) = SPCTRUM(J)/FACTOR GOTO 19881 19882 CONTINUE 19841 CONTINUE GOTO 19821 19822 CONTINUE RETURN END SUBROUTINE RMTLFL IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER I 19890 I=1 GOTO 19893 19891 I=I+1 19893 IF((I).GT.(NOLINES))GOTO 19892 IF(LINEID(I) .NE. 'TELLURIC ')GOTO 19911 CALL REMFLS(I) I = I - 1 19911 CONTINUE GOTO 19891 19892 CONTINUE RETURN END SUBROUTINE FITDSP IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK REAL*8 X(100),Y(100) INTEGER EXCLUDE IF(NORFLN .LE. NOGDLN)GOTO 19931 RETURN 19931 CONTINUE EXCLUDE = 0 19940 I=1 GOTO 19943 19941 I=I+1 19943 IF((I).GT.(NOGDLN))GOTO 19942 IF(WAVELN(GOOD(I)) .LE. 0.0 .OR. DABS( CENTRE(GOOD(I))-CHANNEL(WAV *ELN(GOOD(I))) ) .GE. 1.5)GOTO 19961 X(I-EXCLUDE) = CENTRE(GOOD(I)) Y(I-EXCLUDE) = WAVELN(GOOD(I)) GOTO 19971 19961 CONTINUE EXCLUDE = EXCLUDE + 1 19971 CONTINUE 19951 CONTINUE GOTO 19941 19942 CONTINUE N = NOGDLN - EXCLUDE CALL FITLINE(X,Y,N,DISP,OFFSET) IF(N .LE. 2)GOTO 19991 CALL PARABOL(X,Y,N,DISP2,DISP1,OFFSET) 19991 CONTINUE RETURN END SUBROUTINE MEASEW(LINE) IMPLICIT REAL*8(A-H,O-Z) REAL*8 WIDTH,DEEP,PI INTEGER LINE,ICENTRE COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL LOGICAL LINIWD PI = 3.141592654D+0 IF((NOGDLN .LT. 2 .OR. INCPT .LE. 0.0) .AND. (.NOT.(FIXFWHM)))GOTO * 20011 ICENTRE = NINT(CENTRE(LINE)) DEEP = 1.0 - SPEC(ICENTRE)/CONTUM(DBLE(ICENTRE)) WAVE = WAV(CENTRE(LINE)) CALL GTBSFW(WAVE,DEEP,WIDTH,SIGWDTH,SIG_AV_WIDTH) GOTO 20001 20011 IF(FWHM(LINE) .NE. 0.0)GOTO 20021 WRITE(8,20030)LINE 20030 FORMAT (' CANNOT DEFINE AN EW FOR LINE ',I3,' BECAUSE NO FWHM-DEPT %H RELATION', ' EXISTS') EW(LINE) = 0.0 RETURN GOTO 20041 20021 CONTINUE WIDTH = FWHM(LINE) 20041 CONTINUE 20001 CONTINUE IF((.NOT.(LINIWD(WAVELN(LINE)))) .AND. (SIGWDTH .NE. 0.0))GOTO 200 *61 EW(LINE) = FWHM(LINE)*DEPTH(LINE)*0.60056121*DMYSQ(PI) * DISP*1000 *.0 DELTEW(LINE)= DELTEW(LINE) * EW(LINE) RETURN 20061 CONTINUE IF((DABS(1.0-FWHM(LINE)/WIDTH) .LE. 3.0*SIGWDTH/WIDTH) .AND. (FWHM *(LINE) .NE. 0.0 .OR. DEPTH(LINE) .GT. 0.60))GOTO 20081 EW(LINE) = WIDTH*DEEP*0.60056121*DMYSQ(PI)*DISP*1000.0 DELTEW(LINE) = DELTEW(LINE) * EW(LINE) AREA = FWHM(LINE)*DEPTH(LINE)*0.60056121*DMYSQ(PI) * DISP*1000.0 WRITE(8,20090)LINEID(LINE),WAVELN(LINE),FWHM(LINE),AREA,WIDTH,EW(L *INE) 20090 FORMAT (' 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,' DIOD %ES GAVE AN EW OF ',F7.2) FWHM(LINE) = WIDTH GOTO 20101 20081 CONTINUE EW(LINE) = FWHM(LINE)*DEPTH(LINE)*0.60056121*DMYSQ(PI) * DISP*1000 *.0 DELTEW(LINE)= DELTEW(LINE) * EW(LINE) 20101 CONTINUE 20071 CONTINUE RETURN END LOGICAL FUNCTION LINIWD(WAVE) IMPLICIT REAL*8(A-H,O-Z) REAL*8 WAVE COMMON/WIDLIN/WIDE(50) REAL*8 WIDE COMMON/IWIDLI/IWIDE INTEGER IWIDE LINIWD = .FALSE. 20110 I=1 GOTO 20113 20111 I=I+1 20113 IF((I).GT.(IWIDE))GOTO 20112 IF(WIDE(I) .NE. WAVE)GOTO 20131 LINIWD = .TRUE. GOTO 20112 20131 CONTINUE GOTO 20111 20112 CONTINUE RETURN END SUBROUTINE PFWDPF(TITLE) IMPLICIT REAL*8(A-H,O-Z) COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL 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 )') 20140 I=1 GOTO 20143 20141 I=I+1 20143 IF((I).GT.(NOLINES))GOTO 20142 IF(FWHM(I) .EQ. 0.0 .OR. FWHM(I) .GE. MINFWHM)GOTO 20161 MINFWHM = FWHM(I) GOTO 20151 20161 IF(FWHM(I) .EQ. 0.0 .OR. FWHM(I) .LE. MAXFWHM)GOTO 20171 MAXFWHM = FWHM(I) 20171 CONTINUE 20151 CONTINUE IF(DEPTH(I) .LE. MAXDEP)GOTO 20191 MAXDEP = DEPTH(I) 20191 CONTINUE GOTO 20141 20142 CONTINUE 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 )') 20200 I=1 GOTO 20203 20201 I=I+1 20203 IF((I).GT.(NOGDLN))GOTO 20202 WAVE = WAVELN(GOOD(I)) CALL FNDORD(WAVE,IORDER) DELTA_W = DABS( WAVE - WAV(CHANNEL(WAVE)+1.0D+00) ) FAC = WAVE/DELTA_W R = FAC/FWHM(GOOD(I)) GOTO 20201 20202 CONTINUE WRITE(9,'(10H MARKER 3 )') J = 1 20210 I=1 GOTO 20213 20211 I=I+1 20213 IF((I).GT.(NOLINES))GOTO 20212 IF(I .NE. GOOD(J))GOTO 20231 J = J + 1 GOTO 20211 20231 CONTINUE WAVE = WAVELN(I) CALL FNDORD(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 GOTO 20211 20212 CONTINUE WRITE(9,'(6H LINE )') WRITE(9,'(10H NOMARKER )') IF(WIDFLG .NE. -1)GOTO 20251 RETURN GOTO 20241 20251 IF(WIDFLG .NE. 0)GOTO 20261 WRITE(9,'(6H 0.0 ,F13.4,/,6H 0.5 ,F13.4)')INCPT,INCPT GOTO 20271 20261 CONTINUE WIDTH = MINIDP * SLOPE + INCPT WRITE(9,'(6H 0.0 ,F13.4)')WIDTH WRITE(9,'(1H ,F7.4,2X,F13.4)')MINIDP,WIDTH WIDTH = 0.5 * SLOPE + INCPT WRITE(9,'(6H 0.5 ,F13.4)')WIDTH 20271 CONTINUE 20241 CONTINUE RETURN END SUBROUTINE PRHLFL IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK OPEN(UNIT=13,FILE='H2OLIST',STATUS='OLD') REWIND 13 WRITE(13,20280)SLOPE,INCPT,MINIDP 20280 FORMAT(F12.9,2X,F15.9,2X,F15.9) 20290 I=1 GOTO 20293 20291 I=I+1 20293 IF((I).GT.(NOLINES))GOTO 20292 WRITE(13,20300)CENTRE(I),FWHM(I),DEPTH(I) 20300 FORMAT ('TELLURIC ',F10.3,F10.5,F10.7) GOTO 20291 20292 CONTINUE RETURN END SUBROUTINE WRHDRS COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS WRITE(10,20310)SPTITLE 20310 FORMAT (A80) WRITE(10,20320)CURSPC,CURORD,CURIMR 20320 FORMAT ('SPECTRUM ',I3,', ORDER ',I3,', IMAGE ROW ',I3) WRITE(12,20330)SPTITLE 20330 FORMAT (A80) WRITE(12,20340)CURSPC,CURORD,CURIMR 20340 FORMAT ('SPECTRUM ',I3,', ORDER ',I3,', IMAGE ROW ',I3) WRITE(15,20350)SPTITLE 20350 FORMAT (A80) WRITE(15,20360)CURSPC,CURORD,CURIMR 20360 FORMAT ('SPECTRUM ',I3,', ORDER ',I3,', IMAGE ROW ',I3) RETURN END SUBROUTINE PRDMIF(RV,TITLE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK CHARACTER*80 TITLE INTEGER I 20370 I=1 GOTO 20373 20371 I=I+1 20373 IF((I).GT.(NOLINES))GOTO 20372 IF(LINEID(I)(1:4) .EQ. 'JUNK')GOTO 20391 WRITE(10,20400)LINEID(I)(1:5),WAVELN(I),ATOM(I),EPLOW(I),GF(I),EW( *I) 20400 FORMAT (A5,F10.3,F10.1,F10.3,10X,F10.3,20X,F5.1) WRITE(12,20410)LINEID(I)(1:5),WAVELN(I),ATOM(I),EPLOW(I),GF(I),DEP *TH(I) 20410 FORMAT (A5,F10.3,F10.1,F10.3,10X,F10.3,20X,F5.3) WRITE(15,20420)WAVELN(I),ATOM(I),EPLOW(I),GF(I),EW(I) 20420 FORMAT (F10.3,F10.1,F10.3,F10.3,20X,F10.1) 20391 CONTINUE GOTO 20371 20372 CONTINUE CALL FLUSH RETURN END SUBROUTINE PRSPPF(TITLE,NPTS) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) CHARACTER*80 TITLE INTEGER NPTS,I,J,LEFT,RIGHT LOGICAL BADPLT SCREEN =.FALSE. CALL DETPLB (NPTS) IF(NPLOTS .LE. 0)GOTO 20441 20450 I=1 GOTO 20453 20451 I=I+1 20453 IF((I).GT.(NPLOTS))GOTO 20452 XLENGTH = DBLE( NPLOTR(I)-NPLOTL(I)+1 )*2.54/20.0 IF(.NOT.(BADPLT(WPLOTL(I),WPLOTR(I),NPTS)))GOTO 20471 GOTO 20451 20471 CONTINUE CALL PHINFP(TITLE,WPLOTL(I),WPLOTR(I),0.0D0, 1.1001D0,XLENGTH) CALL PRNTFX(NPLOTL(I),NPLOTR(I)) CALL PRNTCN(NPLOTL(I),NPLOTR(I)) CALL PRTLNF(I) GOTO 20451 20452 CONTINUE GOTO 20431 20441 IF(.NOT.(PLOTALL))GOTO 20481 I = 1 XLENGTH = NPTS*2.54/20.0 WPLOTL(1) = WAV(1.0D0) WPLOTR(1) = WAV( DBLE(NPTS) ) NPLOTL(1) = 1 NPLOTR(1) = NPTS CALL PHINFP(TITLE,WPLOTL(1),WPLOTR(1),0.0D0,1.1001D0,XLENGTH) CALL PRNTFX(NPLOTL(1),NPLOTR(1)) CALL PRNTCN(NPLOTL(1),NPLOTR(1)) CALL PRTLNF(I) 20481 CONTINUE 20431 CONTINUE RETURN END SUBROUTINE DETPLB (NPTS) IMPLICIT REAL*8(A-H,O-Z) INTEGER NPTS,I COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) 20490 I=1 GOTO 20493 20491 I=I+1 20493 IF((I).GT.(NPLOTS))GOTO 20492 NPLOTL(I) = NINT( CHANNEL(WPLOTL(I)) ) IF(NPLOTL(I) .GE. 1)GOTO 20511 NPLOTL(I) = 1 20511 CONTINUE NPLOTR(I) = NINT( CHANNEL(WPLOTR(I)) ) IF(NPLOTR(I) .LE. NPTS)GOTO 20531 NPLOTL(I) = NPTS 20531 CONTINUE WPLOTL(I) = WAV( DBLE(NPLOTL(I)) ) WPLOTR(I) = WAV( DBLE(NPLOTR(I)) ) GOTO 20491 20492 CONTINUE RETURN END LOGICAL FUNCTION BADPLT(WAVEL,WAVER,NPTS) IMPLICIT REAL*8(A-H,O-Z) INTEGER NPTS BADPLT = .FALSE. ENDWAV = WAV(DBLE(NPTS)) IF(WAVEL .GT. WAV(0.0D0))GOTO 20551 IF(WAVER .GT. WAV(41.0D0))GOTO 20571 BADPLT = .TRUE. 20571 CONTINUE WAVEL = WAV(1.0D0) GOTO 20541 20551 IF(WAVER .LE. ENDWAV)GOTO 20581 IF(WAVEL .LE. WAV(DBLE(NPTS-41)))GOTO 20601 BADPLT = .TRUE. 20601 CONTINUE WAVER = ENDWAV 20581 CONTINUE 20541 CONTINUE RETURN END SUBROUTINE PHINFP(TITLE,XMIN,XMAX,YMIN,YMAX,XLENGTH) IMPLICIT REAL*8(A-H,O-Z) CHARACTER*80 TITLE REAL*8 XMIN,XMAX,XLENGTH WRITE(11,20610)TITLE(1:50) 20610 FORMAT (8H TITLE $,A50,1H$) WRITE(11,20620) 20620 FORMAT (' XLABEL /WAVELENGTH (A)/') WRITE(11,20630) 20630 FORMAT (23H YLABEL /RELATIVE FLUX/) WRITE(11,20640)XLENGTH 20640 FORMAT (9H XLENGTH ,F6.2) WRITE(11,20650) 20650 FORMAT (14H YLENGTH 24.5 ) WRITE(11,20660) 20660 FORMAT (14H XFORMAT F6.0 ) WRITE(11,20670) 20670 FORMAT (14H YFORMAT F5.2 ) WRITE(11,20680)XMIN 20680 FORMAT (6H XMIN ,F6.1) WRITE(11,20690)XMAX 20690 FORMAT (6H XMAX ,F6.1) WRITE(11,20700)YMIN 20700 FORMAT (6H YMIN ,F10.6) WRITE(11,20710)YMAX 20710 FORMAT (6H YMAX ,F10.6) RETURN END SUBROUTINE PRNTFX(LEFT,RIGHT) IMPLICIT REAL*8(A-H,O-Z) INTEGER LEFT,RIGHT WRITE(11,20720) 20720 FORMAT(10H MARKER 3 ) WRITE(11,20730) 20730 FORMAT(8H NOLINE ) WRITE(11,20740) 20740 FORMAT(' COLOR BLUE ') 20750 I=LEFT GOTO 20753 20751 I=I+1 20753 IF((I).GT.(RIGHT))GOTO 20752 WAVE = WAV(DBLE(I)) FLUX = SPEC(I) WRITE(11,20760)WAVE,FLUX 20760 FORMAT (F10.3,2X,F10.6) GOTO 20751 20752 CONTINUE RETURN END SUBROUTINE PRNTCN(LEFT,RIGHT) IMPLICIT REAL*8(A-H,O-Z) INTEGER LEFT,RIGHT,I REAL*8 WAVE,FLUX WRITE(11,20770) 20770 FORMAT(10H NOMARKER ,/,6H LINE ,/,13H COLOR GREEN ) 20780 I=LEFT GOTO 20783 20781 I=I+1 20783 IF((I).GT.(RIGHT))GOTO 20782 WAVE = WAV(DBLE(I)) FLUX = CONTUM(DBLE(I)) WRITE(11,20790)WAVE,FLUX 20790 FORMAT (F10.3,2X,F10.6) GOTO 20781 20782 CONTINUE RETURN END SUBROUTINE PRTLNF(IPLOT) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK REAL*8 POSN,LEFT,RIGHT,LEFT1,RIGHT1,FLUX0,FLUX1,FLUX2 INTEGER IPLOT,LINE,INEXT,ILAST LOGICAL LNOOBD POSN = 0.0 20800 LINE=1 GOTO 20803 20801 LINE=LINE+1 20803 IF((LINE).GT.(NOLINES))GOTO 20802 INEXT = LINE + 1 ILAST = LINE - 1 CALL GETLNB(LINE,LEFT,RIGHT) CALL GETLNB(INEXT,LEFT1,RIGHT1) IF(LEFT1 .NE. LEFT)GOTO 20821 LEFT1 = RIGHT 20821 CONTINUE IF(POSN .GE. LEFT)GOTO 20841 POSN = LEFT 20841 CONTINUE IF(.NOT.(LNOOBD(LEFT,RIGHT,IPLOT)))GOTO 20861 GOTO 20801 20861 CONTINUE IF((BLEND(LINE) .NE. 0) .AND. (BLEND(LINE) .NE. 1))GOTO 20881 WRITE(11,20890) 20890 FORMAT(' NOMARKER ',/,' LINE ',/,' COLOR RED ',/) 20881 CONTINUE CALL OPCRLF(LINE,POSN,BLEND(LINE),LEFT1,RIGHT) GOTO 20801 20802 CONTINUE WRITE(11,20900) 20900 FORMAT(' COLOR BLACK ',/) RETURN END SUBROUTINE GETLNB(LINE,LEFT,RIGHT) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/ROTCOM/ VSINI REAL*8 VSINI REAL*8 LEFT,RIGHT,WIDTH,VWIDTH,PI INTEGER LINE PI = 3.141592654 LEFT = 0.0 RIGHT = 0.0 IF(LINE .LE. NOLINES)GOTO 20921 RETURN GOTO 20911 20921 IF(DABS(DEPTH(LINE)) .GT. 1.0D-8)GOTO 20931 RETURN 20931 CONTINUE 20911 CONTINUE 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 .LE. 50.0)GOTO 20951 LEFT = CENT - 50.0 RIGHT = CENT + 50.0 20951 CONTINUE RETURN END LOGICAL FUNCTION LNOOBD(LEFT,RIGHT,IPLOT) IMPLICIT REAL*8(A-H,O-Z) COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) REAL*8 LEFT,RIGHT,PLEFT,PRIGHT INTEGER IPLOT LNOOBD = .TRUE. IF(.NOT.(SCREEN))GOTO 20971 PLEFT = DBLE(SCLEFT) PRIGHT= DBLE(SCRGHT) GOTO 20981 20971 CONTINUE PLEFT = DBLE(NPLOTL(IPLOT)) PRIGHT= DBLE(NPLOTR(IPLOT)) 20981 CONTINUE 20961 CONTINUE IF(LEFT .GE. PLEFT)GOTO 21001 IF(RIGHT .GE. PLEFT)GOTO 21021 RETURN 21021 CONTINUE LEFT = PLEFT GOTO 20991 21001 IF(RIGHT .LE. PRIGHT)GOTO 21031 IF(LEFT .LE. PRIGHT)GOTO 21051 RETURN 21051 CONTINUE RIGHT = PRIGHT 21031 CONTINUE 20991 CONTINUE LNOOBD = .FALSE. RETURN END SUBROUTINE OPCRLF(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/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) INEXT = LINE+1 ILAST = LINE-1 FIRST = .TRUE. 21060 CONTINUE 21061 CONTINUE CALL EVALNF(LINE,POSN,FLUX0) 21070 INEXT=LINE+1 GOTO 21073 21071 INEXT=INEXT+1 21073 IF((INEXT).GT.(LINE+2))GOTO 21072 CALL EVALNF(INEXT,POSN,FLUX1) FLUX0 = FLUX0 + FLUX1 GOTO 21071 21072 CONTINUE 21080 ILAST=LINE-1 GOTO 21083 21081 ILAST=ILAST+(-1) 21083 IF((-1)*((ILAST)-(LINE-2)).GT.0)GOTO 21082 CALL EVALNF(ILAST,POSN,FLUX1) FLUX0 = FLUX0 + FLUX1 GOTO 21081 21082 CONTINUE FLUX0 = (1.0 - FLUX0)*CONTUM(POSN) IF(.NOT.(SCREEN))GOTO 21101 IF(.NOT.(FIRST))GOTO 21121 CALL PGP_MOVEA(WAV(POSN),FLUX0) FIRST = .FALSE. 21121 CONTINUE CALL PLTLFX(POSN,FLUX0) GOTO 21131 21101 CONTINUE CALL PRNTPT(POSN,FLUX0) 21131 CONTINUE 21091 CONTINUE IF(BLEND .GT. 0)GOTO 21151 IF((POSN .LT. LEFT1 .OR. LEFT1 .LE. 0.0) .AND. (POSN .LT. RIGHT))G *OTO 21171 GOTO 21062 21171 CONTINUE 21151 CONTINUE IF((POSN .LT. LEFT1 .OR. LEFT1 .LE. 0.0) .AND. (POSN .LT. RIGHT))G *OTO 21191 GOTO 21062 21191 CONTINUE POSN = POSN + 0.25 GOTO 21061 21062 CONTINUE RETURN END SUBROUTINE EVALNF(LINE,POSN,FLUX) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/ROTCOM/ VSINI REAL*8 VSINI 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 21200 I=4 GOTO 21203 21201 I=I+1 21203 IF((I).GT.(9))GOTO 21202 SW(I) = 0.0 GOTO 21201 21202 CONTINUE FLUX = 0.0 IF((LINE .GT. 0) .AND. (LINE .LE. NOLINES))GOTO 21221 FLUX = 0.0 RETURN 21221 CONTINUE IF(FWHM(LINE) .NE. 0.0)GOTO 21241 RETURN 21241 CONTINUE FLUX = PROFILE(POSN, A, SW, VSINI) RETURN END SUBROUTINE PRNTPT(POSN,FLUX) IMPLICIT REAL*8(A-H,O-Z) REAL*8 POSN,FLUX WRITE(11,21250)WAV(POSN),FLUX 21250 FORMAT (F10.3,2X,F10.6) RETURN END SUBROUTINE PTSCPL(NPTS) IMPLICIT REAL*8(A-H,O-Z) COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) INTEGER START,FINISH,NPTS,LPG,PGOPEN LOGICAL PLWIISP IF(.NOT.(.NOT. SCREEN))GOTO 21271 RETURN 21271 CONTINUE SOFT_DEVICE = '/GTERM' CALL PGBEG(14,SOFT_DEVICE,1,1) CALL PGASK(.FALSE.) CALL CONPLT CALL INTUSR(I,ISHIFT) IF(NPLOTS .LE. 0)GOTO 21291 CALL DETPLB (NPTS) WSTART = WAV(1.0D0) WEND = WAV( DBLE(NPTS) ) 21300 I=1 GOTO 21303 21301 I=I+1 21303 IF((I).GT.(NPLOTS))GOTO 21302 IF(.NOT.(PLWIISP (WSTART,WEND,I)))GOTO 21321 START = NPLOTL(I) FINISH= NPLOTR(I) CNPLTG = .FALSE. CALL LFTSPC(START,FINISH,I) 21321 CONTINUE GOTO 21301 21302 CONTINUE GOTO 21281 21291 IF(.NOT.(PLOTALL))GOTO 21331 START = 1 FINISH= NPTS CNPLTG = .FALSE. CALL LFTSPC(START,FINISH,I) 21331 CONTINUE 21281 CONTINUE CALL PGEND RETURN END LOGICAL FUNCTION PLWIISP (WSTART,WEND,NPLOT) IMPLICIT REAL*8(A-H,O-Z) COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) COMMON/IBADD/ NOBAD,IBADL(1000),IBADR(1000), IGROW INTEGER NOBAD,IBADL,IBADR,IGROW PLWIISP = .FALSE. IF(WPLOTR(NPLOT) .LE. WSTART .OR. WPLOTL(NPLOT) .GE. WEND)GOTO 213 *51 21360 I=1 GOTO 21363 21361 I=I+1 21363 IF((I).GT.(NOBAD))GOTO 21362 IF(NPLOTL(NPLOT) .LT. IBADL(I) .OR. NPLOTR(NPLOT) .GT. IBADR(I))GO *TO 21381 RETURN 21381 CONTINUE GOTO 21361 21362 CONTINUE PLWIISP = .TRUE. 21351 CONTINUE RETURN END SUBROUTINE LFTSPC(START,FINISH,IPLOT) IMPLICIT REAL*8(A-H,O-Z) INTEGER IEND,START,FINISH,IPLOT,ISHIFT,J LOGICAL EMPTY J = IPLOT 21390 CONTINUE 21391 CONTINUE IF(FINISH-START .LE. 110)GOTO 21411 IEND = START + 100 CALL PLTSCR(START,IEND,EMPTY) IF(.NOT.(EMPTY))GOTO 21431 START = IEND + 100 GOTO 21391 21431 CONTINUE CALL DSPLUS(ISHIFT) CALL MRKLIN CALL INTUSR(J,ISHIFT) IF(J .EQ. IPLOT)GOTO 21451 IPLOT = J GOTO 21392 21451 CONTINUE IF(IEND+ISHIFT .LT. 1)GOTO 21471 START = IEND + ISHIFT GOTO 21481 21471 CONTINUE START = 1 21481 CONTINUE 21461 CONTINUE GOTO 21401 21411 IF(FINISH-START .LT. 10)GOTO 21491 CALL PLTSCR(START,FINISH,EMPTY) IF(.NOT.(EMPTY))GOTO 21511 START = IEND + 100 GOTO 21391 21511 CONTINUE CALL DSPLUS(ISHIFT) CALL MRKLIN CALL INTUSR(IPLOT,ISHIFT) START = START + ISHIFT + 100 IF(ISHIFT .NE. 0)GOTO 21531 GOTO 21392 21531 CONTINUE GOTO 21541 21491 CONTINUE RETURN 21541 CONTINUE 21401 CONTINUE GOTO 21391 21392 CONTINUE RETURN END SUBROUTINE PLTSCR(ISTART,IEND,EMPTY) IMPLICIT REAL*8(A-H,O-Z) LOGICAL EMPTY EMPTY = .FALSE. CALL SETWIN CALL SEDWIN(ISTART,IEND,XMIN,XMAX,YMIN,YMAX) IF(YMAX .GT. 0.0)GOTO 21561 EMPTY = .TRUE. RETURN 21561 CONTINUE CALL PGPAGE CALL PLDTAY(ISTART,IEND) CALL PLTCTM(ISTART,IEND) CALL PGP_BOX(XMIN,XMAX,YMIN,YMAX) RETURN END SUBROUTINE SETWIN IMPLICIT REAL*8(A-H,O-Z) IXMIN = 100 IXMAX = 900 IYMIN = 275 IYMAX = 750 CALL PGP_TWINDO(IXMIN,IXMAX,IYMIN,IYMAX) RETURN END SUBROUTINE SEDWIN(ISTART,IEND,XMIN,XMAX,YMIN,YMAX) IMPLICIT REAL*8(A-H,O-Z) COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) SCLEFT = ISTART SCRGHT= IEND XMIN = WAV(DBLE(ISTART)) XMAX = WAV(DBLE(IEND)) CALL FNDMIN(ISTART,IEND,YMIN) CALL FNDMAD(ISTART,IEND,YMAX) CALL FDMXCT(ISTART,IEND,CMAX) IF(CMAX .LE. YMAX)GOTO 21581 YMAX = CMAX 21581 CONTINUE YRANGE = YMAX - YMIN YMAX = YMAX + 0.05*YRANGE YMIN = YMIN - 0.05*YRANGE IF(YRANGE .NE. 0.0)GOTO 21601 YMAX = 1.05*YMAX YMIN = 0.95*YMIN 21601 CONTINUE IF(YMIN .GE. 0.0)GOTO 21621 YMIN = 0.0 21621 CONTINUE CALL PGP_DWINDO(XMIN,XMAX,YMIN,YMAX) RETURN END REAL*8 FUNCTION WAV(POSN) IMPLICIT REAL*8(A-H,O-Z) REAL*8 POSN,XI(50) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON/DNONLIN/PIXMIN,PIXMAX,PMIDDLE,PRANGE,C REAL*8 PIXMIN,PIXMAX,PMIDDLE,PRANGE,C(50) COMMON/LNONLIN/NON_LINEAR LOGICAL NON_LINEAR COMMON/NNONLIN/NTERMS INTEGER NTERMS WAV = OFFSET + DISP*(POSN-PIX_OFFSET) IF(.NOT.(NON_LINEAR))GOTO 21641 WAV = 0.0d0 21650 I=1 GOTO 21653 21651 I=I+1 21653 IF((I).GT.(NTERMS))GOTO 21652 CALL COMPXI(POSN,XI) WAV = WAV + C(I)*XI(I) GOTO 21651 21652 CONTINUE 21641 CONTINUE WAV = WAV / (1.0+RV/3.0D+05) RETURN END SUBROUTINE COMPXI(P,XI) IMPLICIT REAL*8(A-H,O-Z) REAL*8 P,XN,XI(50) COMMON/DNONLIN/PIXMIN,PIXMAX,PMIDDLE,PRANGE,C REAL*8 PIXMIN,PIXMAX,PMIDDLE,PRANGE,C(50) COMMON/LNONLIN/NON_LINEAR LOGICAL NON_LINEAR COMMON/NNONLIN/NTERMS INTEGER NTERMS XN = (P-PMIDDLE)/(0.5d0*PRANGE) XI(1) = 1.0d0 XI(2) = XN 21660 I=3 GOTO 21663 21661 I=I+1 21663 IF((I).GT.(NTERMS))GOTO 21662 XI(I) = (DBLE(2*I-3)*XN*XI(I-1) - DBLE(I-2)*XI(I-2)) / DBLE(I-1) GOTO 21661 21662 CONTINUE RETURN END REAL*8 FUNCTION CHANNEL(W) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON/DNONLIN/PIXMIN,PIXMAX,PMIDDLE,PRANGE,C REAL*8 PIXMIN,PIXMAX,PMIDDLE,PRANGE,C(50) COMMON/LNONLIN/NON_LINEAR LOGICAL NON_LINEAR COMMON/NNONLIN/NTERMS INTEGER NTERMS REAL*8 POSN W0 = W * (1.0+RV/3.0D+05) CHANNEL = PIX_OFFSET + (W0-OFFSET)/DISP IF(.NOT.(NON_LINEAR))GOTO 21681 CALL GTNLCHAN(W0,POSN) CHANNEL = POSN 21681 CONTINUE RETURN END SUBROUTINE GTNLCHAN(W,POSN) IMPLICIT REAL*8 (A-H,O-Z) COMMON/DNONLIN/PIXMIN,PIXMAX,PMIDDLE,PRANGE,C REAL*8 PIXMIN,PIXMAX,PMIDDLE,PRANGE,C(50) COMMON/LNONLIN/NON_LINEAR LOGICAL NON_LINEAR COMMON/NNONLIN/NTERMS INTEGER NTERMS P1 = PIXMIN P2 = PIXMAX WA = WAV(P1) WB = WAV(P2) F = 1.00d0 21690 CONTINUE 21691 CONTINUE PEST = P1 + F*(P2-P1)*(W-WA)/(WB-WA) IF(WAV(PEST) .GE. W)GOTO 21711 P1 = PEST WA = WAV(P1) F = F * 2.0 GOTO 21701 21711 IF(WAV(PEST) .LE. W)GOTO 21721 P2 = PEST WB = WAV(P2) F = F * 0.5d0 21721 CONTINUE 21701 CONTINUE IF(DABS(P2-P1).LE.0.1)GOTO 21692 GOTO 21691 21692 CONTINUE POSN = PEST RETURN END SUBROUTINE FNDMIN(ISTART,IEND,YMIN) IMPLICIT REAL*8(A-H,O-Z) LOGICAL BADIOD INTEGER ISTART,IEND REAL*8 YMIN YMIN = SPEC(ISTART) 21730 I=ISTART GOTO 21733 21731 I=I+1 21733 IF((I).GT.(IEND))GOTO 21732 IF(SPEC(I) .GE. YMIN .OR. .NOT.(.NOT.BADIOD(I)))GOTO 21751 YMIN = SPEC(I) 21751 CONTINUE GOTO 21731 21732 CONTINUE YMIN = YMIN RETURN END SUBROUTINE FDMNMX(ISTART,IEND,Y,YMIN,YMAX) IMPLICIT REAL*8(A-H,O-Z) LOGICAL BADIOD INTEGER ISTART,IEND REAL*8 Y(1000),YMIN,YMAX YMAX = Y(ISTART) YMIN = Y(ISTART) 21760 I=ISTART GOTO 21763 21761 I=I+1 21763 IF((I).GT.(IEND))GOTO 21762 IF(Y(I) .LE. YMAX)GOTO 21781 YMAX = Y(I) GOTO 21771 21781 IF(Y(I) .GE. YMIN)GOTO 21791 YMIN = Y(I) 21791 CONTINUE 21771 CONTINUE GOTO 21761 21762 CONTINUE RETURN END SUBROUTINE FNDMAD(ISTART,IEND,YMAX) IMPLICIT REAL*8(A-H,O-Z) LOGICAL BADIOD INTEGER ISTART,IEND REAL*8 YMAX YMAX = SPEC(ISTART) 21800 I=ISTART GOTO 21803 21801 I=I+1 21803 IF((I).GT.(IEND))GOTO 21802 IF(SPEC(I) .LE. YMAX .OR. .NOT.(.NOT.BADIOD(I)))GOTO 21821 YMAX = SPEC(I) 21821 CONTINUE GOTO 21801 21802 CONTINUE YMAX = YMAX RETURN END SUBROUTINE FDMXCT(ISTART,IEND,YMAX) IMPLICIT REAL*8(A-H,O-Z) INTEGER ISTART,IEND REAL*8 YMAX YMAX = CONTUM(DBLE(ISTART)) 21830 I=ISTART GOTO 21833 21831 I=I+1 21833 IF((I).GT.(IEND))GOTO 21832 IF(CONTUM(DBLE(I)) .LE. YMAX)GOTO 21851 YMAX = CONTUM(DBLE(I)) 21851 CONTINUE GOTO 21831 21832 CONTINUE RETURN END SUBROUTINE PLDTAY(ISTART,IEND) IMPLICIT REAL*8(A-H,O-Z) COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) INTEGER N,I REAL*4 XPLOT(1000000),YPLOT(1000000) LOGICAL CENTER N = IEND-ISTART+1 21860 I=1 GOTO 21863 21861 I=I+1 21863 IF((I).GT.(N))GOTO 21862 YPLOT(I) = REAL(SPEC(I+ISTART-1)) XPLOT(I) = REAL(WAV(DBLE(I+ISTART-1))) GOTO 21861 21862 CONTINUE IF(.NOT.(CONNECT))GOTO 21881 CALL PGLINE(N,XPLOT,YPLOT) GOTO 21871 21881 IF(.NOT.(BINNED))GOTO 21891 CENTER = .TRUE. CALL PGBIN(N,XPLOT,YPLOT,CENTER) GOTO 21901 21891 CONTINUE CALL PGPT(N,XPLOT,YPLOT,2) 21901 CONTINUE 21871 CONTINUE RETURN END SUBROUTINE SETPLTYP IMPLICIT REAL*8(A-H,O-Z) COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) CHARACTER*1 ANS CALL DISPRM WRITE(6,21910) 21910 FORMAT(' Enter spectrum plotting method: (P)oints, (C)onnected, (B %)inned') CALL DISPRM READ(5,*)ANS BINNED = .FALSE. CONNECT = .FALSE. IF((ANS .NE. 'c') .AND. (ANS .NE. 'C'))GOTO 21931 CONNECT = .TRUE. GOTO 21921 21931 IF((ANS .NE. 'b') .AND. (ANS .NE. 'B'))GOTO 21941 BINNED = .TRUE. 21941 CONTINUE 21921 CONTINUE RETURN END SUBROUTINE OVRPDAT IMPLICIT REAL*8(A-H,O-Z) INTEGER ISTART,IEND,I,II REAL*8 XMIN,XMAX,YMIN,YMAX REAL*4 XPLOT(1000000),YPLOT(1000000) CALL PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) ISTART = NINT(CHANNEL(XMIN)) IEND = NINT(CHANNEL(XMAX)) 21950 I=ISTART GOTO 21953 21951 I=I+1 21953 IF((I).GT.(IEND))GOTO 21952 II = I-ISTART+1 YPLOT(II) = REAL(SPEC(I)) XPLOT(II) = WAV(DBLE(I)) GOTO 21951 21952 CONTINUE CALL PGPT(IEND-ISTART+1,XPLOT,YPLOT,1) RETURN END SUBROUTINE PLTCTM(ISTART,IEND) IMPLICIT REAL*8(A-H,O-Z) CALL PGSCI(3) CALL PGP_MOVEA(WAV(DBLE(ISTART)),CONTUM(DBLE(ISTART))) 21960 I=ISTART GOTO 21963 21961 I=I+1 21963 IF((I).GT.(IEND))GOTO 21962 CALL PGP_DRAWA(WAV(DBLE(I)),CONTUM(DBLE(I))) GOTO 21961 21962 CONTINUE CALL PGSCI(1) RETURN END SUBROUTINE PGP_BOX(XMIN,XMAX,YMIN,YMAX) 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 SUBROUTINE PGP_WDBOX(XMIN,XMAX,YMIN,YMAX) 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('DEPTH','1/R**2',' ') RETURN END SUBROUTINE DSPLUS(ISHIFT) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK LOGICAL LNOOBD INTEGER ISHIFT,LINE REAL*8 LEFT,RIGHT,LEFT1,RIGHT1 LEFT = 0.0 RIGHT = 0.0 ISHIFT = 0 POSN = 0.0 CALL PGSCI(2) 21970 LINE=1 GOTO 21973 21971 LINE=LINE+1 21973 IF((LINE).GT.(NOLINES))GOTO 21972 INEXT = LINE + 1 ILAST = LINE - 1 CALL GETLNB(LINE,LEFT,RIGHT) CALL GETLNB(INEXT,LEFT1,RIGHT1) IF(LEFT1 .NE. LEFT)GOTO 21991 LEFT1 = RIGHT 21991 CONTINUE IF(POSN .GE. LEFT)GOTO 22011 POSN = LEFT 22011 CONTINUE IF(INEXT .LE. NOLINES)GOTO 22031 LEFT1 = RIGHT 22031 CONTINUE IF(.NOT.(LNOOBD(LEFT,RIGHT,ISHIFT)))GOTO 22051 GOTO 21971 22051 CONTINUE CALL OPCRLF(LINE,POSN,BLEND(LINE),LEFT1,RIGHT) GOTO 21971 21972 CONTINUE CALL PGSCI(1) RETURN END SUBROUTINE PLNXTL(ISHIFT) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) CHARACTER*1 ANS IF(.NOT.(CNPLTG))GOTO 22071 RETURN 22071 CONTINUE 22080 LINE=1 GOTO 22083 22081 LINE=LINE+1 22083 IF((LINE).GT.(NOLINES))GOTO 22082 IF(CENTRE(LINE) .LE. DBLE(SCRGHT))GOTO 22101 MID = (SCLEFT + SCRGHT)/2 ISHIFT = NINT(CENTRE(LINE)) - MID - 100 RETURN 22101 CONTINUE GOTO 22081 22082 CONTINUE CALL DISPRM WRITE(6,'(A)')'No more lines; skip to next order/spectrum?' CALL DISPRM READ(5,'(A)')ANS IF((ANS .NE. 'Y') .AND. (ANS .NE. 'y'))GOTO 22121 ISHIFT = 10000 GOTO 22131 22121 CONTINUE ISHIFT = -100 22131 CONTINUE 22111 CONTINUE RETURN END SUBROUTINE PLLSTL(ISHIFT) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) IF(.NOT.(CNPLTG))GOTO 22151 RETURN 22151 CONTINUE 22160 LINE=NOLINES GOTO 22163 22161 LINE=LINE+(-1) 22163 IF((-1)*((LINE)-(1)).GT.0)GOTO 22162 IF(CENTRE(LINE) .GE. DBLE(SCLEFT))GOTO 22181 MID = (SCLEFT + SCRGHT)/2 ISHIFT = NINT(CENTRE(LINE)) - MID - 100 RETURN 22181 CONTINUE GOTO 22161 22162 CONTINUE WRITE(6,'(A)')'This is the first line' ISHIFT = -100 RETURN END SUBROUTINE INTUSR(IPLOT,ISHIFT) IMPLICIT REAL*8(A-H,O-Z) CHARACTER*2 COMM INTEGER ISHIFT,IPLOT LOGICAL PAPER,FOUND COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL COMMON/FLSYN/ FILES(7) CHARACTER*7 FILES COMMON/INSYN/ NFILE INTEGER NFILE COMMON/WAVSYN/WZERO(7),WINC(7) REAL*8 WZERO,WINC CONTINUE NFILE = 0 PAPER = .FALSE. 22190 CONTINUE 22191 CONTINUE CALL DISPRM READ(5,'(A2)')COMM IF(COMM .NE. 'a ')GOTO 22211 CALL AGAN GOTO 22201 22211 IF(COMM .NE. 'ac')GOTO 22221 CALL ADDCT GOTO 22201 22221 IF(COMM .NE. 'b ')GOTO 22231 LINE_COLOR = 4 CALL BLOWUP GOTO 22201 22231 IF(COMM .NE. 'z ')GOTO 22241 CALL ZROPLT GOTO 22201 22241 IF(COMM .NE. 'cc')GOTO 22251 CALL DELCNT(FOUND) IF(.NOT.(FOUND))GOTO 22271 CALL ADDCT 22271 CONTINUE GOTO 22201 22251 IF(COMM .NE. 'dc')GOTO 22281 CALL DELCNT(FOUND) GOTO 22201 22281 IF(COMM .NE. 'cp')GOTO 22291 CALL CONPLT GOTO 22201 22291 IF(COMM .NE. 'fc')GOTO 22301 CALL CONFIT GOTO 22201 22301 IF(COMM .NE. 'nf')GOTO 22311 CALL DTTODT GOTO 22201 22311 IF(COMM .NE. 'ml')GOTO 22321 CALL MRKLIN GOTO 22201 22321 IF(COMM .NE. 'op')GOTO 22331 CALL OVRPDAT GOTO 22201 22331 IF(COMM .NE. 'pt')GOTO 22341 CALL SETPLTYP CALL AGAN CALL DSPLUS(I) GOTO 22201 22341 IF(COMM .NE. 'ds')GOTO 22351 CNPLTG = .FALSE. ISHIFT = -100 LINE_COLOR = 4 RETURN GOTO 22201 22351 IF(COMM .NE. 'ew')GOTO 22361 CALL MEASFET GOTO 22201 22361 IF(COMM .NE. 'fl')GOTO 22371 CALL PLFLSP GOTO 22201 22371 IF(COMM .NE. 'ha')GOTO 22381 CALL PAPCPY GOTO 22201 22381 IF(COMM .NE. 'r ')GOTO 22391 CALL REJECT GOTO 22201 22391 IF(COMM .NE. 'rm')GOTO 22401 CALL RMEASLN GOTO 22201 22401 IF(COMM .NE. 'p ')GOTO 22411 CALL PNT GOTO 22201 22411 IF(COMM .NE. 'pb')GOTO 22421 ISHIFT = - 200 LINE_COLOR = 4 RETURN GOTO 22201 22421 IF(COMM .NE. 'pl')GOTO 22431 CALL OPSYNF(W0,WSTEP) CALL PLTSYN(W0,WSTEP,PAPER) CLOSE(UNIT=13) GOTO 22201 22431 IF(COMM .NE. 'nn')GOTO 22441 LINE_COLOR = 4 ISHIFT = 10000 RETURN GOTO 22201 22441 IF(COMM .NE. 'n ')GOTO 22451 LINE_COLOR = 4 CALL PLNXTL(ISHIFT) RETURN GOTO 22201 22451 IF(COMM .NE. 'l ')GOTO 22461 LINE_COLOR = 4 CALL PLLSTL(ISHIFT) RETURN GOTO 22201 22461 IF(COMM .NE. 'll')GOTO 22471 IF(IPLOT .NE. 0)GOTO 22491 GOTO 22191 22491 CONTINUE IPLOT = IPLOT - 2 IF(IPLOT .GE. 0)GOTO 22511 IPLOT = 0 22511 CONTINUE RETURN GOTO 22201 22471 IF(COMM .NE. 'c ')GOTO 22521 LINE_COLOR = 4 RETURN GOTO 22201 22521 IF(COMM .NE. 'q ')GOTO 22531 IPLOT = 100 RETURN GOTO 22201 22531 IF(COMM .NE. 'sg')GOTO 22541 NGAUSS = 1 CALL INMLGS(NGAUSS) GOTO 22201 22541 IF(COMM .NE. 'dg')GOTO 22551 NGAUSS = 2 CALL INMLGS(NGAUSS) GOTO 22201 22551 IF(COMM .NE. 'tg')GOTO 22561 NGAUSS = 3 CALL INMLGS(NGAUSS) GOTO 22201 22561 IF(COMM .NE. 'sl')GOTO 22571 CALL DSPLUS(I) GOTO 22201 22571 IF(COMM .NE. 'v ')GOTO 22581 CALL SETVSNI GOTO 22201 22581 IF(COMM .NE. 'ab')GOTO 22591 STOP GOTO 22201 22591 IF((COMM .NE. '? ') .AND. ((COMM .NE. ' ?') .AND. (COMM .NE. '??') %))GOTO 22601 CALL PRCMDHLP 22601 CONTINUE 22201 CONTINUE GOTO 22191 22192 CONTINUE RETURN END SUBROUTINE PRCMDHLP WRITE(6,22610) 22610 FORMAT('a : AGAIN refresh present data display') WRITE(6,22620) 22620 FORMAT('ac: ADD CONTINUUM add a continuum region using the %cursor') WRITE(6,22630) 22630 FORMAT('b : BLOWUP use cursor to expand in x, y or e %') WRITE(6,22640) 22640 FORMAT('z : ZERO replot present screen from zero f %lux') WRITE(6,22650) 22650 FORMAT('cc: CORRECT CONTINUUM replace a continuum region') WRITE(6,22660) 22660 FORMAT('dc: DELETE CONTINUUM delete a continuum region') WRITE(6,22670) 22670 FORMAT('cp: CONTINUUM PLOT plot continuum points and fit') WRITE(6,22680) 22680 FORMAT ('fc: FIT CONTINUUM fit continuum polynomial (up to %order 20)') WRITE(6,22690) 22690 FORMAT('nf: NO FIT linear interpolation between cont %inua') WRITE(6,22700) 22700 FORMAT('ml: MARK LINES mark line positions') WRITE(6,22710) 22710 FORMAT('op: OVERPLOT overplot data on continuum plot') WRITE(6,22720) 22720 FORMAT('ds: DISPLAY plot present spectrum window') WRITE(6,22730) 22730 FORMAT('ew: EQUIVALENT WIDTH measure EW by Simpsons Rule integ %ration') WRITE(6,22740) 22740 FORMAT('fl: FULL LENGTH plot entire spectrum on screen') WRITE(6,22750) 22750 FORMAT('ha: HARD COPY write data window and syntheses t %o file') WRITE(6,22760) 22760 FORMAT('r : REJECT reject a line from list') WRITE(6,22770) 22770 FORMAT ('rm: RE-MEASURE recompute line fits necessary if % continuum changes') WRITE(6,22780) 22780 FORMAT('p : POINT print cursor pixel and wavelength % posn.') WRITE(6,22790) 22790 FORMAT('pb: PAGE BACK go back one display page') WRITE(6,22800) 22800 FORMAT('pl: PLOT overplot a MOOG spectrum synthesi %s file') WRITE(6,22810) 22810 FORMAT('pt: PLOT TYPE change data plotting style') WRITE(6,22820) 22820 FORMAT('n : NEXT LINE go to the next line') WRITE(6,22830) 22830 FORMAT('nn: NEXT next plot region, order or spectr %um') WRITE(6,22840) 22840 FORMAT('l : LAST LINE go to the previous line') WRITE(6,22850) 22850 FORMAT('ll: LAST go to the last plot region') WRITE(6,22860) 22860 FORMAT('c : CONTINUE go to next display page') WRITE(6,22870) 22870 FORMAT('q : QUIT quit inspection of present plot r %egion') WRITE(6,22880) 22880 FORMAT('sg: SINGLE GAUSSIAN single gaussian fit (f to fix par %ams.)') WRITE(6,22890) 22890 FORMAT('dg: DOUBLE GAUSSIAN double gaussian fit (f to fix par %ams.)') WRITE(6,22900) 22900 FORMAT('tg: TRIPLE GAUSSIAN triple gaussian fit (f to fix par %ams.)') WRITE(6,22910) 22910 FORMAT('sl: SHOW LINES show fits in the present screen') WRITE(6,22920) 22920 FORMAT('v : VSINI set vsini (if vsini>0 fitting is % slow)') WRITE(6,22930) 22930 FORMAT('ab: ABORT write output and exit the program %') WRITE(6,22940) 22940 FORMAT('? : HELP print list of interactive command %s') RETURN END SUBROUTINE AGAN IMPLICIT REAL*8(A-H,O-Z) COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) LOGICAL PAPER PAPER = .FALSE. CALL PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) CALL PGPAGE ISTART = NINT(CHANNEL(XMIN)) IEND = NINT(CHANNEL(XMAX)) IF(.NOT.(CNPLTG))GOTO 22961 CALL RPLTCT CALL DCRONP GOTO 22971 22961 CONTINUE CALL PLDTAY(ISTART,IEND) CALL PLTCTM(ISTART,IEND) CALL REPSYN(PAPER) 22971 CONTINUE 22951 CONTINUE CALL PGP_BOX(XMIN,XMAX,YMIN,YMAX) CONTINUE RETURN END SUBROUTINE MRKLIN IMPLICIT REAL*8(A-H,O-Z) COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK LOGICAL PAPER REAL*8 TOP,BOTTOM,YTEXT PAPER = .FALSE. CALL PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) TOP = 0.4 * (YMAX - YMIN) + YMIN BOTTOM = 0.3 * (YMAX - YMIN) + YMIN YTEXT = 0.25 * (YMAX - YMIN) + YMIN 22980 I=1 GOTO 22983 22981 I=I+1 22983 IF((I).GT.(NOLINES))GOTO 22982 IF(WAVELN(I) .LT. XMIN .OR. WAVELN(I) .GT. XMAX)GOTO 23001 CALL PGP_MOVEA(WAVELN(I),BOTTOM) CALL PGP_DRAWA(WAVELN(I),TOP) CALL PTLINL(WAVELN(I),YTEXT,LINEID(I)) 23001 CONTINUE GOTO 22981 22982 CONTINUE RETURN END SUBROUTINE PTLINL(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 ZROPLT IMPLICIT REAL*8(A-H,O-Z) COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) LOGICAL PAPER PAPER = .FALSE. CALL PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) YMIN = 0.0 ISTART = NINT(CHANNEL(XMIN)) IEND = NINT(CHANNEL(XMAX)) CALL PGPAGE CALL PGP_DWINDO(XMIN,XMAX,YMIN,YMAX) CALL PLTCTM(ISTART,IEND) CALL PGP_BOX(XMIN,XMAX,YMIN,YMAX) IF(.NOT.(CNPLTG))GOTO 23021 CALL DCRONP GOTO 23031 23021 CONTINUE CALL PLDTAY(ISTART,IEND) CALL REPSYN(PAPER) 23031 CONTINUE 23011 CONTINUE CONTINUE RETURN END SUBROUTINE DISPRM WRITE(6,'(1H>$)') RETURN END SUBROUTINE BLOWUP IMPLICIT REAL*8(A-H,O-Z) COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) INTEGER ICHAR LOGICAL PAPER PAPER = .FALSE. CALL PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) CALL PGP_VCURSR(ICHAR,X1,Y1) IF(ICHAR .NE. 121)GOTO 23051 CALL PGP_VCURSR(ICHAR,X2,Y2) IF(Y1 .LE. Y2)GOTO 23071 YMIN = Y2 YMAX = Y1 GOTO 23061 23071 IF(Y2 .LE. Y1)GOTO 23081 YMIN = Y1 YMAX = Y2 GOTO 23091 23081 CONTINUE RETURN 23091 CONTINUE 23061 CONTINUE GOTO 23041 23051 IF(ICHAR .NE. 120)GOTO 23101 CALL PGP_VCURSR(ICHAR,X2,Y2) IF(X1 .LE. X2)GOTO 23121 XMIN = X2 XMAX = X1 GOTO 23111 23121 IF(X2 .LE. X1)GOTO 23131 XMIN = X1 XMAX = X2 GOTO 23141 23131 CONTINUE RETURN 23141 CONTINUE 23111 CONTINUE GOTO 23041 23101 IF(ICHAR .NE. 101)GOTO 23151 CALL PGP_VCURSR(ICHAR,X2,Y2) IF(X1 .LE. X2)GOTO 23171 XMIN = X2 XMAX = X1 GOTO 23161 23171 IF(X2 .LE. X1)GOTO 23181 XMIN = X1 XMAX = X2 23181 CONTINUE 23161 CONTINUE IF(Y1 .LE. Y2)GOTO 23201 YMIN = Y2 YMAX = Y1 GOTO 23191 23201 IF(Y2 .LE. Y1)GOTO 23211 YMIN = Y1 YMAX = Y2 23211 CONTINUE 23191 CONTINUE IF(X1 .NE. X2 .OR. Y1 .NE. Y2)GOTO 23231 RETURN 23231 CONTINUE GOTO 23241 23151 CONTINUE CALL DISPRM WRITE(6,23250) 23250 FORMAT('MUST ENTER x OR y OR e') RETURN 23241 CONTINUE 23041 CONTINUE CALL PGPAGE ISTART = NINT(CHANNEL(XMIN)) XMIN = WAV(DBLE(ISTART)) IEND = NINT(CHANNEL(XMAX)) XMAX = WAV(DBLE(IEND)) SCLEFT = ISTART SCRGHT= IEND CALL PGP_DWINDO(XMIN,XMAX,YMIN,YMAX) CALL PLTCTM(ISTART,IEND) CALL PGP_BOX(XMIN,XMAX,YMIN,YMAX) IF(.NOT.(CNPLTG))GOTO 23271 CALL DCRONP GOTO 23281 23271 CONTINUE CALL PLDTAY(ISTART,IEND) CALL REPSYN(PAPER) 23281 CONTINUE 23261 CONTINUE CONTINUE RETURN END SUBROUTINE REPLCT IMPLICIT REAL*8(A-H,O-Z) COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM LOGICAL FOUND,CNTIOO,CNTBAD CALL DCRONP CALL PGP_VCURSR(ICHAR,X,Y) X = CHANNEL(X) CALL FINDCT(X,ICONT,FOUND) IF(.NOT.(.NOT.FOUND))GOTO 23301 CALL DISPRM WRITE(6,23310) 23310 FORMAT('NO CONTINUUM FOUND') RETURN 23301 CONTINUE CALL DISPRM WRITE(6,23320) 23320 FORMAT('ENTER BOUNDS') CALL PGP_VCURSR(ICHAR,X1,Y1) CALL PGP_VCURSR(ICHAR,X2,Y2) IF(X2 .GE. X1)GOTO 23341 XTEMP = X2 X2 = X1 X1 = XTEMP 23341 CONTINUE X1 = NINT(CHANNEL(X1)) X2 = NINT(CHANNEL(X2)) IF(.NOT.(CNTIOO(X1,X2,ICONT)))GOTO 23361 CALL DISPRM WRITE(6,23370) 23370 FORMAT('BAD CONTINUUM ORDER') RETURN 23361 CONTINUE OLEFT = CONLFT(ICONT) ORIGHT = CONRHT(ICONT) OSIZE = CONSIZE(ICONT) OCFAC = CFACTOR(ICONT) CONLFT(ICONT) = X1 CONRHT(ICONT) = X2 CONSIZE(ICONT) = X2-X1+1.0 CFACTOR(ICONT) = 1.00000 IF(.NOT.(CNTBAD(ICONT)))GOTO 23391 CALL DISPRM WRITE(6,23400) 23400 FORMAT('BAD DIODES IN RANGE') CONLFT(ICONT) = OLEFT CONRHT(ICONT) = ORIGHT CONSIZE(ICONT) = OSIZE CFACTOR(ICONT) = OCFAC RETURN 23391 CONTINUE CALL FITCONT CALL RPLTCT RETURN END SUBROUTINE ADDCT IMPLICIT REAL*8(A-H,O-Z) COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS LOGICAL CNTBAD CALL DCRONP CALL DISPRM WRITE(6,23410) 23410 FORMAT('ENTER BOUNDS') CALL PGP_VCURSR(ICHAR,X1,Y1) CALL PGP_VCURSR(ICHAR,X2,Y2) IF(X2 .GE. X1)GOTO 23431 XTEMP = X2 X2 = X1 X1 = XTEMP 23431 CONTINUE IX1 = NINT(CHANNEL(X1)) IX2 = NINT(CHANNEL(X2)) IF(IX1 .GE. 1)GOTO 23451 IX1 = 1 23451 CONTINUE IF(IX2 .LE. NPTS)GOTO 23471 IX2 = NPTS 23471 CONTINUE IF((IX2 .GE. 1) .AND. (IX1 .LE. NPTS))GOTO 23491 CALL DISPRM WRITE(6,23500) 23500 FORMAT('WARNING: OUT OF BOUNDS; NO CONTINUUM ADDED ') RETURN 23491 CONTINUE NOCONT = NOCONT + 1 CONLFT(NOCONT) = IX1 CONRHT(NOCONT) = IX2 CONSIZE(NOCONT) = IX2-IX1+1 CFACTOR(NOCONT) = 1.00000 IF(.NOT.(CNTBAD(NOCONT)))GOTO 23521 CALL DISPRM WRITE(6,23530) 23530 FORMAT('WARNING: TOO MANY BAD DIODES; NO CONTINUUM ADDED') NOCONT = NOCONT - 1 RETURN 23521 CONTINUE CALL SINGLE_CONTUM_FLUX(NOCONT) CALL SORTCON CALL PERFIT CALL RPLTCT CALL DCRONP RETURN END SUBROUTINE SINGLE_CONTUM_FLUX(ICONT) IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS REAL*8 AVG,SNSIG,SNR LOGICAL CNTBAD,BADIOD INTEGER K,MIDDLE SXI = 0.0 SXIWI = 0.0 SXI2 = 0.0 SNSIG = 0.0 MIDDLE = 0 ANUM = 0.0 23540 K=CONLFT(ICONT) GOTO 23543 23541 K=K+1 23543 IF((K).GT.(CONRHT(ICONT)))GOTO 23542 IF(.NOT.(.NOT. BADIOD(K)))GOTO 23561 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 23561 CONTINUE GOTO 23541 23542 CONTINUE AVG = SXIWI/SNSIG SNSIG = 1.D0/DSQRT(SNSIG) IF(CONSIZE(ICONT) .LE. 1)GOTO 23581 CSIG = DMYSQ( ( SXI2 - (SXI**2)/ANUM )/(ANUM-1.0) ) CSIG = CSIG/DMYSQ(ANUM) 23581 CONTINUE CONFLUX(ICONT) = AVG SIGFLUX(ICONT) = CSIG IF(CSIG .GE. AVG*SNSIG)GOTO 23601 SIGFLUX(ICONT) = AVG*SNSIG 23601 CONTINUE CONCENT(ICONT) = 0.5D0*DBLE(CONLFT(ICONT)+CONRHT(ICONT)) RETURN END SUBROUTINE FINDCT(X,ICONT,FOUND) IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM LOGICAL FOUND FOUND = .FALSE. 23610 I=1 GOTO 23613 23611 I=I+1 23613 IF((I).GT.(NOCONT))GOTO 23612 DX = DBLE(CONSIZE(I))/2.0D0 IF(CONCENT(I) + DX .LT. X)GOTO 23631 IF(CONCENT(I) - DX .GT. X)GOTO 23651 ICONT = I FOUND = .TRUE. 23651 CONTINUE RETURN 23631 CONTINUE GOTO 23611 23612 CONTINUE RETURN END SUBROUTINE DCRONP IMPLICIT REAL*8(A-H,O-Z) REAL*4 XLOWER(10000),XUPPER(10000),YPLOT(10000) INTEGER IYELLOW,IWHITE COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM IYELLOW = 6 IWHITE = 1 CALL PGSCI(IYELLOW) IF(.NOT.(SCALED_CONTUM))GOTO 23671 23680 I=1 GOTO 23683 23681 I=I+1 23683 IF((I).GT.(NOCONT))GOTO 23682 DX = DBLE(CONSIZE(I))/2.0D0 XLOWER(I) = WAV(CONCENT(I)-DX) XUPPER(I) = WAV(CONCENT(I)+DX) YPLOT(I) = CONFLUX(I)*CFACTOR(I) GOTO 23681 23682 CONTINUE CALL PGERRX(NOCONT,XLOWER,XUPPER,YPLOT,13.0) GOTO 23691 23671 CONTINUE 23700 I=1 GOTO 23703 23701 I=I+1 23703 IF((I).GT.(NOCONT))GOTO 23702 DX = DBLE(CONSIZE(I))/2.0D0 XLOWER(I) = WAV(CONCENT(I)-DX) XUPPER(I) = WAV(CONCENT(I)+DX) YPLOT(I) = CONFLUX(I) GOTO 23701 23702 CONTINUE CALL PGERRX(NOCONT,XLOWER,XUPPER,YPLOT,3.0) 23691 CONTINUE 23661 CONTINUE CALL PGSCI(IWHITE) RETURN END LOGICAL FUNCTION CNTIOO(X1,X2,ICONT) IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM CNTIOO = .FALSE. XAVG = (X1+X2)/2.0 IF(ICONT .NE. 1)GOTO 23721 IF(NOCONT .NE. 1)GOTO 23741 RETURN 23741 CONTINUE IF(XAVG .LE. CONCENT(ICONT+1))GOTO 23761 CNTIOO = .TRUE. 23761 CONTINUE RETURN 23721 CONTINUE IF(ICONT .NE. NOCONT)GOTO 23781 IF(XAVG .GE. CONCENT(ICONT-1))GOTO 23801 CNTIOO = .TRUE. 23801 CONTINUE RETURN 23781 CONTINUE IF((XAVG .GE. CONCENT(ICONT-1)) .AND. (XAVG .LE. CONCENT(ICONT+1)) *)GOTO 23821 CNTIOO = .TRUE. 23821 CONTINUE RETURN END SUBROUTINE RPLTCT IMPLICIT REAL*8(A-H,O-Z) CALL PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) ISTART = NINT(CHANNEL(XMIN)) IEND = NINT(CHANNEL(XMAX)) CALL PLTCTM(ISTART,IEND) RETURN END SUBROUTINE DELCNT(FOUND) IMPLICIT REAL*8(A-H,O-Z) LOGICAL FOUND COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL CALL DCRONP CALL PGP_VCURSR(ICHAR,X,Y) X = CHANNEL(X) CALL FINDCT(X,ICONT,FOUND) IF(.NOT.(.NOT.FOUND))GOTO 23841 CALL DISPRM WRITE(6,23850) 23850 FORMAT('NO CONTINUUM FOUND') RETURN 23841 CONTINUE CALL REMCTP(ICONT) CALL PERFIT CALL AGAN RETURN END SUBROUTINE CONPLT IMPLICIT REAL*8(A-H,O-Z) COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) CNPLTG = .TRUE. ISTART = 1 IEND = NPTS XMIN = WAV(DBLE(ISTART)) XMAX = WAV(DBLE(IEND)) IF(NOCONT .LT. 1)GOTO 23871 YMIN = CONFLUX(1) YMAX = CONFLUX(1) IF(.NOT.(SCALED_CONTUM))GOTO 23891 YMIN = CONFLUX(1)* CFACTOR(1) YMAX = CONFLUX(1)* CFACTOR(1) 23891 CONTINUE IF(NOCONT .LT. 2)GOTO 23911 IF(.NOT.(SCALED_CONTUM))GOTO 23931 23940 I=2 GOTO 23943 23941 I=I+1 23943 IF((I).GT.(NOCONT))GOTO 23942 IF(CONFLUX(I)*CFACTOR(I) .LE. YMAX)GOTO 23961 YMAX = CONFLUX(I)*CFACTOR(I) GOTO 23951 23961 IF(CONFLUX(I)*CFACTOR(I) .GE. YMIN)GOTO 23971 YMIN = CONFLUX(I)*CFACTOR(I) 23971 CONTINUE 23951 CONTINUE GOTO 23941 23942 CONTINUE GOTO 23981 23931 CONTINUE 23990 I=2 GOTO 23993 23991 I=I+1 23993 IF((I).GT.(NOCONT))GOTO 23992 IF(CONFLUX(I) .LE. YMAX)GOTO 24011 YMAX = CONFLUX(I) GOTO 24001 24011 IF(CONFLUX(I) .GE. YMIN)GOTO 24021 YMIN = CONFLUX(I) 24021 CONTINUE 24001 CONTINUE GOTO 23991 23992 CONTINUE 23981 CONTINUE 23921 CONTINUE 23911 CONTINUE YMIN = YMIN - 0.03 YMAX = YMAX + 0.03 GOTO 24031 23871 CONTINUE YMIN = 0.93 YMAX = 1.07 24031 CONTINUE 23861 CONTINUE CALL PGPAGE CALL PGP_DWINDO(XMIN,XMAX,YMIN,YMAX) CALL PLTCTM(ISTART,IEND) CALL DCRONP CALL PGP_BOX(XMIN,XMAX,YMIN,YMAX) CONTINUE RETURN END SUBROUTINE PLWD(X,Y,N,XMIN,XMAX,YMIN,YMAX) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK REAL*8 XMIN,XMAX,YMIN,YMAX,X(1000),Y(1000) REAL*4 XDUM(1000),YDUM(1000) INTEGER N 24040 I=1 GOTO 24043 24041 I=I+1 24043 IF((I).GT.(N))GOTO 24042 XDUM(I) = X(I) YDUM(I) = Y(I) GOTO 24041 24042 CONTINUE CALL PGBEG(14,'/GTERM',1,1) CALL PGASK(.FALSE.) CALL PGPAGE CALL PGP_DWINDO(XMIN,XMAX,YMIN,YMAX) CALL PGPT(N,XDUM,YDUM,2) CALL PGP_WDBOX(XMIN,XMAX,YMIN,YMAX) CALL PGSCI(4) IF(SLOPE .EQ. 0.0D0)GOTO 24061 Y1 = INCPT + SLOPE X1 = (MINIWD - INCPT)/SLOPE CALL PGP_MOVEA(0.0d0,MINIWD) CALL PGP_DRAWA(X1,MINIWD) CALL PGP_DRAWA(1.0d0,Y1) CALL PGSCI(1) 24061 CONTINUE CONTINUE RETURN END SUBROUTINE PLFLSP IMPLICIT REAL*8(A-H,O-Z) COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL CALL PGPAGE ISTART = 1 IEND = NPTS CALL SEDWIN(ISTART,IEND,XMIN,XMAX,YMIN,YMAX) CALL PLDTAY(ISTART,IEND) CALL PLTCTM(ISTART,IEND) CALL PGP_BOX(XMIN,XMAX,YMIN,YMAX) CONTINUE RETURN END SUBROUTINE OPSYNF(W0,WSTEP) IMPLICIT REAL*8(A-H,O-Z) COMMON/FLSYN/ FILES(7) CHARACTER*7 FILES COMMON/INSYN/ NFILE INTEGER NFILE COMMON/WAVSYN/WZERO(7),WINC(7) REAL*8 WZERO,WINC COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL IF(NFILE .LT. 7)GOTO 24081 CALL DISPRM WRITE(6,24090) 24090 FORMAT('ONLY 7 SYNTHESIS FILES ALLOWED') RETURN 24081 CONTINUE CALL DISPRM WRITE(6,24100) 24100 FORMAT('ENTER FILENAME') CALL DISPRM NFILE = NFILE + 1 READ(5,'(A7)')FILES(NFILE) CALL DISPRM WRITE(6,24110) 24110 FORMAT('ENTER WAVE ZERO & STEP') CALL DISPRM 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 PAPCPY IMPLICIT REAL*8(A-H,O-Z) CHARACTER*80 TITLE LOGICAL PAPER TITLE = ' ' XLENGTH = 35.0 PAPER = .TRUE. CALL PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) CALL PHINFP(TITLE,XMIN,XMAX,YMIN,YMAX,XLENGTH) CALL PRNTFX(INT(CHANNEL(XMIN)),NINT(CHANNEL(XMAX))) CALL PRNTCN(INT(CHANNEL(XMIN)),NINT(CHANNEL(XMAX))) CALL REPSYN(PAPER) RETURN END SUBROUTINE PLTSYN(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. CALL PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) IF(W0 .GT. XMAX)GOTO 24131 W = W0 READ(13,*,END=24140)(FLUX(J),J=1,10) 24150 CONTINUE 24151 CONTINUE 24160 I=1 GOTO 24163 24161 I=I+1 24163 IF((I).GT.(10))GOTO 24162 IF(W .GT. XMAX .OR. W .LT. XMIN)GOTO 24181 Y = (1.0-FLUX(I))*CONTUM(CHANNEL(W)) IF(.NOT.(FIRST))GOTO 24201 IF(.NOT.(PAPER))GOTO 24221 WRITE(11,24230) 24230 FORMAT('COLOR BLACK') WRITE(11,24240) 24240 FORMAT('NOMARKER') WRITE(11,24250) 24250 FORMAT('DASHEDLINE 4') GOTO 24261 24221 CONTINUE CALL PGP_MOVEA(W,Y) 24261 CONTINUE 24211 CONTINUE FIRST = .FALSE. GOTO 24271 24201 CONTINUE IF(.NOT.(PAPER))GOTO 24291 WRITE(11,24300)W,Y 24300 FORMAT (F10.3,2X,F10.6) GOTO 24311 24291 CONTINUE CALL PGP_DRAWA(W,Y) 24311 CONTINUE 24281 CONTINUE 24271 CONTINUE 24191 CONTINUE 24181 CONTINUE W = W + WSTEP GOTO 24161 24162 CONTINUE READ(13,*,END=24140)(FLUX(J),J=1,10) IF(W .GT. XMAX)GOTO 24152 GOTO 24151 24152 CONTINUE RETURN 24140 CONTINUE IMAX = J - 1 24320 I=1 GOTO 24323 24321 I=I+1 24323 IF((I).GT.(IMAX))GOTO 24322 IF(W .GT. XMAX .OR. W .LT. XMIN)GOTO 24341 Y = (1.0-FLUX(I))*CONTUM(CHANNEL(W)) IF(.NOT.(FIRST))GOTO 24361 IF(.NOT.(PAPER))GOTO 24381 WRITE(11,24390) 24390 FORMAT('COLOR BLACK') WRITE(11,24400) 24400 FORMAT('NOMARKER') WRITE(11,24410) 24410 FORMAT('DASHEDLINE 4') GOTO 24421 24381 CONTINUE CALL PGP_MOVEA(W,Y) FIRST = .FALSE. 24421 CONTINUE 24371 CONTINUE GOTO 24431 24361 CONTINUE IF(.NOT.(PAPER))GOTO 24451 WRITE(11,24460)W,Y 24460 FORMAT (F10.3,2X,F10.6) GOTO 24471 24451 CONTINUE CALL PGP_DRAWA(W,Y) 24471 CONTINUE 24441 CONTINUE 24431 CONTINUE 24351 CONTINUE 24341 CONTINUE W = W + WSTEP GOTO 24321 24322 CONTINUE 24131 CONTINUE RETURN END SUBROUTINE REPSYN(PAPER) IMPLICIT REAL*8(A-H,O-Z) COMMON/FLSYN/ FILES(7) CHARACTER*7 FILES COMMON/INSYN/ NFILE INTEGER NFILE COMMON/WAVSYN/WZERO(7),WINC(7) REAL*8 WZERO,WINC LOGICAL PAPER IF(NFILE .GT. 0)GOTO 24491 RETURN 24491 CONTINUE 24500 I=1 GOTO 24503 24501 I=I+1 24503 IF((I).GT.(NFILE))GOTO 24502 OPEN(UNIT=13,FILE=FILES(I),STATUS='OLD') REWIND 13 CALL PLTSYN(WZERO(I),WINC(I),PAPER) CLOSE(UNIT=13) GOTO 24501 24502 CONTINUE PAPER = .FALSE. RETURN END SUBROUTINE MEASFET IMPLICIT REAL*8(A-H,O-Z) COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL REAL*8 PI,COV(9,9),SW(9) PI = 3.141592654 CALL PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) CALL PGP_VCURSR(ICHAR,X1,Y1) CALL PGP_VCURSR(ICHAR,X2,Y2) IF(X1 .GE. X2)GOTO 24521 XLEFT = X1 XRIGHT = X2 GOTO 24531 24521 CONTINUE XLEFT = X2 XRIGHT = X1 24531 CONTINUE 24511 CONTINUE IF(XLEFT .GE. XMIN)GOTO 24551 XLEFT = XMIN 24551 CONTINUE IF(XRIGHT .LE. XMAX)GOTO 24571 XRIGHT = XMAX 24571 CONTINUE CALL INTEGRT(XLEFT,XRIGHT,AREA) A1 = SPEC(NINT(XLEFT)) A2 = DNINT(XLEFT) 24580 I=NINT(XLEFT)+1 GOTO 24583 24581 I=I+1 24583 IF((I).GT.(INT(XRIGHT)))GOTO 24582 IF(SPEC(I) .GE. A1)GOTO 24601 A1 = SPEC(I) A2 = DBLE(I) 24601 CONTINUE GOTO 24581 24582 CONTINUE A1 = 1.0 - SPEC(INT(A2))/CONTUM(A2) A3 = AREA/(A1*DMYSQ(PI)) 24610 I=1 GOTO 24613 24611 I=I+1 24613 IF((I).GT.(9))GOTO 24612 24620 J=1 GOTO 24623 24621 J=J+1 24623 IF((J).GT.(9))GOTO 24622 COV(I,J) = 0.0D0 GOTO 24621 24622 CONTINUE COV(I,I) = 1.0D0 SW(I) = 0.0D0 GOTO 24611 24612 CONTINUE SW(1) = 1.0D0 SW(2) = 1.0D0 SW(3) = 1.0D0 N = 1 CALL REPLEW(A1,A2,A3,COV,SW,N) RETURN END SUBROUTINE INTEGRT(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) .EQ. XMIN)GOTO 24641 ISTART = ISTART + 1 FRAC1 = DBLE(ISTART) - XMIN 24641 CONTINUE FRAC2 = XMAX - DBLE(IEND) N = IEND - ISTART + 1 IF(N .GT. 1)GOTO 24661 SUM = 0.0 GOTO 24651 24661 IF(N .NE. 2)GOTO 24671 I = ISTART SUM = 1.0-(SPEC(I)/CONTUM(DBLE(I))+SPEC(IEND)/CONTUM(DBLE(IEND)))/ *2.0 GOTO 24681 24671 CONTINUE SUM5 = 2.0-SPEC(ISTART)/CONTUM(DBLE(ISTART))-SPEC(IEND)/CONTUM(DBL *E(IEND)) HALF = DBLE(N)/2.0 IF(HALF .NE. DBLE(N/2))GOTO 24701 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 .NE. 4)GOTO 24721 SUM5 = 0.0 GOTO 24731 24721 CONTINUE SUM5=2.0-SPEC(I+3)/CONTUM(DBLE(I+3))-SPEC(IEND)/CONTUM(DBLE(IEND)) * 24731 CONTINUE 24711 CONTINUE IZERO = 3 24701 CONTINUE 24740 I=ISTART+IZERO+1 GOTO 24743 24741 I=I+(2) 24743 IF((2)*((I)-(IEND-1)).GT.0)GOTO 24742 SUM2 = SUM2 + 4.0*(1.0-SPEC(I)/CONTUM(DBLE(I))) GOTO 24741 24742 CONTINUE 24750 I=ISTART+IZERO+2 GOTO 24753 24751 I=I+(2) 24753 IF((2)*((I)-(IEND-2)).GT.0)GOTO 24752 SUM3 = SUM3 + 2.0*(1.0-SPEC(I)/CONTUM(DBLE(I))) GOTO 24751 24752 CONTINUE SUM = SUM1 + (SUM2 + SUM3 + SUM5)/3.0 24681 CONTINUE 24651 CONTINUE IF(FRAC1 .EQ. 0.0)GOTO 24771 I = ISTART SUM4 = FRAC1* (1.0-SPEC(I)/CONTUM(DBLE(I))) + FRAC1**2*(SPEC(I)/C *ONTUM(DBLE(I)) - SPEC(I-1)/CONTUM(DBLE(I-1)))/2.0 24771 CONTINUE IF(FRAC2 .EQ. 0.0)GOTO 24791 I = IEND SUM4 = SUM4 + FRAC2*(1.0-SPEC(I)/CONTUM(DBLE(I))) - FRAC2**2*(SPE *C(I+1)/CONTUM(DBLE(I+1))-SPEC(I)/CONTUM(DBLE(I)))/2.0 24791 CONTINUE IF(N .GT. 0)GOTO 24811 I = ISTART SUM4 = -1.0+(SPEC(I)/CONTUM(DBLE(I))+SPEC(IEND)/CONTUM(DBLE(IEND)) *)/2.0 + SUM4 24811 CONTINUE WIDTH = SUM + SUM4 RETURN END SUBROUTINE REJECT IMPLICIT REAL*8(A-H,O-Z) COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL CHARACTER*1 CHAR INTEGER ICENTRE,ICHAR,LINE CALL PGP_VCURSR(ICHAR,X,Y) CALL DISPRM WRITE(6,24820) 24820 FORMAT(' REJECT LINE. ARE YOU SURE?') CALL DISPRM READ(5,'(A1)')CHAR IF(CHAR .EQ. 'Y' .OR. CHAR .EQ. 'y')GOTO 24841 RETURN 24841 CONTINUE CALL FINDLN(CHANNEL(X),LINE) IF(LINE .NE. 0)GOTO 24861 RETURN 24861 CONTINUE CALL REMFLS(LINE) RETURN END SUBROUTINE PNT IMPLICIT REAL*8(A-H,O-Z) COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL CALL PGP_VCURSR(ICHAR,X,Y) XCHAN = CHANNEL(X) LINENO = LINENO - 1 CALL DISPRM WRITE(6,24870)XCHAN 24870 FORMAT(' DIODE ',F7.2) CALL DISPRM WRITE(6,24880)X 24880 FORMAT(' WAVE ',F8.3) RETURN END SUBROUTINE FINDLN(CENT,LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK 24890 LINE=1 GOTO 24893 24891 LINE=LINE+1 24893 IF((LINE).GT.(NOLINES))GOTO 24892 WAVE = WAV(CENT) IF((DABS(WAVELN(LINE)-WAVE) .GT. 2.0*DISP) .AND. (DABS(WAVELN(LINE *)-WAVE) .GT. 0.04))GOTO 24911 IF(LINE .GE. NOLINES)GOTO 24931 IF(DABS(WAVELN(LINE)-WAVE) .GT. DABS(WAVELN(LINE+1)-WAVE))GOTO 249 *51 RETURN 24951 CONTINUE GOTO 24961 24931 CONTINUE RETURN 24961 CONTINUE 24921 CONTINUE 24911 CONTINUE GOTO 24891 24892 CONTINUE LINE = 0 RETURN END SUBROUTINE CONFIT IMPLICIT REAL*8(A-H,O-Z) CHARACTER*1 ANS,ANS2*2 REAL*8 X(1000),Y(1000),SIGMA(1000),ADUM(50),COVAR(50,50) REAL ACHISQ,SMEAN,PDEV LOGICAL ISANUMBER COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/CPARMS/A,B,C REAL*8 A,B,C COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL CALL DISPRM WRITE(6,24970) 24970 FORMAT(' ENTER ORDER OF POLYNOMIAL') LINENO = LINENO - 1 CALL DISPRM 24980 CONTINUE 24981 CONTINUE READ(5,'(A2)')ANS2 IF(.NOT.(ISANUMBER(ANS2)))GOTO 25001 GOTO 24982 25001 CONTINUE CALL DISPRM WRITE(6,25010) 25010 FORMAT(' NOT AN INTEGER. TRY AGAIN. ') GOTO 24981 24982 CONTINUE READ(ANS2,*)IORD IF(NOCONT .GE. IORD)GOTO 25031 CALL DISPRM WRITE(6,25040) 25040 FORMAT('ORDER TOO BIG') RETURN 25031 CONTINUE CALL DISPRM WRITE(6,25050) 25050 FORMAT(' FIT TO SCALED CONTINUUM?') LINENO = LINENO - 1 CALL DISPRM READ(5,'(A1)')ANS IF((ANS .NE. 'Y') .AND. (ANS .NE. 'y'))GOTO 25071 SCALED_CONTUM = .TRUE. GOTO 25081 25071 CONTINUE SCALED_CONTUM = .FALSE. 25081 CONTINUE 25061 CONTINUE FITCON = .TRUE. IF(NOCONT .LT. 1)GOTO 25101 SMEAN = 0.0 IF(.NOT.(SCALED_CONTUM))GOTO 25121 25130 J=1 GOTO 25133 25131 J=J+1 25133 IF((J).GT.(NOCONT))GOTO 25132 Y(J) = CONFLUX(J) * CFACTOR(J) GOTO 25131 25132 CONTINUE GOTO 25141 25121 CONTINUE 25150 J=1 GOTO 25153 25151 J=J+1 25153 IF((J).GT.(NOCONT))GOTO 25152 Y(J) = CONFLUX(J) GOTO 25151 25152 CONTINUE 25141 CONTINUE 25111 CONTINUE 25160 J=1 GOTO 25163 25161 J=J+1 25163 IF((J).GT.(NOCONT))GOTO 25162 X(J) = CONCENT(J) SIGMA(J) = SIGFLUX(J) SMEAN = SMEAN + 1.0/SIGMA(J)**2 GOTO 25161 25162 CONTINUE CALL POLYLIN(X,Y,SIGMA,IORD,ADUM,COVAR,CHISQ,NOCONT) CONORD(CURIMR) = IORD 25170 ITERM=1 GOTO 25173 25171 ITERM=ITERM+1 25173 IF((ITERM).GT.(IORD))GOTO 25172 ACON(ITERM,CURIMR) = ADUM(ITERM) GOTO 25171 25172 CONTINUE CALL RPLTCT ACHISQ = REAL(CHISQ/DBLE(NOCONT-IORD)) PDEV = 100.0 * (SQRT(ACHISQ) / SQRT(SMEAN))/CONFLUX(NOCONT/2) CALL DISPRM WRITE(6,25180)ACHISQ 25180 FORMAT('Chi2/Ndf = ',F8.3) CALL DISPRM WRITE(6,25190)PDEV 25190 FORMAT('wrms dev.% =',F7.3) GOTO 25201 25101 CONTINUE CONORD(CURIMR) = 1 ACON(1,CURIMR) = 1.0 25201 CONTINUE 25091 CONTINUE RETURN END LOGICAL FUNCTION ISANUMBER(ANS) CHARACTER*1 ANS*2,NUM(11) NUM(1) = '1' NUM(2) = '2' NUM(3) = '3' NUM(4) = '4' NUM(5) = '5' NUM(6) = '6' NUM(7) = '7' NUM(8) = '8' NUM(9) = '9' NUM(10) = '0' NUM(11) = ' ' ISANUMBER = .FALSE. IF(ANS .NE. ' ')GOTO 25221 RETURN 25221 CONTINUE 25230 I=1 GOTO 25233 25231 I=I+1 25233 IF((I).GT.(11))GOTO 25232 IF(ANS(1:1) .NE. NUM(I))GOTO 25251 25260 J=1 GOTO 25263 25261 J=J+1 25263 IF((J).GT.(11))GOTO 25262 IF(ANS(2:2) .NE. NUM(J))GOTO 25281 ISANUMBER = .TRUE. RETURN 25281 CONTINUE GOTO 25261 25262 CONTINUE 25251 CONTINUE GOTO 25231 25232 CONTINUE RETURN END SUBROUTINE DTTODT IMPLICIT REAL*8 (A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/CPARMS/A,B,C REAL*8 A,B,C COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL CONORD(CURIMR) = 0 CALL PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) ISTART = NINT(CHANNEL(XMIN)) IEND = NINT(CHANNEL(XMAX)) CALL PLTCTM(ISTART,IEND) RETURN END SUBROUTINE INMLGS(NGAUSS) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/ROTCOM/ VSINI REAL*8 VSINI COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) REAL*8 SWITCH(9),A(9),COV(9,9),X(200),PHOTONS,VWIDTH,SWDUMMY(9) INTEGER NGAUSS,I,LEFT,RIGHT,N,ICENT 25290 I=1 GOTO 25293 25291 I=I+1 25293 IF((I).GT.(9))GOTO 25292 A(I) = 0.0D0 IF(I .GT. 3*NGAUSS)GOTO 25311 SWITCH(I) = 1.0 SWDUMMY(I) = 1.0 GOTO 25321 25311 CONTINUE SWITCH(I) = 0.0 SWDUMMY(I) = 0.0 25321 CONTINUE 25301 CONTINUE GOTO 25291 25292 CONTINUE 25330 I=1 GOTO 25333 25331 I=I+1 25333 IF((I).GT.(NGAUSS))GOTO 25332 CALL PRMCAD(A(3*I-1),A(3*I-2),SWITCH,I) GOTO 25331 25332 CONTINUE CALL PRMBOU(LEFT,RIGHT,SWITCH,NGAUSS) IF(LEFT .NE. 0 .OR. RIGHT .NE. 0)GOTO 25351 RETURN 25351 CONTINUE CALL SETUPTS(X,LEFT,RIGHT,N) 25360 I=1 GOTO 25363 25361 I=I+1 25363 IF((I).GT.(NGAUSS))GOTO 25362 W = WAV(A(3*I-1)) CALL FNDSIG(W,A(3*I-2),A(3*I),SWITCH(3*I)) IF(SWITCH(3*I) .NE. 1.0)GOTO 25381 A(3*I) = 0.5*( X(2*N-1) - X(1) )/3.0 25381 CONTINUE IF(SWITCH(3*I) .NE. 1.0 .OR. A(3*I) .GE. 2.0)GOTO 25401 A(3*I) = 2.0 25401 CONTINUE GOTO 25361 25362 CONTINUE ICENT = NINT(A(2)) PHOTONS = SNR(ICENT)**2 * CONTUM(DBLE(ICENT))/SPEC(ICENT) CALL GAUSFT(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 FLUX = PROFILE(POSN, A, SWDUMMY, VSINI) LINE_COLOR = LINE_COLOR + 1 IF(LINE_COLOR .LE. 9)GOTO 25421 LINE_COLOR = 1 25421 CONTINUE CALL PGSCI(LINE_COLOR) FLUX = (1.0-FLUX)*CONTUM(POSN) CALL PGP_MOVEA(WAV(POSN),FLUX) 25430 POSN=START + 0.25 GOTO 25433 25431 POSN=POSN+(0.25) 25433 IF((0.25)*((POSN)-(END)).GT.0)GOTO 25432 FLUX = 0.0 FLUX = PROFILE(POSN, A, SWDUMMY, VSINI) FLUX = (1.0-FLUX)*CONTUM(POSN) CALL PGP_DRAWA(WAV(POSN),FLUX) GOTO 25431 25432 CONTINUE 25440 I=1 GOTO 25443 25441 I=I+1 25443 IF((I).GT.(NGAUSS))GOTO 25442 CALL REPLEW(A(3*I-2),A(3*I-1),A(3*I),COV,SWITCH,I) GOTO 25441 25442 CONTINUE CALL PGSCI(1) RETURN END SUBROUTINE PRMBOU(LEFT,RIGHT,SWITCH,NGAUSS) IMPLICIT REAL*8(A-H,O-Z) COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL REAL*8 SWITCH(9) INTEGER LEFT,RIGHT,NGAUSS,NPOINT CHARACTER*1 ANS CALL DISPRM WRITE(6,25450) 25450 FORMAT(12HENTER BOUNDS) CALL PGP_VCURSR(ICHAR1,X1,Y1) CALL PGP_VCURSR(ICHAR2,X2,Y2) IF(X1 .LE. X2)GOTO 25471 LEFT = NINT(CHANNEL(X2)) RIGHT= NINT(CHANNEL(X1)) GOTO 25481 25471 CONTINUE RIGHT = NINT(CHANNEL(X2)) LEFT = NINT(CHANNEL(X1)) 25481 CONTINUE 25461 CONTINUE NPOINT = 0 25490 I=1 GOTO 25493 25491 I=I+1 25493 IF((I).GT.(3*NGAUSS))GOTO 25492 NPOINT = INT(SWITCH(I)) + NPOINT GOTO 25491 25492 CONTINUE IF(RIGHT - LEFT + 1 .GE. NPOINT)GOTO 25511 CALL DISPRM WRITE(6,25520) 25520 FORMAT(19HINSUFFICIENT POINTS) LEFT = 0 RIGHT = 0 25511 CONTINUE RETURN END SUBROUTINE PRMCAD(CENTRE,DEPTH,SWITCH,NGAUSS) IMPLICIT REAL*8(A-H,O-Z) COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL REAL*8 CENTRE,DEPTH,SWITCH(9) INTEGER NGAUSS CHARACTER*1 ANS CALL DISPRM WRITE(6,25530) 25530 FORMAT(13HSET LINE APEX) CALL PGP_VCURSR(ICHAR,X,Y) CENTRE = CHANNEL(X) DEPTH = 1.0 - Y/CONTUM(CENTRE) IF(ICHAR .NE. 102)GOTO 25551 CALL DISPRM WRITE(6,25560) 25560 FORMAT(' FIX DEPTH ?') LINENO = LINENO - 1 CALL DISPRM READ(5,'(A1)')ANS IF(ANS .NE. 'y')GOTO 25581 SWITCH(3*NGAUSS-2) = 0.0 25581 CONTINUE CALL DISPRM WRITE(6,25590) 25590 FORMAT(' FIX CENTRE?') LINENO = LINENO - 1 CALL DISPRM READ(5,'(A1)')ANS IF(ANS .NE. 'y')GOTO 25611 SWITCH(3*NGAUSS-1) = 0.0 25611 CONTINUE CALL DISPRM WRITE(6,25620) 25620 FORMAT(' FIX FWHM ?') LINENO = LINENO - 1 CALL DISPRM READ(5,'(A1)')ANS IF(ANS .NE. 'y')GOTO 25641 SWITCH(3*NGAUSS) = 0.0 25641 CONTINUE 25551 CONTINUE RETURN END SUBROUTINE SETVSNI IMPLICIT REAL*8 (A-H,O-Z) COMMON/ROTCOM/ VSINI REAL*8 VSINI CALL DISPRM WRITE(6,25650) 25650 FORMAT('ENTER VSINI:') CALL DISPRM READ(5,'(F10.3)')VSINI RETURN END SUBROUTINE FNDSIG(W,ADEPTH,SIGMA,SWITCH) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL REAL*8 ADEPTH,SIGMA,SWITCH IF(SWITCH .NE. 0.0)GOTO 25671 CALL GTBSFW(W,ADEPTH,WIDTH,SIGWDTH,SIG_AV_WIDTH) IF((NOGDLN .NE. 0 .OR. .NOT.(.NOT. FIXFWHM)) .AND. (WIDTH .NE. 0.0 *))GOTO 25691 CALL DISPRM WRITE(6,25700) 25700 FORMAT(19HNO MEAN FWHM EXISTS) SWITCH = 1.0 25691 CONTINUE SIGMA = WIDTH*0.60056121 25671 CONTINUE RETURN END SUBROUTINE REPLEW(A1,A2,A3,COV,SWITCH,N) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL CHARACTER*1 ANS REAL*8 COV(9,9),SWITCH(9),PI INTEGER N,N0 PI = 3.141592654D0 WAVE = WAV(A2) CALL FINDLN(A2,LINE) AREA = A1*DABS(A3)*DMYSQ(PI)*DISP*1000.0 IF(LINE .NE. 0)GOTO 25721 CALL DISPRM WRITE(6,25730) 25730 FORMAT (16HLINE NOT ON LIST) CALL DISPRM WRITE(6,25740)AREA 25740 FORMAT(4HEW =,F7.2,2HMA) CALL DISPRM WRITE(6,25750)WAVE 25750 FORMAT(7HWAVE = ,F8.2,1HA) GOTO 25761 25721 CONTINUE WAVE2 = WAV(CENTRE(LINE)) CALL DISPRM WRITE(6,25770)AREA 25770 FORMAT(8HNEW EW =,F7.2,2HMA) CALL DISPRM WRITE(6,25780)WAVE 25780 FORMAT(7HWAVE = ,F8.2,1HA) CALL DISPRM WRITE(6,25790)EW(LINE) 25790 FORMAT(8HOLD EW =,F7.2,2HMA) CALL DISPRM WRITE(6,25800)WAVE2 25800 FORMAT(7HWAVE = ,F8.2,1HA) CALL DISPRM WRITE(6,25810) 25810 FORMAT(15HREPLACE OLD EW?) CALL DISPRM READ(5,'(A1)')ANS IF((ANS .NE. 'Y') .AND. (ANS .NE. 'y'))GOTO 25831 EW(LINE) = AREA DEPTH(LINE) = A1 CENTRE(LINE)= A2 CALL CPDELE(A1,A3,COV,SWITCH,N,LINE) DELTEW(LINE) = DELTEW(LINE) * EW(LINE) CALL DISPRM WRITE(6,25840)DELTEW(LINE) 25840 FORMAT(7HD_EW = ,F7.2,2HMA) FWHM(LINE) = DABS(A3)/0.60056121 25831 CONTINUE 25761 CONTINUE 25711 CONTINUE RETURN END SUBROUTINE CPDELE(A1,A3,COV,SWITCH,N,LINE) IMPLICIT REAL*8 (A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK 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 CALL GTBSFW(WAVELN(LINE),A1,WIDTH,SIGWDTH,SIG_AV_WIDTH) IF(SWITCH(ND) .NE. 1.0)GOTO 25861 IF(SWITCH(NW) .NE. 1.0)GOTO 25881 DELTA = COV(NW,NW)/A3**2 + COV(ND,ND)/A1**2 + 2.0*COV(ND,NW)/(A3* *A1) GOTO 25891 25881 CONTINUE DELTA = COV(ND,ND)/A1**2 DELTA = DELTA + (0.60056121*SIG_AV_WIDTH/A3)**2 25891 CONTINUE 25871 CONTINUE GOTO 25851 25861 IF(SWITCH(NW) .NE. 1.0)GOTO 25901 DELTA = COV(NW,NW)/A3**2 GOTO 25911 25901 CONTINUE DELTA = (0.60056121*SIG_AV_WIDTH/A3)**2 25911 CONTINUE 25851 CONTINUE DELTEW(LINE) = DSQRT(DELTA) RETURN END SUBROUTINE PLTLFX(POSN,FLUX) IMPLICIT REAL*8(A-H,O-Z) REAL*8 POSN,FLUX,XMIN,XMAX,YMIN,YMAX CALL PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) IF(FLUX .LT. YMIN .OR. FLUX .GT. YMAX)GOTO 25931 CALL PGP_DRAWA(WAV(POSN),FLUX) GOTO 25921 25931 IF(FLUX .GE. YMIN)GOTO 25941 CALL PGP_DRAWA(WAV(POSN),YMIN) GOTO 25951 25941 CONTINUE CALL PGP_DRAWA(WAV(POSN),YMAX) 25951 CONTINUE 25921 CONTINUE RETURN END REAL*8 FUNCTION SPEC(I) IMPLICIT REAL*8(A-H,O-Z) COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS INTEGER I IF((I .GT. 0) .AND. (I .LE. NPTS))GOTO 25971 SPEC = 0.0 GOTO 25981 25971 CONTINUE SPEC = SPCTRUM(I) 25981 CONTINUE 25961 CONTINUE RETURN END REAL*8 FUNCTION SNR(I) IMPLICIT REAL*8(A-H,O-Z) COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL INTEGER I IF(.NOT.(.NOT.VARFIL))GOTO 26001 IF(SPEC(I)/CONTUM(DBLE(I)) .LE. 0.0)GOTO 26021 SNR = SN * DSQRT( SPEC(I)/CONTUM(DBLE(I)) ) GOTO 26031 26021 CONTINUE SNR = 0.0 26031 CONTINUE 26011 CONTINUE GOTO 25991 26001 IF((I .GT. 0) .AND. (I .LE. NPTS))GOTO 26041 SNR = 0.0 GOTO 25991 26041 IF(VARSPEC(I) .GT. 0.0)GOTO 26051 SNR = 0.0 GOTO 26061 26051 CONTINUE SNR = DSQRT( VARSPEC(I) ) 26061 CONTINUE 25991 CONTINUE RETURN END REAL*8 FUNCTION CONTUM(DIODE) IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON/CPARMS/A,B,C REAL*8 A,B,C COMMON/LTELL/TELSET,TELPRES LOGICAL TELSET,TELPRES COMMON/ITELL/LBOUND(100),RBOUND(100),NBOUNDS,NH2O INTEGER LBOUND,RBOUND,NBOUNDS,NH2O COMMON/RTELL/H2OCENT(100),H2OFWHM(100),H2ODEEP(100), H2OSLOP,H2OIN *T,H2OMIN REAL*8 H2OCENT,H2OFWHM,H2ODEEP,H2OSLOP,H2OINT,H2OMIN INTEGER RED,BLUE REAL*8 DIODE IF(.NOT.(NRMLSD))GOTO 26081 CONTUM = 1.0 RETURN 26081 CONTINUE IF(.NOT.(TELSET))GOTO 26101 CONTUM = 1.0 RETURN 26101 CONTINUE X=DIODE IF((DIODE .LT. CONCENT(1) .OR. DIODE .GT. CONCENT(NOCONT)) .AND. ( *.NOT.(OLD_CONTUM)))GOTO 26121 IF(CONORD(CURIMR) .LE. 0)GOTO 26141 C = 0.0 26150 I=1 GOTO 26153 26151 I=I+1 26153 IF((I).GT.(CONORD(CURIMR)))GOTO 26152 C = C + ACON(I,CURIMR)*X**(I-1) GOTO 26151 26152 CONTINUE CONTUM = C GOTO 26131 26141 IF(CFLAG .NE. 1)GOTO 26161 CONTUM = A*X*X + B*X +C GOTO 26131 26161 IF(CFLAG .NE. 2)GOTO 26171 CONTUM = A*X + B GOTO 26131 26171 IF(CFLAG .NE. 3)GOTO 26181 CONTUM = A GOTO 26131 26181 IF(CFLAG .NE. 4)GOTO 26191 CALL FNDCNT(DIODE,BLUE,RED) CALL POLATE(BLUE,RED,DIODE,VALUE) CONTUM = VALUE GOTO 26131 26191 IF(CFLAG .NE. 5)GOTO 26201 CALL FNDCNT(DIODE,BLUE,RED) CONTUM = (CONFLUX(BLUE)+CONFLUX(RED))/2.0 26201 CONTINUE 26131 CONTINUE RETURN 26121 CONTINUE IF(CONORD(CURIMR) .LE. 0)GOTO 26221 IF(DIODE .GE. CONCENT(1))GOTO 26241 X = CONCENT(1) C = 0.0 26250 I=1 GOTO 26253 26251 I=I+1 26253 IF((I).GT.(CONORD(CURIMR)))GOTO 26252 C = C + ACON(I,CURIMR)*X**(I-1) GOTO 26251 26252 CONTINUE CONTUM = C GOTO 26231 26241 IF(DIODE .LE. CONCENT(NOCONT))GOTO 26261 X = CONCENT(NOCONT) C = 0.0 26270 I=1 GOTO 26273 26271 I=I+1 26273 IF((I).GT.(CONORD(CURIMR)))GOTO 26272 C = C + ACON(I,CURIMR)*X**(I-1) GOTO 26271 26272 CONTINUE CONTUM = C 26261 CONTINUE 26231 CONTINUE RETURN 26221 CONTINUE IF(DIODE .GE. CONCENT(1))GOTO 26291 I1=1 I2=2 GOTO 26281 26291 IF(DIODE .LE. CONCENT(NOCONT))GOTO 26301 I1=NOCONT-1 I2=NOCONT 26301 CONTINUE 26281 CONTINUE IF(EFLAG .NE. 1)GOTO 26321 CALL POLATE(I1,I2,DIODE,CONTUM) GOTO 26311 26321 IF(EFLAG .NE. 2 .OR. I1 .NE. 1)GOTO 26331 CONTUM = CONFLUX(I1) GOTO 26311 26331 IF(EFLAG .NE. 2)GOTO 26341 CONTUM = CONFLUX(I2) GOTO 26311 26341 IF(EFLAG .NE. 3)GOTO 26351 CONTUM = A*X + B 26351 CONTINUE 26311 CONTINUE RETURN END SUBROUTINE FNDCNT(DIODE,BLUE,RED) IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM INTEGER BLUE,RED REAL*8 DIODE BLUE=0 RED=0 26360 I=1 GOTO 26363 26361 I=I+1 26363 IF((I).GT.(NOCONT-1))GOTO 26362 IF(DIODE .LT. CONCENT(I) .OR. DIODE .GT. CONCENT(I+1))GOTO 26381 BLUE=I RED=I+1 GOTO 26362 26381 CONTINUE GOTO 26361 26362 CONTINUE RETURN END SUBROUTINE POLATE(I1,I2,DIODE,VALUE) IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF INTEGER I1,I2 REAL*8 VALUE,DIODE VALUE = (CONCENT(I1)-DIODE)*(CONFLUX(I1)- CONFLUX(I2)) / (CONCENT( *I2)-CONCENT(I1)) + CONFLUX(I1) RETURN END SUBROUTINE FINSH IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL WRITE(1,26390)CURSPC,CURORD 26390 FORMAT (/,'RESULTS FOR SPECTRUM ',I3,' ORDER ',I3,1H:) WRITE(1,26400)CURIMR 26400 FORMAT ('CURRENT IMAGE ROW ',I3,/) IF(.NOT.(.NOT.NRMLSD))GOTO 26421 WRITE(1,26430) 26430 FORMAT(' CONTINUUM REGIONS ',//) WRITE(1,26440) 26440 FORMAT(' WAVELENGTH SCALE') WRITE(1,26450) 26450 FORMAT(' BLUE RED FLUX FACTOR ',/) WRITE(1,26460)(WAV(DBLE(CONLFT(I))-0.5),WAV(DBLE(CONRHT(I))+0.5), *CONFLUX(I),CFACTOR(I),I=1,NOCONT) 26460 FORMAT (2F10.3,2X,F8.6,2X,F8.6) WRITE(1,26470)CONORD(CURIMR) 26470 FORMAT(//,'ORDER OF POLYNOMIAL FIT = ',I4) WRITE(1,26480) 26480 FORMAT(/,'POLYNOMIAL COEFFICIENTS: ') WRITE(1,26490)( ACON(ITERM,CURIMR),ITERM=1,CONORD(CURIMR)) 26490 FORMAT (5(G16.9,1X)) GOTO 26501 26421 CONTINUE WRITE(1,26510) 26510 FORMAT('NORMALISED CONTINUUM AT 1.00 USED THROUGHOUT') 26501 CONTINUE 26411 CONTINUE 26520 IPAGE=1 GOTO 26523 26521 IPAGE=IPAGE+1 26523 IF((IPAGE).GT.(100))GOTO 26522 N = (IPAGE-1)*50 WRITE(1,26530) 26530 FORMAT (///, ' LINE ID WAVELENGTH LEFT RIGHT DEPTH CENTRE F %WHM EW(MA) +/-EW'//) 26540 I=N+1 GOTO 26543 26541 I=I+1 26543 IF((I).GT.(N+50))GOTO 26542 IF(I .LE. NOLINES)GOTO 26561 RETURN 26561 CONTINUE WRITE(1,26570)LINEID(I),WAVELN(I),LFTDIO(I),RHTDIO(I),DEPTH(I), CE *NTRE(I),FWHM(I),EW(I),DELTEW(I) 26570 FORMAT (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) IF(I .GE. NOLINES)GOTO 26542 GOTO 26541 26542 CONTINUE WRITE(1,26580) 26580 FORMAT(1H1) IF(I .GE. NOLINES)GOTO 26522 GOTO 26521 26522 CONTINUE CALL FLUSH RETURN END SUBROUTINE CLSFILS COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL 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 SUBROUTINE GAUSFT(X,AOLD,N,PHOTONS,COV,SWITCH,CHISQ) IMPLICIT REAL*8(A-H,O-Z) COMMON/ROTCOM/ VSINI REAL*8 VSINI 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),FAC *TOR,NU REAL*8 SWITCH(9),CHISQ,COVOLD(9,9),WOLD(100),PHIOLD(100) INTEGER N,I,J,NITER,NPARAM,NZERO,NRUN LOGICAL CONVRG,GASSWD NRUN = 0 26590 CONTINUE NITER = 1 NZERO = 0 NU = 1000.0 26600 J=1 GOTO 26603 26601 J=J+1 26603 IF((J).GT.(9))GOTO 26602 ANEW(J) = AOLD(J) GOTO 26601 26602 CONTINUE CALL INITPA(V,X,XBEST,N,AOLD,F,SIGMA,PHOTONS,SWITCH,COV,NPARAM) IF(N-NZERO .GE. NPARAM)GOTO 26621 IF(N .NE. 1)GOTO 26641 IF(SWITCH(1) .NE. 1.0)GOTO 26661 AOLD(1) = 0.0 GOTO 26651 26661 IF(SWITCH(4) .NE. 1.0)GOTO 26671 AOLD(4) = 0.0 GOTO 26651 26671 IF(SWITCH(7) .NE. 1.0)GOTO 26681 AOLD(7) = 0.0 26681 CONTINUE 26651 CONTINUE RETURN 26641 CONTINUE WRITE(8,26690) 26690 FORMAT (' INSUFFICIENT NUMBER OF POINTS IN GAUSS FIT ') WRITE(8,26700)SWITCH,X 26700 FORMAT (' SWITCH ',9F3.0,/,' X VALUES ',20(8E15.6,/),/) RETURN 26621 CONTINUE CALL FNDERI(XBEST,FA,FX,W,SIGMA,N,AOLD,SWITCH) CALL DETPHI(PHI,F,V,FX,N) CALL FNDXCR(V,N,FA,FX,PHI,W,SIGMA,DELTA,AOLD,X) CALL CMPRES(PHI,W,SOLD,N) 26710 CONTINUE 26711 CONTINUE CALL FNDPCR(DELTA,N,NU,W,FA,PHI,COV,NPARAM,IER) CALL CKFIME(IER,N,AOLD,X) CALL CORPAR(X,XBEST,V,N,ANEW,DELTA,F,SWITCH) CALL FNDERI(XBEST,FA,FX,W,SIGMA,N,ANEW,SWITCH) CALL DETPHI(PHI,F,V,FX,N) CALL FNDXCR(V,N,FA,FX,PHI,W,SIGMA,DELTA,ANEW,X) CALL CMPRES(PHI,W,SNEW,N) IF(SNEW .LT. SOLD)GOTO 26731 NU = NU/10.0 GOTO 26741 26731 CONTINUE NU = 10.0*NU 26750 J=1 GOTO 26753 26751 J=J+1 26753 IF((J).GT.(9))GOTO 26752 AOLD(J) = ANEW(J) 26760 JJ=1 GOTO 26763 26761 JJ=JJ+1 26763 IF((JJ).GT.(9))GOTO 26762 COVOLD(J,JJ) = COV(J,JJ) GOTO 26761 26762 CONTINUE GOTO 26751 26752 CONTINUE 26770 JJ=1 GOTO 26773 26771 JJ=JJ+1 26773 IF((JJ).GT.(N))GOTO 26772 WOLD(JJ) = W(JJ) PHIOLD(JJ) = PHI(JJ) GOTO 26771 26772 CONTINUE CALL FNDXCR(V,N,FA,FX,PHI,W,SIGMA,DELTA,AOLD,X) CALL DETPHI(PHI,F,V,FX,N) CALL FNDPCR(DELTA,N,NU,W,FA,PHI,COV,NPARAM,IER) CALL CKFIME(IER,N,AOLD,X) CALL CMPRES(PHI,W,SOLD,N) 26741 CONTINUE 26721 CONTINUE NITER = NITER + 1 IF(CONVRG(AOLD,ANEW,DELTA,SWITCH) .OR. NITER .GT. 16)GOTO 26712 GOTO 26711 26712 CONTINUE IF(N .LE. NPARAM)GOTO 26791 FACTOR = 0.0 26800 I=1 GOTO 26803 26801 I=I+1 26803 IF((I).GT.(N))GOTO 26802 FACTOR = FACTOR + WOLD(I)*PHIOLD(I)**2 GOTO 26801 26802 CONTINUE FACTOR = FACTOR/DBLE(N-NPARAM) 26791 CONTINUE FACTOR = 1.00 CALL FINCOVM(COV,COVOLD,FACTOR,SWITCH) CALL CMPCHI(X,N,AOLD,SIGMA,SWITCH,CHISQ) RETURN END SUBROUTINE INITPA(V,X,XBEST,N,A,F,SIGMA,PHOTONS,SW,COV,NPARAM) IMPLICIT REAL*8(A-H,O-Z) COMMON/ROTCOM/ VSINI REAL*8 VSINI REAL*8 V(200),X(200),XBEST(200),A(9),F(100),SIGMA(200),PHOTONS,DEL *TA,SW(9) REAL*8 MYEXP,COV(9,9),PROFILE INTEGER N,I,NPARAM 26810 I=1 GOTO 26813 26811 I=I+1 26813 IF((I).GT.(9))GOTO 26812 26820 II=1 GOTO 26823 26821 II=II+1 26823 IF((II).GT.(9))GOTO 26822 COV(I,II) = 0.0 GOTO 26821 26822 CONTINUE GOTO 26811 26812 CONTINUE 26830 I=1 GOTO 26833 26831 I=I+1 26833 IF((I).GT.(2*N))GOTO 26832 V(I) = 0.0 XBEST(I) = X(I) GOTO 26831 26832 CONTINUE NPARAM = 0 26840 J=1 GOTO 26843 26841 J=J+1 26843 IF((J).GT.(9))GOTO 26842 IF(SW(J) .NE. 1.0)GOTO 26861 NPARAM = NPARAM + 1 26861 CONTINUE GOTO 26841 26842 CONTINUE 26870 I=1 GOTO 26873 26871 I=I+1 26873 IF((I).GT.(N))GOTO 26872 F(I) = PROFILE(X(2*I-1),A,SW,VSINI) - X(2*I) GOTO 26871 26872 CONTINUE IF(N .LE. 1)GOTO 26891 DELTA = X(3) - X(1) GOTO 26901 26891 CONTINUE DELTA = 1.0 26901 CONTINUE 26881 CONTINUE IF(PHOTONS .NE. 0.0)GOTO 26921 PHOTONS = 1.0 26921 CONTINUE 26930 J=1 GOTO 26933 26931 J=J+(2) 26933 IF((2)*((J)-(2*N-1)).GT.0)GOTO 26932 SIGMA(J) = DELTA**2/(12.0*(1.0-X(J+1))*PHOTONS) SIGMA(J+1) = ( 1.0 - X(J+1) )/PHOTONS GOTO 26931 26932 CONTINUE RETURN END SUBROUTINE FNDZRO(X,N,NZERO) IMPLICIT REAL*8(A-H,O-Z) REAL*8 X(200) INTEGER N,NZERO,I NZERO = 0 26940 I=2 GOTO 26943 26941 I=I+(2) 26943 IF((2)*((I)-(2*N)).GT.0)GOTO 26942 IF(X(I) .GT. 0.0)GOTO 26961 NZERO = NZERO + 1 26961 CONTINUE GOTO 26941 26942 CONTINUE RETURN END SUBROUTINE FNDERI(XBEST,FA,FX,W,SIGMA,N,A,SW) IMPLICIT REAL*8(A-H,O-Z) COMMON/ROTCOM/ VSINI REAL*8 VSINI COMMON/ITRCOM/ DA(9),DX,PROF_TOL REAL*8 DA,DX,PROF_TOL 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 .LE. 0.1D0)GOTO 26981 26990 IPAR=1 GOTO 26993 26991 IPAR=IPAR+1 26993 IF((IPAR).GT.(9))GOTO 26992 ADUM(IPAR) = A(IPAR) GOTO 26991 26992 CONTINUE 27000 I=1 GOTO 27003 27001 I=I+1 27003 IF((I).GT.(N))GOTO 27002 K = 1 27010 ISW=1 GOTO 27013 27011 ISW=ISW+1 27013 IF((ISW).GT.(9))GOTO 27012 IF(SW(ISW) .NE. 1.0)GOTO 27031 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) 27031 CONTINUE GOTO 27011 27012 CONTINUE GOTO 27001 27002 CONTINUE J = 1 27040 I=1 GOTO 27043 27041 I=I+1 27043 IF((I).GT.(N))GOTO 27042 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 GOTO 27041 27042 CONTINUE GOTO 27051 26981 CONTINUE CALL GEXDER(XBEST,FA,FX,W,SIGMA,N,A,SW) 27051 CONTINUE 26971 CONTINUE RETURN END SUBROUTINE GEXDER(XBEST,FA,FX,W,SIGMA,N,A,SW) 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 27060 I=1 GOTO 27063 27061 I=I+1 27063 IF((I).GT.(N))GOTO 27062 K = 1 IF(SW(1) .NE. 1.0)GOTO 27081 FA(I,K) = MYEXP(-((XBEST(2*I-1)-A(2))/A(3))**2) K = K + 1 27081 CONTINUE IF(SW(2) .NE. 1.0)GOTO 27101 FA(I,K) = (2.0*(XBEST(2*I-1)-A(2))/A(3)**2)*A(1) * MYEXP( -((XBES *T(2*I-1)-A(2))/A(3))**2) K = K + 1 27101 CONTINUE IF(SW(3) .NE. 1.0)GOTO 27121 FA(I,K) = 2.0*( ( XBEST(2*I-1)-A(2) )/A(3) )**2 *A(1)/A(3) * MYEX *P( -((XBEST(2*I-1)-A(2))/A(3))**2) K = K + 1 27121 CONTINUE IF(SW(4) .NE. 1.0)GOTO 27141 FA(I,K) = MYEXP(-((XBEST(2*I-1)-A(5))/A(6))**2) K = K + 1 27141 CONTINUE IF(SW(5) .NE. 1.0)GOTO 27161 FA(I,K) = (2.0*(XBEST(2*I-1)-A(5))/A(6)**2)*A(4) * MYEXP( -((XBES *T(2*I-1)-A(5))/A(6))**2) K = K + 1 27161 CONTINUE IF(SW(6) .NE. 1.0)GOTO 27181 FA(I,K) = 2.0*( ( XBEST(2*I-1)-A(5) )/A(6) )**2 *A(4)/A(6) * MYEX *P( -((XBEST(2*I-1)-A(5))/A(6))**2) K = K + 1 27181 CONTINUE IF(SW(7) .NE. 1.0)GOTO 27201 FA(I,K) = MYEXP(-((XBEST(2*I-1)-A(8))/A(9))**2) K = K + 1 27201 CONTINUE IF(SW(8) .NE. 1.0)GOTO 27221 FA(I,K) = (2.0*(XBEST(2*I-1)-A(8))/A(9)**2)*A(7) * MYEXP( -((XBES *T(2*I-1)-A(8))/A(9))**2) K = K + 1 27221 CONTINUE IF(SW(9) .NE. 1.0)GOTO 27241 FA(I,K) = 2.0*( ( XBEST(2*I-1)-A(8) )/A(9) )**2 *A(7)/A(9) * MYEX *P( -((XBEST(2*I-1)-A(8))/A(9))**2) K = K + 1 27241 CONTINUE GOTO 27061 27062 CONTINUE 27250 I=1 GOTO 27253 27251 I=I+1 27253 IF((I).GT.(N))GOTO 27252 27260 J=1 GOTO 27263 27261 J=J+1 27263 IF((J).GT.(2*N))GOTO 27262 FX(I,J) = 0.0 GOTO 27261 27262 CONTINUE GOTO 27251 27252 CONTINUE J=1 27270 I=1 GOTO 27273 27271 I=I+1 27273 IF((I).GT.(N))GOTO 27272 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) .NE. 1.0) .AND. ((SW(5) .NE. 1.0) .AND. (SW(6) .NE. 1.0) *))GOTO 27291 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) 27291 CONTINUE IF((SW(7) .NE. 1.0) .AND. ((SW(8) .NE. 1.0) .AND. (SW(9) .NE. 1.0) *))GOTO 27311 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) 27311 CONTINUE W(I) = 1.0/( FX(I,J)**2*SIGMA(J)+SIGMA(J+1) ) J = J+1 FX(I,J) = -1.0 J = J+1 GOTO 27271 27272 CONTINUE RETURN END REAL*8 FUNCTION PROFILE(X, A, SW, VSINI) IMPLICIT REAL*8 (A-H,O-Z) REAL*8 DUMMY, X, A(9), SW(9), VSINI, GAUSPRF, ROTPROF INTEGER I, NGAUSS DUMMY = 0.0D0 27320 I=1 GOTO 27323 27321 I=I+1 27323 IF((I).GT.(NGAUSS(SW)))GOTO 27322 IF(VSINI .GE. 0.1D0)GOTO 27341 DUMMY = DUMMY + GAUSPRF(X, A, I) GOTO 27351 27341 CONTINUE DUMMY = DUMMY + ROTPROF(X, A, I, VSINI) 27351 CONTINUE 27331 CONTINUE GOTO 27321 27322 CONTINUE PROFILE = DUMMY RETURN END INTEGER FUNCTION NGAUSS(SW) REAL*8 SW(9) NGAUSS = 0 IF(SW(1)+SW(2)+SW(3) .LT. 1.0)GOTO 27371 NGAUSS = 1 27371 CONTINUE IF(SW(4)+SW(5)+SW(6) .LT. 1.0)GOTO 27391 NGAUSS = 2 27391 CONTINUE IF(SW(7)+SW(8)+SW(9) .LT. 1.0)GOTO 27411 NGAUSS = 3 27411 CONTINUE RETURN END REAL*8 FUNCTION GAUSPRF(X, A, ILINE) IMPLICIT REAL*8 (A-H,O-Z) 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) GAUSPRF = A1 * MYEXP( -((X-A2)/A3)**2 ) RETURN END REAL*8 FUNCTION ROTPROF(PIX, A, ILINE, VSINI ) IMPLICIT REAL*8 (A-H,O-Z) REAL*8 PIX, A(9), VSINI, C, COEFF(3), LAMC,LAM, DLAML, DPIXL, XSTE *PR 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) 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 .GE. XSTEPG)GOTO 27431 XSTEP = XSTEPR 27431 CONTINUE XSTEP = 0.05 NLAM = 2*INT(DPIXL/XSTEP) + 1 DPIX = -DPIXL 27440 I=1 GOTO 27443 27441 I=I+1 27443 IF((I).GT.(NLAM))GOTO 27442 F(I) = H(PIX-DPIX,COEFF)*G(DPIX,DPIXL,DLAML,LAMC) X(I) = DPIX DPIX = -DPIXL + DBLE(I)*XSTEP GOTO 27441 27442 CONTINUE ROTPROF = HELENA(X,F,SUM,NLAM) RETURN END REAL*8 FUNCTION H(X,COEFF) 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) 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) .LE. DABS(DPIXL))GOTO 27461 G = 0.0D0 GOTO 27471 27461 CONTINUE 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) 27471 CONTINUE 27451 CONTINUE RETURN END REAL*8 FUNCTION MYEXP(ARG) IMPLICIT REAL*8(A-H,O-Z) REAL*8 ARG IF(ARG .GE. -150.D0)GOTO 27491 MYEXP = 0.0D0 GOTO 27501 27491 CONTINUE MYEXP = DEXP(ARG) 27501 CONTINUE 27481 CONTINUE RETURN END SUBROUTINE DETPHI(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 27510 J=1 GOTO 27513 27511 J=J+1 27513 IF((J).GT.(N))GOTO 27512 PHI(J) = 0.0 27520 I=1 GOTO 27523 27521 I=I+(2) 27523 IF((2)*((I)-(2*N-1)).GT.0)GOTO 27522 PHI(J) = PHI(J) - FX(J,I)*V(I) GOTO 27521 27522 CONTINUE PHI(J) = PHI(J) + F(J) GOTO 27511 27512 CONTINUE RETURN END SUBROUTINE CMPRES(PHI,W,S,N) IMPLICIT REAL*8(A-H,O-Z) REAL*8 PHI(100),W(100),S INTEGER I,N S = 0.0 27530 I=1 GOTO 27533 27531 I=I+1 27533 IF((I).GT.(N))GOTO 27532 S = S + PHI(I)**2 * W(I) GOTO 27531 27532 CONTINUE S = 0.5*S RETURN END SUBROUTINE FNDPCR(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 27540 I=1 GOTO 27543 27541 I=I+1 27543 IF((I).GT.(9))GOTO 27542 27550 J=1 GOTO 27553 27551 J=J+1 27553 IF((J).GT.(9))GOTO 27552 MINV(I,J) = 0.0 GOTO 27551 27552 CONTINUE GOTO 27541 27542 CONTINUE 27560 I=1 GOTO 27563 27561 I=I+1 27563 IF((I).GT.(NPARAM))GOTO 27562 27570 J=1 GOTO 27573 27571 J=J+1 27573 IF((J).GT.(NPARAM))GOTO 27572 M(I,J) = 0.0 27580 K=1 GOTO 27583 27581 K=K+1 27583 IF((K).GT.(N))GOTO 27582 M(I,J) = M(I,J) + W(K)*FA(K,I)*FA(K,J) GOTO 27581 27582 CONTINUE GOTO 27571 27572 CONTINUE GOTO 27561 27562 CONTINUE 27590 I=1 GOTO 27593 27591 I=I+1 27593 IF((I).GT.(NPARAM))GOTO 27592 M(I,I) = M(I,I)*(1.0+1.0/NU) GOTO 27591 27592 CONTINUE CALL LINV2F(M,NPARAM,NINE,MINV,IDIGIT,WKAREA,IER) 27600 J=1 GOTO 27603 27601 J=J+1 27603 IF((J).GT.(NPARAM))GOTO 27602 COL(J) = 0.0 27610 I=1 GOTO 27613 27611 I=I+1 27613 IF((I).GT.(N))GOTO 27612 COL(J) = COL(J) + W(I)*PHI(I)*FA(I,J) GOTO 27611 27612 CONTINUE GOTO 27601 27602 CONTINUE 27620 J=1 GOTO 27623 27621 J=J+1 27623 IF((J).GT.(NPARAM))GOTO 27622 DELTA(J) = 0.0 27630 I=1 GOTO 27633 27631 I=I+1 27633 IF((I).GT.(NPARAM))GOTO 27632 DELTA(J) = DELTA(J) - MINV(J,I)*COL(I) GOTO 27631 27632 CONTINUE GOTO 27621 27622 CONTINUE RETURN END SUBROUTINE CKFIME(IER,N,A,X) IMPLICIT REAL*8(A-H,O-Z) REAL*8 A(9),X(200) INTEGER IER,N,I IF(IER .EQ. 0)GOTO 27651 WRITE(8,27660)IER 27660 FORMAT (/' IMSL ERROR NUMBER ',I3) WRITE(8,27670)A 27670 FORMAT (' A VALUES: ',/,3(3E15.6,/)) WRITE(8,27680)(X(I),I=1,2*N) 27680 FORMAT(' X VALUES: ',/,25(8E15.6,/)) 27651 CONTINUE RETURN END SUBROUTINE FNDXCR(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 27690 I=1 GOTO 27693 27691 I=I+1 27693 IF((I).GT.(N))GOTO 27692 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) GOTO 27691 27692 CONTINUE RETURN END SUBROUTINE CORPAR(X,XBEST,V,N,A,DELTA,F,SW) IMPLICIT REAL*8(A-H,O-Z) COMMON/ROTCOM/ VSINI REAL*8 VSINI REAL*8 X(200),XBEST(200),V(200),F(100),A(9),DELTA(9),SW(9),PROFILE * INTEGER N,I 27700 I=1 GOTO 27703 27701 I=I+1 27703 IF((I).GT.(2*N))GOTO 27702 XBEST(I) = X(I) + V(I) GOTO 27701 27702 CONTINUE J = 0 27710 I=1 GOTO 27713 27711 I=I+1 27713 IF((I).GT.(9))GOTO 27712 IF(SW(I) .NE. 1.0)GOTO 27731 J = J + 1 A(I) = A(I) + DELTA(J) 27731 CONTINUE GOTO 27711 27712 CONTINUE 27740 I=1 GOTO 27743 27741 I=I+1 27743 IF((I).GT.(N))GOTO 27742 F(I) = PROFILE(X(2*I-1),A,SW,VSINI) - X(2*I) GOTO 27741 27742 CONTINUE RETURN END LOGICAL FUNCTION CONVRG(AOLD,ANEW,DELTA,SWITCH) IMPLICIT REAL*8(A-H,O-Z) REAL*8 AOLD(9),ANEW(9),DELTA(9),SWITCH(9) CONVRG = .FALSE. K = 0 27750 I=1 GOTO 27753 27751 I=I+1 27753 IF((I).GT.(9))GOTO 27752 IF(SWITCH(I) .NE. 1.0)GOTO 27771 K = K + 1 IF(DLOG10(DABS(DELTA(K))) .GE. -60.0)GOTO 27791 CONVRG = .TRUE. GOTO 27781 27791 IF(DABS( ANEW(I) ) .LE. 30000.0)GOTO 27801 CONVRG = .TRUE. WRITE(8,27810) 27810 FORMAT(' GAUSSIAN FIT DIVERGING, ITERATIONS ABANDONED ') GOTO 27752 GOTO 27781 27801 IF(DABS( AOLD(I)/DELTA(K) ) .LE. 10000.0)GOTO 27821 CONVRG = .TRUE. GOTO 27831 27821 CONTINUE CONVRG = .FALSE. GOTO 27752 27831 CONTINUE 27781 CONTINUE 27771 CONTINUE GOTO 27751 27752 CONTINUE RETURN END LOGICAL FUNCTION GASSWD(AOLD,SWITCH) IMPLICIT REAL*8 (A-H,O-Z) REAL*8 AOLD(9),SWITCH(9),ADUM(3) INTEGER I,NGAUSS GASSWD = .FALSE. IF(NGAUSS(SWITCH) .NE. 1)GOTO 27851 RETURN 27851 CONTINUE 26590 CONTINUE 27860 I=1 GOTO 27863 27861 I=I+1 27863 IF((I).GT.(NGAUSS(SWITCH)-1))GOTO 27862 IF(AOLD(3*(I-1)+2) .LE. AOLD(3*I+2))GOTO 27881 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) GASSWD = .TRUE. 27881 CONTINUE GOTO 27861 27862 CONTINUE IF(AOLD(2) .LE. AOLD(5))GOTO 27901 GOTO 26590 27901 CONTINUE RETURN END SUBROUTINE CMPCHI(X,N,A,SIGMA,SW,CHISQ) IMPLICIT REAL*8(A-H,O-Z) COMMON/ROTCOM/ VSINI REAL*8 VSINI REAL*8 X(200),A(9),SIGMA(200),PROFILE,CHISQ,SW(9) INTEGER N,I CHISQ = 0.0 27910 I=1 GOTO 27913 27911 I=I+1 27913 IF((I).GT.(N))GOTO 27912 YRES = PROFILE(X(2*I-1),A,SW,VSINI) - X(2*I) CHISQ = CHISQ + YRES**2/SIGMA(2*I) GOTO 27911 27912 CONTINUE RETURN END SUBROUTINE FINCOVM(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 IC = 0 27920 I=1 GOTO 27923 27921 I=I+1 27923 IF((I).GT.(9))GOTO 27922 IPARAM(I) = 0 IF(SWITCH(I) .NE. 1.0)GOTO 27941 IC = IC + 1 IPARAM(I) = IC 27941 CONTINUE GOTO 27921 27922 CONTINUE 27950 I=1 GOTO 27953 27951 I=I+1 27953 IF((I).GT.(9))GOTO 27952 27960 J=1 GOTO 27963 27961 J=J+1 27963 IF((J).GT.(9))GOTO 27962 IF(SWITCH(I) .NE. 1.0 .OR. SWITCH(J) .NE. 1.0)GOTO 27981 COV(I,J) = FACTOR * COVOLD( IPARAM(I),IPARAM(J) ) GOTO 27991 27981 CONTINUE COV(I,J) = 0.0 27991 CONTINUE 27971 CONTINUE GOTO 27961 27962 CONTINUE GOTO 27951 27952 CONTINUE RETURN END SUBROUTINE RADIALV IMPLICIT REAL*8(A-H,O-Z) COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(1000000),VARSPEC(1000000),SN,LAMBDA(1000000),RV,SIG *RV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON/DNONLIN/PIXMIN,PIXMAX,PMIDDLE,PRANGE,C REAL*8 PIXMIN,PIXMAX,PMIDDLE,PRANGE,C(50) COMMON/LNONLIN/NON_LINEAR LOGICAL NON_LINEAR COMMON/NNONLIN/NTERMS INTEGER NTERMS INTEGER JREF,J,I,WRONG INTEGER NREF,IEND,ISTART,STDORDER REAL*8 FMIN,WREF(1000),NSIG,PMIN,RVI(1000) REAL*8 RVT,AN,RVT2,SIG,WEND,CENTER,SHIFTSTD,WSTD,RV_FAC WRITE(6,28000) 28000 FORMAT(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') READ(14,*)WSTD WJUNK = WSTD * RV_FZERO CALL FNDORD(WJUNK,STDORDER) IF(STDORDER .NE. 0)GOTO 28021 WRITE(6,28030)WSTD 28030 FORMAT(32H Cannot locate standard line at ,F10.3) STOP 28021 CONTINUE CALL RDSPEC(STDORDER) IF(.NOT.(NON_LINEAR))GOTO 28051 WEND = WAV(DBLE(NPTS)) WSTART = WAV(1.0d0) GOTO 28061 28051 CONTINUE WEND = W1(STDORDER) + DW(STDORDER)*(DBLE(NPTS)-PIX1(STDORDER)) WSTART = W1(STDORDER) + DW(STDORDER)*(1.0d0-PIX1(STDORDER)) 28061 CONTINUE 28041 CONTINUE RV_FAC = 1.0D+00 + 350. / 3.0D+05 IF((WSTART .LE. WSTD/RV_FAC) .AND. (WEND .GE. WSTD*RV_FAC))GOTO 28 *081 WRITE(6,'(55H WARNING: Standard line within 350 Km/s of spectrum e %nd)') GOTO 28071 28081 IF(WSTART .GT. WSTD-0.7 .OR. WEND .LT. WSTD+0.7)GOTO 28091 RV_FZERO = 1.0D+00 + RV_EST / 3.0D+05 RV_FAC = 1.0D+00 + RV_SRCH / 3.0D+05 IF(.NOT.(NON_LINEAR))GOTO 28111 ISTART = NINT(CHANNEL(WSTD*RV_FZERO/RV_FAC)) IEND = NINT(CHANNEL(WSTD*RV_FZERO*RV_FAC)) GOTO 28121 28111 CONTINUE ISTART = NINT( (WSTD*RV_FZERO/RV_FAC - WSTART)/DW(STDORDER) + 1.0 *) IEND = NINT( (WSTD*RV_FZERO*RV_FAC - WSTART)/DW(STDORDER) + 1.0 ) 28121 CONTINUE 28101 CONTINUE IF(ISTART .GE. 1)GOTO 28141 ISTART=1 28141 CONTINUE IF(IEND .LE. NPTS)GOTO 28161 IEND=NPTS 28161 CONTINUE FMIN = 1.0 28170 I=ISTART GOTO 28173 28171 I=I+1 28173 IF((I).GT.(IEND))GOTO 28172 IF(SPEC(I) .GE. FMIN)GOTO 28191 FMIN = SPEC(I) PMIN = DBLE(I) 28191 CONTINUE GOTO 28171 28172 CONTINUE GOTO 28201 28091 CONTINUE WRITE(6,'(43H end of spectrum too close to standard line)') STOP 28201 CONTINUE 28071 CONTINUE CALL GTSTDMIN(PMIN,FMIN,CENTER) IF(.NOT.(NON_LINEAR))GOTO 28221 SHIFTSTD = WAV(CENTER)/WSTD GOTO 28231 28221 CONTINUE SHIFTSTD = ( WSTART + (CENTER-PIX1(STDORDER))*DW(STDORDER) ) / WST *D 28231 CONTINUE 28211 CONTINUE 28240 J=1 GOTO 28243 28241 J=J+1 28243 IF((J).GT.(1000))GOTO 28242 READ(14,*,END=26590)WREF(J) GOTO 28241 28242 CONTINUE 26590 CONTINUE REWIND(UNIT=14) CLOSE(UNIT=14) NREF = J - 1 WRONG = 0 RVT = 0.0 RVT2 = 0.0 28250 J=1 GOTO 28253 28251 J=J+1 28253 IF((J).GT.(NREF))GOTO 28252 CALL FNDORD(WREF(J),NEWORD) IF(NEWORD .NE. 0)GOTO 28271 CALL RMRVRF(WREF,J,NREF) J = J - 1 GOTO 28251 28271 CONTINUE IF(NEWORD .EQ. CURORD)GOTO 28291 CALL RDSPEC(NEWORD) 28291 CONTINUE IF(.NOT.(NON_LINEAR))GOTO 28311 WEND = WAV(DBLE(NPTS)) WSTART = WAV(1.0d0) JREF = NINT( CHANNEL(WREF(J)*SHIFTSTD) ) GOTO 28321 28311 CONTINUE WEND = W1(NEWORD) + DW(NEWORD) * (DBLE(NPTS)-PIX1(NEWORD)) WSTART = W1(NEWORD) + DW(NEWORD)*(1.0d0-PIX1(NEWORD)) JREF = NINT((WREF(J)*SHIFTSTD - WSTART) / DW(NEWORD) + 1.0D+00) 28321 CONTINUE 28301 CONTINUE CALL GETMIN(JREF,CENTER,NPTS) IF(.NOT.(NON_LINEAR))GOTO 28341 WCENT = WAV(CENTER) GOTO 28351 28341 CONTINUE WCENT = WSTART + DW(NEWORD)*(CENTER-1.0D+00) 28351 CONTINUE 28331 CONTINUE RVI(J) = 3.0D+05*( WCENT/WREF(J) - 1.0D+00 ) GOTO 28251 28252 CONTINUE CALL GTMEDN2(RVI,WREF,NREF,RVMED) 28360 J=1 GOTO 28363 28361 J=J+1 28363 IF((J).GT.(NREF))GOTO 28362 DVLIMIT = 25.0 IF(DABS(RVI(J)-RVMED) .LE. DVLIMIT)GOTO 28381 IF(J .GE. NREF)GOTO 28401 28410 JJ=J GOTO 28413 28411 JJ=JJ+1 28413 IF((JJ).GT.(NREF-1))GOTO 28412 WREF(JJ) = WREF(JJ+1) RVI(JJ) = RVI(JJ+1) GOTO 28411 28412 CONTINUE 28401 CONTINUE NREF = NREF - 1 J = J - 1 GOTO 28361 GOTO 28421 28381 CONTINUE RVT = RVT + RVI(J) RVT2 = RVT2 + RVI(J)**2 WRITE(6,'(7h wav = ,F10.3,2X,6h RV = ,F10.3)')WREF(J),RVI(J) 28421 CONTINUE 28371 CONTINUE IF(J.GE.NREF)GOTO 28362 GOTO 28361 28362 CONTINUE 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 IF(.NOT.(NON_LINEAR))GOTO 28441 DWAV = WAV(DBLE(NPTS/2)) - WAV(DBLE(NPTS/2-2)) DV = 2.0D0 * 3.0D+05 * DWAV/WAV(DBLE(NPTS/2)) GOTO 28451 28441 CONTINUE DV = 2.0 * 3.0D+05*DW(NREF/2)/WREF(NREF/2) 28451 CONTINUE 28431 CONTINUE IF(DABS(RV-RVMED) .LE. DV)GOTO 28471 RV = RVMED WRITE(6,'(16H MEDIAN RV USED )') 28471 CONTINUE RETURN END SUBROUTINE RMRVRF(WREF,J,NREF) REAL*8 WREF(1000) INTEGER NREF,J,I 28480 I=J GOTO 28483 28481 I=I+1 28483 IF((I).GT.(NREF-1))GOTO 28482 WREF(I) = WREF(I+1) GOTO 28481 28482 CONTINUE NREF = NREF - 1 RETURN END SUBROUTINE GTSTDMIN(PMIN,FMIN,CENTER) IMPLICIT REAL*8 (A-H,O-Z) REAL*8 X(100),Y(100) ICENT = INT(PMIN) ILEFT = 0 IRIGHT = 0 28490 I=1 GOTO 28493 28491 I=I+1 28493 IF((I).GT.(50))GOTO 28492 IF(1.0 - SPEC(ICENT-I) .GE. 0.5*(1.0-FMIN) .OR. ILEFT .NE. 0)GOTO *28511 ILEFT = ICENT - I 28511 CONTINUE IF(1.0 - SPEC(ICENT+I) .GE. 0.5*(1.0-FMIN) .OR. IRIGHT .NE. 0)GOTO * 28531 IRIGHT = ICENT + I 28531 CONTINUE GOTO 28491 28492 CONTINUE IF((ILEFT .NE. 0) .AND. (IRIGHT .NE. 0))GOTO 28551 WRITE(6,28560) 28560 FORMAT(67H CANNOT DEFINE STD LINE - half depth not within 50 pixel *s of center) STOP 28551 CONTINUE II = 0 28570 I=ILEFT GOTO 28573 28571 I=I+1 28573 IF((I).GT.(IRIGHT))GOTO 28572 II = II + 1 X(II) = DBLE(I) Y(II) = SPEC(I) GOTO 28571 28572 CONTINUE N = IRIGHT - ILEFT + 1 CALL PARABOL(X,Y,N,A,B,C) CENTER = -B/(2.0*A) RETURN END SUBROUTINE GETMIN(J,CENTER,NPTS) IMPLICIT REAL*8 (A-H,O-Z) INTEGER J,JMIN,N,ILEFT,IRIGHT,NPTS LOGICAL RIGHT,LEFT REAL*8 DFMIN,DFL,DFR,FMIN,NSIG,SNR REAL*8 A(9),COV(9,9),X(200),PHOTONS,SINGLE(9),CENTER 28580 I=1 GOTO 28583 28581 I=I+1 28583 IF((I).GT.(3))GOTO 28582 SINGLE(I) = 1.0 GOTO 28581 28582 CONTINUE 28590 I=4 GOTO 28593 28591 I=I+1 28593 IF((I).GT.(9))GOTO 28592 SINGLE(I) = 0.0 GOTO 28591 28592 CONTINUE NSIG = 1.8 JMIN = J-2 FMIN = SPEC(JMIN) 28600 I=J-2 GOTO 28603 28601 I=I+1 28603 IF((I).GT.(J+2))GOTO 28602 IF(SPEC(I) .GE. FMIN)GOTO 28621 FMIN = SPEC(I) JMIN = I 28621 CONTINUE GOTO 28601 28602 CONTINUE DFMIN = NSIG * DMYSQ(FMIN)/SNR(NINT(CENTER)) RIGHT = .FALSE. LEFT = .FALSE. 28630 I=1 GOTO 28633 28631 I=I+1 28633 IF((I).GT.(15))GOTO 28632 IF(.NOT.(.NOT.RIGHT) .OR. JMIN+I .GT. NPTS)GOTO 28651 DFR = NSIG * DMYSQ(SPEC(JMIN+I))/SNR(JMIN+I) IF(SPEC(JMIN+I) .LE. FMIN+DFMIN+DFR)GOTO 28671 RIGHT = .TRUE. IRIGHT = I + JMIN 28671 CONTINUE 28651 CONTINUE IF(.NOT.(.NOT.LEFT) .OR. JMIN-I .LT. 1)GOTO 28691 DFL = NSIG * DMYSQ(SPEC(JMIN-I))/SNR(JMIN-I) IF(SPEC(JMIN-I) .LE. FMIN+DFMIN+DFR)GOTO 28711 LEFT = .TRUE. ILEFT = JMIN-I 28711 CONTINUE 28691 CONTINUE IF(.NOT.(LEFT) .OR. .NOT.(RIGHT))GOTO 28731 GOTO 28740 28731 CONTINUE GOTO 28631 28632 CONTINUE WRITE(6,'(44H COULD NOT FIND MINIMUM FOR LINE NEAR PIXEL ,I6)')J CENTER = DBLE(J) RETURN 28740 CONTINUE N = IRIGHT - ILEFT + 1 INDEX = ILEFT 28750 I=1 GOTO 28753 28751 I=I+(2) 28753 IF((2)*((I)-(2*N-1)).GT.0)GOTO 28752 X(I) = DBLE(INDEX) X(I+1) = 1.0 - SPEC(INDEX) INDEX = INDEX + 1 GOTO 28751 28752 CONTINUE A(1) = 1.0 - FMIN A(2) = DBLE(JMIN) A(3) = 0.5*( X(2*N-1) - X(1) ) IF(FMIN .LT. 0.0D0)GOTO 28771 PHOTONS = SNR(JMIN)**2/FMIN GOTO 28781 28771 CONTINUE PHOTONS = 0.0D0 28781 CONTINUE 28761 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) IF(A(2)-DBLE(J) .GE. 8)GOTO 28801 CENTER = A(2) GOTO 28811 28801 CONTINUE CENTER = DBLE(J) 28811 CONTINUE 28791 CONTINUE RETURN END SUBROUTINE GTMEDN2(RVI,WREF,N,RVMED) REAL*8 RVI(1000),WREF(1000),RVMED,DUMMY INTEGER N 28820 J=1 GOTO 28823 28821 J=J+1 28823 IF((J).GT.(N-1))GOTO 28822 K = N - J 28830 I=1 GOTO 28833 28831 I=I+1 28833 IF((I).GT.(K))GOTO 28832 IF(RVI(I) .GE. RVI(I+1))GOTO 28851 DUMMY = RVI(I+1) RVI(I+1) = RVI(I) RVI(I) = DUMMY DUMMY = WREF(I+1) WREF(I+1) = WREF(I) WREF(I) = DUMMY 28851 CONTINUE GOTO 28831 28832 CONTINUE GOTO 28821 28822 CONTINUE N2 = N/2 IODD = N - 2*N2 IF(IODD .NE. 0)GOTO 28871 RVMED = ( RVI(N2) + RVI(N2+1) )/2.0 GOTO 28861 28871 IF(N .LE. 1)GOTO 28881 RVMED = RVI(N2) GOTO 28891 28881 CONTINUE RVMED = RVI(1) 28891 CONTINUE 28861 CONTINUE RETURN END SUBROUTINE GTMEDN(RVI,N,RVMED) REAL*8 RVI(1000),RVMED,DUMMY INTEGER N 28900 J=1 GOTO 28903 28901 J=J+1 28903 IF((J).GT.(N-1))GOTO 28902 K = N - J 28910 I=1 GOTO 28913 28911 I=I+1 28913 IF((I).GT.(K))GOTO 28912 IF(RVI(I) .GE. RVI(I+1))GOTO 28931 DUMMY = RVI(I+1) RVI(I+1) = RVI(I) RVI(I) = DUMMY 28931 CONTINUE GOTO 28911 28912 CONTINUE GOTO 28901 28902 CONTINUE N2 = N/2 IODD = N - 2*N2 IF(IODD .NE. 0)GOTO 28951 RVMED = ( RVI(N2) + RVI(N2+1) )/2.0 GOTO 28941 28951 IF(N .LE. 1)GOTO 28961 RVMED = RVI(N2+1) GOTO 28971 28961 CONTINUE RVMED = RVI(1) 28971 CONTINUE 28941 CONTINUE RETURN END SUBROUTINE FNDORD(W,IORDER) IMPLICIT REAL*8 (A-H,O-Z) COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON/DNONLIN/PIXMIN,PIXMAX,PMIDDLE,PRANGE,C REAL*8 PIXMIN,PIXMAX,PMIDDLE,PRANGE,C(50) COMMON/LNONLIN/NON_LINEAR LOGICAL NON_LINEAR COMMON/NNONLIN/NTERMS INTEGER NTERMS INTEGER IORDER IORDER = 0 NPTS = AXLEN(1) IF(.NOT.(NON_LINEAR))GOTO 28991 WSTART = WAV(1.0d0) WEND = WAV(DBLE(NPTS)) IF(W .GT. WEND .OR. W .LT. WSTART)GOTO 29011 IORDER = 1 29011 CONTINUE RETURN 28991 CONTINUE 29020 I=1 GOTO 29023 29021 I=I+1 29023 IF((I).GT.(NORD))GOTO 29022 WEND = W1(I) + DW(I)*(DBLE(NPTS)-PIX1(I)) WSTART = W1(I) + DW(I)*(1.0d0-PIX1(I)) IF(WEND .LT. W .OR. WSTART .GE. W)GOTO 29041 X1 = 1.0 + (W-WSTART)/DW(I) IORDER = I GOTO 29022 29041 CONTINUE GOTO 29021 29022 CONTINUE IF(I .GE. NORD)GOTO 29061 WEND = W1(I+1) + DW(I+1)*(DBLE(NPTS)-PIX1(I+1)) WSTART = W1(I+1) + DW(I+1)*(1.0d0-PIX1(I+1)) IF(WEND .LT. W .OR. WSTART .GT. W)GOTO 29081 X2 = 1.0 + (W-WSTART)/DW(I+1) IF(DABS(X1-DBLE(NPTS)/2.0) .LE. DABS(X2-DBLE(NPTS)/2.0))GOTO 29101 * IORDER = I + 1 29101 CONTINUE 29081 CONTINUE 29061 CONTINUE RETURN END SUBROUTINE RDCUCT(RV) IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/IBADD/ NOBAD,IBADL(1000),IBADR(1000), IGROW INTEGER NOBAD,IBADL,IBADR,IGROW COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) COMMON/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL CHARACTER*10 ID,LINE*80 REAL*8 WAV1,WAV2,NPX,CFAC INTEGER SEARCH,ISIZE I=0 NOCONT = 0 NOBAD = 0 NPTS = AXLEN(1) WSTART = WAV(1.0D+00) WEND = WAV(DBLE(NPTS)) 29110 CONTINUE 29111 CONTINUE I=I+1 READ(4,'(A80)',END=11860)LINE IF(ID .NE. 'CONTINUUM ')GOTO 29131 READ(LINE,'(A10,4D10.3))',END=11860)ID,WAV1,WAV2,NPX,CFAC I = I - 1 WAV1 = WAV1 WAV2 = WAV2 IF(WAV1 .GE. WEND .OR. WAV2 .LE. WSTART)GOTO 29151 NOCONT = NOCONT + 1 CONLFT(NOCONT) = NINT(CHANNEL(WAV1)) CONRHT(NOCONT) = NINT(CHANNEL(WAV2)) IF(CONLFT(NOCONT) .GE. 1)GOTO 29171 CONLFT(NOCONT) = 1 29171 CONTINUE IF(CONRHT(NOCONT) .LE. NPTS)GOTO 29191 CONRHT(NOCONT) = NPTS 29191 CONTINUE ISIZE = CONRHT(NOCONT) - CONLFT(NOCONT) + 1 IF(NPX .NE. 0.0)GOTO 29211 CONSIZE(NOCONT) = ISIZE GOTO 29221 29211 CONTINUE CONSIZE(NOCONT) = NINT(NPX) 29221 CONTINUE 29201 CONTINUE IF(CONSIZE(NOCONT) .LE. ISIZE)GOTO 29241 CONSIZE(NOCONT) = ISIZE 29241 CONTINUE CFACTOR(NOCONT) = 1.00000 IF(CFAC .LE. 0.00000)GOTO 29261 CFACTOR(NOCONT) = CFAC 29261 CONTINUE 29151 CONTINUE GOTO 29111 GOTO 29121 29131 IF(ID .NE. 'FITCONTIN')GOTO 29271 FITCON = .TRUE. I = I - 1 GOTO 29111 GOTO 29121 29271 IF(ID .NE. 'AUTOCONTIN')GOTO 29281 AUTOCON = .TRUE. I = I - 1 CONRHT(1) = INT(WAV1) CONLFT(1) = 1 CONSIZE(1) = INT(WAV2) CFACTOR(1) = 1.00000 GOTO 29111 GOTO 29121 29281 IF(ID .NE. 'NORMALISED')GOTO 29291 NRMLSD = .TRUE. I = I - 1 GOTO 29111 GOTO 29121 29291 IF(ID .NE. 'BADGROW ')GOTO 29301 IGROW = NINT(WAV1) GOTO 29111 GOTO 29121 29301 IF(ID .NE. 'BADDIODE ')GOTO 29311 IF(INT(NPX) .NE. CURIMR)GOTO 29331 IF(NOBAD .NE. 1000)GOTO 29351 WRITE(8,29360) 29360 FORMAT('MAXIMUM NUMBER OF BAD DIODE REGIONS EXCEEDED') RETURN 29351 CONTINUE NOBAD = NOBAD + 1 I = I - 1 IBADL(NOBAD) = INT( WAV1 ) IBADR(NOBAD)= INT( WAV2 ) 29331 CONTINUE GOTO 29111 29311 CONTINUE 29121 CONTINUE GOTO 29111 29112 CONTINUE 11860 CONTINUE REWIND(UNIT=4) CALL SORTCON RETURN END SUBROUTINE RDGDLO(RV) IMPLICIT REAL*8(A-H,O-Z) COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF COMMON/WIDLIN/WIDE(50) REAL*8 WIDE COMMON/IWIDLI/IWIDE INTEGER IWIDE COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/IBADD/ NOBAD,IBADL(1000),IBADR(1000), IGROW INTEGER NOBAD,IBADL,IBADR,IGROW COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) COMMON/LTELL/TELSET,TELPRES LOGICAL TELSET,TELPRES COMMON/ITELL/LBOUND(100),RBOUND(100),NBOUNDS,NH2O INTEGER LBOUND,RBOUND,NBOUNDS,NH2O COMMON/RTELL/H2OCENT(100),H2OFWHM(100),H2ODEEP(100), H2OSLOP,H2OIN *T,H2OMIN REAL*8 H2OCENT,H2OFWHM,H2ODEEP,H2OSLOP,H2OINT,H2OMIN 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/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL CHARACTER*80 LINE INTEGER SEARCH I=0 NOGDLN = 0 NOLINES = 0 NOBAD = 0 NPTS = AXLEN(1) WSTART = WAV(1.0D+00) WEND = WAV(DBLE(NPTS)) 29370 CONTINUE 29371 CONTINUE READ(4,'(A80)',END=11860)LINE IF(LINE(:9) .NE. 'OLDCONTIN')GOTO 29391 GOTO 29371 29391 CONTINUE READ(LINE,'(A10,4D10.3,3(2X,I3))')LINEID(I+1),WAVELN(I+1), ATOM(I %+1),EPLOW(I+1),GF(I+1),IGOOD,ILEFT(I+1),IRIGHT(I+1) IF(LINEID(I+1) .NE. 'CONTINUUM ')GOTO 29411 GOTO 29371 GOTO 29401 29411 IF(LINEID(I+1) .NE. 'FITCONTIN')GOTO 29421 GOTO 29371 GOTO 29401 29421 IF(LINEID(I+1) .NE. 'AUTOCONTIN')GOTO 29431 GOTO 29371 GOTO 29401 29431 IF(LINEID(I+1) .NE. 'NORMALISED')GOTO 29441 GOTO 29371 GOTO 29401 29441 IF(LINEID(I+1)(:5) .NE. 'FOCUS')GOTO 29451 READ(LINE(6:10),'(F5.1)')XROW IROW = NINT(XROW) IF(IROW .LE. 0)GOTO 29471 FOCUS_PARS(IROW) = .TRUE. READ(LINE(11:),'(7F10.5)')WFC(IROW),(A_FOCUS(IROW,IPAR),IPAR=1,6) GOTO 29481 29471 CONTINUE GLOBAL_FOCUS = .TRUE. READ(LINE(11:),'(7F10.5)')GLOBAL_WFC,(GLOBAL_A(IPAR),IPAR=1,6) 29481 CONTINUE 29461 CONTINUE GOTO 29371 GOTO 29401 29451 IF(LINEID(I+1) .NE. 'INST_PROF ')GOTO 29491 INST_PROF = .TRUE. GOTO 29371 GOTO 29401 29491 IF(LINEID(I+1) .NE. 'BOUNDS ')GOTO 29501 GOTO 29371 GOTO 29401 29501 IF(LINEID(I+1) .NE. 'PLOT ')GOTO 29511 GOTO 29371 GOTO 29401 29511 IF(LINEID(I+1) .NE. 'PLOTALL ')GOTO 29521 GOTO 29371 GOTO 29401 29521 IF(LINEID(I+1) .NE. 'PLOTCONTIN')GOTO 29531 GOTO 29371 GOTO 29401 29531 IF(LINEID(I+1) .NE. 'BADDIODE ')GOTO 29541 IF(INT(EPLOW(I+1)) .NE. CURIMR)GOTO 29561 IF(NOBAD .NE. 1000)GOTO 29581 WRITE(8,29590) 29590 FORMAT('MAXIMUM NUMBER OF BAD DIODE REGIONS EXCEEDED') RETURN 29581 CONTINUE NOBAD = NOBAD + 1 IBADL(NOBAD) = INT( WAVELN(I+1) ) IBADR(NOBAD)= INT( ATOM(I+1) ) 29561 CONTINUE GOTO 29371 GOTO 29401 29541 IF(LINEID(I+1) .NE. 'LLIMIT ')GOTO 29601 GOTO 29371 GOTO 29401 29601 IF(LINEID(I+1) .NE. 'ULIMIT ')GOTO 29611 GOTO 29371 GOTO 29401 29611 IF(LINEID(I+1) .NE. 'FWHM ')GOTO 29621 GOTO 29371 29621 CONTINUE 29401 CONTINUE IF(IGOOD .NE. 999)GOTO 29641 I = I + 1 NOGDLN = NOGDLN + 1 GOOD(NOGDLN) = I IGOOD = 0 29641 CONTINUE IF(I.GE.1000 .OR. NOCONT.GE.10000)GOTO 29372 GOTO 29371 29372 CONTINUE WRITE(8,29650) 29650 FORMAT(' LINE OR CONTINUUM BUFFER MAXIMUM REACHED') WRITE(8,29660)I,1000 29660 FORMAT(I3,1X,27H LINES USED, MAX ALLOWED IS,1X,I3) WRITE(8,29670)NOCONT,10000 29670 FORMAT (I3,1X,30H CONTINUA USED, MAX ALLOWED IS,1X,I3) 11860 CONTINUE NOLINES=I REWIND(UNIT=4) RETURN END SUBROUTINE QKRDALL(RV) IMPLICIT REAL*8(A-H,O-Z) COMMON/FLAGS/EFLAG,CFLAG,WIDFLG INTEGER EFLAG,CFLAG,WIDFLG COMMON/DEF/DEFAULT,FIXFWHM,INST_PROF LOGICAL DEFAULT,FIXFWHM,INST_PROF COMMON/WIDLIN/WIDE(50) REAL*8 WIDE COMMON/IWIDLI/IWIDE INTEGER IWIDE COMMON /LINID/LINEID CHARACTER*(10) LINEID(1000) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(1000), ILEFT(1000),IRIGHT(1000) *,BLEND(1000),NREDO COMMON /LSPEF/WAVELN,FWHM,DEPTH,CENTRE,EW,SLOPE,MINIDP, MINIWD,DEL *TRV,LFTDIO,RHTDIO,INCPT,SIGFWHM, SIG_AV_FWHM,SIGFRAC,DISP,OFFSET, *PIX_OFFSET,DISP1,DISP2,EPLOW,GF,ATOM, REDO,LLIMIT, ULIMIT,DELTEW REAL*8 MINIDP,WAVELN(1000),FWHM(1000),CENTRE(1000), DELTRV(1000),D *EPTH(1000),LFTDIO(1000), RHTDIO(1000),MINIWD,EW(1000),INCPT,SLOPE, * SIGFWHM,SIG_AV_FWHM,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF( *1000),EPLOW(1000),ATOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(10 *00) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(10000),CONORD(1000), CONRHT(10000),CONLFT(1 *0000) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(10000),SIGFLUX(10000), CONTUM_BLUE_PIX(10000),CONTU *M_RED_PIX(10000), CONCENT(10000),CFACTOR(10000), ACON(50,1000), CH *I_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/IBADD/ NOBAD,IBADL(1000),IBADR(1000), IGROW INTEGER NOBAD,IBADL,IBADR,IGROW COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG, CONNECT,BINNED LOGICAL PLOTALL,SCREEN,CNPLTG,CONNECT,BINNED COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT,LINE_COLOR INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT,LINE_COLOR COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) COMMON/LTELL/TELSET,TELPRES LOGICAL TELSET,TELPRES COMMON/ITELL/LBOUND(100),RBOUND(100),NBOUNDS,NH2O INTEGER LBOUND,RBOUND,NBOUNDS,NH2O COMMON/RTELL/H2OCENT(100),H2OFWHM(100),H2ODEEP(100), H2OSLOP,H2OIN *T,H2OMIN REAL*8 H2OCENT,H2OFWHM,H2ODEEP,H2OSLOP,H2OINT,H2OMIN 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/IRAFIN/IM,IVM,NAXIS,AXLEN(7),CURIMR, NORD,CURORD,NSPEC,CURS *PC, SPEC_START,SPEC_STEP INTEGER IM,IVM,NAXIS,AXLEN,CURIMR,NORD,CURORD, NSPEC,CURSPC,SPEC_S *TART,SPEC_STEP COMMON/IRAFRL/W1(1000),DW(1000),PIX1(1000) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL CHARACTER*80 LINE INTEGER SEARCH I=0 NOGDLN = 0 NOLINES = 0 NOBAD = 0 NPTS = AXLEN(1) WSTART = WAV(1.0D+00) WEND = WAV(DBLE(NPTS)) 29680 CONTINUE 29681 CONTINUE READ(4,'(A80)',END=11860)LINE IF(LINE(:9) .NE. 'OLDCONTIN')GOTO 29701 GOTO 29681 29701 CONTINUE READ(LINE,'(A10,4D10.3,3(2X,I3))')LINEID(I+1),WAVELN(I+1), ATOM(I %+1),EPLOW(I+1),GF(I+1),IGOOD,ILEFT(I+1),IRIGHT(I+1) IF(LINEID(I+1) .NE. 'CONTINUUM ')GOTO 29721 GOTO 29681 GOTO 29711 29721 IF(LINEID(I+1) .NE. 'FITCONTIN')GOTO 29731 GOTO 29681 GOTO 29711 29731 IF(LINEID(I+1) .NE. 'AUTOCONTIN')GOTO 29741 GOTO 29681 GOTO 29711 29741 IF(LINEID(I+1) .NE. 'NORMALISED')GOTO 29751 GOTO 29681 GOTO 29711 29751 IF(LINEID(I+1)(:5) .NE. 'FOCUS')GOTO 29761 READ(LINE(6:10),'(F5.1)')XROW IROW = NINT(XROW) IF(IROW .LE. 0)GOTO 29781 FOCUS_PARS(IROW) = .TRUE. READ(LINE(11:),'(7F10.5)')WFC(IROW),(A_FOCUS(IROW,IPAR),IPAR=1,6) GOTO 29791 29781 CONTINUE GLOBAL_FOCUS = .TRUE. READ(LINE(11:),'(7F10.5)')GLOBAL_WFC,(GLOBAL_A(IPAR),IPAR=1,6) 29791 CONTINUE 29771 CONTINUE GOTO 29681 GOTO 29711 29761 IF(LINEID(I+1) .NE. 'INST_PROF ')GOTO 29801 INST_PROF = .TRUE. GOTO 29681 GOTO 29711 29801 IF(LINEID(I+1) .NE. 'BOUNDS ')GOTO 29811 GOTO 29681 GOTO 29711 29811 IF(LINEID(I+1) .NE. 'PLOT ')GOTO 29821 GOTO 29681 GOTO 29711 29821 IF(LINEID(I+1) .NE. 'PLOTALL ')GOTO 29831 GOTO 29681 GOTO 29711 29831 IF(LINEID(I+1) .NE. 'PLOTCONTIN')GOTO 29841 GOTO 29681 GOTO 29711 29841 IF(LINEID(I+1) .NE. 'BADDIODE ')GOTO 29851 IF(INT(EPLOW(I+1)) .NE. CURIMR)GOTO 29871 IF(NOBAD .NE. 1000)GOTO 29891 WRITE(8,29900) 29900 FORMAT('MAXIMUM NUMBER OF BAD DIODE REGIONS EXCEEDED') RETURN 29891 CONTINUE NOBAD = NOBAD + 1 IBADL(NOBAD) = INT( WAVELN(I+1) ) IBADR(NOBAD)= INT( ATOM(I+1) ) 29871 CONTINUE GOTO 29681 GOTO 29711 29851 IF(LINEID(I+1) .NE. 'LLIMIT ')GOTO 29911 GOTO 29681 GOTO 29711 29911 IF(LINEID(I+1) .NE. 'ULIMIT ')GOTO 29921 GOTO 29681 GOTO 29711 29921 IF(LINEID(I+1) .NE. 'FWHM ')GOTO 29931 GOTO 29681 29931 CONTINUE 29711 CONTINUE I = I + 1 NOLINES = I IF(I.GE.1000 .OR. NOCONT.GE.10000)GOTO 29682 GOTO 29681 29682 CONTINUE WRITE(8,29940) 29940 FORMAT(' LINE OR CONTINUUM BUFFER MAXIMUM REACHED') WRITE(8,29950)I,1000 29950 FORMAT(I3,1X,27H LINES USED, MAX ALLOWED IS,1X,I3) WRITE(8,29960)NOCONT,10000 29960 FORMAT (I3,1X,30H CONTINUA USED, MAX ALLOWED IS,1X,I3) 11860 CONTINUE NOLINES=I REWIND(UNIT=4) RETURN END REAL*8 FUNCTION DMYSQ(X) IMPLICIT REAL*8 (A-H,O-Z) IF(X .GT. 0.0)GOTO 29981 DMYSQ = 0.0 GOTO 29991 29981 CONTINUE DMYSQ = DSQRT(X) 29991 CONTINUE 29971 CONTINUE RETURN END SUBROUTINE PGP_TWINDO(IXMIN,IXMAX,IYMIN,IYMAX) INTEGER IXMIN,IXMAX,IYMIN,IYMAX REAL*4 X1,X2,Y1,Y2 X1 = FLOAT(IXMIN)/FLOAT(1024) X2 = FLOAT(IXMAX)/FLOAT(1024) Y1 = FLOAT(IYMIN)/(0.75*FLOAT(1024)) Y2 = FLOAT(IYMAX)/(0.75*FLOAT(1024)) CALL PGSVP(X1,X2,Y1,Y2) RETURN END SUBROUTINE PGP_DWINDO(XMIN,XMAX,YMIN,YMAX) 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 SUBROUTINE PGP_MOVEA(X,Y) REAL*8 X,Y REAL*4 FX,FY FX=X FY=Y CALL PGMOVE(FX,FY) RETURN END SUBROUTINE PGP_DRAWA(X,Y) REAL*8 X,Y REAL*4 FX,FY FX=X FY=Y CALL PGDRAW(FX,FY) RETURN END SUBROUTINE PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) 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 SUBROUTINE PGP_VCURSR(ICH,X,Y) 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