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(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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 REAL*8 DA,DX 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 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 REAL*8 DA,DX 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 RV = 0.0 PLOTALL = .FALSE. SCREEN = .TRUE. NPLOTS = 0 NSPEC = 1 SOFT_DEVICE=' ' HARD_DEVICE=' ' DEFAULT=.TRUE. NRMLSD = .FALSE. AUTOCON = .FALSE. OLD_CONTUM = .FALSE. SCALED_CONTUM=.FALSE. FITCON = .FALSE. PLOTCON=.FALSE. TELSET = .FALSE. TELPRES= .FALSE. FIXFWHM = .FALSE. INST_PROF = .FALSE. 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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) INTEGER NWAT2,I,IORD,NORD,IC CHARACTER*68 WAT2(1000),STRING*200,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,IDUM2,WAV1,DWAV,INUM 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 10601 WRITE(SPECID(5:5),'(I1)')IORD SPECID(6:9) = ' = "' IS = 9 GOTO 10591 10601 IF(IORD .GE. 100)GOTO 10611 WRITE(SPECID(5:6),'(I2)')IORD SPECID(7:10) = ' = "' IS = 10 GOTO 10591 10611 IF(IORD .GE. 1000)GOTO 10621 WRITE(SPECID(4:6),'(I3)')IORD SPECID(8:11) = ' = "' IS = 11 GOTO 10631 10621 CONTINUE WRITE(SPECID(5:7),'(I4)')IORD SPECID(9:12) = ' = "' IS = 12 10631 CONTINUE 10591 CONTINUE RETURN END SUBROUTINE CKWVP(W1,DW,NORD) REAL*8 W1(1000),DW(1000) INTEGER I,NORD 10640 I=1 GOTO 10643 10641 I=I+1 10643 IF((I).GT.(NORD))GOTO 10642 IF((W1(I) .NE. 0.0D0) .AND. (DW(I) .NE. 0.0D0))GOTO 10661 WRITE(6,10670)I 10670 FORMAT ('ERROR: Could not find wavelength solution for order',I3) STOP 10661 CONTINUE GOTO 10641 10642 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) INTEGER IORD,IDUM1,IDUM2 REAL*8 RV CALL RDLNCL(RV) IF(.NOT.(FITCON))GOTO 10691 10700 IORD=1 GOTO 10703 10701 IORD=IORD+1 10703 IF((IORD).GT.(NORD))GOTO 10702 CALL RDSPEC(IORD) CALL RDCUCT(RV) IF(.NOT.(FITCON))GOTO 10721 CALL FITCONT 10721 CONTINUE GOTO 10701 10702 CONTINUE 10691 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT 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 10741 SOFT_DEVICE = '/GTERM' CALL PGBEG(14,SOFT_DEVICE,1,1) CALL PGASK(.FALSE.) CALL PGSCR(1,0,240,0) CALL PGSCI(1) CALL SETWIN 10741 CONTINUE IF((.NOT.(PLOTCON)) .AND. (.NOT.(FITCON)))GOTO 10761 10770 IORD=1 GOTO 10773 10771 IORD=IORD+1 10773 IF((IORD).GT.(NORD))GOTO 10772 CALL RDSPEC(IORD) CALL RDCUCT(RV) IF(.NOT.(FITCON))GOTO 10791 CALL FITCONT 10791 CONTINUE IF(.NOT.(PLOTCON))GOTO 10811 CALL CONPLT CALL INTUSR(IDUM1,IDUM2) 10811 CONTINUE GOTO 10771 10772 CONTINUE 10761 CONTINUE IF(.NOT.(PLOTCON))GOTO 10831 CALL PGEND 10831 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER LMIN,LMAX,I,IORDER LOGICAL ZERO LMIN = 1 ZERO=.FALSE. CALL RDGDLO(RV) 10840 LMIN=1 GOTO 10843 10841 LMIN=LMIN+1 10843 IF((LMIN).GT.(NOLINES))GOTO 10842 CALL FNDORD(WAVELN(LMIN),IORDER) IF(IORDER .EQ. 0)GOTO 10861 CALL RDSPEC(IORDER) GOTO 10842 10861 CONTINUE GOTO 10841 10842 CONTINUE ILOW = LMIN 10870 I=ILOW GOTO 10873 10871 I=I+1 10873 IF((I).GT.(NOLINES))GOTO 10872 CALL FNDORD(WAVELN(I),IORDER) IF(IORDER .EQ. CURORD .OR. .NOT.(.NOT.ZERO))GOTO 10891 LMAX = I - 1 CALL RDCUCT(RV) CALL MLICUO(LMIN,LMAX) IF(IORDER .EQ. 0)GOTO 10911 CALL RDSPEC(IORDER) GOTO 10921 10911 CONTINUE ZERO = .TRUE. 10921 CONTINUE 10901 CONTINUE LMIN = I GOTO 10881 10891 IF(.NOT.(ZERO) .OR. IORDER .EQ. 0)GOTO 10931 ZERO = .FALSE. CALL RDSPEC(IORDER) 10931 CONTINUE 10881 CONTINUE GOTO 10871 10872 CONTINUE IF(IORDER .EQ. 0)GOTO 10951 LMAX = NOLINES CALL RDSPEC(IORDER) CALL RDCUCT(RV) CALL MLICUO(LMIN,LMAX) 10951 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 10971 CALL FITCONT 10971 CONTINUE 10980 LINE=LMIN GOTO 10983 10981 LINE=LINE+1 10983 IF((LINE).GT.(LMAX))GOTO 10982 CALL FCDNAD(LINE,A,COV,DELETED) IF(.NOT.(DELETED))GOTO 11001 LINE = LINE - 1 GOTO 10981 11001 CONTINUE CALL OBFWHML (LINE,A,COV,NPTS) CALL FT1GAUS(LINE) CALL CMLINRV(LINE) GOTO 10981 10982 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS DV = 0.0 DV2 = 0.0 NZERO = 0 11010 I=1 GOTO 11013 11011 I=I+1 11013 IF((I).GT.(NOGDLN))GOTO 11012 IF(CHANNEL(WAVELN(GOOD(I))) .NE. CENTRE(GOOD(I)))GOTO 11031 NZERO = NZERO + 1 11031 CONTINUE DV = DV + DELTRV(GOOD(I)) DV2 = DV2 + DELTRV(GOOD(I))**2 GOTO 11011 11012 CONTINUE IF(NOGDLN-NZERO .LE. 2)GOTO 11051 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 11051 CONTINUE WRITE(6,'(19H RADIAL VELOCITY = ,F10.3,5H +/- ,F6.2)')ROT,RVERR WRITE(6,'(12H SIGMA RV = ,F10.3)')SIGROT WRITE(1,11060)RV 11060 FORMAT('RADIAL VELOCITY = ',F10.4,' KM/S') WRITE(1,11070)SIGROT 11070 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 11091 CALL FITCONT 11100 LINE=1 GOTO 11103 11101 LINE=LINE+1 11103 IF((LINE).GT.(NOLINES))GOTO 11102 CALL FCDNAD(LINE,A,COV,DELETED) IF(.NOT.(DELETED))GOTO 11121 LINE = LINE - 1 GOTO 11101 11121 CONTINUE CALL OBFWHML (LINE,A,COV,NPTS) CALL FT1GAUS(LINE) GOTO 11101 11102 CONTINUE CALL FITWKL 11130 LINE=1 GOTO 11133 11131 LINE=LINE+1 11133 IF((LINE).GT.(NOLINES))GOTO 11132 CALL SFTBLS(LINE) GOTO 11131 11132 CONTINUE CALL FNBRDLN CALL FTBLIN(NOLINES) 11140 LINE=1 GOTO 11143 11141 LINE=LINE+1 11143 IF((LINE).GT.(NOLINES))GOTO 11142 CALL MEASEW(LINE) GOTO 11141 11142 CONTINUE IF(NOLINES .LT. 1)GOTO 11161 CALL PTSCPL(NPTS) CALL PRDMIF(RV,SPTITLE) CALL FINSH 11161 CONTINUE 11091 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 11181 11190 LINE=1 GOTO 11193 11191 LINE=LINE+1 11193 IF((LINE).GT.(NOLINES))GOTO 11192 CALL FCDNAD(LINE,A,COV,DELETED) IF(.NOT.(DELETED))GOTO 11211 LINE = LINE - 1 GOTO 11191 11211 CONTINUE CALL OBFWHML (LINE,A,COV,NPTS) CALL FT1GAUS(LINE) GOTO 11191 11192 CONTINUE CALL FITWKL 11220 LINE=1 GOTO 11223 11221 LINE=LINE+1 11223 IF((LINE).GT.(NOLINES))GOTO 11222 CALL SFTBLS(LINE) GOTO 11221 11222 CONTINUE CALL FNBRDLN CALL FTBLIN(NOLINES) 11230 LINE=1 GOTO 11233 11231 LINE=LINE+1 11233 IF((LINE).GT.(NOLINES))GOTO 11232 CALL MEASEW(LINE) GOTO 11231 11232 CONTINUE 11181 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(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 11251 CALL FTGMSG(ERRMSG) WRITE(*,'(8H Error: ,A80)')ERRMSG STOP 11251 CONTINUE DISP = DW(IROW) OFFSET = W1(IROW) PIX_OFFSET = PIX1(IROW) CURORD = IROW IF(.NOT.(VARFIL))GOTO 11271 CALL FTGSVD(IVM,1,NAXIS,NAXES,FPIX,LPIX,INCS,NULLVAL,VARSPEC, ANYF *,IER) IF(IER .EQ. 0)GOTO 11291 CALL FTGMSG(ERRMSG) WRITE(*,'(8H Error: ,A80)')ERRMSG STOP 11291 CONTINUE 11271 CONTINUE 11300 I=1 GOTO 11303 11301 I=I+1 11303 IF((I).GT.(NPTS))GOTO 11302 LAMBDA(I) = OFFSET + (I-1)*DISP GOTO 11301 11302 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 11310 I=1 GOTO 11313 11311 I=I+1 11313 IF((I).GT.(NBOUNDS))GOTO 11312 LBOUND(I) = LBOUND(I) + ISHIFT RBOUND(I) = RBOUND(I) + ISHIFT GOTO 11311 11312 CONTINUE 11320 I=1 GOTO 11323 11321 I=I+1 11323 IF((I).GT.(NBOUNDS))GOTO 11322 IF(LBOUND(I) .GE. 1)GOTO 11341 IF(RBOUND(I) .GE. 1)GOTO 11361 11370 J=I GOTO 11373 11371 J=J+1 11373 IF((J).GT.(NBOUNDS - 1))GOTO 11372 LBOUND(J) = LBOUND(J+1) RBOUND(J) = RBOUND(J+1) GOTO 11371 11372 CONTINUE NBOUNDS = NBOUNDS - 1 I = I - 1 GOTO 11381 11361 CONTINUE LBOUND(I) = 1 11381 CONTINUE 11351 CONTINUE GOTO 11331 11341 IF(RBOUND(I) .LE. NPTS)GOTO 11391 IF(LBOUND(I) .LE. NPTS)GOTO 11411 11420 J=I GOTO 11423 11421 J=J+1 11423 IF((J).GT.(NBOUNDS - 1))GOTO 11422 LBOUND(J) = LBOUND(J+1) RBOUND(J) = RBOUND(J+1) GOTO 11421 11422 CONTINUE NBOUNDS = NBOUNDS - 1 I = I - 1 GOTO 11431 11411 CONTINUE RBOUND(I) = NPTS 11431 CONTINUE 11401 CONTINUE 11391 CONTINUE 11331 CONTINUE GOTO 11321 11322 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(10000) LOGICAL TELDIOD 11440 I=1 GOTO 11443 11441 I=I+1 11443 IF((I).GT.(NBOUNDS))GOTO 11442 IF(LBOUND(I) .EQ. 1 .OR. RBOUND(I) .EQ. NPTS)GOTO 11461 GRAD = (SPCTRUM(RBOUND(I)+1)-SPCTRUM(LBOUND(I)-1))/ DBLE( RBOUND(I *) - LBOUND(I) + 2 ) 11470 J=LBOUND(I) GOTO 11473 11471 J=J+1 11473 IF((J).GT.(RBOUND(I)))GOTO 11472 CONT = GRAD*DBLE( J - LBOUND(I) + 1 ) + SPCTRUM(LBOUND(I)-1) SPCTRUM(J) = SPCTRUM(J)/CONT IF(SPCTRUM(J) .LE. 1.0)GOTO 11491 SPCTRUM(J) = 1.0 11491 CONTINUE GOTO 11471 11472 CONTINUE GOTO 11501 11461 CONTINUE IF(LBOUND(I) .NE. 1)GOTO 11521 DIODE = RBOUND(I) + 1 GOTO 11511 11521 IF(RBOUND(I) .NE. NPTS)GOTO 11531 DIODE = LBOUND(I) - 1 11531 CONTINUE 11511 CONTINUE 11540 J=LBOUND(I) GOTO 11543 11541 J=J+1 11543 IF((J).GT.(RBOUND(I)))GOTO 11542 SPCTRUM(J) = SPCTRUM(J)*1.0/SPCTRUM(DIODE) GOTO 11541 11542 CONTINUE 11501 CONTINUE 11451 CONTINUE GOTO 11441 11442 CONTINUE 11550 I=1 GOTO 11553 11551 I=I+1 11553 IF((I).GT.(NPTS))GOTO 11552 IF(.NOT.(.NOT. TELDIOD(I)))GOTO 11571 SPCTRUM(I) = 1.0 11571 CONTINUE GOTO 11551 11552 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. 11580 J=1 GOTO 11583 11581 J=J+1 11583 IF((J).GT.(NBOUNDS))GOTO 11582 IF(I .GE. LBOUND(J))GOTO 11601 RETURN GOTO 11591 11601 IF(I .GT. RBOUND(J))GOTO 11611 TELDIOD = .TRUE. RETURN 11611 CONTINUE 11591 CONTINUE GOTO 11581 11582 CONTINUE RETURN END SUBROUTINE SUCCPF(TITLE) IMPLICIT REAL*8(A-H,O-Z) CHARACTER*80 TITLE WRITE(8,11620)TITLE(1:45) 11620 FORMAT(' TITLE $',A45,'$') WRITE(8,11630) 11630 FORMAT(' XLABEL $DIODE SHIFT$') WRITE(8,11640) 11640 FORMAT(' YLABEL $CROSS PRODUCT$') WRITE(8,11650) 11650 FORMAT(' XFORMAT I5') WRITE(8,11660) 11660 FORMAT(' YFORMAT F6.2') WRITE(8,11670) 11670 FORMAT(' NOMARKER ') WRITE(8,11680) 11680 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/IBADD/ NOBAD,IBADL(300),IBADR(300) INTEGER NOBAD,IBADL,IBADR COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT 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 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)) 11690 CONTINUE 11691 CONTINUE READ(4,'(A80)',END=11700)LINE IF(LINE(:9) .NE. 'OLDCONTIN')GOTO 11721 READ(LINE(11:),'(A70)')OLDCFILE OLD_CONTUM = .TRUE. CALL GRABCOF(OLDCFILE,ACON,CONORD) READ(4,'(A80)',END=11700)LINE 11721 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 11741 I = I - 1 WAV1 = WAVELN(I+1) WAV2 = ATOM(I+1) IF(WAV1 .GE. WEND .OR. WAV2 .LE. WSTART)GOTO 11761 NOCONT = NOCONT + 1 CONLFT(NOCONT) = NINT(CHANNEL(WAV1)+0.5) CONRHT(NOCONT) = NINT(CHANNEL(WAV2)-0.5) IF(CONLFT(NOCONT) .GE. 1)GOTO 11781 CONLFT(NOCONT) = 1 11781 CONTINUE IF(CONRHT(NOCONT) .LE. NPTS)GOTO 11801 CONRHT(NOCONT) = NPTS 11801 CONTINUE ISIZE = CONRHT(NOCONT) - CONLFT(NOCONT) + 1 IF(EPLOW(I+1) .NE. 0.0)GOTO 11821 CONSIZE(NOCONT) = ISIZE GOTO 11831 11821 CONTINUE CONSIZE(NOCONT) = NINT(EPLOW(I+1)) 11831 CONTINUE 11811 CONTINUE IF(CONSIZE(NOCONT) .LE. ISIZE)GOTO 11851 CONSIZE(NOCONT) = ISIZE 11851 CONTINUE CFACTOR(NOCONT) = 1.00000 IF(GF(I+1) .LE. 0.00000)GOTO 11871 CFACTOR(NOCONT) = GF(I+1) SCALED_CONTUM = .TRUE. 11871 CONTINUE 11761 CONTINUE GOTO 11691 GOTO 11731 11741 IF(LINEID(I) .NE. 'FITCONTIN')GOTO 11881 FITCON = .TRUE. I = I - 1 GOTO 11691 GOTO 11731 11881 IF(LINEID(I) .NE. 'AUTOCONTIN')GOTO 11891 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 11691 GOTO 11731 11891 IF(LINEID(I) .NE. 'NORMALISED')GOTO 11901 NRMLSD = .TRUE. I = I - 1 GOTO 11691 GOTO 11731 11901 IF(LINEID(I)(:5) .NE. 'FOCUS')GOTO 11911 READ(LINE(6:10),'(F5.1)')XROW IROW = NINT(XROW) IF(IROW .LE. 0)GOTO 11931 FOCUS_PARS(IROW) = .TRUE. READ(LINE(11:),'(7F10.5)')WFC(IROW),(A_FOCUS(IROW,IPAR),IPAR=1,6) GOTO 11941 11931 CONTINUE GLOBAL_FOCUS = .TRUE. READ(LINE(11:),'(7F10.5)')GLOBAL_WFC,(GLOBAL_A(IPAR),IPAR=1,6) 11941 CONTINUE 11921 CONTINUE I = I - 1 GOTO 11691 GOTO 11731 11911 IF(LINEID(I) .NE. 'INST_PROF ')GOTO 11951 INST_PROF = .TRUE. I = I - 1 GOTO 11691 GOTO 11731 11951 IF(LINEID(I) .NE. 'BOUNDS ')GOTO 11961 NBOUNDS = NBOUNDS + 1 I = I - 1 LBOUND(NBOUNDS) = INT( WAVELN(I+1) ) RBOUND(NBOUNDS) = INT( ATOM(I+1) ) GOTO 11691 GOTO 11731 11961 IF(LINEID(I) .NE. 'PLOT ')GOTO 11971 I = I - 1 IF((NPLOTS .LT. 500) .AND. (.NOT.(PLOTALL)))GOTO 11991 GOTO 11691 11991 CONTINUE NPLOTS = NPLOTS + 1 WPLOTL(NPLOTS) = WAVELN(I+1) WPLOTR(NPLOTS) = ATOM(I+1) GOTO 11691 GOTO 11731 11971 IF(LINEID(I) .NE. 'PLOTALL ')GOTO 12001 I = I - 1 PLOTALL = .TRUE. NPLOTS = 0 GOTO 11691 GOTO 11731 12001 IF(LINEID(I) .NE. 'PLOTCONTIN')GOTO 12011 PLOTCON = .TRUE. I = I - 1 GOTO 11691 GOTO 11731 12011 IF(LINEID(I) .NE. 'BADDIODE ')GOTO 12021 I = I - 1 IF(NINT(EPLOW(I+1)) .NE. CURIMR)GOTO 12041 IF(NOBAD .NE. 300)GOTO 12061 WRITE(8,12070) 12070 FORMAT('MAXIMUM NUMBER OF BAD DIODE REGIONS EXCEEDED') RETURN 12061 CONTINUE NOBAD = NOBAD + 1 IBADL(NOBAD) = NINT( WAVELN(I+1) ) IBADR(NOBAD)= NINT( ATOM(I+1) ) 12041 CONTINUE GOTO 11691 GOTO 11731 12021 IF(LINEID(I) .NE. 'LLIMIT ')GOTO 12081 LLIMIT = WAVELN(I) I = I - 1 GOTO 11691 GOTO 11731 12081 IF(LINEID(I) .NE. 'ULIMIT ')GOTO 12091 ULIMIT = WAVELN(I) I = I - 1 GOTO 11691 GOTO 11731 12091 IF(LINEID(I) .NE. 'FWHM ')GOTO 12101 FIXFWHM = .TRUE. INCPT = WAVELN(I) SLOPE = ATOM(I) MINIDP = EPLOW(I) SIGFRAC = GF(I) I = I - 1 GOTO 11691 GOTO 11731 12101 IF(LINEID(I) .NE. 'VSINI ')GOTO 12111 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 11691 12111 CONTINUE 11731 CONTINUE IF((ILEFT(I) .GE. 0) .AND. (IRIGHT(I) .GE. 0))GOTO 12131 IF(IGOOD .NE. 999)GOTO 12151 WRITE(8,12160)I 12160 FORMAT (' CANNOT USE LINE ',I3,' AS A GOOD LINE SINCE ONLY DEPTH', % ' IS TO BE USED FOR ITS EW ') IGOOD = 0 12151 CONTINUE 12131 CONTINUE IF(IGOOD .NE. 999)GOTO 12181 NOGDLN = NOGDLN + 1 GOOD(NOGDLN) = I IGOOD = 0 12181 CONTINUE IF(IGOOD .NE. 100)GOTO 12201 IF(IWIDE .GE. 50)GOTO 12221 IWIDE = IWIDE + 1 WIDE(IWIDE) = WAVELN(I) GOTO 12231 12221 CONTINUE WRITE(8,12240) 12240 FORMAT(' WARNING: ONLY THE FIRST 50 WIDE LINES USED ') 12231 CONTINUE 12211 CONTINUE IGOOD = 0 12201 CONTINUE WEAK(I) = .FALSE. BLEND(I) = 0 IF(I.GE.1000 .OR. NOCONT.GE.1000)GOTO 11692 GOTO 11691 11692 CONTINUE WRITE(8,12250) 12250 FORMAT(' LINE OR CONTINUUM BUFFER MAXIMUM REACHED') WRITE(8,12260)I,1000 12260 FORMAT(I3,1X,27H LINES USED, MAX ALLOWED IS,1X,I3) WRITE(8,12270)NOCONT,1000 12270 FORMAT (I3,1X,30H CONTINUA USED, MAX ALLOWED IS,1X,I3) 11700 CONTINUE CALL SORTCON NOLINES=I-1 REWIND(UNIT=4) RETURN END SUBROUTINE SORTCON IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 12280 J=1 GOTO 12283 12281 J=J+1 12283 IF((J).GT.(NOCONT-1))GOTO 12282 12290 I=1 GOTO 12293 12291 I=I+1 12293 IF((I).GT.(NOCONT-J))GOTO 12292 IF(CONLFT(I) .LE. CONLFT(I+1))GOTO 12311 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 12311 CONTINUE GOTO 12291 12292 CONTINUE GOTO 12281 12282 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 12320 CONTINUE 12321 CONTINUE READ(30,'(A80)',END=12330)LINE IF(LINE(:18) .NE. 'CURRENT IMAGE ROW ')GOTO 12351 NROW = NROW + 1 READ(LINE(19:),*)IROW(NROW) 12360 CONTINUE 12361 CONTINUE READ(30,'(A80)',END=12330)LINE IF(LINE(:25) .NE. 'ORDER OF POLYNOMIAL FIT =')GOTO 12381 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. 12381 CONTINUE IF(FOUND)GOTO 12362 GOTO 12361 12362 CONTINUE 12351 CONTINUE FOUND = .FALSE. GOTO 12321 12322 CONTINUE 12330 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 12390 I=1 GOTO 12393 12391 I=I+1 12393 IF((I).GT.(100))GOTO 12392 READ(12,*,END=12400)H2OCENT(I),H2OFWHM(I),H2ODEEP(I) GOTO 12391 12392 CONTINUE WRITE(8,12410) 12410 FORMAT(/,'WARNING: ONLY THE FIRST 100 TELLURIC LINES WILL BE USED' %,/) NH2O = 100 RETURN 12400 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM INTEGER I,ISHIFT,NPTS 12420 I=1 GOTO 12423 12421 I=I+1 12423 IF((I).GT.(NOCONT))GOTO 12422 CONRHT(I) = CONRHT(I) + ISHIFT CONLFT(I) = CONLFT(I) + ISHIFT IF(CONLFT(I) .GE. 1)GOTO 12441 IF(CONRHT(I) .GE. 1)GOTO 12461 CALL REMCTP(I) GOTO 12471 12461 CONTINUE CONLFT(I) = 1 12471 CONTINUE 12451 CONTINUE GOTO 12431 12441 IF(CONRHT(I) .LE. NPTS)GOTO 12481 IF(CONLFT(I) .LE. NPTS)GOTO 12501 CALL REMCTP(I) GOTO 12511 12501 CONTINUE CONRHT(I) = NPTS 12511 CONTINUE 12491 CONTINUE 12481 CONTINUE 12431 CONTINUE GOTO 12421 12422 CONTINUE RETURN END SUBROUTINE REMCTP(ICONT) IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 12531 ICONT = ICONT - 1 NOCONT = NOCONT - 1 RETURN 12531 CONTINUE 12540 I=ICONT GOTO 12543 12541 I=I+1 12543 IF((I).GT.(NOCONT - 1))GOTO 12542 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 12541 12542 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER I,LMIN,LMAX 12550 I=LMIN GOTO 12553 12551 I=I+1 12553 IF((I).GT.(LMAX))GOTO 12552 CENTRE(I) = CHANNEL(WAVELN(I)) GOTO 12551 12552 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER I,NPTS 12560 I=1 GOTO 12563 12561 I=I+1 12563 IF((I).GT.(NOLINES))GOTO 12562 CENTRE(I) = CHANNEL(WAVELN(I)) IF((INT(CENTRE(I)) .GE. 3) .AND. (INT(CENTRE(I)) .LE. NPTS - 2))GO *TO 12581 CALL REMFLS(I) I = I - 1 12581 CONTINUE GOTO 12561 12562 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK K = 1 ID = 'TELLURIC ' 12590 I=1 GOTO 12593 12591 I=I+1 12593 IF((I).GT.(NOLINES + NH2O - 1))GOTO 12592 IF(H2OCENT(K) .GT. CENTRE(I))GOTO 12611 WAVE = WAV(H2OCENT(K)) CALL INSBFL(I,ID,WAVE,H2OCENT(K),H2OFWHM(K),H2ODEEP(K)) K = K + 1 GOTO 12601 12611 IF(I .LT. NOLINES + K - 1)GOTO 12621 GOTO 12592 12621 CONTINUE 12601 CONTINUE IF(K .GT. NH2O)GOTO 12592 GOTO 12591 12592 CONTINUE IF(K .LE. NH2O)GOTO 12641 RETURN 12641 CONTINUE 12650 N=K GOTO 12653 12651 N=N+1 12653 IF((N).GT.(NH2O))GOTO 12652 I = I + 1 WAVE = WAV(H2OCENT(N)) CALL INSBFL(I,ID,WAVE,H2OCENT(N),H2OFWHM(N),H2ODEEP(N)) GOTO 12651 12652 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK REAL*8 PI CHARACTER*10 ID INTEGER I,J,K IF(NOLINES .NE. 1000)GOTO 12671 WRITE(8,12680)ID,WAVE 12680 FORMAT ('ERROR: COULD NOT INSERT LINE WITH ID ',A10,' AT ',F9.3,' %A.') RETURN 12671 CONTINUE 12690 J=NOLINES GOTO 12693 12691 J=J+(-1) 12693 IF((-1)*((J)-(I)).GT.0)GOTO 12692 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 12691 12692 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 12700 J=1 GOTO 12703 12701 J=J+1 12703 IF((J).GT.(NOGDLN))GOTO 12702 IF(GOOD(J) .LT. I)GOTO 12721 12730 K=J GOTO 12733 12731 K=K+1 12733 IF((K).GT.(NOGDLN))GOTO 12732 GOOD(K) = GOOD(K) + 1 GOTO 12731 12732 CONTINUE GOTO 12702 12721 CONTINUE GOTO 12701 12702 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER LINE,I IF(LINE .EQ. 1)GOTO 12751 IF(BLEND(LINE-1) .NE. 2)GOTO 12771 BLEND(LINE-1) = -1 GOTO 12761 12771 IF(BLEND(LINE-1) .NE. 1)GOTO 12781 BLEND(LINE-1) = 0 12781 CONTINUE 12761 CONTINUE 12751 CONTINUE IF(LINE .EQ. NOLINES)GOTO 12801 IF(BLEND(LINE+1) .NE. 2)GOTO 12821 BLEND(LINE+1) = 1 GOTO 12811 12821 IF(BLEND(LINE+1) .NE. -1)GOTO 12831 BLEND(LINE+1) = 0 12831 CONTINUE 12811 CONTINUE 12801 CONTINUE IF(.NOT.(TELPRES) .OR. LINEID(LINE) .NE. 'TELLURIC ')GOTO 12851 INDEX = 1 12860 I=1 GOTO 12863 12861 I=I+1 12863 IF((I).GT.(LINE - 1))GOTO 12862 IF(LINEID(I) .NE. 'TELLURIC ')GOTO 12881 INDEX = INDEX + 1 12881 CONTINUE GOTO 12861 12862 CONTINUE 12890 I=INDEX GOTO 12893 12891 I=I+1 12893 IF((I).GT.(NH2O - 1))GOTO 12892 H2OCENT(I) = H2OCENT(I+1) H2OFWHM(I) = H2OFWHM(I+1) H2ODEEP(I) = H2ODEEP(I+1) GOTO 12891 12892 CONTINUE NH2O = NH2O - 1 12851 CONTINUE 12900 I=LINE GOTO 12903 12901 I=I+1 12903 IF((I).GT.(NOLINES))GOTO 12902 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 12902 GOTO 12901 12902 CONTINUE NOLINES = NOLINES - 1 12910 I=1 GOTO 12913 12911 I=I+1 12913 IF((I).GT.(NOGDLN))GOTO 12912 IF(GOOD(I) .NE. LINE)GOTO 12931 CALL RMLFGL(LINE) RETURN GOTO 12921 12931 IF(GOOD(I) .LE. LINE)GOTO 12941 RETURN 12941 CONTINUE 12921 CONTINUE GOTO 12911 12912 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER I,J,LINE 12950 I=1 GOTO 12953 12951 I=I+1 12953 IF((I).GT.(NOGDLN))GOTO 12952 IF(GOOD(I) .NE. LINE)GOTO 12971 NOGDLN = NOGDLN - 1 12980 J=I GOTO 12983 12981 J=J+1 12983 IF((J).GT.(NOGDLN))GOTO 12982 GOOD(J) = GOOD(J+1) DELTRV(J) = DELTRV(J+1) GOTO 12981 12982 CONTINUE RETURN 12971 CONTINUE GOTO 12951 12952 CONTINUE RETURN END SUBROUTINE FITCONT IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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 13001 RETURN GOTO 13011 13001 CONTINUE CALL CCCAFV CALL PERFIT 13011 CONTINUE 12991 CONTINUE RETURN END SUBROUTINE CCCAFV IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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 13031 ISTEP = CONRHT(1) NOCONT = NPTS/CONRHT(1) IF(NOCONT .LE. 1000)GOTO 13051 WRITE(8,13060) 13060 FORMAT(' CONTINUUM BUFFER MAXIMUM REACHED') WRITE(8,13070)NOCONT,1000 13070 FORMAT (I3,1X,30H CONTINUA USED, MAX ALLOWED IS,1X,I3) NOCONT = 1000 13051 CONTINUE 13080 I=2 GOTO 13083 13081 I=I+1 13083 IF((I).GT.(NOCONT))GOTO 13082 CONLFT(I) = CONRHT(I-1) - CONSIZE(1) + 1 CONRHT(I) = CONRHT(I-1) + ISTEP CONSIZE(I) = CONSIZE(1) CFACTOR(I) = CFACTOR(1) GOTO 13081 13082 CONTINUE CONRHT(NOCONT) = NPTS 13031 CONTINUE 13090 J=1 GOTO 13093 13091 J=J+1 13093 IF((J).GT.(NOCONT))GOTO 13092 IF(.NOT.(CNTBAD(J)))GOTO 13111 WRITE(8,13120)J 13120 FORMAT('CONTINUUM NO. ',I3,' REMOVED DUE TO BAD DIODES') CALL REMCTP(J) GOTO 13091 13111 CONTINUE CONFLUX(J) = 0.0 13130 I=CONLFT(J) GOTO 13133 13131 I=I+1 13133 IF((I).GT.(CONRHT(J)-CONSIZE(J)+1))GOTO 13132 SXI = 0.0 SXIWI = 0.0 SXI2 = 0.0 SNSIG = 0.0 MIDDLE = 0 ANUM = 0.0 13140 K=1 GOTO 13143 13141 K=K+1 13143 IF((K).GT.(CONSIZE(J)))GOTO 13142 IF(.NOT.(.NOT. BADIOD(I+K-1)))GOTO 13161 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 13161 CONTINUE GOTO 13141 13142 CONTINUE AVG = SXIWI/SNSIG SNSIG = 1.D0/DSQRT(SNSIG) IF(CONSIZE(J) .LE. 1)GOTO 13181 CSIG = DMYSQ( ( SXI2 - (SXI**2)/ANUM )/(ANUM-1.0) ) CSIG = CSIG/DMYSQ(ANUM) 13181 CONTINUE IF(AVG .LT. CONFLUX(J))GOTO 13201 CONFLUX(J) = AVG SIGFLUX(J) = CSIG IF(CSIG .GE. AVG*SNSIG)GOTO 13221 SIGFLUX(J) = AVG*SNSIG 13221 CONTINUE CONCENT(J) = DBLE(MIDDLE)/ANUM 13201 CONTINUE GOTO 13131 13132 CONTINUE IF(CONFLUX(J) .GT. 0.0)GOTO 13241 WRITE(8,13250)J 13250 FORMAT('CONTINUUM NO. ',I3,' REMOVED: ZERO OR NEGATIVE FLUX') CALL REMCTP(J) GOTO 13091 13241 CONTINUE GOTO 13091 13092 CONTINUE IF(.NOT.(AUTOCON))GOTO 13271 13280 J=1 GOTO 13283 13281 J=J+1 13283 IF((J).GT.(NOCONT))GOTO 13282 CONLFT(J) = CONCENT(J)-0.5*DBLE(CONSIZE(J)) + 0.5 CONRHT(J) = CONCENT(J)+0.5*DBLE(CONSIZE(J)) -0.5 GOTO 13281 13282 CONTINUE 13271 CONTINUE RETURN END LOGICAL FUNCTION CNTBAD(ICONT) IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/IBADD/ NOBAD,IBADL(300),IBADR(300) INTEGER NOBAD,IBADL,IBADR LOGICAL BADIOD INTEGER I,J,NBAD_PIX,ICONT CNTBAD = .FALSE. IF(NOBAD .NE. 0)GOTO 13301 RETURN 13301 CONTINUE 13310 I=CONLFT(ICONT) GOTO 13313 13311 I=I+1 13313 IF((I).GT.(CONRHT(ICONT)-CONSIZE(ICONT)+1))GOTO 13312 NBAD_PIX = 0 13320 J=1 GOTO 13323 13321 J=J+1 13323 IF((J).GT.(CONSIZE(ICONT)))GOTO 13322 IF(.NOT.(BADIOD(I+J-1)))GOTO 13341 NBAD_PIX = NBAD_PIX + 1 13341 CONTINUE GOTO 13321 13322 CONTINUE IF(NBAD_PIX .LE. CONSIZE(ICONT)-NBAD_PIX)GOTO 13361 CNTBAD = .TRUE. RETURN 13361 CONTINUE GOTO 13311 13312 CONTINUE RETURN END LOGICAL FUNCTION BADIOD(IPOINT) IMPLICIT REAL*8(A-H,O-Z) COMMON/IBADD/ NOBAD,IBADL(300),IBADR(300) INTEGER NOBAD,IBADL,IBADR INTEGER I,IPOINT BADIOD = .FALSE. IF(NOBAD .NE. 0)GOTO 13381 RETURN 13381 CONTINUE 13390 I=1 GOTO 13393 13391 I=I+1 13393 IF((I).GT.(NOBAD))GOTO 13392 IF(IPOINT .LT. IBADL(I) .OR. IPOINT .GT. IBADR(I))GOTO 13411 BADIOD = .TRUE. RETURN 13411 CONTINUE GOTO 13391 13392 CONTINUE RETURN END SUBROUTINE PERFIT IMPLICIT REAL*8(A-H,O-Z) REAL*8 X(1000),Y(1000),SIGMA(1000),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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 13431 CALL SETFLG(NOCONT) 13431 CONTINUE IF(.NOT.(FITCON))GOTO 13451 CONORD(CURIMR) = 0 IF(NOCONT .LT. 1)GOTO 13471 13480 J=1 GOTO 13483 13481 J=J+1 13483 IF((J).GT.(NOCONT))GOTO 13482 Y(J) = CONFLUX(J)*CFACTOR(J) X(J) = CONCENT(J) SIGMA(J) = SIGFLUX(J) GOTO 13481 13482 CONTINUE IORD = 1 CALL POLYLIN(X,Y,SIGMA,IORD,ADUM,COVAR,CHISQ,NOCONT) 13490 ITERM=1 GOTO 13493 13491 ITERM=ITERM+1 13493 IF((ITERM).GT.(IORD))GOTO 13492 ACON(ITERM,CURIMR) = ADUM(ITERM) GOTO 13491 13492 CONTINUE NFREE = NOCONT-IORD CALL G3SIGCH(NFREE,CHI3SIG) OCHIRAT = CHISQ / CHI3SIG CONORD(CURIMR) = IORD 13500 IORD=2 GOTO 13503 13501 IORD=IORD+1 13503 IF((IORD).GT.(5))GOTO 13502 IF(3*(IORD+1) .LE. NOCONT)GOTO 13521 GOTO 13502 13521 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 13541 13550 ITERM=1 GOTO 13553 13551 ITERM=ITERM+1 13553 IF((ITERM).GT.(IORD))GOTO 13552 ACON(ITERM,CURIMR) = ADUM(ITERM) GOTO 13551 13552 CONTINUE OCHIRAT = CHIRAT CONORD(CURIMR) = IORD GOTO 13531 13541 IF(CHIRAT .LE. OCHIRAT)GOTO 13561 GOTO 13502 13561 CONTINUE 13531 CONTINUE GOTO 13501 13502 CONTINUE GOTO 13571 13471 CONTINUE CONORD(CURIMR) = 1 ACON(1,CURIMR) = 1.0 13571 CONTINUE 13461 CONTINUE 13451 CONTINUE CHI_SCALE = OCHIRAT IF(CFLAG .NE. 1 .OR. NOCONT .LT. 3)GOTO 13591 CALL PARABOL(CONCENT,CONFLUX,NOCONT,A,B,C) GOTO 13581 13591 IF(CFLAG .NE. 2 .OR. NOCONT .LT. 2)GOTO 13601 CALL FITLINE(CONCENT,CONFLUX,NOCONT,A,B) GOTO 13581 13601 IF(CFLAG .NE. 3 .OR. NOCONT .LT. 1)GOTO 13611 CALL AVRGE(CONFLUX,NOCONT,A) 13611 CONTINUE 13581 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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) 13620 I=101 GOTO 13623 13621 I=I+1 13623 IF((I).GT.(NPTS - 100))GOTO 13622 CUTOFF = (ANSIG+1.0)/SNR(I) DIODE = DBLE(I) IF(.NOT.(.NOT.BADIOD(I)))GOTO 13641 IF(SPEC(I) .GT. CONTUM(DIODE)-CUTOFF)GOTO 13661 ILOW = ILOW + 1 13661 CONTINUE GOTO 13671 13641 CONTINUE NBAD = NBAD + 1 13671 CONTINUE 13631 CONTINUE GOTO 13621 13622 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 13691 NLIN = 0 13691 CONTINUE CSIZE = (CWINDOW-CBIN+1.0)*FC/(NLIN+1) IF(CSIZE .LT. CBIN)GOTO 13711 NBINS = (CWINDOW-CBIN+1.0)*FC/CBIN PROB = ( 0.5/NBINS )**(1.0/CBIN) GOTO 13721 13711 CONTINUE PROB = ( 0.5/((CWINDOW-CBIN+1.0)*(2.0*FC)**(CBIN-1.0)) )**(1.0/CBI *N) 13721 CONTINUE 13701 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 13741 WRITE(6,'(28H Shifting continuum down by ,F5.2,8H percent)')PERCNT GOTO 13751 13741 CONTINUE WRITE(6,'(26H Shifting continuum up by ,F5.2,8H percent)')PERCNT 13751 CONTINUE 13731 CONTINUE 13760 I=1 GOTO 13763 13761 I=I+1 13763 IF((I).GT.(NOCONT))GOTO 13762 HEIGHT = (ANSIG)/SNR(NINT(CONCENT(I))) FACTOR = 1.0-HEIGHT CONFLUX(I) = CONFLUX(I)*FACTOR GOTO 13761 13762 CONTINUE RETURN END SUBROUTINE GETNSIG(PROB,ANSIG) IMPLICIT REAL*8 (A-H,O-Z) INTEGER I IF(PROB .LE. 0.50)GOTO 13781 P = 1.0 - PROB GOTO 13791 13781 CONTINUE P = PROB 13791 CONTINUE 13771 CONTINUE ANSIG = 0.0 STEP = 1.0 PROB1 = ERFCC(ANSIG)/2.0 13800 I=1 GOTO 13803 13801 I=I+1 13803 IF((I).GT.(10000))GOTO 13802 ANSIG = ANSIG + STEP PROB2 = ERFCC(ANSIG)/2.0 IF(PROB1 .LT. P .OR. PROB2 .GT. P)GOTO 13821 ANSIG = ANSIG - STEP STEP = STEP/10.0 GOTO 13831 13821 CONTINUE PROB1 = PROB2 13831 CONTINUE 13811 CONTINUE IF(STEP.LE.0.0001)GOTO 13802 GOTO 13801 13802 CONTINUE ANSIG = DMYSQ(2.0D+00)*(ANSIG + STEP/2.0) IF(PROB .LE. 0.5)GOTO 13851 ANSIG = -ANSIG 13851 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 13871 ERFCC=2.0-ERFCC 13871 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 13880 J=1 GOTO 13883 13881 J=J+1 13883 IF((J).GT.(I))GOTO 13882 A = VALUE(J)/DBLE(I) + A GOTO 13881 13882 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 13901 CFLAG = 4 EFLAG = 2 GOTO 13891 13901 IF(NOCONT .LT. 3)GOTO 13911 CFLAG = 2 EFLAG = 2 GOTO 13921 13911 CONTINUE CFLAG = 3 EFLAG = 2 13921 CONTINUE 13891 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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 13941 SINGLE(3) = 0.0 13941 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 13961 START = ICENTRE - 1 GOTO 13951 13961 IF(ILEFT(LINE) .GT. -2)GOTO 13971 START = ICENTRE 13971 CONTINUE 13951 CONTINUE IF((IRIGHT(LINE) .NE. 1) .AND. (IRIGHT(LINE) .NE. -1))GOTO 13991 END = ICENTRE + 1 GOTO 13981 13991 IF(IRIGHT(LINE) .GT. -2)GOTO 14001 END = ICENTRE 14001 CONTINUE 13981 CONTINUE 14010 I=START GOTO 14013 14011 I=I+1 14013 IF((I).GT.(END))GOTO 14012 IF(SPEC(I) .GE. SPEC(ICENTRE) .OR. .NOT.(.NOT. BADIOD(I)))GOTO 140 *31 ICENTRE = I 14031 CONTINUE GOTO 14011 14012 CONTINUE IF(.NOT.(BADIOD(ICENTRE)))GOTO 14051 ILEFT(LINE) = -1 IRIGHT(LINE)= -1 CALL REMFLS(LINE) DELETED = .TRUE. RETURN 14051 CONTINUE IF(SPEC(ICENTRE) .LE. 0.0)GOTO 14071 CFLUX = SNR(ICENTRE)**2 * CONTUM(DBLE(ICENTRE))/SPEC(ICENTRE) DFLUX = DMYSQ( CFLUX + CNTUNC(ICENTRE)**2 ) GOTO 14081 14071 CONTINUE CFLUX = SN**2 DFLUX = 0.0 14081 CONTINUE 14061 CONTINUE IF(SNR(ICENTRE)**2 .LE. CFLUX-2.0*DFLUX)GOTO 14101 WRITE(8,14110)WAVELN(LINE),LINEID(LINE) 14110 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 14101 CONTINUE IF(SNR(ICENTRE)**2 .LE. CFLUX-4.0*DFLUX)GOTO 14131 WEAK(LINE) = .TRUE. WRITE(8,14140)WAVELN(LINE),LINEID(LINE) 14140 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 14131 CONTINUE IF(SNR(ICENTRE)**2 .LE. CFLUX-6.0*DFLUX)GOTO 14161 CALL RMLFGL(LINE) 14161 CONTINUE IF(ILEFT(LINE) .GE. 0)GOTO 14181 IF(IRIGHT(LINE) .GE. 0)GOTO 14201 RHTDIO(LINE) = DBLE(ICENTRE) RETURN 14201 CONTINUE LFTDIO(LINE) = DBLE(ICENTRE) 14181 CONTINUE IF(IRIGHT(LINE) .GE. 0)GOTO 14221 RHTDIO(LINE) = DBLE(ICENTRE) 14221 CONTINUE LAST = 0 NEXT = 0 IF(LINE .LE. 1)GOTO 14241 LAST = NINT( CHANNEL(WAVELN(LINE-1)) ) 14241 CONTINUE IF(LINE .GE. NOLINES)GOTO 14261 NEXT = NINT( CHANNEL(WAVELN(LINE+1)) ) 14261 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 14281 IF(LFTDIO(LINE) .NE. DBLE(ICENTRE))GOTO 14301 LFTDIO(LINE) = DNINT(CENTRE(LINE)) ILEFT(LINE) = -1 14301 CONTINUE IF(RHTDIO(LINE) .NE. DBLE(ICENTRE))GOTO 14321 RHTDIO(LINE) = DNINT(CENTRE(LINE)) IRIGHT(LINE) = -1 14321 CONTINUE CALL RMLFGL(LINE) RETURN 14281 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 14341 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 14350 I=1 GOTO 14353 14351 I=I+1 14353 IF((I).GT.(3))GOTO 14352 14360 J=1 GOTO 14363 14361 J=J+1 14363 IF((J).GT.(3))GOTO 14362 COV(I,J) = 0.0 GOTO 14361 14362 CONTINUE GOTO 14351 14352 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) 14341 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 14381 DEPTH(LINE) = 1.0 14381 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 14401 CNTUNC = SIGFLUX(1) RETURN GOTO 14391 14401 IF(NOCONT .NE. 0)GOTO 14411 CNTUNC = 0.0D0 RETURN 14411 CONTINUE 14391 CONTINUE IF(DBLE(ICENTRE) .GT. CONCENT(1))GOTO 14431 CNTUNC = SIGFLUX(1) GOTO 14421 14431 IF(DBLE(ICENTRE) .LT. CONCENT(NOCONT))GOTO 14441 CNTUNC = SIGFLUX(NOCONT) GOTO 14451 14441 CONTINUE 14460 I=1 GOTO 14463 14461 I=I+1 14463 IF((I).GT.(NOCONT))GOTO 14462 IF(DBLE(ICENTRE) .LT. CONCENT(I) .OR. DBLE(ICENTRE) .GT. CONCENT(I *+1))GOTO 14481 CNTUNC = 0.5D0*(SIGFLUX(I)+SIGFLUX(I+1)) 14481 CONTINUE GOTO 14461 14462 CONTINUE 14451 CONTINUE 14421 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 14501 CALL GTBSFW(WAVE,DEEP,WIDTH,SIGWDTH) A(3) = WIDTH*0.60056121 GOTO 14511 14501 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 14531 A(3) = DX1/DSQRT(-DLOG(Y1/A(1))) GOTO 14541 14531 CONTINUE A(3) = DXN/DSQRT(-DLOG(YN/A(1))) 14541 CONTINUE 14521 CONTINUE 14511 CONTINUE 14491 CONTINUE IF(A(3) .GE. 1.20)GOTO 14561 A(3) = 1.20 14561 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 14581 14590 NEXT=LINE+1 GOTO 14593 14591 NEXT=NEXT+1 14593 IF((NEXT).GT.(NOLINES))GOTO 14592 IF(ILEFT(NEXT) .LT. 0 .OR. IRIGHT(NEXT) .LT. 0 .OR. LINEID(NEXT) . *EQ. 'TELLURIC ')GOTO 14611 CENT1 = CHANNEL(WAVELN(LINE)) - CHANNEL(WAVELN(NEXT)) CENT1 = CENT1 + CENTRE(NEXT) WAVE1 = WAVELN(NEXT) GOTO 14592 14611 CONTINUE GOTO 14591 14592 CONTINUE 14581 CONTINUE CENT2 = 0.0 IF(LINE .EQ. 1)GOTO 14631 14640 LAST=LINE-1 GOTO 14643 14641 LAST=LAST+(-1) 14643 IF((-1)*((LAST)-(1)).GT.0)GOTO 14642 IF(ILEFT(LAST) .LT. 0 .OR. IRIGHT(LAST) .LT. 0 .OR. LINEID(LAST) . *EQ. 'TELLURIC ')GOTO 14661 CENT2 = CHANNEL(WAVELN(LINE)) - CHANNEL(WAVELN(LAST)) CENT2 = CENT2 + CENTRE(LAST) WAVE2 = WAVELN(LAST) GOTO 14642 14661 CONTINUE GOTO 14641 14642 CONTINUE 14631 CONTINUE IF(CENT1 .EQ. 0.0 .OR. DABS( CENT1-CHANNEL(WAVELN(LINE)) ) .GE. 1. *5)GOTO 14681 IF(CENT2 .EQ. 0.0 .OR. DABS( CENT2-CHANNEL(WAVELN(LINE)) ) .GE. 1. *5)GOTO 14701 CENT = ( CENT1*(WAVELN(LINE)-WAVE2) + CENT2*(WAVE1-WAVELN(LINE)) ) * / (WAVE1-WAVE2) GOTO 14711 14701 CONTINUE CENT = CENT1 14711 CONTINUE 14691 CONTINUE GOTO 14671 14681 IF(CENT2 .EQ. 0.0 .OR. DABS( CENT2-CHANNEL(WAVELN(LINE)) ) .GE. 1. *5)GOTO 14721 CENT = CENT2 GOTO 14731 14721 CONTINUE CENT = CHANNEL( WAVELN(LINE) ) 14731 CONTINUE 14671 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 *14751 IF(INT(LIMIT) .GE. ICENTRE)GOTO 14771 WRITE(8,14780)WAVE 14780 FORMAT (' WARNING FOR LINE AT ',F9.3,' ILL DEFINED GAUSSIAN MAY RE %SULT FROM ', 'USE OF LEFT LIMIT') LIMIT = DBLE(ICENTRE-ILIMIT) GOTO 14791 14771 CONTINUE WRITE(8,14800)WAVE 14800 FORMAT (' WARNING FOR LINE AT ',F9.3,' ILL DEFINED GAUSSIAN MAY RE %SULT FROM', ' USE OF RIGHT LIMIT') LIMIT = DBLE(ICENTRE+ILIMIT) 14791 CONTINUE 14761 CONTINUE 14751 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 14821 DYCEN = YCEN/SNR(ICENTRE) GOTO 14831 14821 CONTINUE DYCEN = 0.0 14831 CONTINUE 14811 CONTINUE 14840 INDEX=ICENTRE + STEP GOTO 14843 14841 INDEX=INDEX+(STEP) 14843 IF((STEP)*((INDEX)-(ICENTRE + STEP * 40)).GT.0)GOTO 14842 IF((INDEX .GE. 1) .AND. (INDEX .LE. NUMBER))GOTO 14861 GOTO 14842 14861 CONTINUE Y = SPEC(INDEX)/CONTUM(DBLE(INDEX)) IF(Y .LE. 0.0)GOTO 14881 DY = Y/SNR(INDEX) GOTO 14891 14881 CONTINUE DY = 0.0 14891 CONTINUE 14871 CONTINUE IF(STEP .NE. -1 .OR. NEXT .EQ. 0)GOTO 14911 IF(INDEX .GT. NEXT)GOTO 14931 GOTO 14842 14931 CONTINUE GOTO 14901 14911 IF(STEP .NE. 1 .OR. NEXT .EQ. 0)GOTO 14941 IF(INDEX .LT. NEXT)GOTO 14961 GOTO 14842 14961 CONTINUE 14941 CONTINUE 14901 CONTINUE IF(.NOT.(BADIOD(INDEX)))GOTO 14981 WRITE(8,14990)INDEX,WAVE 14990 FORMAT (' BAD DIODE NO. ',I4,' RUINS HALF OF LINE AT ',F9.3,' A') LIMIT = DBLE(ICENTRE) RETURN 14981 CONTINUE IF(Y-2.0*DY .LE. YCEN+2.0*DYCEN)GOTO 15011 LIMIT = DBLE(INDEX) RETURN 15011 CONTINUE IF(YCEN-2.0*DYCEN .LE. Y+2.0*DY)GOTO 15031 GOTO 14842 15031 CONTINUE IF(Y + DY .LE. 1.00)GOTO 15051 LIMIT = DBLE(ICENTRE) WRITE(8,15060)WAVE,ID 15060 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 15051 CONTINUE GOTO 14841 14842 CONTINUE LIMIT = DBLE(ICENTRE) WRITE(8,15070)WAVE,ID 15070 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 15091 FWHM(LINE) = 0.0 RETURN 15091 CONTINUE SINGLE(1) = 1.0 SINGLE(2) = 1.0 SINGLE(3) = 1.0 IF(.NOT.(INST_PROF))GOTO 15111 SINGLE(3) = 0.0 15111 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 15131 LFTDIO(LINE) = LEFT STEP = 1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,RIGHT) FWHM(LINE) = DABS(A(3))*1.66510921 GOTO 15121 15131 IF(SIGMAR + 2.0*DELTAR .GE. SIGMAL - 2.0*DELTAL)GOTO 15141 RHTDIO(LINE) = RIGHT STEP = -1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,LEFT) FWHM(LINE) = DABS(A(3))*1.66510921 GOTO 15151 15141 CONTINUE FWHM(LINE) = ( SIGMAR+SIGMAL )*0.83255460 15151 CONTINUE 15121 CONTINUE IF(A(2)-LEFT .LE. 2.0*FWHM(LINE))GOTO 15171 LEFT = A(2) - 2.0*FWHM(LINE) 15171 CONTINUE IF(RIGHT-A(2) .LE. 2.0*FWHM(LINE))GOTO 15191 RIGHT = A(2) + 2.0*FWHM(LINE) 15191 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 15211 RETURN 15211 CONTINUE IF((NOGDLN .LT. 2 .OR. INCPT .LE. 0.0) .AND. (.NOT.(FIXFWHM)))GOTO * 15231 15240 I=1 GOTO 15243 15241 I=I+1 15243 IF((I).GT.(NOLINES))GOTO 15242 ICENTRE = NINT(CHANNEL(WAVELN(I))) DEEP = 1.0 - SPEC(ICENTRE)/CONTUM(DBLE(ICENTRE)) CALL GTBSFW(WAVELN(I),DEEP,WIDTH,SIGWDTH) 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 15261 CALL RBLWFF(I) 15261 CONTINUE GOTO 15241 15242 CONTINUE 15231 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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 15270 I=2 GOTO 15273 15271 I=I+1 15273 IF((I).GT.(9))GOTO 15272 SINGLE(I) = 0.0 GOTO 15271 15272 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) 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 15291 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 15300 I=1 GOTO 15303 15301 I=I+1 15303 IF((I).GT.(3))GOTO 15302 15310 J=1 GOTO 15313 15311 J=J+1 15313 IF((J).GT.(3))GOTO 15312 COV(I,J) = 0.0 GOTO 15311 15312 CONTINUE GOTO 15301 15302 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) SINGLE(2) = 1.0 15291 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)) 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 15331 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 15340 I=1 GOTO 15343 15341 I=I+1 15343 IF((I).GT.(3))GOTO 15342 15350 J=1 GOTO 15353 15351 J=J+1 15353 IF((J).GT.(3))GOTO 15352 COV(I,J) = 0.0 GOTO 15351 15352 CONTINUE GOTO 15341 15342 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) 15331 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 15371 LFTDIO(LINE) = LEFT STEP = 1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,RIGHT) GOTO 15361 15371 IF(A1R .GE. A1L)GOTO 15381 RHTDIO(LINE) = RIGHT STEP = -1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,LEFT) 15381 CONTINUE 15361 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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 15390 II=1 GOTO 15393 15391 II=II+1 15393 IF((II).GT.(3))GOTO 15392 ANEW(II) = A(II) GOTO 15391 15392 CONTINUE IF(STEP .LE. 0)GOTO 15411 START = INT(LFTDIO(LINE)) GOTO 15421 15411 CONTINUE START = INT(RHTDIO(LINE)) 15421 CONTINUE 15401 CONTINUE IF(IRIGHT(LINE) .LE. 0 .OR. STEP .LE. 0)GOTO 15441 END = NINT(CENTRE(LINE)) + IRIGHT(LINE) GOTO 15431 15441 IF(ILEFT(LINE) .LE. 0 .OR. STEP .GE. 0)GOTO 15451 END = NINT(CENTRE(LINE)) - ILEFT(LINE) GOTO 15461 15451 CONTINUE END = NINT(CENTRE(LINE)) + STEP * 40 15461 CONTINUE 15431 CONTINUE IF(END .GE. 1)GOTO 15481 END = 1 GOTO 15471 15481 IF(END .LE. NPTS)GOTO 15491 END = NPTS 15491 CONTINUE 15471 CONTINUE N = INT( RHTDIO(LINE) - LFTDIO(LINE) ) + 1 INDEX = START 15500 I=1 GOTO 15503 15501 I=I+(2) 15503 IF((2)*((I)-(2*N-1)).GT.0)GOTO 15502 X(I) = DBLE(INDEX) X(I+1) = 1.0 - SPEC(INDEX)/CONTUM(DBLE(INDEX)) INDEX = INDEX + STEP GOTO 15501 15502 CONTINUE ICENTRE = NINT(CENTRE(LINE)) PHOTONS = SNR(ICENTRE)**2 * CONTUM(DBLE(ICENTRE))/SPEC(ICENTRE) 15510 I=2*N+1 GOTO 15513 15511 I=I+(2) 15513 IF((2)*((I)-(2*IABS(START - END) + 1)).GT.0)GOTO 15512 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 15531 GOTO 15512 15531 CONTINUE IF(DABS( A(2)-CHANNEL(WAVELN(LINE)) ) .LE. 6.0D+00)GOTO 15551 GOTO 15512 15551 CONTINUE 15560 J=INDEX + STEP GOTO 15563 15561 J=J+(STEP) 15563 IF((STEP)*((J)-(END)).GT.0)GOTO 15562 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 15581 END = J - STEP GOTO 15562 15581 CONTINUE GOTO 15561 15562 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 15601 WRITE(24,'(9H LINE AT ,F10.3)')WAVELN(LINE) GOTO 15512 15601 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 15621 GOTO 15512 15621 CONTINUE 15630 J=START+N*STEP GOTO 15633 15631 J=J+(STEP) 15633 IF((STEP)*((J)-(INDEX)).GT.0)GOTO 15632 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 15651 DIODE = DBLE(INDEX-STEP) RETURN 15651 CONTINUE GOTO 15631 15632 CONTINUE 15660 II=1 GOTO 15663 15661 II=II+1 15663 IF((II).GT.(3))GOTO 15662 A(II) = ANEW(II) GOTO 15661 15662 CONTINUE INDEX = INDEX + STEP IF(2*N+1 .GE. 2*IABS(START-END)+1)GOTO 15512 GOTO 15511 15512 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 15670 I=1 GOTO 15673 15671 I=I+1 15673 IF((I).GT.(9))GOTO 15672 NPARAMS = NPARAMS + DBLE(SINGLE(I)) GOTO 15671 15672 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 15691 CHI3SIG = 0.0 GOTO 15681 15691 IF(NFREE .GT. 20)GOTO 15701 CHI3SIG = CHIRAY(NFREE) GOTO 15681 15701 IF(NFREE .LE. 20)GOTO 15711 CHI3SIG = CHIRAY(20) + 1.4d0 * DBLE(NFREE-20) 15711 CONTINUE 15681 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 REAL*8 DA,DX REAL*8 A(9),AOLD(9),SW(9),COV(9,9),Y,DY,YEST,DYEST,DYEST2,DMYSQ,PR *OFILE REAL*8 GRAD(9) DEPTOL = .FALSE. 15720 I=1 GOTO 15723 15721 I=I+1 15723 IF((I).GT.(9))GOTO 15722 AOLD(I) = A(I) GOTO 15721 15722 CONTINUE YEST = PROFILE(X, A, SW, VSINI) 15730 I=1 GOTO 15733 15731 I=I+1 15733 IF((I).GT.(9))GOTO 15732 IF(SW(I) .NE. 1.D0)GOTO 15751 A(I) = A(I) + DA(I) GRAD(I) = ( PROFILE(X, A, SW, VSINI) - YEST ) / DA(I) A(I) = AOLD(I) GOTO 15761 15751 CONTINUE GRAD(I) = 0.0D0 15761 CONTINUE 15741 CONTINUE GOTO 15731 15732 CONTINUE DYEST2 = 0.0D0 15770 I=1 GOTO 15773 15771 I=I+1 15773 IF((I).GT.(9))GOTO 15772 IF(SW(I) .NE. 1.0D0)GOTO 15791 15800 J=1 GOTO 15803 15801 J=J+1 15803 IF((J).GT.(9))GOTO 15802 IF(SW(J) .NE. 1.0D0)GOTO 15821 DYEST2 = DYEST2 + GRAD(I)*GRAD(J)*COV(I,J) 15821 CONTINUE GOTO 15801 15802 CONTINUE 15791 CONTINUE GOTO 15771 15772 CONTINUE DYEST = DMYSQ(DYEST2) IF((Y - 2.0*DY .LE. YEST + 2.0*DYEST) .AND. (Y - 2.0*DY .LT. A(1)) *)GOTO 15841 DEPTOL = .TRUE. 15841 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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 15861 SINGLE(3) = 0.0 15861 CONTINUE IF((ILEFT(LINE) .GE. 0) .AND. ((IRIGHT(LINE) .GE. 0) .AND. (.NOT.( *WEAK(LINE)))))GOTO 15881 RETURN 15881 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 15901 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 15910 I=1 GOTO 15913 15911 I=I+1 15913 IF((I).GT.(3))GOTO 15912 15920 J=1 GOTO 15923 15921 J=J+1 15923 IF((J).GT.(3))GOTO 15922 COV(I,J) = 0.0 GOTO 15921 15922 CONTINUE GOTO 15911 15912 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) 15901 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 X(100),Y(100),SLOPE2,INCPT2 INTEGER N,KODE IF(.NOT.(INST_PROF))GOTO 15941 RETURN 15941 CONTINUE IF(.NOT.(FIXFWHM))GOTO 15961 SLOPE = 0.0 RETURN 15961 CONTINUE MINIDP = 1.0 IF(NOGDLN .GE. 2)GOTO 15981 SIGFWHM = 0.0 INCPT = 0.0 SLOPE = 0.0 RETURN 15981 CONTINUE CALL MINWTD(KODE) FIXFWHM = .TRUE. 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 15990 I=1 GOTO 15993 15991 I=I+1 15993 IF((I).GT.(NOGDLN))GOTO 15992 IF((DEPTH(GOOD(I)) .LT. LLIMIT .OR. DEPTH(GOOD(I)) .GT. ULIMIT) .A *ND. (.NOT.(TELSET)))GOTO 16011 CALL FNDORD(WAVELN(GOOD(I)),IORDER) MEAN = MEAN + WAVELN(GOOD(I))/(FWHM(GOOD(I))*DW(IORDER)) GOTO 16021 16011 CONTINUE EXCLUDE = EXCLUDE + 1 16021 CONTINUE 16001 CONTINUE GOTO 15991 15992 CONTINUE IF(NOGDLN .LE. EXCLUDE)GOTO 16041 INCPT = MEAN/DBLE(NOGDLN - EXCLUDE) GOTO 16051 16041 CONTINUE INCPT = 0.0 WRITE(8,16060) 16060 FORMAT ('ERROR: NO GOOD LINES WITHIN DEPTH LIMITS FOR FWHM TO DEP %TH RELATION') 16051 CONTINUE 16031 CONTINUE SLOPE = 0.0 16070 I=1 GOTO 16073 16071 I=I+1 16073 IF((I).GT.(NOGDLN))GOTO 16072 FAC = WAVELN(GOOD(I))/DW(IORDER) IF((DEPTH(GOOD(I)) .GE. 0.10 .OR. DEPTH(GOOD(I)) .GE. 0.50) .AND. *(.NOT.(TELSET)))GOTO 16091 VAR = VAR + (FAC/FWHM(GOOD(I))-INCPT)**2 16091 CONTINUE GOTO 16071 16072 CONTINUE SIGFWHM = DMYSQ( VAR )/DBLE(NOGDLN -2 - EXCLUDE) RETURN END SUBROUTINE MINWTD(KODE) IMPLICIT REAL*8(A-H,O-Z) COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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(53,4),X(4),RES(51),CU(2,53),RDUMMY(100),SL,Y0 *,Y1 INTEGER K,L,M,N,KLMD,KLM2D,NKLMD,N2D,IU(2,53),S(51),ITER,KODE,IORD *ER INTEGER IAVG,INUM K = NOGDLN L = 0 M = 1 N = 2 KLMD = 51 KLM2D = 53 N2D = 4 KODE = 0 TOLER = 0.002 ITER = 510 NKLMD = 53 IAVG = 0 INUM = 0 DMIN = 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 )') 16100 I=1 GOTO 16103 16101 I=I+1 16103 IF((I).GT.(NOGDLN))GOTO 16102 IF(DEPTH(GOOD(I)) .LT. DMIN)GOTO 16121 CALL FNDORD(WAVELN(GOOD(I)),IORDER) R = WAVELN(GOOD(I))/(FWHM(GOOD(I))*DW(IORDER)) RW = DLOG10( 1.065*DW(IORDER)*FWHM(GOOD(I))*DEPTH(GOOD(I))/ WAVELN *(GOOD(I)) ) IF(RW .LT. -5.22)GOTO 16141 INUM = INUM + 1 Q(INUM,1) = DEPTH(GOOD(I)) Q(INUM,2) = 1.0 IF((.NOT.(GLOBAL_FOCUS)) .AND. (.NOT.(FOCUS_PARS(CURIMR))))GOTO 16 *161 Q(INUM,3) = 1.0/R**2 - 1.0/RFOCUS(WAVELN(GOOD(I)))**2 GOTO 16171 16161 CONTINUE Q(INUM,3) = 1.0/R**2 16171 CONTINUE 16151 CONTINUE WRITE(9,*)DEPTH(GOOD(I)),Q(INUM,3),WAVELN(GOOD(I)) Q(INUM,4) = 0.0 16141 CONTINUE IF(RW .GE. -4.85)GOTO 16191 IAVG = IAVG + 1 RDUMMY(IAVG) = 1.0/R**2 - 1.0/RFOCUS(WAVELN(GOOD(I)))**2 16191 CONTINUE 16121 CONTINUE GOTO 16101 16102 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 16211 WRITE(8,16220)KODE 16220 FORMAT (29H MINSUM ROUTINE ABORTED CODE ,I2) RETURN 16211 CONTINUE IF(INUM .LE. 1)GOTO 16241 SIGFWHM = 1.33*ERROR/DBLE(NOGDLN-2) GOTO 16251 16241 CONTINUE SIGFWHM = 0.0 16251 CONTINUE 16231 CONTINUE SLOPE = X(1) INCPT = X(2) IF(IAVG .LE. 2 .OR. SLOPE .LE. 0.0)GOTO 16271 CALL GTMEDN(RDUMMY,IAVG,RMEDIAN) IF(RMEDIAN .GE. 2.5D-11)GOTO 16291 RW = 1.41D-05 CALL GETDEPT(RW,SLOPE,INCPT,MINIDP) write(30,'(24h in get w to depth reln )') write(30,'(10hmin depth ,d15.9)')MINIDP GOTO 16301 16291 CONTINUE MINIDP = (RMEDIAN-INCPT)/SLOPE 16301 CONTINUE 16281 CONTINUE GOTO 16311 16271 CONTINUE RW = 1.41D-05 CALL GETDEPT(RW,SLOPE,INCPT,MINIDP) 16311 CONTINUE 16261 CONTINUE Y0 = INCPT + MINIDP * SLOPE Y1 = INCPT + SLOPE WRITE(9,'(9h nomarker)') WRITE(9,'(5h line)') WRITE(9,'(5h 0.0 ,g13.6)')Y0 WRITE(9,'(2g13.6)')MINIDP,Y0 WRITE(9,'(5h 1.0 ,g13.6)')Y1 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 16331 X = W - WFC(IROW) 16340 I=1 GOTO 16343 16341 I=I+1 16343 IF((I).GT.(6))GOTO 16342 R = R + A_FOCUS(IROW,I)*X**(I-1) GOTO 16341 16342 CONTINUE GOTO 16321 16331 IF(.NOT.(GLOBAL_FOCUS))GOTO 16351 X = W - GLOBAL_WFC 16360 I=1 GOTO 16363 16361 I=I+1 16363 IF((I).GT.(6))GOTO 16362 R = R + GLOBAL_A(I)*X**(I-1) GOTO 16361 16362 CONTINUE 16351 CONTINUE 16321 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 16370 I=1 GOTO 16373 16371 I=I+1 16373 IF((I).GT.(100000))GOTO 16372 R = 1.0/(INCPT + SLOPE*D) R = DMYSQ(R) RWCALC = 1.067*D/R IF(RWCALC .GE. RW)GOTO 16391 D = D + DELTAD DELTAD = DELTAD/10.0 ICOUNT = ICOUNT + 1 GOTO 16401 16391 CONTINUE D = D - DELTAD 16401 CONTINUE 16381 CONTINUE IF(ICOUNT .LT. 6)GOTO 16421 IF(R .LE. RMIN)GOTO 16441 WRITE(8,16450) 16450 FORMAT('ERROR: WIDTH TO DEPTH RELATION TOO NARROW') 16441 CONTINUE GOTO 16372 16421 CONTINUE GOTO 16371 16372 CONTINUE MINIDP = D RETURN END SUBROUTINE FNDSGL 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 INTEGER LINE MINIDP = 1.0 16460 I=1 GOTO 16463 16461 I=I+1 16463 IF((I).GT.(NOGDLN))GOTO 16462 CALL FNDORD(WAVELN(GOOD(I)),IORDER) FAC = WAVELN(GOOD(I))/DW(IORDER) IF(FAC/FWHM(GOOD(I)) .GT. INCPT + SLOPE*DEPTH(GOOD(I)) + 3.0*SIGFW *HM)GOTO 16481 IF(DEPTH(GOOD(I)) .GT. MINIDP .OR. DEPTH(GOOD(I)) .LT. LLIMIT)GOTO * 16501 MINIDP = DEPTH(GOOD(I)) 16501 CONTINUE 16481 CONTINUE GOTO 16461 16462 CONTINUE RETURN END SUBROUTINE DISBDW(X,Y,N) 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK 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 EXCLUDE,LINE,N REAL*8 X(100),Y(100) EXCLUDE = 0 16510 I=1 GOTO 16513 16511 I=I+1 16513 IF((I).GT.(NOGDLN))GOTO 16512 CALL FNDORD(WAVELN(GOOD(I)),IORDER) FAC = WAVELN(GOOD(I))/DW(IORDER) IF((FAC/FWHM(GOOD(I)) .GT. INCPT + SLOPE*DEPTH(GOOD(I)) + 3.0*SIGF *WHM .OR. DEPTH(GOOD(I)) .LT. 0.10) .AND. (.NOT.(TELSET)))GOTO 1653 *1 X(I-EXCLUDE) = DEPTH(GOOD(I)) Y(I-EXCLUDE) = FWHM(GOOD(I)) GOTO 16541 16531 CONTINUE EXCLUDE = EXCLUDE + 1 16541 CONTINUE 16521 CONTINUE GOTO 16511 16512 CONTINUE N = NOGDLN - EXCLUDE 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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 16550 I=3 GOTO 16553 16551 I=I+1 16553 IF((I).GT.(9))GOTO 16552 A(I) = 0.0 SINGLE(I) = 0.0 GOTO 16551 16552 CONTINUE 16560 LINE=1 GOTO 16563 16561 LINE=LINE+1 16563 IF((LINE).GT.(NOLINES))GOTO 16562 IF(.NOT.(WEAK(LINE)))GOTO 16581 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) IF(WIDTH .NE. 0.0)GOTO 16601 RETURN 16601 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 16621 IF(RHTDIO(LINE) .LT. CHANNEL(WAVELN(LINE+1)))GOTO 16641 GOTO 16561 16641 CONTINUE 16621 CONTINUE IF(LINE .LE. 1)GOTO 16661 IF(LFTDIO(LINE) .GT. CHANNEL(WAVELN(LINE-1)))GOTO 16681 GOTO 16561 16681 CONTINUE 16661 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) 16690 I=1 GOTO 16693 16691 I=I+1 16693 IF((I).GT.(3))GOTO 16692 16700 J=1 GOTO 16703 16701 J=J+1 16703 IF((J).GT.(3))GOTO 16702 COV(I,J) = 0.0 GOTO 16701 16702 CONTINUE GOTO 16691 16692 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 16721 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 16730 I=1 GOTO 16733 16731 I=I+1 16733 IF((I).GT.(3))GOTO 16732 16740 J=1 GOTO 16743 16741 J=J+1 16743 IF((J).GT.(3))GOTO 16742 COV(I,J) = 0.0 GOTO 16741 16742 CONTINUE GOTO 16731 16732 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) SINGLE(2) = 1.0 16721 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) 16581 CONTINUE GOTO 16561 16562 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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 16761 RETURN 16761 CONTINUE CALL GUESLC(LINE,CENTRE(LINE),FIRST) ICENTRE = NINT(CENTRE(LINE)) IF(.NOT.(BADIOD(ICENTRE)))GOTO 16781 WRITE(8,16790)WAVELN(LINE) 16790 FORMAT (' REMOVED LINE AT ',F9.3,' A DUE TO BAD DIODES') WRITE(6,16800)WAVELN(LINE) 16800 FORMAT (' REMOVED LINE AT ',F9.3,' A DUE TO BAD DIODES') CALL REMFLS(LINE) LINE = LINE - 1 RETURN 16781 CONTINUE IF(.NOT.(LNABST(CENTRE(LINE))) .OR. LINEID(LINE) .EQ. 'TELLURIC ' %)GOTO 16821 WRITE(8,16830)LINEID(LINE),WAVELN(LINE) 16830 FORMAT (' LINE WITH ID ',A10,' AT ',F9.3,' WAS REMOVED - TOO WEAK %TO MEASURE.') WRITE(6,16840)LINEID(LINE),WAVELN(LINE) 16840 FORMAT (' LINE WITH ID ',A10,' AT ',F9.3,' WAS REMOVED - TOO WEAK %TO MEASURE.') CALL REMFLS(LINE) LINE = LINE - 1 RETURN 16821 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) IF(ILEFT(LINE) .GE. 0 .OR. IRIGHT(LINE) .GE. 0 .OR. FWHM(LINE) .NE *. 0.0)GOTO 16861 RETURN GOTO 16851 16861 IF(FWHM(LINE) .NE. 0.0)GOTO 16871 FWHM(LINE) = 4.5 16871 CONTINUE 16851 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) 16880 I=1 GOTO 16883 16881 I=I+1 16883 IF((I).GT.(3))GOTO 16882 16890 J=1 GOTO 16893 16891 J=J+1 16893 IF((J).GT.(3))GOTO 16892 COV(I,J) = 0.0 GOTO 16891 16892 CONTINUE GOTO 16881 16882 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 16911 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 16920 I=1 GOTO 16923 16921 I=I+1 16923 IF((I).GT.(3))GOTO 16922 16930 J=1 GOTO 16933 16931 J=J+1 16933 IF((J).GT.(3))GOTO 16932 COV(I,J) = 0.0 GOTO 16931 16932 CONTINUE GOTO 16921 16922 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) 16911 CONTINUE IF(ILEFT(LINE) .GE. 0 .OR. IRIGHT(LINE) .LT. 0)GOTO 16951 STEP = 1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,RHTDIO(LINE)) GOTO 16941 16951 IF(IRIGHT(LINE) .GE. 0 .OR. ILEFT(LINE) .LT. 0)GOTO 16961 STEP = -1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,LFTDIO(LINE)) 16961 CONTINUE 16941 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 16981 LNABST = .TRUE. 16981 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK NEXT = 0 LAST = 0 IF(LINE .GE. NOLINES)GOTO 17001 NEXT = NINT( CHANNEL(WAVELN(LINE+1)) ) 17001 CONTINUE STEP = 1 CALL DETLIM(ICENTRE,STEP,RHTDIO(LINE),NPTS,NEXT, WAVELN(LINE),LINE *ID(LINE)) IF(LINE .LE. 1)GOTO 17021 LAST = NINT( CHANNEL(WAVELN(LINE-1)) ) 17021 CONTINUE STEP = -1 CALL DETLIM(ICENTRE,STEP,LFTDIO(LINE),NPTS,LAST, WAVELN(LINE),LINE *ID(LINE)) IF(RHTDIO(LINE) .NE. DBLE(ICENTRE))GOTO 17041 IRIGHT(LINE) = -1 17041 CONTINUE IF(LFTDIO(LINE) .NE. DBLE(ICENTRE))GOTO 17061 ILEFT(LINE) = -1 17061 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 17081 SINGLE(1) = 1.0 SINGLE(2) = 0.0 SINGLE(3) = 0.0 GOTO 17091 17081 CONTINUE IF(ILEFT(LINE) .GE. 0)GOTO 17111 NEXT = 0 ILIMIT = INT(RHTDIO(LINE)) STEP = 1 IF(LINE .GE. NOLINES)GOTO 17131 NEXT = NINT( CHANNEL(WAVELN(LINE+1)) ) 17131 CONTINUE CALL DETLIM(ILIMIT,STEP,RHTDIO(LINE),NPTS, NEXT,WAVELN(LINE),LINEI *D(LINE)) GOTO 17101 17111 IF(IRIGHT(LINE) .GE. 0)GOTO 17141 LAST = 0 ILIMIT = INT(LFTDIO(LINE)) STEP = -1 IF(LINE .LE. 1)GOTO 17161 LAST = NINT( CHANNEL(WAVELN(LINE-1)) ) 17161 CONTINUE CALL DETLIM(ILIMIT,STEP,LFTDIO(LINE),NPTS, LAST,WAVELN(LINE),LINEI *D(LINE)) 17141 CONTINUE 17101 CONTINUE SINGLE(1) = 1.0 SINGLE(2) = 0.0 SINGLE(3) = 1.0 IF(.NOT.(INST_PROF))GOTO 17181 SINGLE(3) = 0.0 17181 CONTINUE IF((RHTDIO(LINE) .NE. DBLE(ILIMIT)) .AND. ((LFTDIO(LINE) .NE. DBLE *(ILIMIT)) .AND. (.NOT.(NOTURN(LINE,CENTRE(LINE),NPTS,NOLINES)))))G *OTO 17201 SINGLE(3) = 0.0 ILEFT(LINE) = -1 IRIGHT(LINE) = -1 17201 CONTINUE 17091 CONTINUE 17071 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 17221 RETURN GOTO 17211 17221 IF(SPEC(ICENT+1) .LT. SPEC(ICENT) .OR. SPEC(ICENT) .LT. SPEC(ICENT *-1))GOTO 17231 RETURN GOTO 17211 17231 IF(SPEC(ICENT+1) .GT. SPEC(ICENT) .OR. SPEC(ICENT) .GT. SPEC(ICENT *-1))GOTO 17241 RETURN 17241 CONTINUE 17211 CONTINUE IF(LINE .GE. NOLINES)GOTO 17261 CALL GUESLC(LINE+1,CNEXT,FIRST) 17261 CONTINUE IF(LINE .LE. 1)GOTO 17281 CALL GUESLC(LINE-1,CLAST,FIRST) 17281 CONTINUE IF((DBLE(ICENT-1) .GT. CLAST) .AND. (DBLE(ICENT+1) .LT. CNEXT))GOT *O 17301 RETURN 17301 CONTINUE NOTURN = .FALSE. RETURN END SUBROUTINE GTBSFW(WAVE,DEEP,WIDTH,SIGWDTH) 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 WIDTH = 0.0 D = DEEP IF(DEEP .GE. MINIDP)GOTO 17321 D = MINIDP 17321 CONTINUE RILIN2 = INCPT + D*SLOPE IF((.NOT.(FOCUS_PARS(CURIMR))) .AND. (.NOT.(GLOBAL_FOCUS)))GOTO 17 *341 RIOBS2 = 1.0/RFOCUS(WAVE)**2 + RILIN2 GOTO 17351 17341 CONTINUE RIOBS2 = RILIN2 17351 CONTINUE 17331 CONTINUE DELTA_W = DABS( WAVE - WAV(CHANNEL(WAVE)+1.0D+00) ) WIDTH = DMYSQ(RIOBS2) * WAVE / DELTA_W SIGWDTH = WIDTH * SIGFRAC IF(.NOT.(INST_PROF))GOTO 17371 SIGWDTH = WIDTH * 0.05 17371 CONTINUE RETURN END SUBROUTINE FTBLIN(NOLINES) IMPLICIT REAL*8(A-H,O-Z) INTEGER LINE,NOLINES 17380 LINE=1 GOTO 17383 17381 LINE=LINE+1 17383 IF((LINE).GT.(NOLINES))GOTO 17382 CALL FTBLND(LINE) GOTO 17381 17382 CONTINUE RETURN END SUBROUTINE FTBLND(LINE) IMPLICIT REAL*8(A-H,O-Z) INTEGER LINE LOGICAL RHTWGB IF(.NOT.(RHTWGB(LINE)))GOTO 17401 IF(.NOT.(RHTWGB(LINE-1)))GOTO 17421 CALL FT3GAUS(LINE) GOTO 17431 17421 CONTINUE CALL FT2GAUS(LINE) 17431 CONTINUE 17411 CONTINUE 17401 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 17451 RETURN 17451 CONTINUE FWHM1 = FWHM(LINE) DEEP = DEPTH(LINE) IF(FWHM1 .NE. 0.0)GOTO 17471 CALL GTBSFW(W,DEEP,FWHM1,SIGWDTH) 17471 CONTINUE FWHM2 = FWHM(LINE+1) DEEP = DEPTH(LINE+1) IF(FWHM2 .NE. 0.0)GOTO 17491 CALL GTBSFW(W,DEEP,FWHM2,SIGWDTH) 17491 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 17511 LIMIT1 = CENTRE(LINE) + FWHM1*0.60056121*DMYSQ( DLOG(DEPTH(LINE)/D *EPTH1) ) GOTO 17521 17511 CONTINUE LIMIT1 = CENTRE(LINE) 17521 CONTINUE 17501 CONTINUE IF(DEPTH(LINE+1) .LE. DEPTH2)GOTO 17541 LIMIT2 = CENTRE(LINE+1)-FWHM2*0.60056121*DMYSQ(DLOG(DEPTH(LINE+1)/ *DEPTH2)) GOTO 17551 17541 CONTINUE LIMIT2 = CENTRE(LINE+1) 17551 CONTINUE 17531 CONTINUE IF((LIMIT2 .GE. LIMIT1) .AND. (CENTRE(LINE+1)-CENTRE(LINE) .GE. FW *HM1+FWHM2+1.8D0*VWIDTH))GOTO 17571 RHTWGB = .TRUE. 17571 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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/ 17580 I=1 GOTO 17583 17581 I=I+1 17583 IF((I).GT.(9))GOTO 17582 TRIPLE(I) = 1.0 GOTO 17581 17582 CONTINUE BLEND(LINE) = 2 BLEND(LINE+1) = -1 17590 INDEX=1 GOTO 17593 17591 INDEX=INDEX+1 17593 IF((INDEX).GT.(3))GOTO 17592 L = LINE - 2 + INDEX CALL SMGSWI(TRIPLE,L,INDEX,ILEFT(L),IRIGHT(L)) IF(BLEND(LINE-1) .NE. 2)GOTO 17611 TRIPLE(1) = 0.0 TRIPLE(2) = 0.0 TRIPLE(3) = 0.0 17611 CONTINUE GOTO 17591 17592 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) 17620 I=1 GOTO 17623 17621 I=I+1 17623 IF((I).GT.(3))GOTO 17622 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 17641 WAVE = WAV(A((I-1)*3+2)) CALL GTBSFW(WAVE,DEPTH(LINE-2+I),WIDTH,SIGWDTH) A( (I-1)*3+3 ) = WIDTH*0.60056121 TRIPLE((I-1)*3+3) = 0.00 17641 CONTINUE GOTO 17621 17622 CONTINUE IF(DABS(CHANNEL(WAVELN(LINE+1))-CHANNEL(WAVELN(LINE))) .GT. 2.0D+0 *0)GOTO 17661 TRIPLE(5) = 0.0 A(5) = CHANNEL(WAVELN(LINE)) TRIPLE(8) = 0.0 A(8) = CHANNEL(WAVELN(LINE+1)) 17661 CONTINUE IF(DABS(CHANNEL(WAVELN(LINE-1))-CHANNEL(WAVELN(LINE))) .GT. 2.0D+0 *0)GOTO 17681 TRIPLE(2) = 0.0 A(2) = CHANNEL(WAVELN(LINE-1)) TRIPLE(5) = 0.0 A(5) = CHANNEL(WAVELN(LINE)) 17681 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,TRIPLE,CHISQ) 17690 I=1 GOTO 17693 17691 I=I+1 17693 IF((I).GT.(3))GOTO 17692 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 17711 FWHM(LINE-2+I) = DABS(A( (I-1)*3+3 ))/0.60056121 17711 CONTINUE GOTO 17691 17692 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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/ 17720 I=1 GOTO 17723 17721 I=I+1 17723 IF((I).GT.(6))GOTO 17722 DOUBLE(I) = 1.0 GOTO 17721 17722 CONTINUE 17730 I=7 GOTO 17733 17731 I=I+1 17733 IF((I).GT.(9))GOTO 17732 DOUBLE(I) = 0.0 GOTO 17731 17732 CONTINUE BLEND(LINE) = 1 BLEND(LINE+1) = -1 17740 INDEX=1 GOTO 17743 17741 INDEX=INDEX+1 17743 IF((INDEX).GT.(2))GOTO 17742 L = LINE -1 + INDEX CALL SMGSWI(DOUBLE,L,INDEX,ILEFT(L),IRIGHT(L)) GOTO 17741 17742 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) 17750 I=1 GOTO 17753 17751 I=I+1 17753 IF((I).GT.(2))GOTO 17752 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 17771 WAVE = WAV(A((I-1)*3+2)) CALL GTBSFW(WAVE,DEPTH(LINE-1+I),WIDTH,SIGWDTH) A( (I-1)*3+3 ) = WIDTH*0.60056121 DOUBLE((I-1)*3+3) = 0.0 17771 CONTINUE GOTO 17751 17752 CONTINUE IF(DABS(CHANNEL(WAVELN(LINE+1))-CHANNEL(WAVELN(LINE))) .GT. 2.0D+0 *0)GOTO 17791 DOUBLE(2) = 0.0 A(2) = CHANNEL(WAVELN(LINE)) DOUBLE(5) = 0.0 A(5) = CHANNEL(WAVELN(LINE+1)) 17791 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,DOUBLE,CHISQ) 17800 I=1 GOTO 17803 17801 I=I+1 17803 IF((I).GT.(2))GOTO 17802 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 17821 FWHM(LINE-1+I) = DABS(A( (I-1)*3+3 ))/0.60056121 17821 CONTINUE GOTO 17801 17802 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 17841 SWITCH(3*(INDEX-1)+3) = 0.0 17841 CONTINUE IF(ILEFT .GE. 0 .OR. IRIGHT .GE. 0)GOTO 17861 SWITCH(3*(INDEX-1)+3) = 0.0 17861 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 17881 LEFT = INT( LFTDIO(LINE) ) 17881 CONTINUE IF(INT( LFTDIO(LINE+1) ) .GE. LEFT)GOTO 17901 LEFT = INT( LFTDIO(LINE+1) ) 17901 CONTINUE RIGHT = INT( RHTDIO(LINE+1) ) IF(INT( RHTDIO(LINE) ) .LE. RIGHT)GOTO 17921 RIGHT = INT( RHTDIO(LINE) ) 17921 CONTINUE IF(INT( RHTDIO(LINE-1) ) .LE. RIGHT)GOTO 17941 RIGHT = INT( RHTDIO(LINE-1) ) 17941 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 17961 LEFT = INT( LFTDIO(LINE+1) ) 17961 CONTINUE IF(INT( RHTDIO(LINE) ) .LE. RIGHT)GOTO 17981 RIGHT = INT( RHTDIO(LINE) ) 17981 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 17990 I=1 GOTO 17993 17991 I=I+(2) 17993 IF((2)*((I)-(2*N-1)).GT.0)GOTO 17992 X(I) = DBLE(INDEX) X(I+1) = 1.0 - SPEC(INDEX)/CONTUM(DBLE(INDEX)) INDEX = INDEX + 1 GOTO 17991 17992 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER NPTS REAL*8 A(9),COV(9,9) LOGICAL RHTWGB,DELETED 18000 I=1 GOTO 18003 18001 I=I+1 18003 IF((I).GT.(NREDO))GOTO 18002 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 18021 NREDO = NREDO - 1 18030 J=I GOTO 18033 18031 J=J+1 18033 IF((J).GT.(NREDO))GOTO 18032 REDO(J) = REDO(J+1) GOTO 18031 18032 CONTINUE I = I - 1 GOTO 18001 18021 CONTINUE CALL OBFWHML(LINE,A,COV,NPTS) CALL FT1GAUS(LINE) CALL SFTBLS(LINE) GOTO 18001 18002 CONTINUE 18040 I=1 GOTO 18043 18041 I=I+1 18043 IF((I).GT.(NREDO))GOTO 18042 CALL FNDRDL(REDO(I),LINE,WAVELN,NOLINES) IF((.NOT.(RHTWGB(LINE))) .AND. (.NOT.(RHTWGB(LINE-1))))GOTO 18061 CALL FNDSAE(LINE,ISTART,IEND,I) 18070 J=ISTART GOTO 18073 18071 J=J+1 18073 IF((J).GT.(IEND))GOTO 18072 CALL FTBLND(J) GOTO 18071 18072 CONTINUE 18061 CONTINUE GOTO 18041 18042 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER LINE,ISTART,IEND,IREDO LOGICAL RHTWGB 18080 IEND=LINE GOTO 18083 18081 IEND=IEND+1 18083 IF((IEND).GT.(NOLINES))GOTO 18082 IF(.NOT.(.NOT. RHTWGB(IEND)))GOTO 18101 GOTO 18082 18101 CONTINUE IF(REDO(IREDO+1) .NE. WAVELN(IEND) .OR. IREDO .GE. NREDO)GOTO 1812 *1 IREDO = IREDO + 1 18121 CONTINUE GOTO 18081 18082 CONTINUE 18130 ISTART=LINE GOTO 18133 18131 ISTART=ISTART+(-1) 18133 IF((-1)*((ISTART)-(1)).GT.0)GOTO 18132 IF(.NOT.(.NOT. RHTWGB(ISTART-1)))GOTO 18151 GOTO 18132 18151 CONTINUE GOTO 18131 18132 CONTINUE RETURN END SUBROUTINE FNDRDL(WAVE,LINE,WAVELN,N) IMPLICIT REAL*8(A-H,O-Z) REAL*8 WAVE,WAVELN(1000) INTEGER LINE,N 18160 LINE=1 GOTO 18163 18161 LINE=LINE+1 18163 IF((LINE).GT.(N))GOTO 18162 IF(WAVE .NE. WAVELN(LINE))GOTO 18181 RETURN 18181 CONTINUE GOTO 18161 18162 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER I,IDUMMY REAL*8 LAST NREDO = 0 LAST = 0.0 TLINWS = .FALSE. 18190 I=1 GOTO 18193 18191 I=I+1 18193 IF((I).GT.(NOLINES))GOTO 18192 IF(.NOT.(RHTWGB(I)))GOTO 18211 IF((LINEID(I) .NE. 'TELLURIC ' .OR. LINEID(I+1) .EQ. 'TELLURIC ' %) .AND. (LINEID(I+1) .NE. 'TELLURIC ' .OR. LINEID(I) .EQ. 'TELLUR %IC '))GOTO 18231 TLINWS = .TRUE. IF(NREDO .LT. 100)GOTO 18251 WRITE(8,18260) 18260 FORMAT('MAXIMUM NUMBER OF REDO LINES REACHED') GOTO 18192 18251 CONTINUE IF(LINEID(I+1) .NE. 'TELLURIC ' .OR. WAVELN(I) .EQ. LAST)GOTO 182 %81 NREDO = NREDO + 1 REDO(NREDO) = WAVELN(I) GOTO 18271 18281 IF(LINEID(I) .NE. 'TELLURIC ')GOTO 18291 NREDO = NREDO + 1 REDO(NREDO) = WAVELN(I+1) LAST = REDO(NREDO) 18291 CONTINUE 18271 CONTINUE 18231 CONTINUE 18211 CONTINUE GOTO 18191 18192 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 18300 I=1 GOTO 18303 18301 I=I+1 18303 IF((I).GT.(NH2O))GOTO 18302 IF(WEIGHT(I) .LT. 0.0)GOTO 18321 FACTOR(COUNT) = FACTOR(I) ERROR(COUNT) = ERROR(I) WEIGHT(COUNT) = WEIGHT(I) SHIFT(COUNT) = SHIFT(I) COUNT = COUNT + 1 18321 CONTINUE GOTO 18301 18302 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 18330 I=1 GOTO 18333 18331 I=I+1 18333 IF((I).GT.(NFAC - 1))GOTO 18332 18340 J=1 GOTO 18343 18341 J=J+1 18343 IF((J).GT.(NFAC - 1))GOTO 18342 IF(FACTOR(J) .LE. FACTOR(J+1))GOTO 18361 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 18361 CONTINUE GOTO 18341 18342 CONTINUE GOTO 18331 18332 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 18370 I=J GOTO 18373 18371 I=I+1 18373 IF((I).GT.(NFAC-1))GOTO 18372 FACTOR(I) = FACTOR(I+1) ERROR(I) = ERROR(I+1) WEIGHT(I) = WEIGHT(I+1) SHIFT(I) = SHIFT(I+1) GOTO 18371 18372 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK REAL*8 SPCTRUM(10000) INTEGER NPTS,I,J 18380 I=1 GOTO 18383 18381 I=I+1 18383 IF((I).GT.(NOLINES))GOTO 18382 IF(LINEID(I) .NE. 'TELLURIC ')GOTO 18401 LIMIT1 = NINT(CENTRE(I)-2.0*FWHM(I)) LIMIT2 = NINT(CENTRE(I)+2.0*FWHM(I)) IF(LIMIT1 .GE. 1)GOTO 18421 LIMIT1 = 1 GOTO 18411 18421 IF(LIMIT2 .LE. NPTS)GOTO 18431 LIMIT2 = NPTS 18431 CONTINUE 18411 CONTINUE A1 = DEPTH(I) A2 = CENTRE(I) A3 = FWHM(I)*0.60056121 18440 J=LIMIT1 GOTO 18443 18441 J=J+1 18443 IF((J).GT.(LIMIT2))GOTO 18442 FACTOR = 1.0 - A1*EXP(-( (A2-DBLE(J))/A3 )**2) SPCTRUM(J) = SPCTRUM(J)/FACTOR GOTO 18441 18442 CONTINUE 18401 CONTINUE GOTO 18381 18382 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK INTEGER I 18450 I=1 GOTO 18453 18451 I=I+1 18453 IF((I).GT.(NOLINES))GOTO 18452 IF(LINEID(I) .NE. 'TELLURIC ')GOTO 18471 CALL REMFLS(I) I = I - 1 18471 CONTINUE GOTO 18451 18452 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK REAL*8 X(100),Y(100) INTEGER EXCLUDE IF(NORFLN .LE. NOGDLN)GOTO 18491 RETURN 18491 CONTINUE EXCLUDE = 0 18500 I=1 GOTO 18503 18501 I=I+1 18503 IF((I).GT.(NOGDLN))GOTO 18502 IF(WAVELN(GOOD(I)) .LE. 0.0 .OR. DABS( CENTRE(GOOD(I))-CHANNEL(WAV *ELN(GOOD(I))) ) .GE. 1.5)GOTO 18521 X(I-EXCLUDE) = CENTRE(GOOD(I)) Y(I-EXCLUDE) = WAVELN(GOOD(I)) GOTO 18531 18521 CONTINUE EXCLUDE = EXCLUDE + 1 18531 CONTINUE 18511 CONTINUE GOTO 18501 18502 CONTINUE N = NOGDLN - EXCLUDE CALL FITLINE(X,Y,N,DISP,OFFSET) IF(N .LE. 2)GOTO 18551 CALL PARABOL(X,Y,N,DISP2,DISP1,OFFSET) 18551 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 * 18571 ICENTRE = NINT(CENTRE(LINE)) DEEP = 1.0 - SPEC(ICENTRE)/CONTUM(DBLE(ICENTRE)) WAVE = WAV(CENTRE(LINE)) CALL GTBSFW(WAVE,DEEP,WIDTH,SIGWDTH) GOTO 18561 18571 IF(FWHM(LINE) .NE. 0.0)GOTO 18581 WRITE(8,18590)LINE 18590 FORMAT (' CANNOT DEFINE AN EW FOR LINE ',I3,' BECAUSE NO FWHM-DEPT %H RELATION', ' EXISTS') EW(LINE) = 0.0 RETURN GOTO 18601 18581 CONTINUE WIDTH = FWHM(LINE) 18601 CONTINUE 18561 CONTINUE IF((.NOT.(LINIWD(WAVELN(LINE)))) .AND. (SIGWDTH .NE. 0.0))GOTO 186 *21 EW(LINE) = FWHM(LINE)*DEPTH(LINE)*0.60056121*DMYSQ(PI) * DISP*1000 *.0 DELTEW(LINE)= DELTEW(LINE) * EW(LINE) RETURN 18621 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 18641 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,18650)LINEID(LINE),WAVELN(LINE),FWHM(LINE),AREA,WIDTH,EW(L *INE) 18650 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 18661 18641 CONTINUE EW(LINE) = FWHM(LINE)*DEPTH(LINE)*0.60056121*DMYSQ(PI) * DISP*1000 *.0 DELTEW(LINE)= DELTEW(LINE) * EW(LINE) 18661 CONTINUE 18631 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. 18670 I=1 GOTO 18673 18671 I=I+1 18673 IF((I).GT.(IWIDE))GOTO 18672 IF(WIDE(I) .NE. WAVE)GOTO 18691 LINIWD = .TRUE. GOTO 18672 18691 CONTINUE GOTO 18671 18672 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 )') 18700 I=1 GOTO 18703 18701 I=I+1 18703 IF((I).GT.(NOLINES))GOTO 18702 IF(FWHM(I) .EQ. 0.0 .OR. FWHM(I) .GE. MINFWHM)GOTO 18721 MINFWHM = FWHM(I) GOTO 18711 18721 IF(FWHM(I) .EQ. 0.0 .OR. FWHM(I) .LE. MAXFWHM)GOTO 18731 MAXFWHM = FWHM(I) 18731 CONTINUE 18711 CONTINUE IF(DEPTH(I) .LE. MAXDEP)GOTO 18751 MAXDEP = DEPTH(I) 18751 CONTINUE GOTO 18701 18702 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 )') 18760 I=1 GOTO 18763 18761 I=I+1 18763 IF((I).GT.(NOGDLN))GOTO 18762 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 18761 18762 CONTINUE WRITE(9,'(10H MARKER 3 )') J = 1 18770 I=1 GOTO 18773 18771 I=I+1 18773 IF((I).GT.(NOLINES))GOTO 18772 IF(I .NE. GOOD(J))GOTO 18791 J = J + 1 GOTO 18771 18791 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 18771 18772 CONTINUE WRITE(9,'(6H LINE )') WRITE(9,'(10H NOMARKER )') IF(WIDFLG .NE. -1)GOTO 18811 RETURN GOTO 18801 18811 IF(WIDFLG .NE. 0)GOTO 18821 WRITE(9,'(6H 0.0 ,F13.4,/,6H 0.5 ,F13.4)')INCPT,INCPT GOTO 18831 18821 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 18831 CONTINUE 18801 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK OPEN(UNIT=13,FILE='H2OLIST',STATUS='OLD') REWIND 13 WRITE(13,18840)SLOPE,INCPT,MINIDP 18840 FORMAT(F12.9,2X,F15.9,2X,F15.9) 18850 I=1 GOTO 18853 18851 I=I+1 18853 IF((I).GT.(NOLINES))GOTO 18852 WRITE(13,18860)CENTRE(I),FWHM(I),DEPTH(I) 18860 FORMAT ('TELLURIC ',F10.3,F10.5,F10.7) GOTO 18851 18852 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(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS WRITE(10,18870)SPTITLE 18870 FORMAT (A80) WRITE(10,18880)CURSPC,CURORD,CURIMR 18880 FORMAT ('SPECTRUM ',I3,', ORDER ',I3,', IMAGE ROW ',I3) WRITE(12,18890)SPTITLE 18890 FORMAT (A80) WRITE(12,18900)CURSPC,CURORD,CURIMR 18900 FORMAT ('SPECTRUM ',I3,', ORDER ',I3,', IMAGE ROW ',I3) WRITE(15,18910)SPTITLE 18910 FORMAT (A80) WRITE(15,18920)CURSPC,CURORD,CURIMR 18920 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK CHARACTER*80 TITLE INTEGER I 18930 I=1 GOTO 18933 18931 I=I+1 18933 IF((I).GT.(NOLINES))GOTO 18932 IF(LINEID(I)(1:4) .EQ. 'JUNK')GOTO 18951 WRITE(10,18960)LINEID(I)(1:5),WAVELN(I),ATOM(I),EPLOW(I),GF(I),EW( *I) 18960 FORMAT (A5,F10.3,F10.1,F10.3,10X,F10.3,20X,F5.1) WRITE(12,18970)LINEID(I)(1:5),WAVELN(I),ATOM(I),EPLOW(I),GF(I),DEP *TH(I) 18970 FORMAT (A5,F10.3,F10.1,F10.3,10X,F10.3,20X,F5.3) WRITE(15,18980)WAVELN(I),ATOM(I),EPLOW(I),GF(I),EW(I) 18980 FORMAT (F10.3,F10.1,F10.3,F10.3,20X,F10.1) 18951 CONTINUE GOTO 18931 18932 CONTINUE 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT 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 19001 19010 I=1 GOTO 19013 19011 I=I+1 19013 IF((I).GT.(NPLOTS))GOTO 19012 XLENGTH = DBLE( NPLOTR(I)-NPLOTL(I)+1 )*2.54/20.0 IF(.NOT.(BADPLT(WPLOTL(I),WPLOTR(I),NPTS)))GOTO 19031 GOTO 19011 19031 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 19011 19012 CONTINUE GOTO 18991 19001 IF(.NOT.(PLOTALL))GOTO 19041 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) 19041 CONTINUE 18991 CONTINUE RETURN END SUBROUTINE DETPLB (NPTS) IMPLICIT REAL*8(A-H,O-Z) INTEGER NPTS,I COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) 19050 I=1 GOTO 19053 19051 I=I+1 19053 IF((I).GT.(NPLOTS))GOTO 19052 NPLOTL(I) = NINT( CHANNEL(WPLOTL(I)) ) IF(NPLOTL(I) .GE. 1)GOTO 19071 NPLOTL(I) = 1 19071 CONTINUE NPLOTR(I) = NINT( CHANNEL(WPLOTR(I)) ) IF(NPLOTR(I) .LE. NPTS)GOTO 19091 NPLOTL(I) = NPTS 19091 CONTINUE WPLOTL(I) = WAV( DBLE(NPLOTL(I)) ) WPLOTR(I) = WAV( DBLE(NPLOTR(I)) ) GOTO 19051 19052 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 19111 IF(WAVER .GT. WAV(41.0D0))GOTO 19131 BADPLT = .TRUE. 19131 CONTINUE WAVEL = WAV(1.0D0) GOTO 19101 19111 IF(WAVER .LE. ENDWAV)GOTO 19141 IF(WAVEL .LE. WAV(DBLE(NPTS-41)))GOTO 19161 BADPLT = .TRUE. 19161 CONTINUE WAVER = ENDWAV 19141 CONTINUE 19101 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,19170)TITLE(1:50) 19170 FORMAT (8H TITLE $,A50,1H$) WRITE(11,19180) 19180 FORMAT (' XLABEL /WAVELENGTH (A)/') WRITE(11,19190) 19190 FORMAT (23H YLABEL /RELATIVE FLUX/) WRITE(11,19200)XLENGTH 19200 FORMAT (9H XLENGTH ,F6.2) WRITE(11,19210) 19210 FORMAT (14H YLENGTH 24.5 ) WRITE(11,19220) 19220 FORMAT (14H XFORMAT F6.0 ) WRITE(11,19230) 19230 FORMAT (14H YFORMAT F5.2 ) WRITE(11,19240)XMIN 19240 FORMAT (6H XMIN ,F6.1) WRITE(11,19250)XMAX 19250 FORMAT (6H XMAX ,F6.1) WRITE(11,19260)YMIN 19260 FORMAT (6H YMIN ,F10.6) WRITE(11,19270)YMAX 19270 FORMAT (6H YMAX ,F10.6) RETURN END SUBROUTINE PRNTFX(LEFT,RIGHT) IMPLICIT REAL*8(A-H,O-Z) INTEGER LEFT,RIGHT WRITE(11,19280) 19280 FORMAT(10H MARKER 3 ) WRITE(11,19290) 19290 FORMAT(8H NOLINE ) WRITE(11,19300) 19300 FORMAT(' COLOR BLUE ') 19310 I=LEFT GOTO 19313 19311 I=I+1 19313 IF((I).GT.(RIGHT))GOTO 19312 WAVE = WAV(DBLE(I)) FLUX = SPEC(I) WRITE(11,19320)WAVE,FLUX 19320 FORMAT (F10.3,2X,F10.6) GOTO 19311 19312 CONTINUE RETURN END SUBROUTINE PRNTCN(LEFT,RIGHT) IMPLICIT REAL*8(A-H,O-Z) INTEGER LEFT,RIGHT,I REAL*8 WAVE,FLUX WRITE(11,19330) 19330 FORMAT(10H NOMARKER ,/,6H LINE ,/,13H COLOR GREEN ) 19340 I=LEFT GOTO 19343 19341 I=I+1 19343 IF((I).GT.(RIGHT))GOTO 19342 WAVE = WAV(DBLE(I)) FLUX = CONTUM(DBLE(I)) WRITE(11,19350)WAVE,FLUX 19350 FORMAT (F10.3,2X,F10.6) GOTO 19341 19342 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 19360 LINE=1 GOTO 19363 19361 LINE=LINE+1 19363 IF((LINE).GT.(NOLINES))GOTO 19362 INEXT = LINE + 1 ILAST = LINE - 1 CALL GETLNB(LINE,LEFT,RIGHT) CALL GETLNB(INEXT,LEFT1,RIGHT1) IF(LEFT1 .NE. LEFT)GOTO 19381 LEFT1 = RIGHT 19381 CONTINUE IF(POSN .GE. LEFT)GOTO 19401 POSN = LEFT 19401 CONTINUE IF(.NOT.(LNOOBD(LEFT,RIGHT,IPLOT)))GOTO 19421 GOTO 19361 19421 CONTINUE IF((BLEND(LINE) .NE. 0) .AND. (BLEND(LINE) .NE. 1))GOTO 19441 WRITE(11,19450) 19450 FORMAT(' NOMARKER ',/,' LINE ',/,' COLOR RED ',/) 19441 CONTINUE CALL OPCRLF(LINE,POSN,BLEND(LINE),LEFT1,RIGHT) GOTO 19361 19362 CONTINUE WRITE(11,19460) 19460 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 19481 RETURN GOTO 19471 19481 IF(DABS(DEPTH(LINE)) .GT. 1.0D-8)GOTO 19491 RETURN 19491 CONTINUE 19471 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 19511 LEFT = CENT - 50.0 RIGHT = CENT + 50.0 19511 CONTINUE RETURN END LOGICAL FUNCTION LNOOBD(LEFT,RIGHT,IPLOT) IMPLICIT REAL*8(A-H,O-Z) COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) REAL*8 LEFT,RIGHT,PLEFT,PRIGHT INTEGER IPLOT LNOOBD = .TRUE. IF(.NOT.(SCREEN))GOTO 19531 PLEFT = DBLE(SCLEFT) PRIGHT= DBLE(SCRGHT) GOTO 19541 19531 CONTINUE PLEFT = DBLE(NPLOTL(IPLOT)) PRIGHT= DBLE(NPLOTR(IPLOT)) 19541 CONTINUE 19521 CONTINUE IF(LEFT .GE. PLEFT)GOTO 19561 IF(RIGHT .GE. PLEFT)GOTO 19581 RETURN 19581 CONTINUE LEFT = PLEFT GOTO 19551 19561 IF(RIGHT .LE. PRIGHT)GOTO 19591 IF(LEFT .LE. PRIGHT)GOTO 19611 RETURN 19611 CONTINUE RIGHT = PRIGHT 19591 CONTINUE 19551 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 LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) INEXT = LINE+1 ILAST = LINE-1 FIRST = .TRUE. 19620 CONTINUE 19621 CONTINUE CALL EVALNF(LINE,POSN,FLUX0) 19630 INEXT=LINE+1 GOTO 19633 19631 INEXT=INEXT+1 19633 IF((INEXT).GT.(LINE+2))GOTO 19632 CALL EVALNF(INEXT,POSN,FLUX1) FLUX0 = FLUX0 + FLUX1 GOTO 19631 19632 CONTINUE 19640 ILAST=LINE-1 GOTO 19643 19641 ILAST=ILAST+(-1) 19643 IF((-1)*((ILAST)-(LINE-2)).GT.0)GOTO 19642 CALL EVALNF(ILAST,POSN,FLUX1) FLUX0 = FLUX0 + FLUX1 GOTO 19641 19642 CONTINUE FLUX0 = (1.0 - FLUX0)*CONTUM(POSN) IF(.NOT.(SCREEN))GOTO 19661 IF(.NOT.(FIRST))GOTO 19681 CALL PGP_MOVEA(WAV(POSN),FLUX0) FIRST = .FALSE. 19681 CONTINUE CALL PLTLFX(POSN,FLUX0) GOTO 19691 19661 CONTINUE CALL PRNTPT(POSN,FLUX0) 19691 CONTINUE 19651 CONTINUE IF(BLEND .GT. 0)GOTO 19711 IF((POSN .LT. LEFT1 .OR. LEFT1 .LE. 0.0) .AND. (POSN .LT. RIGHT))G *OTO 19731 GOTO 19622 19731 CONTINUE 19711 CONTINUE IF((POSN .LT. LEFT1 .OR. LEFT1 .LE. 0.0) .AND. (POSN .LT. RIGHT))G *OTO 19751 GOTO 19622 19751 CONTINUE POSN = POSN + 0.25 GOTO 19621 19622 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 19760 I=4 GOTO 19763 19761 I=I+1 19763 IF((I).GT.(9))GOTO 19762 SW(I) = 0.0 GOTO 19761 19762 CONTINUE FLUX = 0.0 IF((LINE .GT. 0) .AND. (LINE .LE. NOLINES))GOTO 19781 FLUX = 0.0 RETURN 19781 CONTINUE IF(FWHM(LINE) .NE. 0.0)GOTO 19801 RETURN 19801 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,19810)WAV(POSN),FLUX 19810 FORMAT (F10.3,2X,F10.6) RETURN END SUBROUTINE PTSCPL(NPTS) IMPLICIT REAL*8(A-H,O-Z) COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) INTEGER START,FINISH,NPTS,LPG,PGOPEN LOGICAL PLWIISP IF(.NOT.(.NOT. SCREEN))GOTO 19831 RETURN 19831 CONTINUE SOFT_DEVICE = '/GTERM' CALL PGBEG(14,SOFT_DEVICE,1,1) CALL PGASK(.FALSE.) CALL PGSCR(1,0,240,0) CALL PGSCI(1) CALL CONPLT CALL INTUSR(I,ISHIFT) IF(NPLOTS .LE. 0)GOTO 19851 CALL DETPLB (NPTS) WSTART = WAV(1.0D0) WEND = WAV( DBLE(NPTS) ) 19860 I=1 GOTO 19863 19861 I=I+1 19863 IF((I).GT.(NPLOTS))GOTO 19862 IF(.NOT.(PLWIISP (WSTART,WEND,I)))GOTO 19881 START = NPLOTL(I) FINISH= NPLOTR(I) CNPLTG = .FALSE. CALL LFTSPC(START,FINISH,I) 19881 CONTINUE GOTO 19861 19862 CONTINUE GOTO 19841 19851 IF(.NOT.(PLOTALL))GOTO 19891 START = 1 FINISH= NPTS CNPLTG = .FALSE. CALL LFTSPC(START,FINISH,I) 19891 CONTINUE 19841 CONTINUE CALL PGEND RETURN END LOGICAL FUNCTION PLWIISP (WSTART,WEND,NPLOT) IMPLICIT REAL*8(A-H,O-Z) COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) COMMON/IBADD/ NOBAD,IBADL(300),IBADR(300) INTEGER NOBAD,IBADL,IBADR PLWIISP = .FALSE. IF(WPLOTR(NPLOT) .LE. WSTART .OR. WPLOTL(NPLOT) .GE. WEND)GOTO 199 *11 19920 I=1 GOTO 19923 19921 I=I+1 19923 IF((I).GT.(NOBAD))GOTO 19922 IF(NPLOTL(NPLOT) .LT. IBADL(I) .OR. NPLOTR(NPLOT) .GT. IBADR(I))GO *TO 19941 RETURN 19941 CONTINUE GOTO 19921 19922 CONTINUE PLWIISP = .TRUE. 19911 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 19950 CONTINUE 19951 CONTINUE IF(FINISH-START .LE. 110)GOTO 19971 IEND = START + 100 CALL PLTSCR(START,IEND,EMPTY) IF(.NOT.(EMPTY))GOTO 19991 START = IEND + 100 GOTO 19951 19991 CONTINUE CALL DSPLUS(ISHIFT) CALL MRKLIN CALL INTUSR(J,ISHIFT) IF(J .EQ. IPLOT)GOTO 20011 IPLOT = J GOTO 19952 20011 CONTINUE IF(IEND+ISHIFT .LT. 1)GOTO 20031 START = IEND + ISHIFT GOTO 20041 20031 CONTINUE START = 1 20041 CONTINUE 20021 CONTINUE GOTO 19961 19971 IF(FINISH-START .LT. 10)GOTO 20051 CALL PLTSCR(START,FINISH,EMPTY) IF(.NOT.(EMPTY))GOTO 20071 START = IEND + 100 GOTO 19951 20071 CONTINUE CALL DSPLUS(ISHIFT) CALL MRKLIN CALL INTUSR(IPLOT,ISHIFT) START = START + ISHIFT + 100 IF(ISHIFT .NE. 0)GOTO 20091 GOTO 19952 20091 CONTINUE GOTO 20101 20051 CONTINUE RETURN 20101 CONTINUE 19961 CONTINUE GOTO 19951 19952 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 20121 EMPTY = .TRUE. RETURN 20121 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 LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT 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 20141 YMAX = CMAX 20141 CONTINUE YRANGE = YMAX - YMIN YMAX = YMAX + 0.05*YRANGE YMIN = YMIN - 0.05*YRANGE IF(YRANGE .NE. 0.0)GOTO 20161 YMAX = 1.05*YMAX YMIN = 0.95*YMIN 20161 CONTINUE IF(YMIN .GE. 0.0)GOTO 20181 YMIN = 0.0 20181 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 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS WAV = OFFSET + DISP*(POSN-PIX_OFFSET) WAV = WAV / (1.0+RV/3.0D+05) 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS W0 = W * (1.0+RV/3.0D+05) CHANNEL = PIX_OFFSET + (W0-OFFSET)/DISP 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) 20190 I=ISTART GOTO 20193 20191 I=I+1 20193 IF((I).GT.(IEND))GOTO 20192 IF(SPEC(I) .GE. YMIN .OR. .NOT.(.NOT.BADIOD(I)))GOTO 20211 YMIN = SPEC(I) 20211 CONTINUE GOTO 20191 20192 CONTINUE YMIN = YMIN 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) 20220 I=ISTART GOTO 20223 20221 I=I+1 20223 IF((I).GT.(IEND))GOTO 20222 IF(SPEC(I) .LE. YMAX .OR. .NOT.(.NOT.BADIOD(I)))GOTO 20241 YMAX = SPEC(I) 20241 CONTINUE GOTO 20221 20222 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)) 20250 I=ISTART GOTO 20253 20251 I=I+1 20253 IF((I).GT.(IEND))GOTO 20252 IF(CONTUM(DBLE(I)) .LE. YMAX)GOTO 20271 YMAX = CONTUM(DBLE(I)) 20271 CONTINUE GOTO 20251 20252 CONTINUE RETURN END SUBROUTINE PLDTAY(ISTART,IEND) IMPLICIT REAL*8(A-H,O-Z) INTEGER N,I REAL*4 XPLOT(10000),YPLOT(10000) N = IEND-ISTART+1 20280 I=1 GOTO 20283 20281 I=I+1 20283 IF((I).GT.(N))GOTO 20282 YPLOT(I) = REAL(SPEC(I+ISTART-1)) XPLOT(I) = REAL(WAV(DBLE(I+ISTART-1))) GOTO 20281 20282 CONTINUE CALL PGPT(N,XPLOT,YPLOT,2) 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(10000),YPLOT(10000) CALL PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) ISTART = NINT(CHANNEL(XMIN)) IEND = NINT(CHANNEL(XMAX)) 20290 I=ISTART GOTO 20293 20291 I=I+1 20293 IF((I).GT.(IEND))GOTO 20292 II = I-ISTART+1 YPLOT(II) = REAL(SPEC(I)) XPLOT(II) = WAV(DBLE(I)) GOTO 20291 20292 CONTINUE CALL PGPT(IEND-ISTART+1,XPLOT,YPLOT,1) RETURN END SUBROUTINE PLTCTM(ISTART,IEND) IMPLICIT REAL*8(A-H,O-Z) CALL PGP_MOVEA(WAV(DBLE(ISTART)),CONTUM(DBLE(ISTART))) 20300 I=ISTART GOTO 20303 20301 I=I+1 20303 IF((I).GT.(IEND))GOTO 20302 CALL PGP_DRAWA(WAV(DBLE(I)),CONTUM(DBLE(I))) GOTO 20301 20302 CONTINUE 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 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 20310 LINE=1 GOTO 20313 20311 LINE=LINE+1 20313 IF((LINE).GT.(NOLINES))GOTO 20312 INEXT = LINE + 1 ILAST = LINE - 1 CALL GETLNB(LINE,LEFT,RIGHT) CALL GETLNB(INEXT,LEFT1,RIGHT1) IF(LEFT1 .NE. LEFT)GOTO 20331 LEFT1 = RIGHT 20331 CONTINUE IF(POSN .GE. LEFT)GOTO 20351 POSN = LEFT 20351 CONTINUE IF(INEXT .LE. NOLINES)GOTO 20371 LEFT1 = RIGHT 20371 CONTINUE IF(.NOT.(LNOOBD(LEFT,RIGHT,ISHIFT)))GOTO 20391 GOTO 20311 20391 CONTINUE CALL OPCRLF(LINE,POSN,BLEND(LINE),LEFT1,RIGHT) GOTO 20311 20312 CONTINUE 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) CHARACTER*1 ANS IF(.NOT.(CNPLTG))GOTO 20411 RETURN 20411 CONTINUE 20420 LINE=1 GOTO 20423 20421 LINE=LINE+1 20423 IF((LINE).GT.(NOLINES))GOTO 20422 IF(CENTRE(LINE) .LE. DBLE(SCRGHT))GOTO 20441 MID = (SCLEFT + SCRGHT)/2 ISHIFT = NINT(CENTRE(LINE)) - MID - 100 RETURN 20441 CONTINUE GOTO 20421 20422 CONTINUE WRITE(6,'(A)')'No more lines; skip to next order/spectrum?' READ(5,'(A)')ANS IF((ANS .NE. 'Y') .AND. (ANS .NE. 'y'))GOTO 20461 ISHIFT = 10000 GOTO 20471 20461 CONTINUE ISHIFT = -100 20471 CONTINUE 20451 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(500),WPLOTR(500) IF(.NOT.(CNPLTG))GOTO 20491 RETURN 20491 CONTINUE 20500 LINE=NOLINES GOTO 20503 20501 LINE=LINE+(-1) 20503 IF((-1)*((LINE)-(1)).GT.0)GOTO 20502 IF(CENTRE(LINE) .GE. DBLE(SCLEFT))GOTO 20521 MID = (SCLEFT + SCRGHT)/2 ISHIFT = NINT(CENTRE(LINE)) - MID - 100 RETURN 20521 CONTINUE GOTO 20501 20502 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 LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT 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. 20530 CONTINUE 20531 CONTINUE CALL DISPRM READ(5,'(A2)')COMM IF(COMM .NE. 'a ')GOTO 20551 CALL AGAN GOTO 20541 20551 IF(COMM .NE. 'ac')GOTO 20561 CALL ADDCT GOTO 20541 20561 IF(COMM .NE. 'b ')GOTO 20571 CALL BLOWUP GOTO 20541 20571 IF(COMM .NE. 'z ')GOTO 20581 CALL ZROPLT GOTO 20541 20581 IF(COMM .NE. 'cc')GOTO 20591 CALL DELCNT(FOUND) IF(.NOT.(FOUND))GOTO 20611 CALL ADDCT 20611 CONTINUE GOTO 20541 20591 IF(COMM .NE. 'dc')GOTO 20621 CALL DELCNT(FOUND) GOTO 20541 20621 IF(COMM .NE. 'cp')GOTO 20631 CALL CONPLT GOTO 20541 20631 IF(COMM .NE. 'fc')GOTO 20641 CALL CONFIT GOTO 20541 20641 IF(COMM .NE. 'nf')GOTO 20651 CALL DTTODT GOTO 20541 20651 IF(COMM .NE. 'ml')GOTO 20661 CALL MRKLIN GOTO 20541 20661 IF(COMM .NE. 'op')GOTO 20671 CALL OVRPDAT GOTO 20541 20671 IF(COMM .NE. 'ds')GOTO 20681 CNPLTG = .FALSE. ISHIFT = -100 RETURN GOTO 20541 20681 IF(COMM .NE. 'ew')GOTO 20691 CALL MEASFET GOTO 20541 20691 IF(COMM .NE. 'fl')GOTO 20701 CALL PLFLSP GOTO 20541 20701 IF(COMM .NE. 'ha')GOTO 20711 CALL PAPCPY GOTO 20541 20711 IF(COMM .NE. 'r ')GOTO 20721 CALL REJECT GOTO 20541 20721 IF(COMM .NE. 'rm')GOTO 20731 CALL RMEASLN GOTO 20541 20731 IF(COMM .NE. 'p ')GOTO 20741 CALL PNT GOTO 20541 20741 IF(COMM .NE. 'pb')GOTO 20751 ISHIFT = - 200 RETURN GOTO 20541 20751 IF(COMM .NE. 'pl')GOTO 20761 CALL OPSYNF(W0,WSTEP) CALL PLTSYN(W0,WSTEP,PAPER) CLOSE(UNIT=13) GOTO 20541 20761 IF(COMM .NE. 'nn')GOTO 20771 ISHIFT = 10000 RETURN GOTO 20541 20771 IF(COMM .NE. 'n ')GOTO 20781 CALL PLNXTL(ISHIFT) RETURN GOTO 20541 20781 IF(COMM .NE. 'l ')GOTO 20791 CALL PLLSTL(ISHIFT) RETURN GOTO 20541 20791 IF(COMM .NE. 'll')GOTO 20801 IF(IPLOT .NE. 0)GOTO 20821 GOTO 20531 20821 CONTINUE IPLOT = IPLOT - 2 IF(IPLOT .GE. 0)GOTO 20841 IPLOT = 0 20841 CONTINUE RETURN GOTO 20541 20801 IF(COMM .NE. 'c ')GOTO 20851 RETURN GOTO 20541 20851 IF(COMM .NE. 'q ')GOTO 20861 IPLOT = 100 RETURN GOTO 20541 20861 IF(COMM .NE. 'sg')GOTO 20871 NGAUSS = 1 CALL INMLGS(NGAUSS) GOTO 20541 20871 IF(COMM .NE. 'dg')GOTO 20881 NGAUSS = 2 CALL INMLGS(NGAUSS) GOTO 20541 20881 IF(COMM .NE. 'tg')GOTO 20891 NGAUSS = 3 CALL INMLGS(NGAUSS) GOTO 20541 20891 IF(COMM .NE. 'sl')GOTO 20901 CALL DSPLUS(I) GOTO 20541 20901 IF(COMM .NE. 'v ')GOTO 20911 CALL SETVSNI GOTO 20541 20911 IF(COMM .NE. 'ab')GOTO 20921 STOP 20921 CONTINUE 20541 CONTINUE GOTO 20531 20532 CONTINUE RETURN END SUBROUTINE AGAN IMPLICIT REAL*8(A-H,O-Z) COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT 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 20941 CALL RPLTCT CALL DCRONP GOTO 20951 20941 CONTINUE CALL PLDTAY(ISTART,IEND) CALL PLTCTM(ISTART,IEND) CALL REPSYN(PAPER) 20951 CONTINUE 20931 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 20960 I=1 GOTO 20963 20961 I=I+1 20963 IF((I).GT.(NOLINES))GOTO 20962 IF(WAVELN(I) .LT. XMIN .OR. WAVELN(I) .GT. XMAX)GOTO 20981 CALL PGP_MOVEA(WAVELN(I),BOTTOM) CALL PGP_DRAWA(WAVELN(I),TOP) CALL PTLINL(WAVELN(I),YTEXT,LINEID(I)) 20981 CONTINUE GOTO 20961 20962 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 LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT 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 21001 CALL DCRONP GOTO 21011 21001 CONTINUE CALL PLDTAY(ISTART,IEND) CALL REPSYN(PAPER) 21011 CONTINUE 20991 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 LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT 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 21031 CALL PGP_VCURSR(ICHAR,X2,Y2) IF(Y1 .LE. Y2)GOTO 21051 YMIN = Y2 YMAX = Y1 GOTO 21041 21051 IF(Y2 .LE. Y1)GOTO 21061 YMIN = Y1 YMAX = Y2 GOTO 21071 21061 CONTINUE RETURN 21071 CONTINUE 21041 CONTINUE GOTO 21021 21031 IF(ICHAR .NE. 120)GOTO 21081 CALL PGP_VCURSR(ICHAR,X2,Y2) IF(X1 .LE. X2)GOTO 21101 XMIN = X2 XMAX = X1 GOTO 21091 21101 IF(X2 .LE. X1)GOTO 21111 XMIN = X1 XMAX = X2 GOTO 21121 21111 CONTINUE RETURN 21121 CONTINUE 21091 CONTINUE GOTO 21021 21081 IF(ICHAR .NE. 101)GOTO 21131 CALL PGP_VCURSR(ICHAR,X2,Y2) IF(X1 .LE. X2)GOTO 21151 XMIN = X2 XMAX = X1 GOTO 21141 21151 IF(X2 .LE. X1)GOTO 21161 XMIN = X1 XMAX = X2 21161 CONTINUE 21141 CONTINUE IF(Y1 .LE. Y2)GOTO 21181 YMIN = Y2 YMAX = Y1 GOTO 21171 21181 IF(Y2 .LE. Y1)GOTO 21191 YMIN = Y1 YMAX = Y2 21191 CONTINUE 21171 CONTINUE IF(X1 .NE. X2 .OR. Y1 .NE. Y2)GOTO 21211 RETURN 21211 CONTINUE GOTO 21221 21131 CONTINUE CALL DISPRM WRITE(6,21230) 21230 FORMAT('MUST ENTER x OR y OR e') RETURN 21221 CONTINUE 21021 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 21251 CALL DCRONP GOTO 21261 21251 CONTINUE CALL PLDTAY(ISTART,IEND) CALL REPSYN(PAPER) 21261 CONTINUE 21241 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 21281 CALL DISPRM WRITE(6,21290) 21290 FORMAT('NO CONTINUUM FOUND') RETURN 21281 CONTINUE CALL DISPRM WRITE(6,21300) 21300 FORMAT('ENTER BOUNDS') CALL PGP_VCURSR(ICHAR,X1,Y1) CALL PGP_VCURSR(ICHAR,X2,Y2) IF(X2 .GE. X1)GOTO 21321 XTEMP = X2 X2 = X1 X1 = XTEMP 21321 CONTINUE X1 = NINT(CHANNEL(X1)) X2 = NINT(CHANNEL(X2)) IF(.NOT.(CNTIOO(X1,X2,ICONT)))GOTO 21341 CALL DISPRM WRITE(6,21350) 21350 FORMAT('BAD CONTINUUM ORDER') RETURN 21341 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 21371 CALL DISPRM WRITE(6,21380) 21380 FORMAT('BAD DIODES IN RANGE') CONLFT(ICONT) = OLEFT CONRHT(ICONT) = ORIGHT CONSIZE(ICONT) = OSIZE CFACTOR(ICONT) = OCFAC RETURN 21371 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS LOGICAL CNTBAD CALL DCRONP CALL DISPRM WRITE(6,21390) 21390 FORMAT('ENTER BOUNDS') CALL PGP_VCURSR(ICHAR,X1,Y1) CALL PGP_VCURSR(ICHAR,X2,Y2) IF(X2 .GE. X1)GOTO 21411 XTEMP = X2 X2 = X1 X1 = XTEMP 21411 CONTINUE IX1 = NINT(CHANNEL(X1)) IX2 = NINT(CHANNEL(X2)) IF(IX1 .GE. 1)GOTO 21431 IX1 = 1 21431 CONTINUE IF(IX2 .LE. NPTS)GOTO 21451 IX2 = NPTS 21451 CONTINUE IF((IX2 .GE. 1) .AND. (IX1 .LE. NPTS))GOTO 21471 CALL DISPRM WRITE(6,21480) 21480 FORMAT('WARNING: OUT OF BOUNDS; NO CONTINUUM ADDED ') RETURN 21471 CONTINUE NOCONT = NOCONT + 1 CONLFT(NOCONT) = IX1 CONRHT(NOCONT) = IX2 CONSIZE(NOCONT) = IX2-IX1+1 CFACTOR(NOCONT) = 1.00000 IF(.NOT.(CNTBAD(NOCONT)))GOTO 21501 CALL DISPRM WRITE(6,21510) 21510 FORMAT('WARNING: TOO MANY BAD DIODES; NO CONTINUUM ADDED') NOCONT = NOCONT - 1 RETURN 21501 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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 21520 K=CONLFT(ICONT) GOTO 21523 21521 K=K+1 21523 IF((K).GT.(CONRHT(ICONT)))GOTO 21522 IF(.NOT.(.NOT. BADIOD(K)))GOTO 21541 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 21541 CONTINUE GOTO 21521 21522 CONTINUE AVG = SXIWI/SNSIG SNSIG = 1.D0/DSQRT(SNSIG) IF(CONSIZE(ICONT) .LE. 1)GOTO 21561 CSIG = DMYSQ( ( SXI2 - (SXI**2)/ANUM )/(ANUM-1.0) ) CSIG = CSIG/DMYSQ(ANUM) 21561 CONTINUE CONFLUX(ICONT) = AVG SIGFLUX(ICONT) = CSIG IF(CSIG .GE. AVG*SNSIG)GOTO 21581 SIGFLUX(ICONT) = AVG*SNSIG 21581 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM LOGICAL FOUND FOUND = .FALSE. 21590 I=1 GOTO 21593 21591 I=I+1 21593 IF((I).GT.(NOCONT))GOTO 21592 DX = DBLE(CONSIZE(I))/2.0D0 IF(CONCENT(I) + DX .LT. X)GOTO 21611 IF(CONCENT(I) - DX .GT. X)GOTO 21631 ICONT = I FOUND = .TRUE. 21631 CONTINUE RETURN 21611 CONTINUE GOTO 21591 21592 CONTINUE RETURN END SUBROUTINE DCRONP IMPLICIT REAL*8(A-H,O-Z) REAL*4 XLOWER(1000),XUPPER(1000),YPLOT(1000) INTEGER IRED,IWHITE COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM IRED = 2 IWHITE = 1 IF(.NOT.(SCALED_CONTUM))GOTO 21651 21660 I=1 GOTO 21663 21661 I=I+1 21663 IF((I).GT.(NOCONT))GOTO 21662 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 21661 21662 CONTINUE CALL PGERRX(NOCONT,XLOWER,XUPPER,YPLOT,13.0) GOTO 21671 21651 CONTINUE 21680 I=1 GOTO 21683 21681 I=I+1 21683 IF((I).GT.(NOCONT))GOTO 21682 DX = DBLE(CONSIZE(I))/2.0D0 XLOWER(I) = WAV(CONCENT(I)-DX) XUPPER(I) = WAV(CONCENT(I)+DX) YPLOT(I) = CONFLUX(I) GOTO 21681 21682 CONTINUE CALL PGERRX(NOCONT,XLOWER,XUPPER,YPLOT,3.0) 21671 CONTINUE 21641 CONTINUE 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 21701 IF(NOCONT .NE. 1)GOTO 21721 RETURN 21721 CONTINUE IF(XAVG .LE. CONCENT(ICONT+1))GOTO 21741 CNTIOO = .TRUE. 21741 CONTINUE RETURN 21701 CONTINUE IF(ICONT .NE. NOCONT)GOTO 21761 IF(XAVG .GE. CONCENT(ICONT-1))GOTO 21781 CNTIOO = .TRUE. 21781 CONTINUE RETURN 21761 CONTINUE IF((XAVG .GE. CONCENT(ICONT-1)) .AND. (XAVG .LE. CONCENT(ICONT+1)) *)GOTO 21801 CNTIOO = .TRUE. 21801 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 21821 CALL DISPRM WRITE(6,21830) 21830 FORMAT('NO CONTINUUM FOUND') RETURN 21821 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(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT 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 21851 YMIN = CONFLUX(1) YMAX = CONFLUX(1) IF(.NOT.(SCALED_CONTUM))GOTO 21871 YMIN = CONFLUX(1)* CFACTOR(1) YMAX = CONFLUX(1)* CFACTOR(1) 21871 CONTINUE IF(NOCONT .LT. 2)GOTO 21891 IF(.NOT.(SCALED_CONTUM))GOTO 21911 21920 I=2 GOTO 21923 21921 I=I+1 21923 IF((I).GT.(NOCONT))GOTO 21922 IF(CONFLUX(I)*CFACTOR(I) .LE. YMAX)GOTO 21941 YMAX = CONFLUX(I)*CFACTOR(I) GOTO 21931 21941 IF(CONFLUX(I)*CFACTOR(I) .GE. YMIN)GOTO 21951 YMIN = CONFLUX(I)*CFACTOR(I) 21951 CONTINUE 21931 CONTINUE GOTO 21921 21922 CONTINUE GOTO 21961 21911 CONTINUE 21970 I=2 GOTO 21973 21971 I=I+1 21973 IF((I).GT.(NOCONT))GOTO 21972 IF(CONFLUX(I) .LE. YMAX)GOTO 21991 YMAX = CONFLUX(I) GOTO 21981 21991 IF(CONFLUX(I) .GE. YMIN)GOTO 22001 YMIN = CONFLUX(I) 22001 CONTINUE 21981 CONTINUE GOTO 21971 21972 CONTINUE 21961 CONTINUE 21901 CONTINUE 21891 CONTINUE YMIN = YMIN - 0.03 YMAX = YMAX + 0.03 GOTO 22011 21851 CONTINUE YMIN = 0.93 YMAX = 1.07 22011 CONTINUE 21841 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 PLFLSP IMPLICIT REAL*8(A-H,O-Z) COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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 22031 CALL DISPRM WRITE(6,22040) 22040 FORMAT('ONLY 7 SYNTHESIS FILES ALLOWED') RETURN 22031 CONTINUE CALL DISPRM WRITE(6,22050) 22050 FORMAT('ENTER FILENAME') CALL DISPRM NFILE = NFILE + 1 READ(5,'(A7)')FILES(NFILE) CALL DISPRM WRITE(6,22060) 22060 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 22081 W = W0 READ(13,*,END=22090)(FLUX(J),J=1,10) 22100 CONTINUE 22101 CONTINUE 22110 I=1 GOTO 22113 22111 I=I+1 22113 IF((I).GT.(10))GOTO 22112 IF(W .GT. XMAX .OR. W .LT. XMIN)GOTO 22131 Y = (1.0-FLUX(I))*CONTUM(CHANNEL(W)) IF(.NOT.(FIRST))GOTO 22151 IF(.NOT.(PAPER))GOTO 22171 WRITE(11,22180) 22180 FORMAT('COLOR BLACK') WRITE(11,22190) 22190 FORMAT('NOMARKER') WRITE(11,22200) 22200 FORMAT('DASHEDLINE 4') GOTO 22211 22171 CONTINUE CALL PGP_MOVEA(W,Y) 22211 CONTINUE 22161 CONTINUE FIRST = .FALSE. GOTO 22221 22151 CONTINUE IF(.NOT.(PAPER))GOTO 22241 WRITE(11,22250)W,Y 22250 FORMAT (F10.3,2X,F10.6) GOTO 22261 22241 CONTINUE CALL PGP_DRAWA(W,Y) 22261 CONTINUE 22231 CONTINUE 22221 CONTINUE 22141 CONTINUE 22131 CONTINUE W = W + WSTEP GOTO 22111 22112 CONTINUE READ(13,*,END=22090)(FLUX(J),J=1,10) IF(W .GT. XMAX)GOTO 22102 GOTO 22101 22102 CONTINUE RETURN 22090 CONTINUE IMAX = J - 1 22270 I=1 GOTO 22273 22271 I=I+1 22273 IF((I).GT.(IMAX))GOTO 22272 IF(W .GT. XMAX .OR. W .LT. XMIN)GOTO 22291 Y = (1.0-FLUX(I))*CONTUM(CHANNEL(W)) IF(.NOT.(FIRST))GOTO 22311 IF(.NOT.(PAPER))GOTO 22331 WRITE(11,22340) 22340 FORMAT('COLOR BLACK') WRITE(11,22350) 22350 FORMAT('NOMARKER') WRITE(11,22360) 22360 FORMAT('DASHEDLINE 4') GOTO 22371 22331 CONTINUE CALL PGP_MOVEA(W,Y) FIRST = .FALSE. 22371 CONTINUE 22321 CONTINUE GOTO 22381 22311 CONTINUE IF(.NOT.(PAPER))GOTO 22401 WRITE(11,22410)W,Y 22410 FORMAT (F10.3,2X,F10.6) GOTO 22421 22401 CONTINUE CALL PGP_DRAWA(W,Y) 22421 CONTINUE 22391 CONTINUE 22381 CONTINUE 22301 CONTINUE 22291 CONTINUE W = W + WSTEP GOTO 22271 22272 CONTINUE 22081 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 22441 RETURN 22441 CONTINUE 22450 I=1 GOTO 22453 22451 I=I+1 22453 IF((I).GT.(NFILE))GOTO 22452 OPEN(UNIT=13,FILE=FILES(I),STATUS='OLD') REWIND 13 CALL PLTSYN(WZERO(I),WINC(I),PAPER) CLOSE(UNIT=13) GOTO 22451 22452 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 22471 XLEFT = X1 XRIGHT = X2 GOTO 22481 22471 CONTINUE XLEFT = X2 XRIGHT = X1 22481 CONTINUE 22461 CONTINUE IF(XLEFT .GE. XMIN)GOTO 22501 XLEFT = XMIN 22501 CONTINUE IF(XRIGHT .LE. XMAX)GOTO 22521 XRIGHT = XMAX 22521 CONTINUE CALL INTEGRT(XLEFT,XRIGHT,AREA) A1 = SPEC(NINT(XLEFT)) A2 = DNINT(XLEFT) 22530 I=NINT(XLEFT)+1 GOTO 22533 22531 I=I+1 22533 IF((I).GT.(INT(XRIGHT)))GOTO 22532 IF(SPEC(I) .GE. A1)GOTO 22551 A1 = SPEC(I) A2 = DBLE(I) 22551 CONTINUE GOTO 22531 22532 CONTINUE A1 = 1.0 - SPEC(INT(A2))/CONTUM(A2) A3 = AREA/(A1*DMYSQ(PI)) 22560 I=1 GOTO 22563 22561 I=I+1 22563 IF((I).GT.(9))GOTO 22562 22570 J=1 GOTO 22573 22571 J=J+1 22573 IF((J).GT.(9))GOTO 22572 COV(I,J) = 0.0D0 GOTO 22571 22572 CONTINUE COV(I,I) = 1.0D0 SW(I) = 0.0D0 GOTO 22561 22562 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 22591 ISTART = ISTART + 1 FRAC1 = DBLE(ISTART) - XMIN 22591 CONTINUE FRAC2 = XMAX - DBLE(IEND) N = IEND - ISTART + 1 IF(N .GT. 1)GOTO 22611 SUM = 0.0 GOTO 22601 22611 IF(N .NE. 2)GOTO 22621 I = ISTART SUM = 1.0-(SPEC(I)/CONTUM(DBLE(I))+SPEC(IEND)/CONTUM(DBLE(IEND)))/ *2.0 GOTO 22631 22621 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 22651 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 22671 SUM5 = 0.0 GOTO 22681 22671 CONTINUE SUM5=2.0-SPEC(I+3)/CONTUM(DBLE(I+3))-SPEC(IEND)/CONTUM(DBLE(IEND)) * 22681 CONTINUE 22661 CONTINUE IZERO = 3 22651 CONTINUE 22690 I=ISTART+IZERO+1 GOTO 22693 22691 I=I+(2) 22693 IF((2)*((I)-(IEND-1)).GT.0)GOTO 22692 SUM2 = SUM2 + 4.0*(1.0-SPEC(I)/CONTUM(DBLE(I))) GOTO 22691 22692 CONTINUE 22700 I=ISTART+IZERO+2 GOTO 22703 22701 I=I+(2) 22703 IF((2)*((I)-(IEND-2)).GT.0)GOTO 22702 SUM3 = SUM3 + 2.0*(1.0-SPEC(I)/CONTUM(DBLE(I))) GOTO 22701 22702 CONTINUE SUM = SUM1 + (SUM2 + SUM3 + SUM5)/3.0 22631 CONTINUE 22601 CONTINUE IF(FRAC1 .EQ. 0.0)GOTO 22721 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 22721 CONTINUE IF(FRAC2 .EQ. 0.0)GOTO 22741 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 22741 CONTINUE IF(N .GT. 0)GOTO 22761 I = ISTART SUM4 = -1.0+(SPEC(I)/CONTUM(DBLE(I))+SPEC(IEND)/CONTUM(DBLE(IEND)) *)/2.0 + SUM4 22761 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,22770) 22770 FORMAT(' REJECT LINE. ARE YOU SURE?') CALL DISPRM READ(5,'(A1)')CHAR IF(CHAR .EQ. 'Y' .OR. CHAR .EQ. 'y')GOTO 22791 RETURN 22791 CONTINUE CALL FINDLN(CHANNEL(X),LINE) IF(LINE .NE. 0)GOTO 22811 RETURN 22811 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,22820)XCHAN 22820 FORMAT(' DIODE ',F7.2) CALL DISPRM WRITE(6,22830)X 22830 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK 22840 LINE=1 GOTO 22843 22841 LINE=LINE+1 22843 IF((LINE).GT.(NOLINES))GOTO 22842 WAVE = WAV(CENT) IF((DABS(WAVELN(LINE)-WAVE) .GT. 2.0*DISP) .AND. (DABS(WAVELN(LINE *)-WAVE) .GT. 0.04))GOTO 22861 IF(LINE .GE. NOLINES)GOTO 22881 IF(DABS(WAVELN(LINE)-WAVE) .GT. DABS(WAVELN(LINE+1)-WAVE))GOTO 229 *01 RETURN 22901 CONTINUE GOTO 22911 22881 CONTINUE RETURN 22911 CONTINUE 22871 CONTINUE 22861 CONTINUE GOTO 22841 22842 CONTINUE LINE = 0 RETURN END SUBROUTINE CONFIT IMPLICIT REAL*8(A-H,O-Z) CHARACTER*1 ANS REAL*8 X(1000),Y(1000),SIGMA(1000),ADUM(50),COVAR(50,50) REAL ACHISQ,SMEAN,PDEV 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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,22920) 22920 FORMAT(' ENTER ORDER OF POLYNOMIAL') LINENO = LINENO - 1 CALL DISPRM READ(5,'(I2)')IORD IF(NOCONT .GE. IORD)GOTO 22941 CALL DISPRM WRITE(6,22950) 22950 FORMAT('ORDER TOO BIG') RETURN 22941 CONTINUE CALL DISPRM WRITE(6,22960) 22960 FORMAT(' FIT TO SCALED CONTINUUM?') LINENO = LINENO - 1 CALL DISPRM READ(5,'(A1)')ANS IF((ANS .NE. 'Y') .AND. (ANS .NE. 'y'))GOTO 22981 SCALED_CONTUM = .TRUE. GOTO 22991 22981 CONTINUE SCALED_CONTUM = .FALSE. 22991 CONTINUE 22971 CONTINUE FITCON = .TRUE. IF(NOCONT .LT. 1)GOTO 23011 SMEAN = 0.0 IF(.NOT.(SCALED_CONTUM))GOTO 23031 23040 J=1 GOTO 23043 23041 J=J+1 23043 IF((J).GT.(NOCONT))GOTO 23042 Y(J) = CONFLUX(J) * CFACTOR(J) GOTO 23041 23042 CONTINUE GOTO 23051 23031 CONTINUE 23060 J=1 GOTO 23063 23061 J=J+1 23063 IF((J).GT.(NOCONT))GOTO 23062 Y(J) = CONFLUX(J) GOTO 23061 23062 CONTINUE 23051 CONTINUE 23021 CONTINUE 23070 J=1 GOTO 23073 23071 J=J+1 23073 IF((J).GT.(NOCONT))GOTO 23072 X(J) = CONCENT(J) SIGMA(J) = SIGFLUX(J) SMEAN = SMEAN + 1.0/SIGMA(J)**2 GOTO 23071 23072 CONTINUE CALL POLYLIN(X,Y,SIGMA,IORD,ADUM,COVAR,CHISQ,NOCONT) CONORD(CURIMR) = IORD 23080 ITERM=1 GOTO 23083 23081 ITERM=ITERM+1 23083 IF((ITERM).GT.(IORD))GOTO 23082 ACON(ITERM,CURIMR) = ADUM(ITERM) GOTO 23081 23082 CONTINUE CALL RPLTCT ACHISQ = REAL(CHISQ/DBLE(NOCONT-IORD)) PDEV = 100.0 * (SQRT(ACHISQ) / SQRT(SMEAN))/CONFLUX(NOCONT/2) CALL DISPRM WRITE(6,23090)ACHISQ 23090 FORMAT('Chi2/Ndf = ',F8.3) CALL DISPRM WRITE(6,23100)PDEV 23100 FORMAT('wrms dev.% =',F7.3) GOTO 23111 23011 CONTINUE CONORD(CURIMR) = 1 ACON(1,CURIMR) = 1.0 23111 CONTINUE 23001 CONTINUE RETURN END SUBROUTINE DTTODT IMPLICIT REAL*8 (A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON/ROTCOM/ VSINI REAL*8 VSINI REAL*8 SWITCH(9),A(9),COV(9,9),X(200),PHOTONS,VWIDTH,SWDUMMY(9) INTEGER NGAUSS,I,LEFT,RIGHT,N,ICENT 23120 I=1 GOTO 23123 23121 I=I+1 23123 IF((I).GT.(9))GOTO 23122 A(I) = 0.0D0 IF(I .GT. 3*NGAUSS)GOTO 23141 SWITCH(I) = 1.0 SWDUMMY(I) = 1.0 GOTO 23151 23141 CONTINUE SWITCH(I) = 0.0 SWDUMMY(I) = 0.0 23151 CONTINUE 23131 CONTINUE GOTO 23121 23122 CONTINUE 23160 I=1 GOTO 23163 23161 I=I+1 23163 IF((I).GT.(NGAUSS))GOTO 23162 CALL PRMCAD(A(3*I-1),A(3*I-2),SWITCH,I) GOTO 23161 23162 CONTINUE CALL PRMBOU(LEFT,RIGHT,SWITCH,NGAUSS) IF(LEFT .NE. 0 .OR. RIGHT .NE. 0)GOTO 23181 RETURN 23181 CONTINUE CALL SETUPTS(X,LEFT,RIGHT,N) 23190 I=1 GOTO 23193 23191 I=I+1 23193 IF((I).GT.(NGAUSS))GOTO 23192 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 23211 A(3*I) = 0.5*( X(2*N-1) - X(1) )/3.0 23211 CONTINUE IF(SWITCH(3*I) .NE. 1.0 .OR. A(3*I) .GE. 2.0)GOTO 23231 A(3*I) = 2.0 23231 CONTINUE GOTO 23191 23192 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) FLUX = (1.0-FLUX)*CONTUM(POSN) CALL PGP_MOVEA(WAV(POSN),FLUX) 23240 POSN=START + 0.25 GOTO 23243 23241 POSN=POSN+(0.25) 23243 IF((0.25)*((POSN)-(END)).GT.0)GOTO 23242 FLUX = 0.0 FLUX = PROFILE(POSN, A, SWDUMMY, VSINI) FLUX = (1.0-FLUX)*CONTUM(POSN) CALL PGP_DRAWA(WAV(POSN),FLUX) GOTO 23241 23242 CONTINUE 23250 I=1 GOTO 23253 23251 I=I+1 23253 IF((I).GT.(NGAUSS))GOTO 23252 CALL REPLEW(A(3*I-2),A(3*I-1),A(3*I),COV,SWITCH,I) GOTO 23251 23252 CONTINUE 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,23260) 23260 FORMAT(12HENTER BOUNDS) CALL PGP_VCURSR(ICHAR1,X1,Y1) CALL PGP_VCURSR(ICHAR2,X2,Y2) IF(X1 .LE. X2)GOTO 23281 LEFT = NINT(CHANNEL(X2)) RIGHT= NINT(CHANNEL(X1)) GOTO 23291 23281 CONTINUE RIGHT = NINT(CHANNEL(X2)) LEFT = NINT(CHANNEL(X1)) 23291 CONTINUE 23271 CONTINUE NPOINT = 0 23300 I=1 GOTO 23303 23301 I=I+1 23303 IF((I).GT.(3*NGAUSS))GOTO 23302 NPOINT = INT(SWITCH(I)) + NPOINT GOTO 23301 23302 CONTINUE IF(RIGHT - LEFT + 1 .GE. NPOINT)GOTO 23321 CALL DISPRM WRITE(6,23330) 23330 FORMAT(19HINSUFFICIENT POINTS) LEFT = 0 RIGHT = 0 23321 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,23340) 23340 FORMAT(13HSET LINE APEX) CALL PGP_VCURSR(ICHAR,X,Y) CENTRE = CHANNEL(X) DEPTH = 1.0 - Y/CONTUM(CENTRE) IF(ICHAR .NE. 102)GOTO 23361 CALL DISPRM WRITE(6,23370) 23370 FORMAT(' FIX DEPTH ?') LINENO = LINENO - 1 CALL DISPRM READ(5,'(A1)')ANS IF(ANS .NE. 'y')GOTO 23391 SWITCH(3*NGAUSS-2) = 0.0 23391 CONTINUE CALL DISPRM WRITE(6,23400) 23400 FORMAT(' FIX CENTRE?') LINENO = LINENO - 1 CALL DISPRM READ(5,'(A1)')ANS IF(ANS .NE. 'y')GOTO 23421 SWITCH(3*NGAUSS-1) = 0.0 23421 CONTINUE CALL DISPRM WRITE(6,23430) 23430 FORMAT(' FIX FWHM ?') LINENO = LINENO - 1 CALL DISPRM READ(5,'(A1)')ANS IF(ANS .NE. 'y')GOTO 23451 SWITCH(3*NGAUSS) = 0.0 23451 CONTINUE 23361 CONTINUE RETURN END SUBROUTINE SETVSNI IMPLICIT REAL*8 (A-H,O-Z) COMMON/ROTCOM/ VSINI REAL*8 VSINI CALL DISPRM WRITE(6,23460) 23460 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 23481 CALL GTBSFW(W,ADEPTH,WIDTH,SIGWDTH) IF((NOGDLN .NE. 0 .OR. .NOT.(.NOT. FIXFWHM)) .AND. (WIDTH .NE. 0.0 *))GOTO 23501 CALL DISPRM WRITE(6,23510) 23510 FORMAT(19HNO MEAN FWHM EXISTS) SWITCH = 1.0 23501 CONTINUE SIGMA = WIDTH*0.60056121 23481 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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 23531 CALL DISPRM WRITE(6,23540) 23540 FORMAT (16HLINE NOT ON LIST) CALL DISPRM WRITE(6,23550)AREA 23550 FORMAT(4HEW =,F7.2,2HMA) CALL DISPRM WRITE(6,23560)WAVE 23560 FORMAT(7HWAVE = ,F8.2,1HA) GOTO 23571 23531 CONTINUE WAVE2 = WAV(CENTRE(LINE)) CALL DISPRM WRITE(6,23580)AREA 23580 FORMAT(8HNEW EW =,F7.2,2HMA) CALL DISPRM WRITE(6,23590)WAVE 23590 FORMAT(7HWAVE = ,F8.2,1HA) CALL DISPRM WRITE(6,23600)EW(LINE) 23600 FORMAT(8HOLD EW =,F7.2,2HMA) CALL DISPRM WRITE(6,23610)WAVE2 23610 FORMAT(7HWAVE = ,F8.2,1HA) CALL DISPRM WRITE(6,23620) 23620 FORMAT(15HREPLACE OLD EW?) CALL DISPRM READ(5,'(A1)')ANS IF((ANS .NE. 'Y') .AND. (ANS .NE. 'y'))GOTO 23641 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,23650)DELTEW(LINE) 23650 FORMAT(7HD_EW = ,F7.2,2HMA) FWHM(LINE) = DABS(A3)/0.60056121 23641 CONTINUE 23571 CONTINUE 23521 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) 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) IF(SWITCH(ND) .NE. 1.0)GOTO 23671 IF(SWITCH(NW) .NE. 1.0)GOTO 23691 DELTA = COV(NW,NW)/A3**2 + COV(ND,ND)/A1**2 + 2.0*COV(ND,NW)/(A3* *A1) GOTO 23701 23691 CONTINUE DELTA = COV(ND,ND)/A1**2 DELTA = DELTA + (0.60056121*SIGWDTH/A3)**2 23701 CONTINUE 23681 CONTINUE GOTO 23661 23671 IF(SWITCH(NW) .NE. 1.0)GOTO 23711 DELTA = COV(NW,NW)/A3**2 GOTO 23721 23711 CONTINUE DELTA = (0.60056121*SIGWDTH/A3)**2 23721 CONTINUE 23661 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 23741 CALL PGP_DRAWA(WAV(POSN),FLUX) GOTO 23731 23741 IF(FLUX .GE. YMIN)GOTO 23751 CALL PGP_DRAWA(WAV(POSN),YMIN) GOTO 23761 23751 CONTINUE CALL PGP_DRAWA(WAV(POSN),YMAX) 23761 CONTINUE 23731 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(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS INTEGER I IF((I .GT. 0) .AND. (I .LE. NPTS))GOTO 23781 SPEC = 0.0 GOTO 23791 23781 CONTINUE SPEC = SPCTRUM(I) 23791 CONTINUE 23771 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(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV COMMON /SPBLK2/SPTITLE,RFTITLE CHARACTER*(18)SPTITLE,RFTITLE COMMON /SPBLK3/NPTS INTEGER NPTS COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 23811 IF(SPEC(I)/CONTUM(DBLE(I)) .LE. 0.0)GOTO 23831 SNR = SN * DSQRT( SPEC(I)/CONTUM(DBLE(I)) ) GOTO 23841 23831 CONTINUE SNR = 0.0 23841 CONTINUE 23821 CONTINUE GOTO 23801 23811 IF((I .GT. 0) .AND. (I .LE. NPTS))GOTO 23851 SNR = 0.0 GOTO 23801 23851 IF(VARSPEC(I) .GT. 0.0)GOTO 23861 SNR = 0.0 GOTO 23871 23861 CONTINUE SNR = DSQRT( VARSPEC(I) ) 23871 CONTINUE 23801 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 23891 CONTUM = 1.0 RETURN 23891 CONTINUE IF(.NOT.(TELSET))GOTO 23911 CONTUM = 1.0 RETURN 23911 CONTINUE X=DIODE IF((DIODE .LT. CONCENT(1) .OR. DIODE .GT. CONCENT(NOCONT)) .AND. ( *.NOT.(OLD_CONTUM)))GOTO 23931 IF(CONORD(CURIMR) .LE. 0)GOTO 23951 C = 0.0 23960 I=1 GOTO 23963 23961 I=I+1 23963 IF((I).GT.(CONORD(CURIMR)))GOTO 23962 C = C + ACON(I,CURIMR)*X**(I-1) GOTO 23961 23962 CONTINUE CONTUM = C GOTO 23941 23951 IF(CFLAG .NE. 1)GOTO 23971 CONTUM = A*X*X + B*X +C GOTO 23941 23971 IF(CFLAG .NE. 2)GOTO 23981 CONTUM = A*X + B GOTO 23941 23981 IF(CFLAG .NE. 3)GOTO 23991 CONTUM = A GOTO 23941 23991 IF(CFLAG .NE. 4)GOTO 24001 CALL FNDCNT(DIODE,BLUE,RED) CALL POLATE(BLUE,RED,DIODE,VALUE) CONTUM = VALUE GOTO 23941 24001 IF(CFLAG .NE. 5)GOTO 24011 CALL FNDCNT(DIODE,BLUE,RED) CONTUM = (CONFLUX(BLUE)+CONFLUX(RED))/2.0 24011 CONTINUE 23941 CONTINUE RETURN 23931 CONTINUE IF(CONORD(CURIMR) .LE. 0)GOTO 24031 IF(DIODE .GE. CONCENT(1))GOTO 24051 X = CONCENT(1) C = 0.0 24060 I=1 GOTO 24063 24061 I=I+1 24063 IF((I).GT.(CONORD(CURIMR)))GOTO 24062 C = C + ACON(I,CURIMR)*X**(I-1) GOTO 24061 24062 CONTINUE CONTUM = C GOTO 24041 24051 IF(DIODE .LE. CONCENT(NOCONT))GOTO 24071 X = CONCENT(NOCONT) C = 0.0 24080 I=1 GOTO 24083 24081 I=I+1 24083 IF((I).GT.(CONORD(CURIMR)))GOTO 24082 C = C + ACON(I,CURIMR)*X**(I-1) GOTO 24081 24082 CONTINUE CONTUM = C 24071 CONTINUE 24041 CONTINUE RETURN 24031 CONTINUE IF(DIODE .GE. CONCENT(1))GOTO 24101 I1=1 I2=2 GOTO 24091 24101 IF(DIODE .LE. CONCENT(NOCONT))GOTO 24111 I1=NOCONT-1 I2=NOCONT 24111 CONTINUE 24091 CONTINUE IF(EFLAG .NE. 1)GOTO 24131 CALL POLATE(I1,I2,DIODE,CONTUM) GOTO 24121 24131 IF(EFLAG .NE. 2 .OR. I1 .NE. 1)GOTO 24141 CONTUM = CONFLUX(I1) GOTO 24121 24141 IF(EFLAG .NE. 2)GOTO 24151 CONTUM = CONFLUX(I2) GOTO 24121 24151 IF(EFLAG .NE. 3)GOTO 24161 CONTUM = A*X + B 24161 CONTINUE 24121 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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 24170 I=1 GOTO 24173 24171 I=I+1 24173 IF((I).GT.(NOCONT-1))GOTO 24172 IF(DIODE .LT. CONCENT(I) .OR. DIODE .GT. CONCENT(I+1))GOTO 24191 BLUE=I RED=I+1 GOTO 24172 24191 CONTINUE GOTO 24171 24172 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(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E 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(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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,24200)CURSPC,CURORD 24200 FORMAT (/,'RESULTS FOR SPECTRUM ',I3,' ORDER ',I3,1H:) WRITE(1,24210)CURIMR 24210 FORMAT ('CURRENT IMAGE ROW ',I3,/) IF(.NOT.(.NOT.NRMLSD))GOTO 24231 WRITE(1,24240) 24240 FORMAT(' CONTINUUM REGIONS ',//) WRITE(1,24250) 24250 FORMAT(' WAVELENGTH SCALE') WRITE(1,24260) 24260 FORMAT(' BLUE RED FLUX FACTOR ',/) WRITE(1,24270)(WAV(DBLE(CONLFT(I))-0.5),WAV(DBLE(CONRHT(I))+0.5), *CONFLUX(I),CFACTOR(I),I=1,NOCONT) 24270 FORMAT (2F10.3,2X,F8.6,2X,F8.6) WRITE(1,24280)CONORD(CURIMR) 24280 FORMAT(//,'ORDER OF POLYNOMIAL FIT = ',I4) WRITE(1,24290) 24290 FORMAT(/,'POLYNOMIAL COEFFICIENTS: ') WRITE(1,24300)( ACON(ITERM,CURIMR),ITERM=1,CONORD(CURIMR)) 24300 FORMAT (5(G16.9,1X)) GOTO 24311 24231 CONTINUE WRITE(1,24320) 24320 FORMAT('NORMALISED CONTINUUM AT 1.00 USED THROUGHOUT') 24311 CONTINUE 24221 CONTINUE 24330 IPAGE=1 GOTO 24333 24331 IPAGE=IPAGE+1 24333 IF((IPAGE).GT.(100))GOTO 24332 N = (IPAGE-1)*50 WRITE(1,24340) 24340 FORMAT (///, ' LINE ID WAVELENGTH LEFT RIGHT DEPTH CENTRE F %WHM EW(MA) +/-EW'//) 24350 I=N+1 GOTO 24353 24351 I=I+1 24353 IF((I).GT.(N+50))GOTO 24352 IF(I .LE. NOLINES)GOTO 24371 RETURN 24371 CONTINUE WRITE(1,24380)LINEID(I),WAVELN(I),LFTDIO(I),RHTDIO(I),DEPTH(I), CE *NTRE(I),FWHM(I),EW(I),DELTEW(I) 24380 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 24352 GOTO 24351 24352 CONTINUE WRITE(1,24390) 24390 FORMAT(1H1) IF(I .GE. NOLINES)GOTO 24332 GOTO 24331 24332 CONTINUE 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 24400 CONTINUE NITER = 1 NZERO = 0 NU = 1000.0 24410 J=1 GOTO 24413 24411 J=J+1 24413 IF((J).GT.(9))GOTO 24412 ANEW(J) = AOLD(J) GOTO 24411 24412 CONTINUE CALL INITPA(V,X,XBEST,N,AOLD,F,SIGMA,PHOTONS,SWITCH,COV,NPARAM) IF(N-NZERO .GE. NPARAM)GOTO 24431 IF(N .NE. 1)GOTO 24451 IF(SWITCH(1) .NE. 1.0)GOTO 24471 AOLD(1) = 0.0 GOTO 24461 24471 IF(SWITCH(4) .NE. 1.0)GOTO 24481 AOLD(4) = 0.0 GOTO 24461 24481 IF(SWITCH(7) .NE. 1.0)GOTO 24491 AOLD(7) = 0.0 24491 CONTINUE 24461 CONTINUE RETURN 24451 CONTINUE WRITE(8,24500) 24500 FORMAT (' INSUFFICIENT NUMBER OF POINTS IN GAUSS FIT ') WRITE(8,24510)SWITCH,X 24510 FORMAT (' SWITCH ',9F3.0,/,' X VALUES ',20(8E15.6,/),/) RETURN 24431 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) 24520 CONTINUE 24521 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 24541 NU = NU/10.0 GOTO 24551 24541 CONTINUE NU = 10.0*NU 24560 J=1 GOTO 24563 24561 J=J+1 24563 IF((J).GT.(9))GOTO 24562 AOLD(J) = ANEW(J) 24570 JJ=1 GOTO 24573 24571 JJ=JJ+1 24573 IF((JJ).GT.(9))GOTO 24572 COVOLD(J,JJ) = COV(J,JJ) GOTO 24571 24572 CONTINUE GOTO 24561 24562 CONTINUE 24580 JJ=1 GOTO 24583 24581 JJ=JJ+1 24583 IF((JJ).GT.(N))GOTO 24582 WOLD(JJ) = W(JJ) PHIOLD(JJ) = PHI(JJ) GOTO 24581 24582 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) 24551 CONTINUE 24531 CONTINUE NITER = NITER + 1 IF(CONVRG(AOLD,ANEW,DELTA,SWITCH) .OR. NITER .GT. 16)GOTO 24522 GOTO 24521 24522 CONTINUE IF(N .LE. NPARAM)GOTO 24601 FACTOR = 0.0 24610 I=1 GOTO 24613 24611 I=I+1 24613 IF((I).GT.(N))GOTO 24612 FACTOR = FACTOR + WOLD(I)*PHIOLD(I)**2 GOTO 24611 24612 CONTINUE FACTOR = FACTOR/DBLE(N-NPARAM) 24601 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 24620 I=1 GOTO 24623 24621 I=I+1 24623 IF((I).GT.(9))GOTO 24622 24630 II=1 GOTO 24633 24631 II=II+1 24633 IF((II).GT.(9))GOTO 24632 COV(I,II) = 0.0 GOTO 24631 24632 CONTINUE GOTO 24621 24622 CONTINUE 24640 I=1 GOTO 24643 24641 I=I+1 24643 IF((I).GT.(2*N))GOTO 24642 V(I) = 0.0 XBEST(I) = X(I) GOTO 24641 24642 CONTINUE NPARAM = 0 24650 J=1 GOTO 24653 24651 J=J+1 24653 IF((J).GT.(9))GOTO 24652 IF(SW(J) .NE. 1.0)GOTO 24671 NPARAM = NPARAM + 1 24671 CONTINUE GOTO 24651 24652 CONTINUE 24680 I=1 GOTO 24683 24681 I=I+1 24683 IF((I).GT.(N))GOTO 24682 F(I) = PROFILE(X(2*I-1),A,SW,VSINI) - X(2*I) GOTO 24681 24682 CONTINUE IF(N .LE. 1)GOTO 24701 DELTA = X(3) - X(1) GOTO 24711 24701 CONTINUE DELTA = 1.0 24711 CONTINUE 24691 CONTINUE IF(PHOTONS .NE. 0.0)GOTO 24731 PHOTONS = 1.0 24731 CONTINUE 24740 J=1 GOTO 24743 24741 J=J+(2) 24743 IF((2)*((J)-(2*N-1)).GT.0)GOTO 24742 SIGMA(J) = DELTA**2/(12.0*(1.0-X(J+1))*PHOTONS) SIGMA(J+1) = ( 1.0 - X(J+1) )/PHOTONS GOTO 24741 24742 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 24750 I=2 GOTO 24753 24751 I=I+(2) 24753 IF((2)*((I)-(2*N)).GT.0)GOTO 24752 IF(X(I) .GT. 0.0)GOTO 24771 NZERO = NZERO + 1 24771 CONTINUE GOTO 24751 24752 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 REAL*8 DA,DX 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 24791 24800 IPAR=1 GOTO 24803 24801 IPAR=IPAR+1 24803 IF((IPAR).GT.(9))GOTO 24802 ADUM(IPAR) = A(IPAR) GOTO 24801 24802 CONTINUE 24810 I=1 GOTO 24813 24811 I=I+1 24813 IF((I).GT.(N))GOTO 24812 K = 1 24820 ISW=1 GOTO 24823 24821 ISW=ISW+1 24823 IF((ISW).GT.(9))GOTO 24822 IF(SW(ISW) .NE. 1.0)GOTO 24841 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) 24841 CONTINUE GOTO 24821 24822 CONTINUE GOTO 24811 24812 CONTINUE J = 1 24850 I=1 GOTO 24853 24851 I=I+1 24853 IF((I).GT.(N))GOTO 24852 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 24851 24852 CONTINUE GOTO 24861 24791 CONTINUE CALL GEXDER(XBEST,FA,FX,W,SIGMA,N,A,SW) 24861 CONTINUE 24781 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 24870 I=1 GOTO 24873 24871 I=I+1 24873 IF((I).GT.(N))GOTO 24872 K = 1 IF(SW(1) .NE. 1.0)GOTO 24891 FA(I,K) = MYEXP(-((XBEST(2*I-1)-A(2))/A(3))**2) K = K + 1 24891 CONTINUE IF(SW(2) .NE. 1.0)GOTO 24911 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 24911 CONTINUE IF(SW(3) .NE. 1.0)GOTO 24931 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 24931 CONTINUE IF(SW(4) .NE. 1.0)GOTO 24951 FA(I,K) = MYEXP(-((XBEST(2*I-1)-A(5))/A(6))**2) K = K + 1 24951 CONTINUE IF(SW(5) .NE. 1.0)GOTO 24971 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 24971 CONTINUE IF(SW(6) .NE. 1.0)GOTO 24991 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 24991 CONTINUE IF(SW(7) .NE. 1.0)GOTO 25011 FA(I,K) = MYEXP(-((XBEST(2*I-1)-A(8))/A(9))**2) K = K + 1 25011 CONTINUE IF(SW(8) .NE. 1.0)GOTO 25031 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 25031 CONTINUE IF(SW(9) .NE. 1.0)GOTO 25051 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 25051 CONTINUE GOTO 24871 24872 CONTINUE 25060 I=1 GOTO 25063 25061 I=I+1 25063 IF((I).GT.(N))GOTO 25062 25070 J=1 GOTO 25073 25071 J=J+1 25073 IF((J).GT.(2*N))GOTO 25072 FX(I,J) = 0.0 GOTO 25071 25072 CONTINUE GOTO 25061 25062 CONTINUE J=1 25080 I=1 GOTO 25083 25081 I=I+1 25083 IF((I).GT.(N))GOTO 25082 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 25101 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) 25101 CONTINUE IF((SW(7) .NE. 1.0) .AND. ((SW(8) .NE. 1.0) .AND. (SW(9) .NE. 1.0) *))GOTO 25121 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) 25121 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 25081 25082 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 25130 I=1 GOTO 25133 25131 I=I+1 25133 IF((I).GT.(NGAUSS(SW)))GOTO 25132 IF(VSINI .GE. 0.1D0)GOTO 25151 DUMMY = DUMMY + GAUSPRF(X, A, I) GOTO 25161 25151 CONTINUE DUMMY = DUMMY + ROTPROF(X, A, I, VSINI) 25161 CONTINUE 25141 CONTINUE GOTO 25131 25132 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 25181 NGAUSS = 1 25181 CONTINUE IF(SW(4)+SW(5)+SW(6) .LT. 1.0)GOTO 25201 NGAUSS = 2 25201 CONTINUE IF(SW(7)+SW(8)+SW(9) .LT. 1.0)GOTO 25221 NGAUSS = 3 25221 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 25241 XSTEP = XSTEPR 25241 CONTINUE XSTEP = 0.05 NLAM = 2*INT(DPIXL/XSTEP) + 1 DPIX = -DPIXL 25250 I=1 GOTO 25253 25251 I=I+1 25253 IF((I).GT.(NLAM))GOTO 25252 F(I) = H(PIX-DPIX,COEFF)*G(DPIX,DPIXL,DLAML,LAMC) X(I) = DPIX DPIX = -DPIXL + DBLE(I)*XSTEP GOTO 25251 25252 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 25271 G = 0.0D0 GOTO 25281 25271 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) 25281 CONTINUE 25261 CONTINUE RETURN END REAL*8 FUNCTION MYEXP(ARG) IMPLICIT REAL*8(A-H,O-Z) REAL*8 ARG IF(ARG .GE. -150.D0)GOTO 25301 MYEXP = 0.0D0 GOTO 25311 25301 CONTINUE MYEXP = DEXP(ARG) 25311 CONTINUE 25291 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 25320 J=1 GOTO 25323 25321 J=J+1 25323 IF((J).GT.(N))GOTO 25322 PHI(J) = 0.0 25330 I=1 GOTO 25333 25331 I=I+(2) 25333 IF((2)*((I)-(2*N-1)).GT.0)GOTO 25332 PHI(J) = PHI(J) - FX(J,I)*V(I) GOTO 25331 25332 CONTINUE PHI(J) = PHI(J) + F(J) GOTO 25321 25322 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 25340 I=1 GOTO 25343 25341 I=I+1 25343 IF((I).GT.(N))GOTO 25342 S = S + PHI(I)**2 * W(I) GOTO 25341 25342 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 25350 I=1 GOTO 25353 25351 I=I+1 25353 IF((I).GT.(9))GOTO 25352 25360 J=1 GOTO 25363 25361 J=J+1 25363 IF((J).GT.(9))GOTO 25362 MINV(I,J) = 0.0 GOTO 25361 25362 CONTINUE GOTO 25351 25352 CONTINUE 25370 I=1 GOTO 25373 25371 I=I+1 25373 IF((I).GT.(NPARAM))GOTO 25372 25380 J=1 GOTO 25383 25381 J=J+1 25383 IF((J).GT.(NPARAM))GOTO 25382 M(I,J) = 0.0 25390 K=1 GOTO 25393 25391 K=K+1 25393 IF((K).GT.(N))GOTO 25392 M(I,J) = M(I,J) + W(K)*FA(K,I)*FA(K,J) GOTO 25391 25392 CONTINUE GOTO 25381 25382 CONTINUE GOTO 25371 25372 CONTINUE 25400 I=1 GOTO 25403 25401 I=I+1 25403 IF((I).GT.(NPARAM))GOTO 25402 M(I,I) = M(I,I)*(1.0+1.0/NU) GOTO 25401 25402 CONTINUE CALL LINV2F(M,NPARAM,NINE,MINV,IDIGIT,WKAREA,IER) 25410 J=1 GOTO 25413 25411 J=J+1 25413 IF((J).GT.(NPARAM))GOTO 25412 COL(J) = 0.0 25420 I=1 GOTO 25423 25421 I=I+1 25423 IF((I).GT.(N))GOTO 25422 COL(J) = COL(J) + W(I)*PHI(I)*FA(I,J) GOTO 25421 25422 CONTINUE GOTO 25411 25412 CONTINUE 25430 J=1 GOTO 25433 25431 J=J+1 25433 IF((J).GT.(NPARAM))GOTO 25432 DELTA(J) = 0.0 25440 I=1 GOTO 25443 25441 I=I+1 25443 IF((I).GT.(NPARAM))GOTO 25442 DELTA(J) = DELTA(J) - MINV(J,I)*COL(I) GOTO 25441 25442 CONTINUE GOTO 25431 25432 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 25461 WRITE(8,25470)IER 25470 FORMAT (/' IMSL ERROR NUMBER ',I3) WRITE(8,25480)A 25480 FORMAT (' A VALUES: ',/,3(3E15.6,/)) WRITE(8,25490)(X(I),I=1,2*N) 25490 FORMAT(' X VALUES: ',/,25(8E15.6,/)) 25461 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 25500 I=1 GOTO 25503 25501 I=I+1 25503 IF((I).GT.(N))GOTO 25502 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 25501 25502 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 25510 I=1 GOTO 25513 25511 I=I+1 25513 IF((I).GT.(2*N))GOTO 25512 XBEST(I) = X(I) + V(I) GOTO 25511 25512 CONTINUE J = 0 25520 I=1 GOTO 25523 25521 I=I+1 25523 IF((I).GT.(9))GOTO 25522 IF(SW(I) .NE. 1.0)GOTO 25541 J = J + 1 A(I) = A(I) + DELTA(J) 25541 CONTINUE GOTO 25521 25522 CONTINUE 25550 I=1 GOTO 25553 25551 I=I+1 25553 IF((I).GT.(N))GOTO 25552 F(I) = PROFILE(X(2*I-1),A,SW,VSINI) - X(2*I) GOTO 25551 25552 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 25560 I=1 GOTO 25563 25561 I=I+1 25563 IF((I).GT.(9))GOTO 25562 IF(SWITCH(I) .NE. 1.0)GOTO 25581 K = K + 1 IF(DLOG10(DABS(DELTA(K))) .GE. -60.0)GOTO 25601 CONVRG = .TRUE. GOTO 25591 25601 IF(DABS( ANEW(I) ) .LE. 30000.0)GOTO 25611 CONVRG = .TRUE. WRITE(8,25620) 25620 FORMAT(' GAUSSIAN FIT DIVERGING, ITERATIONS ABANDONED ') GOTO 25562 GOTO 25591 25611 IF(DABS( AOLD(I)/DELTA(K) ) .LE. 10000.0)GOTO 25631 CONVRG = .TRUE. GOTO 25641 25631 CONTINUE CONVRG = .FALSE. GOTO 25562 25641 CONTINUE 25591 CONTINUE 25581 CONTINUE GOTO 25561 25562 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 25661 RETURN 25661 CONTINUE 24400 CONTINUE 25670 I=1 GOTO 25673 25671 I=I+1 25673 IF((I).GT.(NGAUSS(SWITCH)-1))GOTO 25672 IF(AOLD(3*(I-1)+2) .LE. AOLD(3*I+2))GOTO 25691 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. 25691 CONTINUE GOTO 25671 25672 CONTINUE IF(AOLD(2) .LE. AOLD(5))GOTO 25711 GOTO 24400 25711 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 25720 I=1 GOTO 25723 25721 I=I+1 25723 IF((I).GT.(N))GOTO 25722 YRES = PROFILE(X(2*I-1),A,SW,VSINI) - X(2*I) CHISQ = CHISQ + YRES**2/SIGMA(2*I) GOTO 25721 25722 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 25730 I=1 GOTO 25733 25731 I=I+1 25733 IF((I).GT.(9))GOTO 25732 IPARAM(I) = 0 IF(SWITCH(I) .NE. 1.0)GOTO 25751 IC = IC + 1 IPARAM(I) = IC 25751 CONTINUE GOTO 25731 25732 CONTINUE 25760 I=1 GOTO 25763 25761 I=I+1 25763 IF((I).GT.(9))GOTO 25762 25770 J=1 GOTO 25773 25771 J=J+1 25773 IF((J).GT.(9))GOTO 25772 IF(SWITCH(I) .NE. 1.0 .OR. SWITCH(J) .NE. 1.0)GOTO 25791 COV(I,J) = FACTOR * COVOLD( IPARAM(I),IPARAM(J) ) GOTO 25801 25791 CONTINUE COV(I,J) = 0.0 25801 CONTINUE 25781 CONTINUE GOTO 25771 25772 CONTINUE GOTO 25761 25762 CONTINUE RETURN END SUBROUTINE RADIALV IMPLICIT REAL*8(A-H,O-Z) COMMON/SPBLK1/SPCTRUM,VARSPEC,SN,LAMBDA,RV,SIGRV REAL*8 SPCTRUM(10000),VARSPEC(10000),SN,LAMBDA(10000),RV,SIGRV 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 INTEGER JREF,J,I,WRONG INTEGER NREF,IEND,ISTART,STDORDER REAL*8 FMIN,WREF(100),NSIG,PMIN,RVI(100) REAL*8 RVT,AN,RVT2,SIG,WEND,CENTER,SHIFTSTD,WSTD,RV_FAC WRITE(6,25810) 25810 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 25831 WRITE(6,25840)WSTD 25840 FORMAT(32H Cannot locate standard line at ,F10.3) STOP 25831 CONTINUE CALL RDSPEC(STDORDER) WEND = W1(STDORDER) + DW(STDORDER)*(DBLE(NPTS)-PIX1(STDORDER)) WSTART = W1(STDORDER) + DW(STDORDER)*(1.0d0-PIX1(STDORDER)) RV_FAC = 1.0D+00 + 350. / 3.0D+05 IF((WSTART .LE. WSTD/RV_FAC) .AND. (WEND .GE. WSTD*RV_FAC))GOTO 25 *861 WRITE(6,'(55H WARNING: Standard line within 350 Km/s of spectrum e %nd)') GOTO 25851 25861 IF(WSTART .GT. WSTD-0.7 .OR. WEND .LT. WSTD+0.7)GOTO 25871 RV_FZERO = 1.0D+00 + RV_EST / 3.0D+05 RV_FAC = 1.0D+00 + RV_SRCH / 3.0D+05 ISTART = NINT( (WSTD*RV_FZERO/RV_FAC - WSTART)/DW(STDORDER) + 1.0 *) IEND = NINT( (WSTD*RV_FZERO*RV_FAC - WSTART)/DW(STDORDER) + 1.0 ) IF(ISTART .GE. 1)GOTO 25891 ISTART=1 25891 CONTINUE IF(IEND .LE. NPTS)GOTO 25911 IEND=NPTS 25911 CONTINUE FMIN = 1.0 25920 I=ISTART GOTO 25923 25921 I=I+1 25923 IF((I).GT.(IEND))GOTO 25922 IF(SPEC(I) .GE. FMIN)GOTO 25941 FMIN = SPEC(I) PMIN = DBLE(I) 25941 CONTINUE GOTO 25921 25922 CONTINUE GOTO 25951 25871 CONTINUE WRITE(6,'(43H end of spectrum too close to standard line)') STOP 25951 CONTINUE 25851 CONTINUE CALL GTSTDMIN(PMIN,FMIN,CENTER) SHIFTSTD = ( WSTART + (CENTER-1.0)*DW(STDORDER) ) / WSTD 25960 J=1 GOTO 25963 25961 J=J+1 25963 IF((J).GT.(100))GOTO 25962 READ(14,*,END=24400)WREF(J) GOTO 25961 25962 CONTINUE 24400 CONTINUE REWIND(UNIT=14) CLOSE(UNIT=14) NREF = J - 1 WRONG = 0 RVT = 0.0 RVT2 = 0.0 25970 J=1 GOTO 25973 25971 J=J+1 25973 IF((J).GT.(NREF))GOTO 25972 CALL FNDORD(WREF(J),NEWORD) IF(NEWORD .NE. 0)GOTO 25991 CALL RMRVRF(WREF,J,NREF) J = J - 1 GOTO 25971 25991 CONTINUE IF(NEWORD .EQ. CURORD)GOTO 26011 CALL RDSPEC(NEWORD) 26011 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) CALL GETMIN(JREF,CENTER,NPTS) WCENT = WSTART + DW(NEWORD)*(CENTER-1.0D+00) RVI(J) = 3.0D+05*( WCENT/WREF(J) - 1.0D+00 ) GOTO 25971 25972 CONTINUE CALL GTMEDN2(RVI,WREF,NREF,RVMED) 26020 J=1 GOTO 26023 26021 J=J+1 26023 IF((J).GT.(NREF))GOTO 26022 DVLIMIT = 25.0 IF(DABS(RVI(J)-RVMED) .LE. DVLIMIT)GOTO 26041 IF(J .GE. NREF)GOTO 26061 26070 JJ=J GOTO 26073 26071 JJ=JJ+1 26073 IF((JJ).GT.(NREF-1))GOTO 26072 WREF(JJ) = WREF(JJ+1) RVI(JJ) = RVI(JJ+1) GOTO 26071 26072 CONTINUE 26061 CONTINUE NREF = NREF - 1 J = J - 1 GOTO 26021 GOTO 26081 26041 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) 26081 CONTINUE 26031 CONTINUE IF(J.GE.NREF)GOTO 26022 GOTO 26021 26022 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 DV = 2.0 * 3.0D+05*DW(NREF/2)/WREF(NREF/2) IF(DABS(RV-RVMED) .LE. DV)GOTO 26101 RV = RVMED WRITE(6,'(16H MEDIAN RV USED )') 26101 CONTINUE RETURN END SUBROUTINE RMRVRF(WREF,J,NREF) REAL*8 WREF(100) INTEGER NREF,J,I 26110 I=J GOTO 26113 26111 I=I+1 26113 IF((I).GT.(NREF-1))GOTO 26112 WREF(I) = WREF(I+1) GOTO 26111 26112 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 26120 I=1 GOTO 26123 26121 I=I+1 26123 IF((I).GT.(50))GOTO 26122 IF(1.0 - SPEC(ICENT-I) .GE. 0.5*(1.0-FMIN) .OR. ILEFT .NE. 0)GOTO *26141 ILEFT = ICENT - I 26141 CONTINUE IF(1.0 - SPEC(ICENT+I) .GE. 0.5*(1.0-FMIN) .OR. IRIGHT .NE. 0)GOTO * 26161 IRIGHT = ICENT + I 26161 CONTINUE GOTO 26121 26122 CONTINUE IF((ILEFT .NE. 0) .AND. (IRIGHT .NE. 0))GOTO 26181 WRITE(6,26190) 26190 FORMAT(67H CANNOT DEFINE STD LINE - half depth not within 50 pixel *s of center) STOP 26181 CONTINUE II = 0 26200 I=ILEFT GOTO 26203 26201 I=I+1 26203 IF((I).GT.(IRIGHT))GOTO 26202 II = II + 1 X(II) = DBLE(I) Y(II) = SPEC(I) GOTO 26201 26202 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 26210 I=1 GOTO 26213 26211 I=I+1 26213 IF((I).GT.(3))GOTO 26212 SINGLE(I) = 1.0 GOTO 26211 26212 CONTINUE 26220 I=4 GOTO 26223 26221 I=I+1 26223 IF((I).GT.(9))GOTO 26222 SINGLE(I) = 0.0 GOTO 26221 26222 CONTINUE NSIG = 1.8 JMIN = J-2 FMIN = SPEC(JMIN) 26230 I=J-2 GOTO 26233 26231 I=I+1 26233 IF((I).GT.(J+2))GOTO 26232 IF(SPEC(I) .GE. FMIN)GOTO 26251 FMIN = SPEC(I) JMIN = I 26251 CONTINUE GOTO 26231 26232 CONTINUE DFMIN = NSIG * DMYSQ(FMIN)/SNR(NINT(CENTER)) RIGHT = .FALSE. LEFT = .FALSE. 26260 I=1 GOTO 26263 26261 I=I+1 26263 IF((I).GT.(15))GOTO 26262 IF(.NOT.(.NOT.RIGHT) .OR. JMIN+I .GT. NPTS)GOTO 26281 DFR = NSIG * DMYSQ(SPEC(JMIN+I))/SNR(JMIN+I) IF(SPEC(JMIN+I) .LE. FMIN+DFMIN+DFR)GOTO 26301 RIGHT = .TRUE. IRIGHT = I + JMIN 26301 CONTINUE 26281 CONTINUE IF(.NOT.(.NOT.LEFT) .OR. JMIN-I .LT. 1)GOTO 26321 DFL = NSIG * DMYSQ(SPEC(JMIN-I))/SNR(JMIN-I) IF(SPEC(JMIN-I) .LE. FMIN+DFMIN+DFR)GOTO 26341 LEFT = .TRUE. ILEFT = JMIN-I 26341 CONTINUE 26321 CONTINUE IF(.NOT.(LEFT) .OR. .NOT.(RIGHT))GOTO 26361 GOTO 26370 26361 CONTINUE GOTO 26261 26262 CONTINUE WRITE(6,'(44H COULD NOT FIND MINIMUM FOR LINE NEAR PIXEL ,I6)')J CENTER = DBLE(J) RETURN 26370 CONTINUE N = IRIGHT - ILEFT + 1 INDEX = ILEFT 26380 I=1 GOTO 26383 26381 I=I+(2) 26383 IF((2)*((I)-(2*N-1)).GT.0)GOTO 26382 X(I) = DBLE(INDEX) X(I+1) = 1.0 - SPEC(INDEX) INDEX = INDEX + 1 GOTO 26381 26382 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 26401 PHOTONS = SNR(JMIN)**2/FMIN GOTO 26411 26401 CONTINUE PHOTONS = 0.0D0 26411 CONTINUE 26391 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) IF(A(2)-DBLE(J) .GE. 8)GOTO 26431 CENTER = A(2) GOTO 26441 26431 CONTINUE CENTER = DBLE(J) 26441 CONTINUE 26421 CONTINUE RETURN END SUBROUTINE GTMEDN2(RVI,WREF,N,RVMED) REAL*8 RVI(100),WREF(100),RVMED,DUMMY INTEGER N 26450 J=1 GOTO 26453 26451 J=J+1 26453 IF((J).GT.(N-1))GOTO 26452 K = N - J 26460 I=1 GOTO 26463 26461 I=I+1 26463 IF((I).GT.(K))GOTO 26462 IF(RVI(I) .GE. RVI(I+1))GOTO 26481 DUMMY = RVI(I+1) RVI(I+1) = RVI(I) RVI(I) = DUMMY DUMMY = WREF(I+1) WREF(I+1) = WREF(I) WREF(I) = DUMMY 26481 CONTINUE GOTO 26461 26462 CONTINUE GOTO 26451 26452 CONTINUE N2 = N/2 IODD = N - 2*N2 IF(IODD .NE. 0)GOTO 26501 RVMED = RVI(N2) GOTO 26491 26501 IF(N .LE. 1)GOTO 26511 RVMED = ( RVI(N2) + RVI(N2+1) )/2.0 GOTO 26521 26511 CONTINUE RVMED = RVI(1) 26521 CONTINUE 26491 CONTINUE RETURN END SUBROUTINE GTMEDN(RVI,N,RVMED) REAL*8 RVI(100),RVMED,DUMMY INTEGER N 26530 J=1 GOTO 26533 26531 J=J+1 26533 IF((J).GT.(N-1))GOTO 26532 K = N - J 26540 I=1 GOTO 26543 26541 I=I+1 26543 IF((I).GT.(K))GOTO 26542 IF(RVI(I) .GE. RVI(I+1))GOTO 26561 DUMMY = RVI(I+1) RVI(I+1) = RVI(I) RVI(I) = DUMMY 26561 CONTINUE GOTO 26541 26542 CONTINUE GOTO 26531 26532 CONTINUE N2 = N/2 IODD = N - 2*N2 IF(IODD .NE. 0)GOTO 26581 RVMED = RVI(N2) GOTO 26571 26581 IF(N .LE. 1)GOTO 26591 RVMED = ( RVI(N2) + RVI(N2+1) )/2.0 GOTO 26601 26591 CONTINUE RVMED = RVI(1) 26601 CONTINUE 26571 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 INTEGER IORDER IORDER = 0 NPTS = AXLEN(1) 26610 I=1 GOTO 26613 26611 I=I+1 26613 IF((I).GT.(NORD))GOTO 26612 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 26631 X1 = 1.0 + (W-WSTART)/DW(I) IORDER = I GOTO 26612 26631 CONTINUE GOTO 26611 26612 CONTINUE IF(I .GE. NORD)GOTO 26651 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 26671 X2 = 1.0 + (W-WSTART)/DW(I+1) IF(DABS(X1-DBLE(NPTS)/2.0) .LE. DABS(X2-DBLE(NPTS)/2.0))GOTO 26691 * IORDER = I + 1 26691 CONTINUE 26671 CONTINUE 26651 CONTINUE RETURN END SUBROUTINE RDCUCT(RV) IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/IBADD/ NOBAD,IBADL(300),IBADR(300) INTEGER NOBAD,IBADL,IBADR COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT 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)) 26700 CONTINUE 26701 CONTINUE I=I+1 READ(4,'(A80)',END=11700)LINE IF(ID .NE. 'CONTINUUM ')GOTO 26721 READ(LINE,'(A10,4D10.3))',END=11700)ID,WAV1,WAV2,NPX,CFAC I = I - 1 WAV1 = WAV1 WAV2 = WAV2 IF(WAV1 .GE. WEND .OR. WAV2 .LE. WSTART)GOTO 26741 NOCONT = NOCONT + 1 CONLFT(NOCONT) = NINT(CHANNEL(WAV1)) CONRHT(NOCONT) = NINT(CHANNEL(WAV2)) IF(CONLFT(NOCONT) .GE. 1)GOTO 26761 CONLFT(NOCONT) = 1 26761 CONTINUE IF(CONRHT(NOCONT) .LE. NPTS)GOTO 26781 CONRHT(NOCONT) = NPTS 26781 CONTINUE ISIZE = CONRHT(NOCONT) - CONLFT(NOCONT) + 1 IF(NPX .NE. 0.0)GOTO 26801 CONSIZE(NOCONT) = ISIZE GOTO 26811 26801 CONTINUE CONSIZE(NOCONT) = NINT(NPX) 26811 CONTINUE 26791 CONTINUE IF(CONSIZE(NOCONT) .LE. ISIZE)GOTO 26831 CONSIZE(NOCONT) = ISIZE 26831 CONTINUE CFACTOR(NOCONT) = 1.00000 IF(CFAC .LE. 0.00000)GOTO 26851 CFACTOR(NOCONT) = CFAC 26851 CONTINUE 26741 CONTINUE GOTO 26701 GOTO 26711 26721 IF(ID .NE. 'FITCONTIN')GOTO 26861 FITCON = .TRUE. I = I - 1 GOTO 26701 GOTO 26711 26861 IF(ID .NE. 'AUTOCONTIN')GOTO 26871 AUTOCON = .TRUE. I = I - 1 CONRHT(1) = INT(WAV1) CONLFT(1) = 1 CONSIZE(1) = INT(WAV2) CFACTOR(1) = 1.00000 GOTO 26701 GOTO 26711 26871 IF(ID .NE. 'NORMALISED')GOTO 26881 NRMLSD = .TRUE. I = I - 1 GOTO 26701 GOTO 26711 26881 IF(ID .NE. 'BADDIODE ')GOTO 26891 IF(INT(NPX) .NE. CURIMR)GOTO 26911 IF(NOBAD .NE. 300)GOTO 26931 WRITE(8,26940) 26940 FORMAT('MAXIMUM NUMBER OF BAD DIODE REGIONS EXCEEDED') RETURN 26931 CONTINUE NOBAD = NOBAD + 1 I = I - 1 IBADL(NOBAD) = INT( WAV1 ) IBADR(NOBAD)= INT( WAV2 ) 26911 CONTINUE GOTO 26701 26891 CONTINUE 26711 CONTINUE GOTO 26701 26702 CONTINUE 11700 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, DELTRV,LFT *DIO,RHTDIO,INCPT,SIGFWHM,SIGFRAC,DISP,OFFSET, PIX_OFFSET,DISP1,DIS *P2,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), EW(1000),INCPT,SLOPE,SIGFWH *M,SIGFRAC,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(1000),EPLOW(1000),A *TOM(1000),DISP1,DISP2,LLIMIT, ULIMIT, DELTEW(1000) COMMON/LOGLIN/WEAK(1000) LOGICAL WEAK COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(1000), CONRHT(1000),CONLFT(100 *0) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,CFACTOR,ACON, CHI_SCALE,CONTU *M_BLUE_PIX,CONTUM_RED_PIX REAL*8 CONFLUX(1000),SIGFLUX(1000), CONTUM_BLUE_PIX(1000),CONTUM_R *ED_PIX(1000), CONCENT(1000),CFACTOR(1000), ACON(50,1000), CHI_SCAL *E COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONT *UM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM, SCALED_CONTUM COMMON/IBADD/ NOBAD,IBADL(300),IBADR(300) INTEGER NOBAD,IBADL,IBADR COMMON/LPLOT/ PLOTALL,SCREEN,CNPLTG LOGICAL PLOTALL,SCREEN,CNPLTG COMMON/CPLOT/ SOFT_DEVICE,HARD_DEVICE CHARACTER*32 SOFT_DEVICE,HARD_DEVICE COMMON/IPLOT/ NPLOTL,NPLOTR,NPLOTS, SCLEFT,SCRGHT INTEGER NPLOTL(500),NPLOTR(500), NPLOTS,SCLEFT,SCRGHT 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)) 26950 CONTINUE 26951 CONTINUE READ(4,'(A80)',END=11700)LINE IF(LINE(:9) .NE. 'OLDCONTIN')GOTO 26971 GOTO 26951 26971 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) .NE. 'CONTINUUM ')GOTO 26991 GOTO 26951 GOTO 26981 26991 IF(LINEID(I+1) .NE. 'FITCONTIN')GOTO 27001 GOTO 26951 GOTO 26981 27001 IF(LINEID(I+1) .NE. 'AUTOCONTIN')GOTO 27011 GOTO 26951 GOTO 26981 27011 IF(LINEID(I+1) .NE. 'NORMALISED')GOTO 27021 GOTO 26951 GOTO 26981 27021 IF(LINEID(I+1)(:5) .NE. 'FOCUS')GOTO 27031 READ(LINE(6:10),'(F5.1)')XROW IROW = NINT(XROW) IF(IROW .LE. 0)GOTO 27051 FOCUS_PARS(IROW) = .TRUE. READ(LINE(11:),'(7F10.5)')WFC(IROW),(A_FOCUS(IROW,IPAR),IPAR=1,6) GOTO 27061 27051 CONTINUE GLOBAL_FOCUS = .TRUE. READ(LINE(11:),'(7F10.5)')GLOBAL_WFC,(GLOBAL_A(IPAR),IPAR=1,6) 27061 CONTINUE 27041 CONTINUE GOTO 26951 GOTO 26981 27031 IF(LINEID(I+1) .NE. 'INST_PROF ')GOTO 27071 INST_PROF = .TRUE. GOTO 26951 GOTO 26981 27071 IF(LINEID(I+1) .NE. 'BOUNDS ')GOTO 27081 GOTO 26951 GOTO 26981 27081 IF(LINEID(I+1) .NE. 'PLOT ')GOTO 27091 GOTO 26951 GOTO 26981 27091 IF(LINEID(I+1) .NE. 'PLOTALL ')GOTO 27101 GOTO 26951 GOTO 26981 27101 IF(LINEID(I+1) .NE. 'PLOTCONTIN')GOTO 27111 GOTO 26951 GOTO 26981 27111 IF(LINEID(I+1) .NE. 'BADDIODE ')GOTO 27121 IF(INT(EPLOW(I+1)) .NE. CURIMR)GOTO 27141 IF(NOBAD .NE. 300)GOTO 27161 WRITE(8,27170) 27170 FORMAT('MAXIMUM NUMBER OF BAD DIODE REGIONS EXCEEDED') RETURN 27161 CONTINUE NOBAD = NOBAD + 1 IBADL(NOBAD) = INT( WAVELN(I+1) ) IBADR(NOBAD)= INT( ATOM(I+1) ) 27141 CONTINUE GOTO 26951 GOTO 26981 27121 IF(LINEID(I+1) .NE. 'LLIMIT ')GOTO 27181 GOTO 26951 GOTO 26981 27181 IF(LINEID(I+1) .NE. 'ULIMIT ')GOTO 27191 GOTO 26951 GOTO 26981 27191 IF(LINEID(I+1) .NE. 'FWHM ')GOTO 27201 GOTO 26951 27201 CONTINUE 26981 CONTINUE IF(IGOOD .NE. 999)GOTO 27221 I = I + 1 NOGDLN = NOGDLN + 1 GOOD(NOGDLN) = I IGOOD = 0 27221 CONTINUE IF(I.GE.1000 .OR. NOCONT.GE.1000)GOTO 26952 GOTO 26951 26952 CONTINUE WRITE(8,27230) 27230 FORMAT(' LINE OR CONTINUUM BUFFER MAXIMUM REACHED') WRITE(8,27240)I,1000 27240 FORMAT(I3,1X,27H LINES USED, MAX ALLOWED IS,1X,I3) WRITE(8,27250)NOCONT,1000 27250 FORMAT (I3,1X,30H CONTINUA USED, MAX ALLOWED IS,1X,I3) 11700 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 27271 DMYSQ = 0.0 GOTO 27281 27271 CONTINUE DMYSQ = DSQRT(X) 27281 CONTINUE 27261 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