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(100),DW(100),PIX1(100) 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(100),DW(100),PIX1(100) 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL CHARACTER*80 IMAGE,VARIANCE,ERRMSG,ANSWER*1 INTEGER RWMODE,BLOCKSIZE DATA BLEND/500*0/ DATA ILEFT/500*0/ DATA IRIGHT/500*0/ DATA DA,DX/9*1.0D-8,1.0D-8/ DATA FOCUS_PARS,GLOBAL_FOCUS/101*.FALSE./ DATA CONORD/100*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. 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=9,FILE='WIDPLOT') OPEN(UNIT=8,FILE='ERRORS') OPEN(UNIT=4,FILE='LINES',STATUS='OLD') OPEN(UNIT=1,FILE='OUTPUT',STATUS='NEW') 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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(100),DW(100),PIX1(100) 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(100),COMMENT INTEGER NWAT2,NORD,IM REAL*8 W1(100),DW(100),PIX1(100) 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(100),KEYWD*8,COMMENT STATUS = 0 KEYWD = 'WAT2_001' 10440 I=1 GOTO 10443 10441 I=I+1 10443 IF((I).GT.(100))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 10471 CONTINUE 10451 CONTINUE CALL FTGKYS(UNIT,KEYWD,WAT2(I),COMMENT,STATUS) IF(STATUS .EQ. 0)GOTO 10491 CALL FTCMSG NWAT2 = I - 1 RETURN 10491 CONTINUE GOTO 10441 10442 CONTINUE RETURN END SUBROUTINE GETWVP(WAT2,NWAT2,W1,DW,PIX1) IMPLICIT REAL*8 (A-H,O-Z) INTEGER NWAT2 CHARACTER*68 WAT2(100),STRING*200,SPECID*11 REAL*8 W1(100),DW(100),PIX1(100),WAV1,DWAV LOGICAL IN_STRING IN_STRING = .FALSE. NORD = 0 IC = 0 10500 IORD=1 GOTO 10503 10501 IORD=IORD+1 10503 IF((IORD).GT.(100))GOTO 10502 W1(I) = 0.0 DW(I) = 0.0 PIX1(I) = 0.0 GOTO 10501 10502 CONTINUE IORD = 1 CALL SETSPECID(SPECID,IORD,IS) 10510 I=1 GOTO 10513 10511 I=I+1 10513 IF((I).GT.(NWAT2))GOTO 10512 10520 J=1 GOTO 10523 10521 J=J+1 10523 IF((J).GT.(68))GOTO 10522 IC = IC + 1 STRING(IC:IC)=WAT2(I)(J:J) IF((IC .LT. IS) .AND. (.NOT.(IN_STRING)))GOTO 10541 IF(.NOT.(.NOT. IN_STRING) .OR. STRING(IC-IS+1:IC) .NE. SPECID(:IS) *)GOTO 10561 IN_STRING = .TRUE. IC = 0 GOTO 10551 10561 IF(WAT2(I)(J:J) .NE. '"')GOTO 10571 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) 10571 CONTINUE 10551 CONTINUE 10541 CONTINUE GOTO 10521 10522 CONTINUE GOTO 10511 10512 CONTINUE RETURN END SUBROUTINE SETSPECID(SPECID,IORD,IS) INTEGER IORD,IS CHARACTER*11 SPECID SPECID(:4) = 'spec' IF(IORD .GE. 10)GOTO 10591 WRITE(SPECID(5:5),'(I1)')IORD SPECID(6:9) = ' = "' IS = 9 GOTO 10581 10591 IF(IORD .GE. 100)GOTO 10601 WRITE(SPECID(5:6),'(I2)')IORD SPECID(7:10) = ' = "' IS = 10 GOTO 10611 10601 CONTINUE WRITE(SPECID(5:7),'(I3)')IORD SPECID(8:11) = ' = "' IS = 11 10611 CONTINUE 10581 CONTINUE RETURN END SUBROUTINE CKWVP(W1,DW,NORD) REAL*8 W1(100),DW(100) INTEGER I,NORD 10620 I=1 GOTO 10623 10621 I=I+1 10623 IF((I).GT.(NORD))GOTO 10622 IF((W1(I) .NE. 0.0D0) .AND. (DW(I) .NE. 0.0D0))GOTO 10641 WRITE(6,10650)I 10650 FORMAT ('ERROR: Could not find wavelength solution for order',I3) STOP 10641 CONTINUE GOTO 10621 10622 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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) INTEGER IORD,IDUM1,IDUM2 REAL*8 RV CALL RDLNCL(RV) IF(.NOT.(FITCON))GOTO 10671 10680 IORD=1 GOTO 10683 10681 IORD=IORD+1 10683 IF((IORD).GT.(NORD))GOTO 10682 CALL RDSPEC(IORD) CALL RDCUCT(RV) IF(.NOT.(FITCON))GOTO 10701 CALL FITCONT 10701 CONTINUE GOTO 10681 10682 CONTINUE 10671 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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) INTEGER IORD,IDUM1,IDUM2,LPG REAL*8 RV CALL RDLNCL(RV) IF(.NOT.(PLOTCON))GOTO 10721 SOFT_DEVICE = '/GTERM' CALL PGBEG(14,SOFT_DEVICE,1,1) CALL PGASK(.FALSE.) CALL PGSCR(1,0,240,0) CALL PGSCI(1) CALL SETWIN 10721 CONTINUE IF((.NOT.(PLOTCON)) .AND. (.NOT.(FITCON)))GOTO 10741 10750 IORD=1 GOTO 10753 10751 IORD=IORD+1 10753 IF((IORD).GT.(NORD))GOTO 10752 CALL RDSPEC(IORD) CALL RDCUCT(RV) IF(.NOT.(FITCON))GOTO 10771 CALL FITCONT 10771 CONTINUE IF(.NOT.(PLOTCON))GOTO 10791 CALL CONPLT CALL INTUSR(IDUM1,IDUM2) 10791 CONTINUE GOTO 10751 10752 CONTINUE 10741 CONTINUE IF(.NOT.(PLOTCON))GOTO 10811 CALL PGEND 10811 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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK INTEGER LMIN,LMAX,I,IORDER LOGICAL ZERO LMIN = 1 ZERO=.FALSE. CALL RDGDLO(RV) 10820 LMIN=1 GOTO 10823 10821 LMIN=LMIN+1 10823 IF((LMIN).GT.(NOLINES))GOTO 10822 CALL FNDORD(WAVELN(LMIN),IORDER) IF(IORDER .EQ. 0)GOTO 10841 CALL RDSPEC(IORDER) GOTO 10822 10841 CONTINUE GOTO 10821 10822 CONTINUE ILOW = LMIN 10850 I=ILOW GOTO 10853 10851 I=I+1 10853 IF((I).GT.(NOLINES))GOTO 10852 CALL FNDORD(WAVELN(I),IORDER) IF(IORDER .EQ. CURORD .OR. .NOT.(.NOT.ZERO))GOTO 10871 LMAX = I - 1 CALL RDCUCT(RV) CALL MLICUO(LMIN,LMAX) IF(IORDER .EQ. 0)GOTO 10891 CALL RDSPEC(IORDER) GOTO 10901 10891 CONTINUE ZERO = .TRUE. 10901 CONTINUE 10881 CONTINUE LMIN = I GOTO 10861 10871 IF(.NOT.(ZERO) .OR. IORDER .EQ. 0)GOTO 10911 ZERO = .FALSE. CALL RDSPEC(IORDER) 10911 CONTINUE 10861 CONTINUE GOTO 10851 10852 CONTINUE IF(IORDER .EQ. 0)GOTO 10931 LMAX = NOLINES CALL RDSPEC(IORDER) CALL RDCUCT(RV) CALL MLICUO(LMIN,LMAX) 10931 CONTINUE RETURN END SUBROUTINE MLICUO(LMIN,LMAX) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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 10951 CALL FITCONT 10951 CONTINUE 10960 LINE=LMIN GOTO 10963 10961 LINE=LINE+1 10963 IF((LINE).GT.(LMAX))GOTO 10962 CALL FCDNAD(LINE,A,COV,DELETED) IF(.NOT.(DELETED))GOTO 10981 LINE = LINE - 1 GOTO 10961 10981 CONTINUE CALL OBFWHML (LINE,A,COV,NPTS) CALL FT1GAUS(LINE) CALL CMLINRV(LINE) GOTO 10961 10962 CONTINUE RETURN END SUBROUTINE CMLINRV(LINE) IMPLICIT REAL*8 (A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 10990 I=1 GOTO 10993 10991 I=I+1 10993 IF((I).GT.(NOGDLN))GOTO 10992 IF(CHANNEL(WAVELN(GOOD(I))) .NE. CENTRE(GOOD(I)))GOTO 11011 NZERO = NZERO + 1 11011 CONTINUE DV = DV + DELTRV(GOOD(I)) DV2 = DV2 + DELTRV(GOOD(I))**2 GOTO 10991 10992 CONTINUE IF(NOGDLN-NZERO .LE. 2)GOTO 11031 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 11031 CONTINUE WRITE(6,'(19H RADIAL VELOCITY = ,F10.3,5H +/- ,F6.2)')ROT,RVERR WRITE(6,'(12H SIGMA RV = ,F10.3)')SIGROT WRITE(1,11040)RV 11040 FORMAT('RADIAL VELOCITY = ',F10.4,' KM/S') WRITE(1,11050)SIGROT 11050 FORMAT('SIGMA RV = ',F10.3,' KM/S') RETURN END SUBROUTINE MEASALN COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(100),DW(100),PIX1(100) 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 11071 CALL FITCONT 11080 LINE=1 GOTO 11083 11081 LINE=LINE+1 11083 IF((LINE).GT.(NOLINES))GOTO 11082 CALL FCDNAD(LINE,A,COV,DELETED) IF(.NOT.(DELETED))GOTO 11101 LINE = LINE - 1 GOTO 11081 11101 CONTINUE CALL OBFWHML (LINE,A,COV,NPTS) CALL FT1GAUS(LINE) GOTO 11081 11082 CONTINUE CALL FITWKL 11110 LINE=1 GOTO 11113 11111 LINE=LINE+1 11113 IF((LINE).GT.(NOLINES))GOTO 11112 CALL SFTBLS(LINE) GOTO 11111 11112 CONTINUE CALL FNBRDLN CALL FTBLIN(NOLINES) 11120 LINE=1 GOTO 11123 11121 LINE=LINE+1 11123 IF((LINE).GT.(NOLINES))GOTO 11122 CALL MEASEW(LINE) GOTO 11121 11122 CONTINUE IF(NOLINES .LT. 1)GOTO 11141 CALL PTSCPL(NPTS) 11141 CONTINUE CALL PRDMIF(RV,SPTITLE) CALL FINSH 11071 CONTINUE RETURN END SUBROUTINE RMEASLN COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(100),DW(100),PIX1(100) 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 11161 11170 LINE=1 GOTO 11173 11171 LINE=LINE+1 11173 IF((LINE).GT.(NOLINES))GOTO 11172 CALL FCDNAD(LINE,A,COV,DELETED) IF(.NOT.(DELETED))GOTO 11191 LINE = LINE - 1 GOTO 11171 11191 CONTINUE CALL OBFWHML (LINE,A,COV,NPTS) CALL FT1GAUS(LINE) GOTO 11171 11172 CONTINUE CALL FITWKL 11200 LINE=1 GOTO 11203 11201 LINE=LINE+1 11203 IF((LINE).GT.(NOLINES))GOTO 11202 CALL SFTBLS(LINE) GOTO 11201 11202 CONTINUE CALL FNBRDLN CALL FTBLIN(NOLINES) 11210 LINE=1 GOTO 11213 11211 LINE=LINE+1 11213 IF((LINE).GT.(NOLINES))GOTO 11212 CALL MEASEW(LINE) GOTO 11211 11212 CONTINUE 11161 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(100),DW(100),PIX1(100) 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 11231 CALL FTGMSG(ERRMSG) WRITE(*,'(8H Error: ,A80)')ERRMSG STOP 11231 CONTINUE DISP = DW(IROW) OFFSET = W1(IROW) PIX_OFFSET = PIX1(IROW) CURORD = IROW IF(.NOT.(VARFIL))GOTO 11251 CALL FTGSVD(IVM,1,NAXIS,NAXES,FPIX,LPIX,INCS,NULLVAL,VARSPEC, ANYF *,IER) IF(IER .EQ. 0)GOTO 11271 CALL FTGMSG(ERRMSG) WRITE(*,'(8H Error: ,A80)')ERRMSG STOP 11271 CONTINUE 11251 CONTINUE 11280 I=1 GOTO 11283 11281 I=I+1 11283 IF((I).GT.(NPTS))GOTO 11282 LAMBDA(I) = OFFSET + (I-1)*DISP GOTO 11281 11282 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 11290 I=1 GOTO 11293 11291 I=I+1 11293 IF((I).GT.(NBOUNDS))GOTO 11292 LBOUND(I) = LBOUND(I) + ISHIFT RBOUND(I) = RBOUND(I) + ISHIFT GOTO 11291 11292 CONTINUE 11300 I=1 GOTO 11303 11301 I=I+1 11303 IF((I).GT.(NBOUNDS))GOTO 11302 IF(LBOUND(I) .GE. 1)GOTO 11321 IF(RBOUND(I) .GE. 1)GOTO 11341 11350 J=I GOTO 11353 11351 J=J+1 11353 IF((J).GT.(NBOUNDS - 1))GOTO 11352 LBOUND(J) = LBOUND(J+1) RBOUND(J) = RBOUND(J+1) GOTO 11351 11352 CONTINUE NBOUNDS = NBOUNDS - 1 I = I - 1 GOTO 11361 11341 CONTINUE LBOUND(I) = 1 11361 CONTINUE 11331 CONTINUE GOTO 11311 11321 IF(RBOUND(I) .LE. NPTS)GOTO 11371 IF(LBOUND(I) .LE. NPTS)GOTO 11391 11400 J=I GOTO 11403 11401 J=J+1 11403 IF((J).GT.(NBOUNDS - 1))GOTO 11402 LBOUND(J) = LBOUND(J+1) RBOUND(J) = RBOUND(J+1) GOTO 11401 11402 CONTINUE NBOUNDS = NBOUNDS - 1 I = I - 1 GOTO 11411 11391 CONTINUE RBOUND(I) = NPTS 11411 CONTINUE 11381 CONTINUE 11371 CONTINUE 11311 CONTINUE GOTO 11301 11302 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 11420 I=1 GOTO 11423 11421 I=I+1 11423 IF((I).GT.(NBOUNDS))GOTO 11422 IF(LBOUND(I) .EQ. 1 .OR. RBOUND(I) .EQ. NPTS)GOTO 11441 GRAD = (SPCTRUM(RBOUND(I)+1)-SPCTRUM(LBOUND(I)-1))/ DBLE( RBOUND(I *) - LBOUND(I) + 2 ) 11450 J=LBOUND(I) GOTO 11453 11451 J=J+1 11453 IF((J).GT.(RBOUND(I)))GOTO 11452 CONT = GRAD*DBLE( J - LBOUND(I) + 1 ) + SPCTRUM(LBOUND(I)-1) SPCTRUM(J) = SPCTRUM(J)/CONT IF(SPCTRUM(J) .LE. 1.0)GOTO 11471 SPCTRUM(J) = 1.0 11471 CONTINUE GOTO 11451 11452 CONTINUE GOTO 11481 11441 CONTINUE IF(LBOUND(I) .NE. 1)GOTO 11501 DIODE = RBOUND(I) + 1 GOTO 11491 11501 IF(RBOUND(I) .NE. NPTS)GOTO 11511 DIODE = LBOUND(I) - 1 11511 CONTINUE 11491 CONTINUE 11520 J=LBOUND(I) GOTO 11523 11521 J=J+1 11523 IF((J).GT.(RBOUND(I)))GOTO 11522 SPCTRUM(J) = SPCTRUM(J)*1.0/SPCTRUM(DIODE) GOTO 11521 11522 CONTINUE 11481 CONTINUE 11431 CONTINUE GOTO 11421 11422 CONTINUE 11530 I=1 GOTO 11533 11531 I=I+1 11533 IF((I).GT.(NPTS))GOTO 11532 IF(.NOT.(.NOT. TELDIOD(I)))GOTO 11551 SPCTRUM(I) = 1.0 11551 CONTINUE GOTO 11531 11532 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. 11560 J=1 GOTO 11563 11561 J=J+1 11563 IF((J).GT.(NBOUNDS))GOTO 11562 IF(I .GE. LBOUND(J))GOTO 11581 RETURN GOTO 11571 11581 IF(I .GT. RBOUND(J))GOTO 11591 TELDIOD = .TRUE. RETURN 11591 CONTINUE 11571 CONTINUE GOTO 11561 11562 CONTINUE RETURN END SUBROUTINE SUCCPF(TITLE) IMPLICIT REAL*8(A-H,O-Z) CHARACTER*80 TITLE WRITE(8,11600)TITLE(1:45) 11600 FORMAT(' TITLE $',A45,'$') WRITE(8,11610) 11610 FORMAT(' XLABEL $DIODE SHIFT$') WRITE(8,11620) 11620 FORMAT(' YLABEL $CROSS PRODUCT$') WRITE(8,11630) 11630 FORMAT(' XFORMAT I5') WRITE(8,11640) 11640 FORMAT(' YFORMAT F6.2') WRITE(8,11650) 11650 FORMAT(' NOMARKER ') WRITE(8,11660) 11660 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) 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(100),DW(100),PIX1(100) 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)) 11670 CONTINUE 11671 CONTINUE READ(4,'(A80)',END=11680)LINE IF(LINE(:9) .NE. 'OLDCONTIN')GOTO 11701 READ(LINE(11:),'(A70)')OLDCFILE OLD_CONTUM = .TRUE. CALL GRABCOF(OLDCFILE,ACON,CONORD) READ(4,'(A80)',END=11680)LINE 11701 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 11721 I = I - 1 WAV1 = WAVELN(I+1) WAV2 = ATOM(I+1) IF(WAV1 .GE. WEND .OR. WAV2 .LE. WSTART)GOTO 11741 NOCONT = NOCONT + 1 CONLFT(NOCONT) = NINT(CHANNEL(WAV1)) CONRHT(NOCONT) = NINT(CHANNEL(WAV2)) IF(CONLFT(NOCONT) .GE. 1)GOTO 11761 CONLFT(NOCONT) = 1 11761 CONTINUE IF(CONRHT(NOCONT) .LE. NPTS)GOTO 11781 CONRHT(NOCONT) = NPTS 11781 CONTINUE ISIZE = CONRHT(NOCONT) - CONLFT(NOCONT) + 1 IF(EPLOW(I+1) .NE. 0.0)GOTO 11801 CONSIZE(NOCONT) = ISIZE GOTO 11811 11801 CONTINUE CONSIZE(NOCONT) = NINT(EPLOW(I+1)) 11811 CONTINUE 11791 CONTINUE IF(CONSIZE(NOCONT) .LE. ISIZE)GOTO 11831 CONSIZE(NOCONT) = ISIZE 11831 CONTINUE 11741 CONTINUE GOTO 11671 GOTO 11711 11721 IF(LINEID(I) .NE. 'FITCONTIN')GOTO 11841 FITCON = .TRUE. I = I - 1 GOTO 11671 GOTO 11711 11841 IF(LINEID(I) .NE. 'AUTOCONTIN')GOTO 11851 AUTOCON = .TRUE. I = I - 1 CONRHT(1) = INT(WAVELN(I+1)) CONLFT(1) = 1 CONSIZE(1) = INT(ATOM(I+1)) GOTO 11671 GOTO 11711 11851 IF(LINEID(I) .NE. 'NORMALISED')GOTO 11861 NRMLSD = .TRUE. I = I - 1 GOTO 11671 GOTO 11711 11861 IF(LINEID(I)(:5) .NE. 'FOCUS')GOTO 11871 READ(LINE(6:10),'(F5.1)')XROW IROW = NINT(XROW) IF(IROW .LE. 0)GOTO 11891 FOCUS_PARS(IROW) = .TRUE. READ(LINE(11:),'(7F10.5)')WFC(IROW),(A_FOCUS(IROW,IPAR),IPAR=1,6) GOTO 11901 11891 CONTINUE GLOBAL_FOCUS = .TRUE. READ(LINE(11:),'(7F10.5)')GLOBAL_WFC,(GLOBAL_A(IPAR),IPAR=1,6) 11901 CONTINUE 11881 CONTINUE I = I - 1 GOTO 11671 GOTO 11711 11871 IF(LINEID(I) .NE. 'INST_PROF ')GOTO 11911 INST_PROF = .TRUE. I = I - 1 GOTO 11671 GOTO 11711 11911 IF(LINEID(I) .NE. 'BOUNDS ')GOTO 11921 NBOUNDS = NBOUNDS + 1 I = I - 1 LBOUND(NBOUNDS) = INT( WAVELN(I+1) ) RBOUND(NBOUNDS) = INT( ATOM(I+1) ) GOTO 11671 GOTO 11711 11921 IF(LINEID(I) .NE. 'PLOT ')GOTO 11931 I = I - 1 IF((NPLOTS .LT. 300) .AND. (.NOT.(PLOTALL)))GOTO 11951 GOTO 11671 11951 CONTINUE NPLOTS = NPLOTS + 1 WPLOTL(NPLOTS) = WAVELN(I+1) WPLOTR(NPLOTS) = ATOM(I+1) GOTO 11671 GOTO 11711 11931 IF(LINEID(I) .NE. 'PLOTALL ')GOTO 11961 I = I - 1 PLOTALL = .TRUE. NPLOTS = 0 GOTO 11671 GOTO 11711 11961 IF(LINEID(I) .NE. 'PLOTCONTIN')GOTO 11971 PLOTCON = .TRUE. I = I - 1 GOTO 11671 GOTO 11711 11971 IF(LINEID(I) .NE. 'BADDIODE ')GOTO 11981 I = I - 1 IF(NINT(EPLOW(I+1)) .NE. CURIMR)GOTO 12001 IF(NOBAD .NE. 300)GOTO 12021 WRITE(8,12030) 12030 FORMAT('MAXIMUM NUMBER OF BAD DIODE REGIONS EXCEEDED') RETURN 12021 CONTINUE NOBAD = NOBAD + 1 IBADL(NOBAD) = NINT( WAVELN(I+1) ) IBADR(NOBAD)= NINT( ATOM(I+1) ) 12001 CONTINUE GOTO 11671 GOTO 11711 11981 IF(LINEID(I) .NE. 'LLIMIT ')GOTO 12041 LLIMIT = WAVELN(I) I = I - 1 GOTO 11671 GOTO 11711 12041 IF(LINEID(I) .NE. 'ULIMIT ')GOTO 12051 ULIMIT = WAVELN(I) I = I - 1 GOTO 11671 GOTO 11711 12051 IF(LINEID(I) .NE. 'FWHM ')GOTO 12061 FIXFWHM = .TRUE. INCPT = WAVELN(I) SLOPE = ATOM(I) MINIDP = EPLOW(I) SIGFRAC = GF(I) I = I - 1 GOTO 11671 GOTO 11711 12061 IF(LINEID(I) .NE. 'VSINI ')GOTO 12071 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 11671 12071 CONTINUE 11711 CONTINUE IF((ILEFT(I) .GE. 0) .AND. (IRIGHT(I) .GE. 0))GOTO 12091 IF(IGOOD .NE. 999)GOTO 12111 WRITE(8,12120)I 12120 FORMAT (' CANNOT USE LINE ',I3,' AS A GOOD LINE SINCE ONLY DEPTH', % ' IS TO BE USED FOR ITS EW ') IGOOD = 0 12111 CONTINUE 12091 CONTINUE IF(IGOOD .NE. 999)GOTO 12141 NOGDLN = NOGDLN + 1 GOOD(NOGDLN) = I IGOOD = 0 12141 CONTINUE IF(IGOOD .NE. 100)GOTO 12161 IF(IWIDE .GE. 50)GOTO 12181 IWIDE = IWIDE + 1 WIDE(IWIDE) = WAVELN(I) GOTO 12191 12181 CONTINUE WRITE(8,12200) 12200 FORMAT(' WARNING: ONLY THE FIRST 50 WIDE LINES USED ') 12191 CONTINUE 12171 CONTINUE IGOOD = 0 12161 CONTINUE WEAK(I) = .FALSE. BLEND(I) = 0 IF(I.GE.500 .OR. NOCONT.GE.1000)GOTO 11672 GOTO 11671 11672 CONTINUE WRITE(8,12210) 12210 FORMAT(' LINE OR CONTINUUM BUFFER MAXIMUM REACHED') WRITE(8,12220)I,500 12220 FORMAT(I3,1X,27H LINES USED, MAX ALLOWED IS,1X,I3) WRITE(8,12230)NOCONT,1000 12230 FORMAT (I3,1X,30H CONTINUA USED, MAX ALLOWED IS,1X,I3) 11680 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM INTEGER I,J,CLDUM,CRDUM,CSDUM REAL*8 CFDUM,SFDUM,CCDUM 12240 J=1 GOTO 12243 12241 J=J+1 12243 IF((J).GT.(NOCONT-1))GOTO 12242 12250 I=1 GOTO 12253 12251 I=I+1 12253 IF((I).GT.(NOCONT-J))GOTO 12252 IF(CONLFT(I) .LE. CONLFT(I+1))GOTO 12271 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 12271 CONTINUE GOTO 12251 12252 CONTINUE GOTO 12241 12242 CONTINUE RETURN END SUBROUTINE GRABCOF(FILE,A,CONORD) IMPLICIT REAL*8 (A-H,O-Z) REAL*8 A(50,100) INTEGER CONORD(100),IROW(100),NROW CHARACTER*70 FILE,LINE*120 LOGICAL FOUND OPEN(UNIT=30,FILE=FILE,STATUS='OLD') FOUND = .FALSE. NROW = 0 12280 CONTINUE 12281 CONTINUE READ(30,'(A80)',END=12290)LINE IF(LINE(:18) .NE. 'CURRENT IMAGE ROW ')GOTO 12311 NROW = NROW + 1 READ(LINE(19:),*)IROW(NROW) 12320 CONTINUE 12321 CONTINUE READ(30,'(A80)',END=12290)LINE IF(LINE(:25) .NE. 'ORDER OF POLYNOMIAL FIT =')GOTO 12341 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. 12341 CONTINUE IF(FOUND)GOTO 12322 GOTO 12321 12322 CONTINUE 12311 CONTINUE FOUND = .FALSE. GOTO 12281 12282 CONTINUE 12290 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 12350 I=1 GOTO 12353 12351 I=I+1 12353 IF((I).GT.(100))GOTO 12352 READ(12,*,END=12360)H2OCENT(I),H2OFWHM(I),H2ODEEP(I) GOTO 12351 12352 CONTINUE WRITE(8,12370) 12370 FORMAT(/,'WARNING: ONLY THE FIRST 100 TELLURIC LINES WILL BE USED' %,/) NH2O = 100 RETURN 12360 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM INTEGER I,ISHIFT,NPTS 12380 I=1 GOTO 12383 12381 I=I+1 12383 IF((I).GT.(NOCONT))GOTO 12382 CONRHT(I) = CONRHT(I) + ISHIFT CONLFT(I) = CONLFT(I) + ISHIFT IF(CONLFT(I) .GE. 1)GOTO 12401 IF(CONRHT(I) .GE. 1)GOTO 12421 CALL REMCTP(I) GOTO 12431 12421 CONTINUE CONLFT(I) = 1 12431 CONTINUE 12411 CONTINUE GOTO 12391 12401 IF(CONRHT(I) .LE. NPTS)GOTO 12441 IF(CONLFT(I) .LE. NPTS)GOTO 12461 CALL REMCTP(I) GOTO 12471 12461 CONTINUE CONRHT(I) = NPTS 12471 CONTINUE 12451 CONTINUE 12441 CONTINUE 12391 CONTINUE GOTO 12381 12382 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM INTEGER ICONT,I IF(ICONT .NE. NOCONT)GOTO 12491 ICONT = ICONT - 1 NOCONT = NOCONT - 1 RETURN 12491 CONTINUE 12500 I=ICONT GOTO 12503 12501 I=I+1 12503 IF((I).GT.(NOCONT - 1))GOTO 12502 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) SIGFLUX(I) = SIGFLUX(I+1) GOTO 12501 12502 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK INTEGER I,LMIN,LMAX 12510 I=LMIN GOTO 12513 12511 I=I+1 12513 IF((I).GT.(LMAX))GOTO 12512 CENTRE(I) = CHANNEL(WAVELN(I)) GOTO 12511 12512 CONTINUE RETURN END SUBROUTINE EACKLC(NPTS) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK INTEGER I,NPTS 12520 I=1 GOTO 12523 12521 I=I+1 12523 IF((I).GT.(NOLINES))GOTO 12522 CENTRE(I) = CHANNEL(WAVELN(I)) IF((INT(CENTRE(I)) .GE. 3) .AND. (INT(CENTRE(I)) .LE. NPTS - 2))GO *TO 12541 CALL REMFLS(I) I = I - 1 12541 CONTINUE GOTO 12521 12522 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK K = 1 ID = 'TELLURIC ' 12550 I=1 GOTO 12553 12551 I=I+1 12553 IF((I).GT.(NOLINES + NH2O - 1))GOTO 12552 IF(H2OCENT(K) .GT. CENTRE(I))GOTO 12571 WAVE = WAV(H2OCENT(K)) CALL INSBFL(I,ID,WAVE,H2OCENT(K),H2OFWHM(K),H2ODEEP(K)) K = K + 1 GOTO 12561 12571 IF(I .LT. NOLINES + K - 1)GOTO 12581 GOTO 12552 12581 CONTINUE 12561 CONTINUE IF(K .GT. NH2O)GOTO 12552 GOTO 12551 12552 CONTINUE IF(K .LE. NH2O)GOTO 12601 RETURN 12601 CONTINUE 12610 N=K GOTO 12613 12611 N=N+1 12613 IF((N).GT.(NH2O))GOTO 12612 I = I + 1 WAVE = WAV(H2OCENT(N)) CALL INSBFL(I,ID,WAVE,H2OCENT(N),H2OFWHM(N),H2ODEEP(N)) GOTO 12611 12612 CONTINUE RETURN END SUBROUTINE INSBFL(I,ID,WAVE,CENT,WIDTH,DEEP) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK REAL*8 PI CHARACTER*10 ID INTEGER I,J,K IF(NOLINES .NE. 500)GOTO 12631 WRITE(8,12640)ID,WAVE 12640 FORMAT ('ERROR: COULD NOT INSERT LINE WITH ID ',A10,' AT ',F9.3,' %A.') RETURN 12631 CONTINUE 12650 J=NOLINES GOTO 12653 12651 J=J+(-1) 12653 IF((-1)*((J)-(I)).GT.0)GOTO 12652 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 12651 12652 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 12660 J=1 GOTO 12663 12661 J=J+1 12663 IF((J).GT.(NOGDLN))GOTO 12662 IF(GOOD(J) .LT. I)GOTO 12681 12690 K=J GOTO 12693 12691 K=K+1 12693 IF((K).GT.(NOGDLN))GOTO 12692 GOOD(K) = GOOD(K) + 1 GOTO 12691 12692 CONTINUE GOTO 12662 12681 CONTINUE GOTO 12661 12662 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK INTEGER LINE,I IF(LINE .EQ. 1)GOTO 12711 IF(BLEND(LINE-1) .NE. 2)GOTO 12731 BLEND(LINE-1) = -1 GOTO 12721 12731 IF(BLEND(LINE-1) .NE. 1)GOTO 12741 BLEND(LINE-1) = 0 12741 CONTINUE 12721 CONTINUE 12711 CONTINUE IF(LINE .EQ. NOLINES)GOTO 12761 IF(BLEND(LINE+1) .NE. 2)GOTO 12781 BLEND(LINE+1) = 1 GOTO 12771 12781 IF(BLEND(LINE+1) .NE. -1)GOTO 12791 BLEND(LINE+1) = 0 12791 CONTINUE 12771 CONTINUE 12761 CONTINUE IF(.NOT.(TELPRES) .OR. LINEID(LINE) .NE. 'TELLURIC ')GOTO 12811 INDEX = 1 12820 I=1 GOTO 12823 12821 I=I+1 12823 IF((I).GT.(LINE - 1))GOTO 12822 IF(LINEID(I) .NE. 'TELLURIC ')GOTO 12841 INDEX = INDEX + 1 12841 CONTINUE GOTO 12821 12822 CONTINUE 12850 I=INDEX GOTO 12853 12851 I=I+1 12853 IF((I).GT.(NH2O - 1))GOTO 12852 H2OCENT(I) = H2OCENT(I+1) H2OFWHM(I) = H2OFWHM(I+1) H2ODEEP(I) = H2ODEEP(I+1) GOTO 12851 12852 CONTINUE NH2O = NH2O - 1 12811 CONTINUE 12860 I=LINE GOTO 12863 12861 I=I+1 12863 IF((I).GT.(NOLINES))GOTO 12862 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 12862 GOTO 12861 12862 CONTINUE NOLINES = NOLINES - 1 12870 I=1 GOTO 12873 12871 I=I+1 12873 IF((I).GT.(NOGDLN))GOTO 12872 IF(GOOD(I) .NE. LINE)GOTO 12891 CALL RMLFGL(LINE) RETURN GOTO 12881 12891 IF(GOOD(I) .LE. LINE)GOTO 12901 RETURN 12901 CONTINUE 12881 CONTINUE GOTO 12871 12872 CONTINUE RETURN END SUBROUTINE RMLFGL(LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK INTEGER I,J,LINE 12910 I=1 GOTO 12913 12911 I=I+1 12913 IF((I).GT.(NOGDLN))GOTO 12912 IF(GOOD(I) .NE. LINE)GOTO 12931 NOGDLN = NOGDLN - 1 12940 J=I GOTO 12943 12941 J=J+1 12943 IF((J).GT.(NOGDLN))GOTO 12942 GOOD(J) = GOOD(J+1) DELTRV(J) = DELTRV(J+1) GOTO 12941 12942 CONTINUE RETURN 12931 CONTINUE GOTO 12911 12912 CONTINUE RETURN END SUBROUTINE FITCONT IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL IF(.NOT.(OLD_CONTUM) .OR. CONORD(CURIMR) .EQ. 0)GOTO 12961 RETURN GOTO 12971 12961 CONTINUE CALL CCCAFV CALL PERFIT 12971 CONTINUE 12951 CONTINUE RETURN END SUBROUTINE CCCAFV IMPLICIT REAL*8(A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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 12991 ISTEP = CONRHT(1) NOCONT = NPTS/CONRHT(1) IF(NOCONT .LE. 1000)GOTO 13011 WRITE(8,13020) 13020 FORMAT(' CONTINUUM BUFFER MAXIMUM REACHED') WRITE(8,13030)NOCONT,1000 13030 FORMAT (I3,1X,30H CONTINUA USED, MAX ALLOWED IS,1X,I3) NOCONT = 1000 13011 CONTINUE 13040 I=2 GOTO 13043 13041 I=I+1 13043 IF((I).GT.(NOCONT))GOTO 13042 CONLFT(I) = CONRHT(I-1) - CONSIZE(1) + 1 CONRHT(I) = CONRHT(I-1) + ISTEP CONSIZE(I) = CONSIZE(1) GOTO 13041 13042 CONTINUE CONRHT(NOCONT) = NPTS 12991 CONTINUE 13050 J=1 GOTO 13053 13051 J=J+1 13053 IF((J).GT.(NOCONT))GOTO 13052 IF(.NOT.(CNTBAD(J)))GOTO 13071 WRITE(8,13080)J 13080 FORMAT('CONTINUUM NO. ',I3,' REMOVED DUE TO BAD DIODES') CALL REMCTP(J) GOTO 13051 13071 CONTINUE CONFLUX(J) = 0.0 13090 I=CONLFT(J) GOTO 13093 13091 I=I+1 13093 IF((I).GT.(CONRHT(J)-CONSIZE(J)+1))GOTO 13092 SXI = 0.0 SXIWI = 0.0 SXI2 = 0.0 SNSIG = 0.0 MIDDLE = 0 ANUM = 0.0 13100 K=1 GOTO 13103 13101 K=K+1 13103 IF((K).GT.(CONSIZE(J)))GOTO 13102 IF(.NOT.(.NOT. BADIOD(I+K-1)))GOTO 13121 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 13121 CONTINUE GOTO 13101 13102 CONTINUE AVG = SXIWI/SNSIG SNSIG = 1.D0/DSQRT(SNSIG) IF(CONSIZE(J) .LE. 1)GOTO 13141 CSIG = DMYSQ( ( SXI2 - (SXI**2)/ANUM )/(ANUM-1.0) ) CSIG = CSIG/DMYSQ(ANUM) 13141 CONTINUE IF(AVG .LT. CONFLUX(J))GOTO 13161 CONFLUX(J) = AVG SIGFLUX(J) = CSIG IF(CSIG .GE. AVG*SNSIG)GOTO 13181 SIGFLUX(J) = AVG*SNSIG 13181 CONTINUE CONCENT(J) = DBLE(MIDDLE)/ANUM 13161 CONTINUE GOTO 13091 13092 CONTINUE IF(CONFLUX(J) .GT. 0.0)GOTO 13201 WRITE(8,13210)J 13210 FORMAT('CONTINUUM NO. ',I3,' REMOVED: ZERO OR NEGATIVE FLUX') CALL REMCTP(J) GOTO 13051 13201 CONTINUE GOTO 13051 13052 CONTINUE IF(.NOT.(AUTOCON))GOTO 13231 13231 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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 13251 RETURN 13251 CONTINUE 13260 I=CONLFT(ICONT) GOTO 13263 13261 I=I+1 13263 IF((I).GT.(CONRHT(ICONT)-CONSIZE(ICONT)+1))GOTO 13262 NBAD_PIX = 0 13270 J=1 GOTO 13273 13271 J=J+1 13273 IF((J).GT.(CONSIZE(ICONT)))GOTO 13272 IF(.NOT.(BADIOD(I+J-1)))GOTO 13291 NBAD_PIX = NBAD_PIX + 1 13291 CONTINUE GOTO 13271 13272 CONTINUE IF(NBAD_PIX .LE. CONSIZE(ICONT)-NBAD_PIX)GOTO 13311 CNTBAD = .TRUE. RETURN 13311 CONTINUE GOTO 13261 13262 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 13331 RETURN 13331 CONTINUE 13340 I=1 GOTO 13343 13341 I=I+1 13343 IF((I).GT.(NOBAD))GOTO 13342 IF(IPOINT .LT. IBADL(I) .OR. IPOINT .GT. IBADR(I))GOTO 13361 BADIOD = .TRUE. RETURN 13361 CONTINUE GOTO 13341 13342 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL IF(.NOT.(DEFAULT))GOTO 13381 CALL SETFLG(NOCONT) 13381 CONTINUE IF(.NOT.(FITCON))GOTO 13401 CONORD(CURIMR) = 0 IF(NOCONT .LT. 1)GOTO 13421 13430 J=1 GOTO 13433 13431 J=J+1 13433 IF((J).GT.(NOCONT))GOTO 13432 Y(J) = CONFLUX(J) X(J) = CONCENT(J) SIGMA(J) = SIGFLUX(J) GOTO 13431 13432 CONTINUE IORD = 1 CALL POLYLIN(X,Y,SIGMA,IORD,ADUM,COVAR,CHISQ,NOCONT) 13440 ITERM=1 GOTO 13443 13441 ITERM=ITERM+1 13443 IF((ITERM).GT.(IORD))GOTO 13442 ACON(ITERM,CURIMR) = ADUM(ITERM) GOTO 13441 13442 CONTINUE NFREE = NOCONT-IORD CALL G3SIGCH(NFREE,CHI3SIG) OCHIRAT = CHISQ / CHI3SIG CONORD(CURIMR) = IORD 13450 IORD=2 GOTO 13453 13451 IORD=IORD+1 13453 IF((IORD).GT.(5))GOTO 13452 IF(3*(IORD+1) .LE. NOCONT)GOTO 13471 GOTO 13452 13471 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 13491 13500 ITERM=1 GOTO 13503 13501 ITERM=ITERM+1 13503 IF((ITERM).GT.(IORD))GOTO 13502 ACON(ITERM,CURIMR) = ADUM(ITERM) GOTO 13501 13502 CONTINUE OCHIRAT = CHIRAT CONORD(CURIMR) = IORD GOTO 13481 13491 IF(CHIRAT .LE. OCHIRAT)GOTO 13511 GOTO 13452 13511 CONTINUE 13481 CONTINUE GOTO 13451 13452 CONTINUE GOTO 13521 13421 CONTINUE CONORD(CURIMR) = 1 ACON(1,CURIMR) = 1.0 13521 CONTINUE 13411 CONTINUE 13401 CONTINUE CHI_SCALE = OCHIRAT IF(CFLAG .NE. 1 .OR. NOCONT .LT. 3)GOTO 13541 CALL PARABOL(CONCENT,CONFLUX,NOCONT,A,B,C) GOTO 13531 13541 IF(CFLAG .NE. 2 .OR. NOCONT .LT. 2)GOTO 13551 CALL FITLINE(CONCENT,CONFLUX,NOCONT,A,B) GOTO 13531 13551 IF(CFLAG .NE. 3 .OR. NOCONT .LT. 1)GOTO 13561 CALL AVRGE(CONFLUX,NOCONT,A) 13561 CONTINUE 13531 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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) 13570 I=101 GOTO 13573 13571 I=I+1 13573 IF((I).GT.(NPTS - 100))GOTO 13572 CUTOFF = (ANSIG+1.0)/SNR(I) DIODE = DBLE(I) IF(.NOT.(.NOT.BADIOD(I)))GOTO 13591 IF(SPEC(I) .GT. CONTUM(DIODE)-CUTOFF)GOTO 13611 ILOW = ILOW + 1 13611 CONTINUE GOTO 13621 13591 CONTINUE NBAD = NBAD + 1 13621 CONTINUE 13581 CONTINUE GOTO 13571 13572 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 13641 NLIN = 0 13641 CONTINUE CSIZE = (CWINDOW-CBIN+1.0)*FC/(NLIN+1) IF(CSIZE .LT. CBIN)GOTO 13661 NBINS = (CWINDOW-CBIN+1.0)*FC/CBIN PROB = ( 0.5/NBINS )**(1.0/CBIN) GOTO 13671 13661 CONTINUE PROB = ( 0.5/((CWINDOW-CBIN+1.0)*(2.0*FC)**(CBIN-1.0)) )**(1.0/CBI *N) 13671 CONTINUE 13651 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 13691 WRITE(6,'(28H Shifting continuum down by ,F5.2,8H percent)')PERCNT GOTO 13701 13691 CONTINUE WRITE(6,'(26H Shifting continuum up by ,F5.2,8H percent)')PERCNT 13701 CONTINUE 13681 CONTINUE 13710 I=1 GOTO 13713 13711 I=I+1 13713 IF((I).GT.(NOCONT))GOTO 13712 HEIGHT = (ANSIG)/SNR(NINT(CONCENT(I))) FACTOR = 1.0-HEIGHT CONFLUX(I) = CONFLUX(I)*FACTOR GOTO 13711 13712 CONTINUE RETURN END SUBROUTINE GETNSIG(PROB,ANSIG) IMPLICIT REAL*8 (A-H,O-Z) INTEGER I IF(PROB .LE. 0.50)GOTO 13731 P = 1.0 - PROB GOTO 13741 13731 CONTINUE P = PROB 13741 CONTINUE 13721 CONTINUE ANSIG = 0.0 STEP = 1.0 PROB1 = ERFCC(ANSIG)/2.0 13750 I=1 GOTO 13753 13751 I=I+1 13753 IF((I).GT.(10000))GOTO 13752 ANSIG = ANSIG + STEP PROB2 = ERFCC(ANSIG)/2.0 IF(PROB1 .LT. P .OR. PROB2 .GT. P)GOTO 13771 ANSIG = ANSIG - STEP STEP = STEP/10.0 GOTO 13781 13771 CONTINUE PROB1 = PROB2 13781 CONTINUE 13761 CONTINUE IF(STEP.LE.0.0001)GOTO 13752 GOTO 13751 13752 CONTINUE ANSIG = DMYSQ(2.0D+00)*(ANSIG + STEP/2.0) IF(PROB .LE. 0.5)GOTO 13801 ANSIG = -ANSIG 13801 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 13821 ERFCC=2.0-ERFCC 13821 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 13830 J=1 GOTO 13833 13831 J=J+1 13833 IF((J).GT.(I))GOTO 13832 A = VALUE(J)/DBLE(I) + A GOTO 13831 13832 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 13851 CFLAG = 4 EFLAG = 2 GOTO 13841 13851 IF(NOCONT .LT. 3)GOTO 13861 CFLAG = 2 EFLAG = 2 GOTO 13871 13861 CONTINUE CFLAG = 3 EFLAG = 2 13871 CONTINUE 13841 CONTINUE RETURN END SUBROUTINE FCDNAD(LINE,A,COV,DELETED) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 13891 SINGLE(3) = 0.0 13891 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 13911 START = ICENTRE - 1 GOTO 13901 13911 IF(ILEFT(LINE) .GT. -2)GOTO 13921 START = ICENTRE 13921 CONTINUE 13901 CONTINUE IF((IRIGHT(LINE) .NE. 1) .AND. (IRIGHT(LINE) .NE. -1))GOTO 13941 END = ICENTRE + 1 GOTO 13931 13941 IF(IRIGHT(LINE) .GT. -2)GOTO 13951 END = ICENTRE 13951 CONTINUE 13931 CONTINUE 13960 I=START GOTO 13963 13961 I=I+1 13963 IF((I).GT.(END))GOTO 13962 IF(SPEC(I) .GE. SPEC(ICENTRE) .OR. .NOT.(.NOT. BADIOD(I)))GOTO 139 *81 ICENTRE = I 13981 CONTINUE GOTO 13961 13962 CONTINUE IF(.NOT.(BADIOD(ICENTRE)))GOTO 14001 ILEFT(LINE) = -1 IRIGHT(LINE)= -1 CALL REMFLS(LINE) DELETED = .TRUE. RETURN 14001 CONTINUE IF(SPEC(ICENTRE) .LE. 0.0)GOTO 14021 CFLUX = SNR(ICENTRE)**2 * CONTUM(DBLE(ICENTRE))/SPEC(ICENTRE) DFLUX = DMYSQ( CFLUX + CNTUNC(ICENTRE)**2 ) GOTO 14031 14021 CONTINUE CFLUX = SN**2 DFLUX = 0.0 14031 CONTINUE 14011 CONTINUE IF(SNR(ICENTRE)**2 .LE. CFLUX-2.0*DFLUX)GOTO 14051 WRITE(8,14060)WAVELN(LINE),LINEID(LINE) 14060 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 14051 CONTINUE IF(SNR(ICENTRE)**2 .LE. CFLUX-4.0*DFLUX)GOTO 14081 WEAK(LINE) = .TRUE. WRITE(8,14090)WAVELN(LINE),LINEID(LINE) 14090 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 14081 CONTINUE IF(SNR(ICENTRE)**2 .LE. CFLUX-6.0*DFLUX)GOTO 14111 CALL RMLFGL(LINE) 14111 CONTINUE IF(ILEFT(LINE) .GE. 0)GOTO 14131 IF(IRIGHT(LINE) .GE. 0)GOTO 14151 RHTDIO(LINE) = DBLE(ICENTRE) RETURN 14151 CONTINUE LFTDIO(LINE) = DBLE(ICENTRE) 14131 CONTINUE IF(IRIGHT(LINE) .GE. 0)GOTO 14171 RHTDIO(LINE) = DBLE(ICENTRE) 14171 CONTINUE LAST = 0 NEXT = 0 IF(LINE .LE. 1)GOTO 14191 LAST = NINT( CHANNEL(WAVELN(LINE-1)) ) 14191 CONTINUE IF(LINE .GE. NOLINES)GOTO 14211 NEXT = NINT( CHANNEL(WAVELN(LINE+1)) ) 14211 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 14231 IF(LFTDIO(LINE) .NE. DBLE(ICENTRE))GOTO 14251 LFTDIO(LINE) = DNINT(CENTRE(LINE)) ILEFT(LINE) = -1 14251 CONTINUE IF(RHTDIO(LINE) .NE. DBLE(ICENTRE))GOTO 14271 RHTDIO(LINE) = DNINT(CENTRE(LINE)) IRIGHT(LINE) = -1 14271 CONTINUE CALL RMLFGL(LINE) RETURN 14231 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 14291 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 14300 I=1 GOTO 14303 14301 I=I+1 14303 IF((I).GT.(3))GOTO 14302 14310 J=1 GOTO 14313 14311 J=J+1 14313 IF((J).GT.(3))GOTO 14312 COV(I,J) = 0.0 GOTO 14311 14312 CONTINUE GOTO 14301 14302 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) 14291 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 14331 DEPTH(LINE) = 1.0 14331 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL INTEGER ICENTRE IF(NOCONT .NE. 1)GOTO 14351 CNTUNC = SIGFLUX(1) RETURN GOTO 14341 14351 IF(NOCONT .NE. 0)GOTO 14361 CNTUNC = 0.0D0 RETURN 14361 CONTINUE 14341 CONTINUE IF(DBLE(ICENTRE) .GT. CONCENT(1))GOTO 14381 CNTUNC = SIGFLUX(1) GOTO 14371 14381 IF(DBLE(ICENTRE) .LT. CONCENT(NOCONT))GOTO 14391 CNTUNC = SIGFLUX(NOCONT) GOTO 14401 14391 CONTINUE 14410 I=1 GOTO 14413 14411 I=I+1 14413 IF((I).GT.(NOCONT))GOTO 14412 IF(DBLE(ICENTRE) .LT. CONCENT(I) .OR. DBLE(ICENTRE) .GT. CONCENT(I *+1))GOTO 14431 CNTUNC = 0.5D0*(SIGFLUX(I)+SIGFLUX(I+1)) 14431 CONTINUE GOTO 14411 14412 CONTINUE 14401 CONTINUE 14371 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 14451 CALL GTBSFW(WAVE,DEEP,WIDTH,SIGWDTH) A(3) = WIDTH*0.60056121 GOTO 14461 14451 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 14481 A(3) = DX1/DSQRT(-DLOG(Y1/A(1))) GOTO 14491 14481 CONTINUE A(3) = DXN/DSQRT(-DLOG(YN/A(1))) 14491 CONTINUE 14471 CONTINUE 14461 CONTINUE 14441 CONTINUE IF(A(3) .GE. 1.20)GOTO 14511 A(3) = 1.20 14511 CONTINUE RETURN END SUBROUTINE GUESLC(LINE,CENT,FIRST) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 14531 14540 NEXT=LINE+1 GOTO 14543 14541 NEXT=NEXT+1 14543 IF((NEXT).GT.(NOLINES))GOTO 14542 IF(ILEFT(NEXT) .LT. 0 .OR. IRIGHT(NEXT) .LT. 0 .OR. LINEID(NEXT) . *EQ. 'TELLURIC ')GOTO 14561 CENT1 = CHANNEL(WAVELN(LINE)) - CHANNEL(WAVELN(NEXT)) CENT1 = CENT1 + CENTRE(NEXT) WAVE1 = WAVELN(NEXT) GOTO 14542 14561 CONTINUE GOTO 14541 14542 CONTINUE 14531 CONTINUE CENT2 = 0.0 IF(LINE .EQ. 1)GOTO 14581 14590 LAST=LINE-1 GOTO 14593 14591 LAST=LAST+(-1) 14593 IF((-1)*((LAST)-(1)).GT.0)GOTO 14592 IF(ILEFT(LAST) .LT. 0 .OR. IRIGHT(LAST) .LT. 0 .OR. LINEID(LAST) . *EQ. 'TELLURIC ')GOTO 14611 CENT2 = CHANNEL(WAVELN(LINE)) - CHANNEL(WAVELN(LAST)) CENT2 = CENT2 + CENTRE(LAST) WAVE2 = WAVELN(LAST) GOTO 14592 14611 CONTINUE GOTO 14591 14592 CONTINUE 14581 CONTINUE IF(CENT1 .EQ. 0.0 .OR. DABS( CENT1-CHANNEL(WAVELN(LINE)) ) .GE. 1. *5)GOTO 14631 IF(CENT2 .EQ. 0.0 .OR. DABS( CENT2-CHANNEL(WAVELN(LINE)) ) .GE. 1. *5)GOTO 14651 CENT = ( CENT1*(WAVELN(LINE)-WAVE2) + CENT2*(WAVE1-WAVELN(LINE)) ) * / (WAVE1-WAVE2) GOTO 14661 14651 CONTINUE CENT = CENT1 14661 CONTINUE 14641 CONTINUE GOTO 14621 14631 IF(CENT2 .EQ. 0.0 .OR. DABS( CENT2-CHANNEL(WAVELN(LINE)) ) .GE. 1. *5)GOTO 14671 CENT = CENT2 GOTO 14681 14671 CONTINUE CENT = CHANNEL( WAVELN(LINE) ) 14681 CONTINUE 14621 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 *14701 IF(INT(LIMIT) .GE. ICENTRE)GOTO 14721 WRITE(8,14730)WAVE 14730 FORMAT (' WARNING FOR LINE AT ',F9.3,' ILL DEFINED GAUSSIAN MAY RE %SULT FROM ', 'USE OF LEFT LIMIT') LIMIT = DBLE(ICENTRE-ILIMIT) GOTO 14741 14721 CONTINUE WRITE(8,14750)WAVE 14750 FORMAT (' WARNING FOR LINE AT ',F9.3,' ILL DEFINED GAUSSIAN MAY RE %SULT FROM', ' USE OF RIGHT LIMIT') LIMIT = DBLE(ICENTRE+ILIMIT) 14741 CONTINUE 14711 CONTINUE 14701 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 14771 DYCEN = YCEN/SNR(ICENTRE) GOTO 14781 14771 CONTINUE DYCEN = 0.0 14781 CONTINUE 14761 CONTINUE 14790 INDEX=ICENTRE + STEP GOTO 14793 14791 INDEX=INDEX+(STEP) 14793 IF((STEP)*((INDEX)-(ICENTRE + STEP * 40)).GT.0)GOTO 14792 IF((INDEX .GE. 1) .AND. (INDEX .LE. NUMBER))GOTO 14811 GOTO 14792 14811 CONTINUE Y = SPEC(INDEX)/CONTUM(DBLE(INDEX)) IF(Y .LE. 0.0)GOTO 14831 DY = Y/SNR(INDEX) GOTO 14841 14831 CONTINUE DY = 0.0 14841 CONTINUE 14821 CONTINUE IF(STEP .NE. -1 .OR. NEXT .EQ. 0)GOTO 14861 IF(INDEX .GT. NEXT)GOTO 14881 GOTO 14792 14881 CONTINUE GOTO 14851 14861 IF(STEP .NE. 1 .OR. NEXT .EQ. 0)GOTO 14891 IF(INDEX .LT. NEXT)GOTO 14911 GOTO 14792 14911 CONTINUE 14891 CONTINUE 14851 CONTINUE IF(.NOT.(BADIOD(INDEX)))GOTO 14931 WRITE(8,14940)INDEX,WAVE 14940 FORMAT (' BAD DIODE NO. ',I4,' RUINS HALF OF LINE AT ',F9.3,' A') LIMIT = DBLE(ICENTRE) RETURN 14931 CONTINUE IF(Y-2.0*DY .LE. YCEN+2.0*DYCEN)GOTO 14961 LIMIT = DBLE(INDEX) RETURN 14961 CONTINUE IF(YCEN-2.0*DYCEN .LE. Y+2.0*DY)GOTO 14981 GOTO 14792 14981 CONTINUE IF(Y + DY .LE. 1.00)GOTO 15001 LIMIT = DBLE(ICENTRE) WRITE(8,15010)WAVE,ID 15010 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 15001 CONTINUE GOTO 14791 14792 CONTINUE LIMIT = DBLE(ICENTRE) WRITE(8,15020)WAVE,ID 15020 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 15041 FWHM(LINE) = 0.0 RETURN 15041 CONTINUE SINGLE(1) = 1.0 SINGLE(2) = 1.0 SINGLE(3) = 1.0 IF(.NOT.(INST_PROF))GOTO 15061 SINGLE(3) = 0.0 15061 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 15081 LFTDIO(LINE) = LEFT STEP = 1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,RIGHT) FWHM(LINE) = DABS(A(3))*1.66510921 GOTO 15071 15081 IF(SIGMAR + 2.0*DELTAR .GE. SIGMAL - 2.0*DELTAL)GOTO 15091 RHTDIO(LINE) = RIGHT STEP = -1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,LEFT) FWHM(LINE) = DABS(A(3))*1.66510921 GOTO 15101 15091 CONTINUE FWHM(LINE) = ( SIGMAR+SIGMAL )*0.83255460 15101 CONTINUE 15071 CONTINUE IF(A(2)-LEFT .LE. 2.0*FWHM(LINE))GOTO 15121 LEFT = A(2) - 2.0*FWHM(LINE) 15121 CONTINUE IF(RIGHT-A(2) .LE. 2.0*FWHM(LINE))GOTO 15141 RIGHT = A(2) + 2.0*FWHM(LINE) 15141 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL IF(.NOT.(INST_PROF))GOTO 15161 RETURN 15161 CONTINUE IF((NOGDLN .LT. 2 .OR. INCPT .LE. 0.0) .AND. (.NOT.(FIXFWHM)))GOTO * 15181 15190 I=1 GOTO 15193 15191 I=I+1 15193 IF((I).GT.(NOLINES))GOTO 15192 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 15211 CALL RBLWFF(I) 15211 CONTINUE GOTO 15191 15192 CONTINUE 15181 CONTINUE RETURN END SUBROUTINE RBLWFF(LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 15220 I=2 GOTO 15223 15221 I=I+1 15223 IF((I).GT.(9))GOTO 15222 SINGLE(I) = 0.0 GOTO 15221 15222 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 15241 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 15250 I=1 GOTO 15253 15251 I=I+1 15253 IF((I).GT.(3))GOTO 15252 15260 J=1 GOTO 15263 15261 J=J+1 15263 IF((J).GT.(3))GOTO 15262 COV(I,J) = 0.0 GOTO 15261 15262 CONTINUE GOTO 15251 15252 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) SINGLE(2) = 1.0 15241 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 15281 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 15290 I=1 GOTO 15293 15291 I=I+1 15293 IF((I).GT.(3))GOTO 15292 15300 J=1 GOTO 15303 15301 J=J+1 15303 IF((J).GT.(3))GOTO 15302 COV(I,J) = 0.0 GOTO 15301 15302 CONTINUE GOTO 15291 15292 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) 15281 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 15321 LFTDIO(LINE) = LEFT STEP = 1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,RIGHT) GOTO 15311 15321 IF(A1R .GE. A1L)GOTO 15331 RHTDIO(LINE) = RIGHT STEP = -1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,LEFT) 15331 CONTINUE 15311 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 15340 II=1 GOTO 15343 15341 II=II+1 15343 IF((II).GT.(3))GOTO 15342 ANEW(II) = A(II) GOTO 15341 15342 CONTINUE IF(STEP .LE. 0)GOTO 15361 START = INT(LFTDIO(LINE)) GOTO 15371 15361 CONTINUE START = INT(RHTDIO(LINE)) 15371 CONTINUE 15351 CONTINUE IF(IRIGHT(LINE) .LE. 0 .OR. STEP .LE. 0)GOTO 15391 END = NINT(CENTRE(LINE)) + IRIGHT(LINE) GOTO 15381 15391 IF(ILEFT(LINE) .LE. 0 .OR. STEP .GE. 0)GOTO 15401 END = NINT(CENTRE(LINE)) - ILEFT(LINE) GOTO 15411 15401 CONTINUE END = NINT(CENTRE(LINE)) + STEP * 40 15411 CONTINUE 15381 CONTINUE IF(END .GE. 1)GOTO 15431 END = 1 GOTO 15421 15431 IF(END .LE. NPTS)GOTO 15441 END = NPTS 15441 CONTINUE 15421 CONTINUE N = INT( RHTDIO(LINE) - LFTDIO(LINE) ) + 1 INDEX = START 15450 I=1 GOTO 15453 15451 I=I+(2) 15453 IF((2)*((I)-(2*N-1)).GT.0)GOTO 15452 X(I) = DBLE(INDEX) X(I+1) = 1.0 - SPEC(INDEX)/CONTUM(DBLE(INDEX)) INDEX = INDEX + STEP GOTO 15451 15452 CONTINUE ICENTRE = NINT(CENTRE(LINE)) PHOTONS = SNR(ICENTRE)**2 * CONTUM(DBLE(ICENTRE))/SPEC(ICENTRE) 15460 I=2*N+1 GOTO 15463 15461 I=I+(2) 15463 IF((2)*((I)-(2*IABS(START - END) + 1)).GT.0)GOTO 15462 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 15481 GOTO 15462 15481 CONTINUE IF(DABS( A(2)-CHANNEL(WAVELN(LINE)) ) .LE. 6.0D+00)GOTO 15501 GOTO 15462 15501 CONTINUE 15510 J=INDEX + STEP GOTO 15513 15511 J=J+(STEP) 15513 IF((STEP)*((J)-(END)).GT.0)GOTO 15512 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 15531 END = J - STEP GOTO 15512 15531 CONTINUE GOTO 15511 15512 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 15551 WRITE(24,'(9H LINE AT ,F10.3)')WAVELN(LINE) GOTO 15462 15551 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 15571 GOTO 15462 15571 CONTINUE 15580 J=START+N*STEP GOTO 15583 15581 J=J+(STEP) 15583 IF((STEP)*((J)-(INDEX)).GT.0)GOTO 15582 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 15601 DIODE = DBLE(INDEX-STEP) RETURN 15601 CONTINUE GOTO 15581 15582 CONTINUE 15610 II=1 GOTO 15613 15611 II=II+1 15613 IF((II).GT.(3))GOTO 15612 A(II) = ANEW(II) GOTO 15611 15612 CONTINUE INDEX = INDEX + STEP IF(2*N+1 .GE. 2*IABS(START-END)+1)GOTO 15462 GOTO 15461 15462 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 15620 I=1 GOTO 15623 15621 I=I+1 15623 IF((I).GT.(9))GOTO 15622 NPARAMS = NPARAMS + DBLE(SINGLE(I)) GOTO 15621 15622 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 15641 CHI3SIG = 0.0 GOTO 15631 15641 IF(NFREE .GT. 20)GOTO 15651 CHI3SIG = CHIRAY(NFREE) GOTO 15631 15651 IF(NFREE .LE. 20)GOTO 15661 CHI3SIG = CHIRAY(20) + 1.4d0 * DBLE(NFREE-20) 15661 CONTINUE 15631 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. 15670 I=1 GOTO 15673 15671 I=I+1 15673 IF((I).GT.(9))GOTO 15672 AOLD(I) = A(I) GOTO 15671 15672 CONTINUE YEST = PROFILE(X, A, SW, VSINI) 15680 I=1 GOTO 15683 15681 I=I+1 15683 IF((I).GT.(9))GOTO 15682 IF(SW(I) .NE. 1.D0)GOTO 15701 A(I) = A(I) + DA(I) GRAD(I) = ( PROFILE(X, A, SW, VSINI) - YEST ) / DA(I) A(I) = AOLD(I) GOTO 15711 15701 CONTINUE GRAD(I) = 0.0D0 15711 CONTINUE 15691 CONTINUE GOTO 15681 15682 CONTINUE DYEST2 = 0.0D0 15720 I=1 GOTO 15723 15721 I=I+1 15723 IF((I).GT.(9))GOTO 15722 IF(SW(I) .NE. 1.0D0)GOTO 15741 15750 J=1 GOTO 15753 15751 J=J+1 15753 IF((J).GT.(9))GOTO 15752 IF(SW(J) .NE. 1.0D0)GOTO 15771 DYEST2 = DYEST2 + GRAD(I)*GRAD(J)*COV(I,J) 15771 CONTINUE GOTO 15751 15752 CONTINUE 15741 CONTINUE GOTO 15721 15722 CONTINUE DYEST = DMYSQ(DYEST2) IF((Y - 2.0*DY .LE. YEST + 2.0*DYEST) .AND. (Y - 2.0*DY .LT. A(1)) *)GOTO 15791 DEPTOL = .TRUE. 15791 CONTINUE RETURN END SUBROUTINE FT1GAUS(LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 15811 SINGLE(3) = 0.0 15811 CONTINUE IF((ILEFT(LINE) .GE. 0) .AND. ((IRIGHT(LINE) .GE. 0) .AND. (.NOT.( *WEAK(LINE)))))GOTO 15831 RETURN 15831 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 15851 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 15860 I=1 GOTO 15863 15861 I=I+1 15863 IF((I).GT.(3))GOTO 15862 15870 J=1 GOTO 15873 15871 J=J+1 15873 IF((J).GT.(3))GOTO 15872 COV(I,J) = 0.0 GOTO 15871 15872 CONTINUE GOTO 15861 15862 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) 15851 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 15891 RETURN 15891 CONTINUE IF(.NOT.(FIXFWHM))GOTO 15911 SLOPE = 0.0 RETURN 15911 CONTINUE MINIDP = 1.0 IF(NOGDLN .GE. 2)GOTO 15931 SIGFWHM = 0.0 INCPT = 0.0 SLOPE = 0.0 RETURN 15931 CONTINUE CALL MINWTD(KODE) FIXFWHM = .TRUE. RETURN END SUBROUTINE DMNFWH IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(100),DW(100),PIX1(100) 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 15940 I=1 GOTO 15943 15941 I=I+1 15943 IF((I).GT.(NOGDLN))GOTO 15942 IF((DEPTH(GOOD(I)) .LT. LLIMIT .OR. DEPTH(GOOD(I)) .GT. ULIMIT) .A *ND. (.NOT.(TELSET)))GOTO 15961 CALL FNDORD(WAVELN(GOOD(I)),IORDER) MEAN = MEAN + WAVELN(GOOD(I))/(FWHM(GOOD(I))*DW(IORDER)) GOTO 15971 15961 CONTINUE EXCLUDE = EXCLUDE + 1 15971 CONTINUE 15951 CONTINUE GOTO 15941 15942 CONTINUE IF(NOGDLN .LE. EXCLUDE)GOTO 15991 INCPT = MEAN/DBLE(NOGDLN - EXCLUDE) GOTO 16001 15991 CONTINUE INCPT = 0.0 WRITE(8,16010) 16010 FORMAT ('ERROR: NO GOOD LINES WITHIN DEPTH LIMITS FOR FWHM TO DEP %TH RELATION') 16001 CONTINUE 15981 CONTINUE SLOPE = 0.0 16020 I=1 GOTO 16023 16021 I=I+1 16023 IF((I).GT.(NOGDLN))GOTO 16022 FAC = WAVELN(GOOD(I))/DW(IORDER) IF((DEPTH(GOOD(I)) .GE. 0.10 .OR. DEPTH(GOOD(I)) .GE. 0.50) .AND. *(.NOT.(TELSET)))GOTO 16041 VAR = VAR + (FAC/FWHM(GOOD(I))-INCPT)**2 16041 CONTINUE GOTO 16021 16022 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(100),DW(100),PIX1(100) 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 )') 16050 I=1 GOTO 16053 16051 I=I+1 16053 IF((I).GT.(NOGDLN))GOTO 16052 IF(DEPTH(GOOD(I)) .LT. DMIN)GOTO 16071 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 16091 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 *111 Q(INUM,3) = 1.0/R**2 - 1.0/RFOCUS(WAVELN(GOOD(I)))**2 GOTO 16121 16111 CONTINUE Q(INUM,3) = 1.0/R**2 16121 CONTINUE 16101 CONTINUE WRITE(9,*)DEPTH(GOOD(I)),Q(INUM,3),WAVELN(GOOD(I)) Q(INUM,4) = 0.0 16091 CONTINUE IF(RW .GE. -4.85)GOTO 16141 IAVG = IAVG + 1 RDUMMY(IAVG) = 1.0/R**2 - 1.0/RFOCUS(WAVELN(GOOD(I)))**2 16141 CONTINUE 16071 CONTINUE GOTO 16051 16052 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 16161 WRITE(8,16170)KODE 16170 FORMAT (29H MINSUM ROUTINE ABORTED CODE ,I2) RETURN 16161 CONTINUE IF(INUM .LE. 1)GOTO 16191 SIGFWHM = 1.33*ERROR/DBLE(NOGDLN-2) GOTO 16201 16191 CONTINUE SIGFWHM = 0.0 16201 CONTINUE 16181 CONTINUE SLOPE = X(1) INCPT = X(2) IF(IAVG .LE. 2 .OR. SLOPE .LE. 0.0)GOTO 16221 CALL GTMEDN(RDUMMY,IAVG,RMEDIAN) IF(RMEDIAN .GE. 2.5D-11)GOTO 16241 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 16251 16241 CONTINUE MINIDP = (RMEDIAN-INCPT)/SLOPE 16251 CONTINUE 16231 CONTINUE GOTO 16261 16221 CONTINUE RW = 1.41D-05 CALL GETDEPT(RW,SLOPE,INCPT,MINIDP) 16261 CONTINUE 16211 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(100),DW(100),PIX1(100) 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 16281 X = W - WFC(IROW) 16290 I=1 GOTO 16293 16291 I=I+1 16293 IF((I).GT.(6))GOTO 16292 R = R + A_FOCUS(IROW,I)*X**(I-1) GOTO 16291 16292 CONTINUE GOTO 16271 16281 IF(.NOT.(GLOBAL_FOCUS))GOTO 16301 X = W - GLOBAL_WFC 16310 I=1 GOTO 16313 16311 I=I+1 16313 IF((I).GT.(6))GOTO 16312 R = R + GLOBAL_A(I)*X**(I-1) GOTO 16311 16312 CONTINUE 16301 CONTINUE 16271 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 16320 I=1 GOTO 16323 16321 I=I+1 16323 IF((I).GT.(100000))GOTO 16322 R = 1.0/(INCPT + SLOPE*D) R = DMYSQ(R) RWCALC = 1.067*D/R IF(RWCALC .GE. RW)GOTO 16341 D = D + DELTAD DELTAD = DELTAD/10.0 ICOUNT = ICOUNT + 1 GOTO 16351 16341 CONTINUE D = D - DELTAD 16351 CONTINUE 16331 CONTINUE IF(ICOUNT .LT. 6)GOTO 16371 IF(R .LE. RMIN)GOTO 16391 WRITE(8,16400) 16400 FORMAT('ERROR: WIDTH TO DEPTH RELATION TOO NARROW') 16391 CONTINUE GOTO 16322 16371 CONTINUE GOTO 16321 16322 CONTINUE MINIDP = D RETURN END SUBROUTINE FNDSGL IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL INTEGER LINE MINIDP = 1.0 16410 I=1 GOTO 16413 16411 I=I+1 16413 IF((I).GT.(NOGDLN))GOTO 16412 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 16431 IF(DEPTH(GOOD(I)) .GT. MINIDP .OR. DEPTH(GOOD(I)) .LT. LLIMIT)GOTO * 16451 MINIDP = DEPTH(GOOD(I)) 16451 CONTINUE 16431 CONTINUE GOTO 16411 16412 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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 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*SIGF *WHM .OR. DEPTH(GOOD(I)) .LT. 0.10) .AND. (.NOT.(TELSET)))GOTO 1648 *1 X(I-EXCLUDE) = DEPTH(GOOD(I)) Y(I-EXCLUDE) = FWHM(GOOD(I)) GOTO 16491 16481 CONTINUE EXCLUDE = EXCLUDE + 1 16491 CONTINUE 16471 CONTINUE GOTO 16461 16462 CONTINUE N = NOGDLN - EXCLUDE RETURN END SUBROUTINE FITWKL IMPLICIT REAL*8 (A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 16500 I=3 GOTO 16503 16501 I=I+1 16503 IF((I).GT.(9))GOTO 16502 A(I) = 0.0 SINGLE(I) = 0.0 GOTO 16501 16502 CONTINUE 16510 LINE=1 GOTO 16513 16511 LINE=LINE+1 16513 IF((LINE).GT.(NOLINES))GOTO 16512 IF(.NOT.(WEAK(LINE)))GOTO 16531 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 16551 RETURN 16551 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 16571 IF(RHTDIO(LINE) .LT. CHANNEL(WAVELN(LINE+1)))GOTO 16591 GOTO 16511 16591 CONTINUE 16571 CONTINUE IF(LINE .LE. 1)GOTO 16611 IF(LFTDIO(LINE) .GT. CHANNEL(WAVELN(LINE-1)))GOTO 16631 GOTO 16511 16631 CONTINUE 16611 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) 16640 I=1 GOTO 16643 16641 I=I+1 16643 IF((I).GT.(3))GOTO 16642 16650 J=1 GOTO 16653 16651 J=J+1 16653 IF((J).GT.(3))GOTO 16652 COV(I,J) = 0.0 GOTO 16651 16652 CONTINUE GOTO 16641 16642 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 16671 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 16680 I=1 GOTO 16683 16681 I=I+1 16683 IF((I).GT.(3))GOTO 16682 16690 J=1 GOTO 16693 16691 J=J+1 16693 IF((J).GT.(3))GOTO 16692 COV(I,J) = 0.0 GOTO 16691 16692 CONTINUE GOTO 16681 16682 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) SINGLE(2) = 1.0 16671 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) 16531 CONTINUE GOTO 16511 16512 CONTINUE RETURN END SUBROUTINE SFTBLS(LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 16711 RETURN 16711 CONTINUE CALL GUESLC(LINE,CENTRE(LINE),FIRST) ICENTRE = NINT(CENTRE(LINE)) IF(.NOT.(BADIOD(ICENTRE)))GOTO 16731 WRITE(8,16740)WAVELN(LINE) 16740 FORMAT (' REMOVED LINE AT ',F9.3,' A DUE TO BAD DIODES') WRITE(6,16750)WAVELN(LINE) 16750 FORMAT (' REMOVED LINE AT ',F9.3,' A DUE TO BAD DIODES') CALL REMFLS(LINE) LINE = LINE - 1 RETURN 16731 CONTINUE IF(.NOT.(LNABST(CENTRE(LINE))) .OR. LINEID(LINE) .EQ. 'TELLURIC ' %)GOTO 16771 WRITE(8,16780)LINEID(LINE),WAVELN(LINE) 16780 FORMAT (' LINE WITH ID ',A10,' AT ',F9.3,' WAS REMOVED - TOO WEAK %TO MEASURE.') WRITE(6,16790)LINEID(LINE),WAVELN(LINE) 16790 FORMAT (' LINE WITH ID ',A10,' AT ',F9.3,' WAS REMOVED - TOO WEAK %TO MEASURE.') CALL REMFLS(LINE) LINE = LINE - 1 RETURN 16771 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 16811 RETURN GOTO 16801 16811 IF(FWHM(LINE) .NE. 0.0)GOTO 16821 FWHM(LINE) = 4.5 16821 CONTINUE 16801 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) 16830 I=1 GOTO 16833 16831 I=I+1 16833 IF((I).GT.(3))GOTO 16832 16840 J=1 GOTO 16843 16841 J=J+1 16843 IF((J).GT.(3))GOTO 16842 COV(I,J) = 0.0 GOTO 16841 16842 CONTINUE GOTO 16831 16832 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 16861 A(2) = CHANNEL(WAVELN(LINE)) SINGLE(2) = 0.0 16870 I=1 GOTO 16873 16871 I=I+1 16873 IF((I).GT.(3))GOTO 16872 16880 J=1 GOTO 16883 16881 J=J+1 16883 IF((J).GT.(3))GOTO 16882 COV(I,J) = 0.0 GOTO 16881 16882 CONTINUE GOTO 16871 16872 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) 16861 CONTINUE IF(ILEFT(LINE) .GE. 0 .OR. IRIGHT(LINE) .LT. 0)GOTO 16901 STEP = 1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,RHTDIO(LINE)) GOTO 16891 16901 IF(IRIGHT(LINE) .GE. 0 .OR. ILEFT(LINE) .LT. 0)GOTO 16911 STEP = -1 CALL TSTHLN(A,COV,SINGLE,STEP,LINE,LFTDIO(LINE)) 16911 CONTINUE 16891 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 16931 LNABST = .TRUE. 16931 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK NEXT = 0 LAST = 0 IF(LINE .GE. NOLINES)GOTO 16951 NEXT = NINT( CHANNEL(WAVELN(LINE+1)) ) 16951 CONTINUE STEP = 1 CALL DETLIM(ICENTRE,STEP,RHTDIO(LINE),NPTS,NEXT, WAVELN(LINE),LINE *ID(LINE)) IF(LINE .LE. 1)GOTO 16971 LAST = NINT( CHANNEL(WAVELN(LINE-1)) ) 16971 CONTINUE STEP = -1 CALL DETLIM(ICENTRE,STEP,LFTDIO(LINE),NPTS,LAST, WAVELN(LINE),LINE *ID(LINE)) IF(RHTDIO(LINE) .NE. DBLE(ICENTRE))GOTO 16991 IRIGHT(LINE) = -1 16991 CONTINUE IF(LFTDIO(LINE) .NE. DBLE(ICENTRE))GOTO 17011 ILEFT(LINE) = -1 17011 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 17031 SINGLE(1) = 1.0 SINGLE(2) = 0.0 SINGLE(3) = 0.0 GOTO 17041 17031 CONTINUE IF(ILEFT(LINE) .GE. 0)GOTO 17061 NEXT = 0 ILIMIT = INT(RHTDIO(LINE)) STEP = 1 IF(LINE .GE. NOLINES)GOTO 17081 NEXT = NINT( CHANNEL(WAVELN(LINE+1)) ) 17081 CONTINUE CALL DETLIM(ILIMIT,STEP,RHTDIO(LINE),NPTS, NEXT,WAVELN(LINE),LINEI *D(LINE)) GOTO 17051 17061 IF(IRIGHT(LINE) .GE. 0)GOTO 17091 LAST = 0 ILIMIT = INT(LFTDIO(LINE)) STEP = -1 IF(LINE .LE. 1)GOTO 17111 LAST = NINT( CHANNEL(WAVELN(LINE-1)) ) 17111 CONTINUE CALL DETLIM(ILIMIT,STEP,LFTDIO(LINE),NPTS, LAST,WAVELN(LINE),LINEI *D(LINE)) 17091 CONTINUE 17051 CONTINUE SINGLE(1) = 1.0 SINGLE(2) = 0.0 SINGLE(3) = 1.0 IF(.NOT.(INST_PROF))GOTO 17131 SINGLE(3) = 0.0 17131 CONTINUE IF((RHTDIO(LINE) .NE. DBLE(ILIMIT)) .AND. ((LFTDIO(LINE) .NE. DBLE *(ILIMIT)) .AND. (.NOT.(NOTURN(LINE,CENTRE(LINE),NPTS,NOLINES)))))G *OTO 17151 SINGLE(3) = 0.0 ILEFT(LINE) = -1 IRIGHT(LINE) = -1 17151 CONTINUE 17041 CONTINUE 17021 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 17171 RETURN GOTO 17161 17171 IF(SPEC(ICENT+1) .LT. SPEC(ICENT) .OR. SPEC(ICENT) .LT. SPEC(ICENT *-1))GOTO 17181 RETURN GOTO 17161 17181 IF(SPEC(ICENT+1) .GT. SPEC(ICENT) .OR. SPEC(ICENT) .GT. SPEC(ICENT *-1))GOTO 17191 RETURN 17191 CONTINUE 17161 CONTINUE IF(LINE .GE. NOLINES)GOTO 17211 CALL GUESLC(LINE+1,CNEXT,FIRST) 17211 CONTINUE IF(LINE .LE. 1)GOTO 17231 CALL GUESLC(LINE-1,CLAST,FIRST) 17231 CONTINUE IF((DBLE(ICENT-1) .GT. CLAST) .AND. (DBLE(ICENT+1) .LT. CNEXT))GOT *O 17251 RETURN 17251 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(100),DW(100),PIX1(100) 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 17271 D = MINIDP 17271 CONTINUE RILIN2 = INCPT + D*SLOPE IF((.NOT.(FOCUS_PARS(CURIMR))) .AND. (.NOT.(GLOBAL_FOCUS)))GOTO 17 *291 RIOBS2 = 1.0/RFOCUS(WAVE)**2 + RILIN2 GOTO 17301 17291 CONTINUE RIOBS2 = RILIN2 17301 CONTINUE 17281 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 17321 SIGWDTH = WIDTH * 0.05 17321 CONTINUE RETURN END SUBROUTINE FTBLIN(NOLINES) IMPLICIT REAL*8(A-H,O-Z) INTEGER LINE,NOLINES 17330 LINE=1 GOTO 17333 17331 LINE=LINE+1 17333 IF((LINE).GT.(NOLINES))GOTO 17332 CALL FTBLND(LINE) GOTO 17331 17332 CONTINUE RETURN END SUBROUTINE FTBLND(LINE) IMPLICIT REAL*8(A-H,O-Z) INTEGER LINE LOGICAL RHTWGB IF(.NOT.(RHTWGB(LINE)))GOTO 17351 IF(.NOT.(RHTWGB(LINE-1)))GOTO 17371 CALL FT3GAUS(LINE) GOTO 17381 17371 CONTINUE CALL FT2GAUS(LINE) 17381 CONTINUE 17361 CONTINUE 17351 CONTINUE RETURN END LOGICAL FUNCTION RHTWGB(LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 17401 RETURN 17401 CONTINUE FWHM1 = FWHM(LINE) DEEP = DEPTH(LINE) IF(FWHM1 .NE. 0.0)GOTO 17421 CALL GTBSFW(W,DEEP,FWHM1,SIGWDTH) 17421 CONTINUE FWHM2 = FWHM(LINE+1) DEEP = DEPTH(LINE+1) IF(FWHM2 .NE. 0.0)GOTO 17441 CALL GTBSFW(W,DEEP,FWHM2,SIGWDTH) 17441 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 17461 LIMIT1 = CENTRE(LINE) + FWHM1*0.60056121*DMYSQ( DLOG(DEPTH(LINE)/D *EPTH1) ) GOTO 17471 17461 CONTINUE LIMIT1 = CENTRE(LINE) 17471 CONTINUE 17451 CONTINUE IF(DEPTH(LINE+1) .LE. DEPTH2)GOTO 17491 LIMIT2 = CENTRE(LINE+1)-FWHM2*0.60056121*DMYSQ(DLOG(DEPTH(LINE+1)/ *DEPTH2)) GOTO 17501 17491 CONTINUE LIMIT2 = CENTRE(LINE+1) 17501 CONTINUE 17481 CONTINUE IF((LIMIT2 .GE. LIMIT1) .AND. (CENTRE(LINE+1)-CENTRE(LINE) .GE. FW *HM1+FWHM2+1.8D0*VWIDTH))GOTO 17521 RHTWGB = .TRUE. 17521 CONTINUE RETURN END SUBROUTINE FT3GAUS(LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(100),DW(100),PIX1(100) 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/ 17530 I=1 GOTO 17533 17531 I=I+1 17533 IF((I).GT.(9))GOTO 17532 TRIPLE(I) = 1.0 GOTO 17531 17532 CONTINUE BLEND(LINE) = 2 BLEND(LINE+1) = -1 17540 INDEX=1 GOTO 17543 17541 INDEX=INDEX+1 17543 IF((INDEX).GT.(3))GOTO 17542 L = LINE - 2 + INDEX CALL SMGSWI(TRIPLE,L,INDEX,ILEFT(L),IRIGHT(L)) IF(BLEND(LINE-1) .NE. 2)GOTO 17561 TRIPLE(1) = 0.0 TRIPLE(2) = 0.0 TRIPLE(3) = 0.0 17561 CONTINUE GOTO 17541 17542 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) 17570 I=1 GOTO 17573 17571 I=I+1 17573 IF((I).GT.(3))GOTO 17572 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 17591 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 17591 CONTINUE GOTO 17571 17572 CONTINUE IF(DABS(CHANNEL(WAVELN(LINE+1))-CHANNEL(WAVELN(LINE))) .GT. 2.0D+0 *0)GOTO 17611 TRIPLE(5) = 0.0 A(5) = CHANNEL(WAVELN(LINE)) TRIPLE(8) = 0.0 A(8) = CHANNEL(WAVELN(LINE+1)) 17611 CONTINUE IF(DABS(CHANNEL(WAVELN(LINE-1))-CHANNEL(WAVELN(LINE))) .GT. 2.0D+0 *0)GOTO 17631 TRIPLE(2) = 0.0 A(2) = CHANNEL(WAVELN(LINE-1)) TRIPLE(5) = 0.0 A(5) = CHANNEL(WAVELN(LINE)) 17631 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,TRIPLE,CHISQ) 17640 I=1 GOTO 17643 17641 I=I+1 17643 IF((I).GT.(3))GOTO 17642 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 17661 FWHM(LINE-2+I) = DABS(A( (I-1)*3+3 ))/0.60056121 17661 CONTINUE GOTO 17641 17642 CONTINUE RETURN END SUBROUTINE FT2GAUS(LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(100),DW(100),PIX1(100) 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/ 17670 I=1 GOTO 17673 17671 I=I+1 17673 IF((I).GT.(6))GOTO 17672 DOUBLE(I) = 1.0 GOTO 17671 17672 CONTINUE 17680 I=7 GOTO 17683 17681 I=I+1 17683 IF((I).GT.(9))GOTO 17682 DOUBLE(I) = 0.0 GOTO 17681 17682 CONTINUE BLEND(LINE) = 1 BLEND(LINE+1) = -1 17690 INDEX=1 GOTO 17693 17691 INDEX=INDEX+1 17693 IF((INDEX).GT.(2))GOTO 17692 L = LINE -1 + INDEX CALL SMGSWI(DOUBLE,L,INDEX,ILEFT(L),IRIGHT(L)) GOTO 17691 17692 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) 17700 I=1 GOTO 17703 17701 I=I+1 17703 IF((I).GT.(2))GOTO 17702 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 17721 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 17721 CONTINUE GOTO 17701 17702 CONTINUE IF(DABS(CHANNEL(WAVELN(LINE+1))-CHANNEL(WAVELN(LINE))) .GT. 2.0D+0 *0)GOTO 17741 DOUBLE(2) = 0.0 A(2) = CHANNEL(WAVELN(LINE)) DOUBLE(5) = 0.0 A(5) = CHANNEL(WAVELN(LINE+1)) 17741 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,DOUBLE,CHISQ) 17750 I=1 GOTO 17753 17751 I=I+1 17753 IF((I).GT.(2))GOTO 17752 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 17771 FWHM(LINE-1+I) = DABS(A( (I-1)*3+3 ))/0.60056121 17771 CONTINUE GOTO 17751 17752 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 17791 SWITCH(3*(INDEX-1)+3) = 0.0 17791 CONTINUE IF(ILEFT .GE. 0 .OR. IRIGHT .GE. 0)GOTO 17811 SWITCH(3*(INDEX-1)+3) = 0.0 17811 CONTINUE RETURN END SUBROUTINE FN3LBD(LINE,LEFT,RIGHT,LFTDIO,RHTDIO) IMPLICIT REAL*8(A-H,O-Z) REAL*8 LFTDIO(500),RHTDIO(500) INTEGER LINE,LEFT,RIGHT LEFT = INT( LFTDIO(LINE-1) ) IF(INT( LFTDIO(LINE) ) .GE. LEFT)GOTO 17831 LEFT = INT( LFTDIO(LINE) ) 17831 CONTINUE IF(INT( LFTDIO(LINE+1) ) .GE. LEFT)GOTO 17851 LEFT = INT( LFTDIO(LINE+1) ) 17851 CONTINUE RIGHT = INT( RHTDIO(LINE+1) ) IF(INT( RHTDIO(LINE) ) .LE. RIGHT)GOTO 17871 RIGHT = INT( RHTDIO(LINE) ) 17871 CONTINUE IF(INT( RHTDIO(LINE-1) ) .LE. RIGHT)GOTO 17891 RIGHT = INT( RHTDIO(LINE-1) ) 17891 CONTINUE RETURN END SUBROUTINE FN2LBD(LINE,LEFT,RIGHT,LFTDIO,RHTDIO) IMPLICIT REAL*8(A-H,O-Z) REAL*8 LFTDIO(500),RHTDIO(500) INTEGER LINE,LEFT,RIGHT LEFT = INT( LFTDIO(LINE) ) RIGHT= INT( RHTDIO(LINE+1) ) IF(INT( LFTDIO(LINE+1) ) .GE. LEFT)GOTO 17911 LEFT = INT( LFTDIO(LINE+1) ) 17911 CONTINUE IF(INT( RHTDIO(LINE) ) .LE. RIGHT)GOTO 17931 RIGHT = INT( RHTDIO(LINE) ) 17931 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 17940 I=1 GOTO 17943 17941 I=I+(2) 17943 IF((2)*((I)-(2*N-1)).GT.0)GOTO 17942 X(I) = DBLE(INDEX) X(I+1) = 1.0 - SPEC(INDEX)/CONTUM(DBLE(INDEX)) INDEX = INDEX + 1 GOTO 17941 17942 CONTINUE RETURN END SUBROUTINE RDOLIN(NPTS) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK INTEGER NPTS REAL*8 A(9),COV(9,9) LOGICAL RHTWGB,DELETED 17950 I=1 GOTO 17953 17951 I=I+1 17953 IF((I).GT.(NREDO))GOTO 17952 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 17971 NREDO = NREDO - 1 17980 J=I GOTO 17983 17981 J=J+1 17983 IF((J).GT.(NREDO))GOTO 17982 REDO(J) = REDO(J+1) GOTO 17981 17982 CONTINUE I = I - 1 GOTO 17951 17971 CONTINUE CALL OBFWHML(LINE,A,COV,NPTS) CALL FT1GAUS(LINE) CALL SFTBLS(LINE) GOTO 17951 17952 CONTINUE 17990 I=1 GOTO 17993 17991 I=I+1 17993 IF((I).GT.(NREDO))GOTO 17992 CALL FNDRDL(REDO(I),LINE,WAVELN,NOLINES) IF((.NOT.(RHTWGB(LINE))) .AND. (.NOT.(RHTWGB(LINE-1))))GOTO 18011 CALL FNDSAE(LINE,ISTART,IEND,I) 18020 J=ISTART GOTO 18023 18021 J=J+1 18023 IF((J).GT.(IEND))GOTO 18022 CALL FTBLND(J) GOTO 18021 18022 CONTINUE 18011 CONTINUE GOTO 17991 17992 CONTINUE RETURN END SUBROUTINE FNDSAE(LINE,ISTART,IEND,IREDO) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK INTEGER LINE,ISTART,IEND,IREDO LOGICAL RHTWGB 18030 IEND=LINE GOTO 18033 18031 IEND=IEND+1 18033 IF((IEND).GT.(NOLINES))GOTO 18032 IF(.NOT.(.NOT. RHTWGB(IEND)))GOTO 18051 GOTO 18032 18051 CONTINUE IF(REDO(IREDO+1) .NE. WAVELN(IEND) .OR. IREDO .GE. NREDO)GOTO 1807 *1 IREDO = IREDO + 1 18071 CONTINUE GOTO 18031 18032 CONTINUE 18080 ISTART=LINE GOTO 18083 18081 ISTART=ISTART+(-1) 18083 IF((-1)*((ISTART)-(1)).GT.0)GOTO 18082 IF(.NOT.(.NOT. RHTWGB(ISTART-1)))GOTO 18101 GOTO 18082 18101 CONTINUE GOTO 18081 18082 CONTINUE RETURN END SUBROUTINE FNDRDL(WAVE,LINE,WAVELN,N) IMPLICIT REAL*8(A-H,O-Z) REAL*8 WAVE,WAVELN(500) INTEGER LINE,N 18110 LINE=1 GOTO 18113 18111 LINE=LINE+1 18113 IF((LINE).GT.(N))GOTO 18112 IF(WAVE .NE. WAVELN(LINE))GOTO 18131 RETURN 18131 CONTINUE GOTO 18111 18112 CONTINUE RETURN END LOGICAL FUNCTION TLINWS(IDUMMY) IMPLICIT REAL*8(A-H,O-Z) LOGICAL RHTWGB COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK INTEGER I,IDUMMY REAL*8 LAST NREDO = 0 LAST = 0.0 TLINWS = .FALSE. 18140 I=1 GOTO 18143 18141 I=I+1 18143 IF((I).GT.(NOLINES))GOTO 18142 IF(.NOT.(RHTWGB(I)))GOTO 18161 IF((LINEID(I) .NE. 'TELLURIC ' .OR. LINEID(I+1) .EQ. 'TELLURIC ' %) .AND. (LINEID(I+1) .NE. 'TELLURIC ' .OR. LINEID(I) .EQ. 'TELLUR %IC '))GOTO 18181 TLINWS = .TRUE. IF(NREDO .LT. 100)GOTO 18201 WRITE(8,18210) 18210 FORMAT('MAXIMUM NUMBER OF REDO LINES REACHED') GOTO 18142 18201 CONTINUE IF(LINEID(I+1) .NE. 'TELLURIC ' .OR. WAVELN(I) .EQ. LAST)GOTO 182 %31 NREDO = NREDO + 1 REDO(NREDO) = WAVELN(I) GOTO 18221 18231 IF(LINEID(I) .NE. 'TELLURIC ')GOTO 18241 NREDO = NREDO + 1 REDO(NREDO) = WAVELN(I+1) LAST = REDO(NREDO) 18241 CONTINUE 18221 CONTINUE 18181 CONTINUE 18161 CONTINUE GOTO 18141 18142 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 18250 I=1 GOTO 18253 18251 I=I+1 18253 IF((I).GT.(NH2O))GOTO 18252 IF(WEIGHT(I) .LT. 0.0)GOTO 18271 FACTOR(COUNT) = FACTOR(I) ERROR(COUNT) = ERROR(I) WEIGHT(COUNT) = WEIGHT(I) SHIFT(COUNT) = SHIFT(I) COUNT = COUNT + 1 18271 CONTINUE GOTO 18251 18252 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 18280 I=1 GOTO 18283 18281 I=I+1 18283 IF((I).GT.(NFAC - 1))GOTO 18282 18290 J=1 GOTO 18293 18291 J=J+1 18293 IF((J).GT.(NFAC - 1))GOTO 18292 IF(FACTOR(J) .LE. FACTOR(J+1))GOTO 18311 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 18311 CONTINUE GOTO 18291 18292 CONTINUE GOTO 18281 18282 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 18320 I=J GOTO 18323 18321 I=I+1 18323 IF((I).GT.(NFAC-1))GOTO 18322 FACTOR(I) = FACTOR(I+1) ERROR(I) = ERROR(I+1) WEIGHT(I) = WEIGHT(I+1) SHIFT(I) = SHIFT(I+1) GOTO 18321 18322 CONTINUE RETURN END SUBROUTINE DIVTEL(SPCTRUM,NPTS) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK REAL*8 SPCTRUM(10000) INTEGER NPTS,I,J 18330 I=1 GOTO 18333 18331 I=I+1 18333 IF((I).GT.(NOLINES))GOTO 18332 IF(LINEID(I) .NE. 'TELLURIC ')GOTO 18351 LIMIT1 = NINT(CENTRE(I)-2.0*FWHM(I)) LIMIT2 = NINT(CENTRE(I)+2.0*FWHM(I)) IF(LIMIT1 .GE. 1)GOTO 18371 LIMIT1 = 1 GOTO 18361 18371 IF(LIMIT2 .LE. NPTS)GOTO 18381 LIMIT2 = NPTS 18381 CONTINUE 18361 CONTINUE A1 = DEPTH(I) A2 = CENTRE(I) A3 = FWHM(I)*0.60056121 18390 J=LIMIT1 GOTO 18393 18391 J=J+1 18393 IF((J).GT.(LIMIT2))GOTO 18392 FACTOR = 1.0 - A1*EXP(-( (A2-DBLE(J))/A3 )**2) SPCTRUM(J) = SPCTRUM(J)/FACTOR GOTO 18391 18392 CONTINUE 18351 CONTINUE GOTO 18331 18332 CONTINUE RETURN END SUBROUTINE RMTLFL IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK INTEGER I 18400 I=1 GOTO 18403 18401 I=I+1 18403 IF((I).GT.(NOLINES))GOTO 18402 IF(LINEID(I) .NE. 'TELLURIC ')GOTO 18421 CALL REMFLS(I) I = I - 1 18421 CONTINUE GOTO 18401 18402 CONTINUE RETURN END SUBROUTINE FITDSP IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK REAL*8 X(100),Y(100) INTEGER EXCLUDE IF(NORFLN .LE. NOGDLN)GOTO 18441 RETURN 18441 CONTINUE EXCLUDE = 0 18450 I=1 GOTO 18453 18451 I=I+1 18453 IF((I).GT.(NOGDLN))GOTO 18452 IF(WAVELN(GOOD(I)) .LE. 0.0 .OR. DABS( CENTRE(GOOD(I))-CHANNEL(WAV *ELN(GOOD(I))) ) .GE. 1.5)GOTO 18471 X(I-EXCLUDE) = CENTRE(GOOD(I)) Y(I-EXCLUDE) = WAVELN(GOOD(I)) GOTO 18481 18471 CONTINUE EXCLUDE = EXCLUDE + 1 18481 CONTINUE 18461 CONTINUE GOTO 18451 18452 CONTINUE N = NOGDLN - EXCLUDE CALL FITLINE(X,Y,N,DISP,OFFSET) IF(N .LE. 2)GOTO 18501 CALL PARABOL(X,Y,N,DISP2,DISP1,OFFSET) 18501 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(100),DW(100),PIX1(100) 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 * 18521 ICENTRE = NINT(CENTRE(LINE)) DEEP = 1.0 - SPEC(ICENTRE)/CONTUM(DBLE(ICENTRE)) WAVE = WAV(CENTRE(LINE)) CALL GTBSFW(WAVE,DEEP,WIDTH,SIGWDTH) GOTO 18511 18521 IF(FWHM(LINE) .NE. 0.0)GOTO 18531 WRITE(8,18540)LINE 18540 FORMAT (' CANNOT DEFINE AN EW FOR LINE ',I3,' BECAUSE NO FWHM-DEPT %H RELATION', ' EXISTS') EW(LINE) = 0.0 RETURN GOTO 18551 18531 CONTINUE WIDTH = FWHM(LINE) 18551 CONTINUE 18511 CONTINUE IF((.NOT.(LINIWD(WAVELN(LINE)))) .AND. (SIGWDTH .NE. 0.0))GOTO 185 *71 EW(LINE) = FWHM(LINE)*DEPTH(LINE)*0.60056121*DMYSQ(PI) * DISP*1000 *.0 DELTEW(LINE)= DELTEW(LINE) * EW(LINE) RETURN 18571 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 18591 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,18600)LINEID(LINE),WAVELN(LINE),FWHM(LINE),AREA,WIDTH,EW(L *INE) 18600 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 18611 18591 CONTINUE EW(LINE) = FWHM(LINE)*DEPTH(LINE)*0.60056121*DMYSQ(PI) * DISP*1000 *.0 DELTEW(LINE)= DELTEW(LINE) * EW(LINE) 18611 CONTINUE 18581 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. 18620 I=1 GOTO 18623 18621 I=I+1 18623 IF((I).GT.(IWIDE))GOTO 18622 IF(WIDE(I) .NE. WAVE)GOTO 18641 LINIWD = .TRUE. GOTO 18622 18641 CONTINUE GOTO 18621 18622 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(100),DW(100),PIX1(100) 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 )') 18650 I=1 GOTO 18653 18651 I=I+1 18653 IF((I).GT.(NOLINES))GOTO 18652 IF(FWHM(I) .EQ. 0.0 .OR. FWHM(I) .GE. MINFWHM)GOTO 18671 MINFWHM = FWHM(I) GOTO 18661 18671 IF(FWHM(I) .EQ. 0.0 .OR. FWHM(I) .LE. MAXFWHM)GOTO 18681 MAXFWHM = FWHM(I) 18681 CONTINUE 18661 CONTINUE IF(DEPTH(I) .LE. MAXDEP)GOTO 18701 MAXDEP = DEPTH(I) 18701 CONTINUE GOTO 18651 18652 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 )') 18710 I=1 GOTO 18713 18711 I=I+1 18713 IF((I).GT.(NOGDLN))GOTO 18712 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 18711 18712 CONTINUE WRITE(9,'(10H MARKER 3 )') J = 1 18720 I=1 GOTO 18723 18721 I=I+1 18723 IF((I).GT.(NOLINES))GOTO 18722 IF(I .NE. GOOD(J))GOTO 18741 J = J + 1 GOTO 18721 18741 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 18721 18722 CONTINUE WRITE(9,'(6H LINE )') WRITE(9,'(10H NOMARKER )') IF(WIDFLG .NE. -1)GOTO 18761 RETURN GOTO 18751 18761 IF(WIDFLG .NE. 0)GOTO 18771 WRITE(9,'(6H 0.0 ,F13.4,/,6H 0.5 ,F13.4)')INCPT,INCPT GOTO 18781 18771 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 18781 CONTINUE 18751 CONTINUE RETURN END SUBROUTINE PRHLFL IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK OPEN(UNIT=13,FILE='H2OLIST',STATUS='OLD') REWIND 13 WRITE(13,18790)SLOPE,INCPT,MINIDP 18790 FORMAT(F12.9,2X,F15.9,2X,F15.9) 18800 I=1 GOTO 18803 18801 I=I+1 18803 IF((I).GT.(NOLINES))GOTO 18802 WRITE(13,18810)CENTRE(I),FWHM(I),DEPTH(I) 18810 FORMAT ('TELLURIC ',F10.3,F10.5,F10.7) GOTO 18801 18802 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(100),DW(100),PIX1(100) 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,18820)SPTITLE 18820 FORMAT (A80) WRITE(10,18830)CURSPC,CURORD,CURIMR 18830 FORMAT ('SPECTRUM ',I3,', ORDER ',I3,', IMAGE ROW ',I3) WRITE(12,18840)SPTITLE 18840 FORMAT (A80) WRITE(12,18850)CURSPC,CURORD,CURIMR 18850 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK CHARACTER*80 TITLE INTEGER I 18860 I=1 GOTO 18863 18861 I=I+1 18863 IF((I).GT.(NOLINES))GOTO 18862 IF(LINEID(I)(1:4) .EQ. 'JUNK')GOTO 18881 WRITE(10,18890)LINEID(I)(1:5),WAVELN(I),ATOM(I),EPLOW(I),GF(I),EW( *I) 18890 FORMAT (A5,F10.3,F10.1,F10.3,10X,F10.3,20X,F5.1) WRITE(12,18900)LINEID(I)(1:5),WAVELN(I),ATOM(I),EPLOW(I),GF(I),DEP *TH(I) 18900 FORMAT (A5,F10.3,F10.1,F10.3,10X,F10.3,20X,F5.3) 18881 CONTINUE GOTO 18861 18862 CONTINUE RETURN END SUBROUTINE PRSPPF(TITLE,NPTS) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) CHARACTER*80 TITLE INTEGER NPTS,I,J,LEFT,RIGHT LOGICAL BADPLT SCREEN =.FALSE. CALL DETPLB (NPTS) IF(NPLOTS .LE. 0)GOTO 18921 18930 I=1 GOTO 18933 18931 I=I+1 18933 IF((I).GT.(NPLOTS))GOTO 18932 XLENGTH = DBLE( NPLOTR(I)-NPLOTL(I)+1 )*2.54/20.0 IF(.NOT.(BADPLT(WPLOTL(I),WPLOTR(I),NPTS)))GOTO 18951 GOTO 18931 18951 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 18931 18932 CONTINUE GOTO 18911 18921 IF(.NOT.(PLOTALL))GOTO 18961 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) 18961 CONTINUE 18911 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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) 18970 I=1 GOTO 18973 18971 I=I+1 18973 IF((I).GT.(NPLOTS))GOTO 18972 NPLOTL(I) = NINT( CHANNEL(WPLOTL(I)) ) IF(NPLOTL(I) .GE. 1)GOTO 18991 NPLOTL(I) = 1 18991 CONTINUE NPLOTR(I) = NINT( CHANNEL(WPLOTR(I)) ) IF(NPLOTR(I) .LE. NPTS)GOTO 19011 NPLOTL(I) = NPTS 19011 CONTINUE WPLOTL(I) = WAV( DBLE(NPLOTL(I)) ) WPLOTR(I) = WAV( DBLE(NPLOTR(I)) ) GOTO 18971 18972 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 19031 IF(WAVER .GT. WAV(41.0D0))GOTO 19051 BADPLT = .TRUE. 19051 CONTINUE WAVEL = WAV(1.0D0) GOTO 19021 19031 IF(WAVER .LE. ENDWAV)GOTO 19061 IF(WAVEL .LE. WAV(DBLE(NPTS-41)))GOTO 19081 BADPLT = .TRUE. 19081 CONTINUE WAVER = ENDWAV 19061 CONTINUE 19021 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,19090)TITLE(1:50) 19090 FORMAT (8H TITLE $,A50,1H$) WRITE(11,19100) 19100 FORMAT (' XLABEL /WAVELENGTH (A)/') WRITE(11,19110) 19110 FORMAT (23H YLABEL /RELATIVE FLUX/) WRITE(11,19120)XLENGTH 19120 FORMAT (9H XLENGTH ,F6.2) WRITE(11,19130) 19130 FORMAT (14H YLENGTH 24.5 ) WRITE(11,19140) 19140 FORMAT (14H XFORMAT F6.0 ) WRITE(11,19150) 19150 FORMAT (14H YFORMAT F5.2 ) WRITE(11,19160)XMIN 19160 FORMAT (6H XMIN ,F6.1) WRITE(11,19170)XMAX 19170 FORMAT (6H XMAX ,F6.1) WRITE(11,19180)YMIN 19180 FORMAT (6H YMIN ,F10.6) WRITE(11,19190)YMAX 19190 FORMAT (6H YMAX ,F10.6) RETURN END SUBROUTINE PRNTFX(LEFT,RIGHT) IMPLICIT REAL*8(A-H,O-Z) INTEGER LEFT,RIGHT WRITE(11,19200) 19200 FORMAT(10H MARKER 3 ) WRITE(11,19210) 19210 FORMAT(8H NOLINE ) WRITE(11,19220) 19220 FORMAT(' COLOR BLUE ') 19230 I=LEFT GOTO 19233 19231 I=I+1 19233 IF((I).GT.(RIGHT))GOTO 19232 WAVE = WAV(DBLE(I)) FLUX = SPEC(I) WRITE(11,19240)WAVE,FLUX 19240 FORMAT (F10.3,2X,F10.6) GOTO 19231 19232 CONTINUE RETURN END SUBROUTINE PRNTCN(LEFT,RIGHT) IMPLICIT REAL*8(A-H,O-Z) INTEGER LEFT,RIGHT,I REAL*8 WAVE,FLUX WRITE(11,19250) 19250 FORMAT(10H NOMARKER ,/,6H LINE ,/,13H COLOR GREEN ) 19260 I=LEFT GOTO 19263 19261 I=I+1 19263 IF((I).GT.(RIGHT))GOTO 19262 WAVE = WAV(DBLE(I)) FLUX = CONTUM(DBLE(I)) WRITE(11,19270)WAVE,FLUX 19270 FORMAT (F10.3,2X,F10.6) GOTO 19261 19262 CONTINUE RETURN END SUBROUTINE PRTLNF(IPLOT) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK REAL*8 POSN,LEFT,RIGHT,LEFT1,RIGHT1,FLUX0,FLUX1,FLUX2 INTEGER IPLOT,LINE,INEXT,ILAST LOGICAL LNOOBD POSN = 0.0 19280 LINE=1 GOTO 19283 19281 LINE=LINE+1 19283 IF((LINE).GT.(NOLINES))GOTO 19282 INEXT = LINE + 1 ILAST = LINE - 1 CALL GETLNB(LINE,LEFT,RIGHT) CALL GETLNB(INEXT,LEFT1,RIGHT1) IF(LEFT1 .NE. LEFT)GOTO 19301 LEFT1 = RIGHT 19301 CONTINUE IF(POSN .GE. LEFT)GOTO 19321 POSN = LEFT 19321 CONTINUE IF(.NOT.(LNOOBD(LEFT,RIGHT,IPLOT)))GOTO 19341 GOTO 19281 19341 CONTINUE IF((BLEND(LINE) .NE. 0) .AND. (BLEND(LINE) .NE. 1))GOTO 19361 WRITE(11,19370) 19370 FORMAT(' NOMARKER ',/,' LINE ',/,' COLOR RED ',/) 19361 CONTINUE CALL OPCRLF(LINE,POSN,BLEND(LINE),LEFT1,RIGHT) GOTO 19281 19282 CONTINUE WRITE(11,19380) 19380 FORMAT(' COLOR BLACK ',/) RETURN END SUBROUTINE GETLNB(LINE,LEFT,RIGHT) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 19401 RETURN GOTO 19391 19401 IF(DABS(DEPTH(LINE)) .GT. 1.0D-8)GOTO 19411 RETURN 19411 CONTINUE 19391 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 19431 LEFT = CENT - 50.0 RIGHT = CENT + 50.0 19431 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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) REAL*8 LEFT,RIGHT,PLEFT,PRIGHT INTEGER IPLOT LNOOBD = .TRUE. IF(.NOT.(SCREEN))GOTO 19451 PLEFT = DBLE(SCLEFT) PRIGHT= DBLE(SCRGHT) GOTO 19461 19451 CONTINUE PLEFT = DBLE(NPLOTL(IPLOT)) PRIGHT= DBLE(NPLOTR(IPLOT)) 19461 CONTINUE 19441 CONTINUE IF(LEFT .GE. PLEFT)GOTO 19481 IF(RIGHT .GE. PLEFT)GOTO 19501 RETURN 19501 CONTINUE LEFT = PLEFT GOTO 19471 19481 IF(RIGHT .LE. PRIGHT)GOTO 19511 IF(LEFT .LE. PRIGHT)GOTO 19531 RETURN 19531 CONTINUE RIGHT = PRIGHT 19511 CONTINUE 19471 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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) INEXT = LINE+1 ILAST = LINE-1 FIRST = .TRUE. 19540 CONTINUE 19541 CONTINUE CALL EVALNF(LINE,POSN,FLUX0) 19550 INEXT=LINE+1 GOTO 19553 19551 INEXT=INEXT+1 19553 IF((INEXT).GT.(LINE+2))GOTO 19552 CALL EVALNF(INEXT,POSN,FLUX1) FLUX0 = FLUX0 + FLUX1 GOTO 19551 19552 CONTINUE 19560 ILAST=LINE-1 GOTO 19563 19561 ILAST=ILAST+(-1) 19563 IF((-1)*((ILAST)-(LINE-2)).GT.0)GOTO 19562 CALL EVALNF(ILAST,POSN,FLUX1) FLUX0 = FLUX0 + FLUX1 GOTO 19561 19562 CONTINUE FLUX0 = (1.0 - FLUX0)*CONTUM(POSN) IF(.NOT.(SCREEN))GOTO 19581 IF(.NOT.(FIRST))GOTO 19601 CALL PGP_MOVEA(WAV(POSN),FLUX0) FIRST = .FALSE. 19601 CONTINUE CALL PLTLFX(POSN,FLUX0) GOTO 19611 19581 CONTINUE CALL PRNTPT(POSN,FLUX0) 19611 CONTINUE 19571 CONTINUE IF(BLEND .GT. 0)GOTO 19631 IF((POSN .LT. LEFT1 .OR. LEFT1 .LE. 0.0) .AND. (POSN .LT. RIGHT))G *OTO 19651 GOTO 19542 19651 CONTINUE 19631 CONTINUE IF((POSN .LT. LEFT1 .OR. LEFT1 .LE. 0.0) .AND. (POSN .LT. RIGHT))G *OTO 19671 GOTO 19542 19671 CONTINUE POSN = POSN + 0.25 GOTO 19541 19542 CONTINUE RETURN END SUBROUTINE EVALNF(LINE,POSN,FLUX) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 19680 I=4 GOTO 19683 19681 I=I+1 19683 IF((I).GT.(9))GOTO 19682 SW(I) = 0.0 GOTO 19681 19682 CONTINUE FLUX = 0.0 IF((LINE .GT. 0) .AND. (LINE .LE. NOLINES))GOTO 19701 FLUX = 0.0 RETURN 19701 CONTINUE IF(FWHM(LINE) .NE. 0.0)GOTO 19721 RETURN 19721 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,19730)WAV(POSN),FLUX 19730 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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) INTEGER START,FINISH,NPTS,LPG,PGOPEN LOGICAL PLWIISP IF(.NOT.(.NOT. SCREEN))GOTO 19751 RETURN 19751 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 19771 CALL DETPLB (NPTS) WSTART = WAV(1.0D0) WEND = WAV( DBLE(NPTS) ) 19780 I=1 GOTO 19783 19781 I=I+1 19783 IF((I).GT.(NPLOTS))GOTO 19782 IF(.NOT.(PLWIISP (WSTART,WEND,I)))GOTO 19801 START = NPLOTL(I) FINISH= NPLOTR(I) CNPLTG = .FALSE. CALL LFTSPC(START,FINISH,I) 19801 CONTINUE GOTO 19781 19782 CONTINUE GOTO 19761 19771 IF(.NOT.(PLOTALL))GOTO 19811 START = 1 FINISH= NPTS CNPLTG = .FALSE. CALL LFTSPC(START,FINISH,I) 19811 CONTINUE 19761 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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) COMMON/IBADD/ NOBAD,IBADL(300),IBADR(300) INTEGER NOBAD,IBADL,IBADR PLWIISP = .FALSE. IF(WPLOTR(NPLOT) .LE. WSTART .OR. WPLOTL(NPLOT) .GE. WEND)GOTO 198 *31 19840 I=1 GOTO 19843 19841 I=I+1 19843 IF((I).GT.(NOBAD))GOTO 19842 IF(NPLOTL(NPLOT) .LT. IBADL(I) .OR. NPLOTR(NPLOT) .GT. IBADR(I))GO *TO 19861 RETURN 19861 CONTINUE GOTO 19841 19842 CONTINUE PLWIISP = .TRUE. 19831 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 19870 CONTINUE 19871 CONTINUE IF(FINISH-START .LE. 110)GOTO 19891 IEND = START + 100 CALL PLTSCR(START,IEND,EMPTY) IF(.NOT.(EMPTY))GOTO 19911 START = IEND + 100 GOTO 19871 19911 CONTINUE CALL DSPLUS(ISHIFT) CALL MRKLIN CALL INTUSR(J,ISHIFT) IF(J .EQ. IPLOT)GOTO 19931 IPLOT = J GOTO 19872 19931 CONTINUE IF(IEND+ISHIFT .LT. 1)GOTO 19951 START = IEND + ISHIFT GOTO 19961 19951 CONTINUE START = 1 19961 CONTINUE 19941 CONTINUE GOTO 19881 19891 IF(FINISH-START .LT. 10)GOTO 19971 CALL PLTSCR(START,FINISH,EMPTY) IF(.NOT.(EMPTY))GOTO 19991 START = IEND + 100 GOTO 19871 19991 CONTINUE CALL DSPLUS(ISHIFT) CALL MRKLIN CALL INTUSR(IPLOT,ISHIFT) START = START + ISHIFT + 100 IF(ISHIFT .NE. 0)GOTO 20011 GOTO 19872 20011 CONTINUE GOTO 20021 19971 CONTINUE RETURN 20021 CONTINUE 19881 CONTINUE GOTO 19871 19872 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 20041 EMPTY = .TRUE. RETURN 20041 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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) 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 20061 YMAX = CMAX 20061 CONTINUE YRANGE = YMAX - YMIN YMAX = YMAX + 0.05*YRANGE YMIN = YMIN - 0.05*YRANGE IF(YRANGE .NE. 0.0)GOTO 20081 YMAX = 1.05*YMAX YMIN = 0.95*YMIN 20081 CONTINUE IF(YMIN .GE. 0.0)GOTO 20101 YMIN = 0.0 20101 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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) 20110 I=ISTART GOTO 20113 20111 I=I+1 20113 IF((I).GT.(IEND))GOTO 20112 IF(SPEC(I) .GE. YMIN .OR. .NOT.(.NOT.BADIOD(I)))GOTO 20131 YMIN = SPEC(I) 20131 CONTINUE GOTO 20111 20112 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) 20140 I=ISTART GOTO 20143 20141 I=I+1 20143 IF((I).GT.(IEND))GOTO 20142 IF(SPEC(I) .LE. YMAX .OR. .NOT.(.NOT.BADIOD(I)))GOTO 20161 YMAX = SPEC(I) 20161 CONTINUE GOTO 20141 20142 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)) 20170 I=ISTART GOTO 20173 20171 I=I+1 20173 IF((I).GT.(IEND))GOTO 20172 IF(CONTUM(DBLE(I)) .LE. YMAX)GOTO 20191 YMAX = CONTUM(DBLE(I)) 20191 CONTINUE GOTO 20171 20172 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 20200 I=1 GOTO 20203 20201 I=I+1 20203 IF((I).GT.(N))GOTO 20202 YPLOT(I) = REAL(SPEC(I+ISTART-1)) XPLOT(I) = REAL(WAV(DBLE(I+ISTART-1))) GOTO 20201 20202 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)) 20210 I=ISTART GOTO 20213 20211 I=I+1 20213 IF((I).GT.(IEND))GOTO 20212 II = I-ISTART+1 YPLOT(II) = REAL(SPEC(I)) XPLOT(II) = WAV(DBLE(I)) GOTO 20211 20212 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))) 20220 I=ISTART GOTO 20223 20221 I=I+1 20223 IF((I).GT.(IEND))GOTO 20222 CALL PGP_DRAWA(WAV(DBLE(I)),CONTUM(DBLE(I))) GOTO 20221 20222 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK LOGICAL LNOOBD INTEGER ISHIFT,LINE REAL*8 LEFT,RIGHT,LEFT1,RIGHT1 LEFT = 0.0 RIGHT = 0.0 ISHIFT = 0 POSN = 0.0 20230 LINE=1 GOTO 20233 20231 LINE=LINE+1 20233 IF((LINE).GT.(NOLINES))GOTO 20232 INEXT = LINE + 1 ILAST = LINE - 1 CALL GETLNB(LINE,LEFT,RIGHT) CALL GETLNB(INEXT,LEFT1,RIGHT1) IF(LEFT1 .NE. LEFT)GOTO 20251 LEFT1 = RIGHT 20251 CONTINUE IF(POSN .GE. LEFT)GOTO 20271 POSN = LEFT 20271 CONTINUE IF(INEXT .LE. NOLINES)GOTO 20291 LEFT1 = RIGHT 20291 CONTINUE IF(.NOT.(LNOOBD(LEFT,RIGHT,ISHIFT)))GOTO 20311 GOTO 20231 20311 CONTINUE CALL OPCRLF(LINE,POSN,BLEND(LINE),LEFT1,RIGHT) GOTO 20231 20232 CONTINUE RETURN END SUBROUTINE PLNXTL(ISHIFT) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) CHARACTER*1 ANS IF(.NOT.(CNPLTG))GOTO 20331 RETURN 20331 CONTINUE 20340 LINE=1 GOTO 20343 20341 LINE=LINE+1 20343 IF((LINE).GT.(NOLINES))GOTO 20342 IF(CENTRE(LINE) .LE. DBLE(SCRGHT))GOTO 20361 MID = (SCLEFT + SCRGHT)/2 ISHIFT = NINT(CENTRE(LINE)) - MID - 100 RETURN 20361 CONTINUE GOTO 20341 20342 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 20381 ISHIFT = 10000 GOTO 20391 20381 CONTINUE ISHIFT = -100 20391 CONTINUE 20371 CONTINUE RETURN END SUBROUTINE PLLSTL(ISHIFT) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) IF(.NOT.(CNPLTG))GOTO 20411 RETURN 20411 CONTINUE 20420 LINE=NOLINES GOTO 20423 20421 LINE=LINE+(-1) 20423 IF((-1)*((LINE)-(1)).GT.0)GOTO 20422 IF(CENTRE(LINE) .GE. DBLE(SCLEFT))GOTO 20441 MID = (SCLEFT + SCRGHT)/2 ISHIFT = NINT(CENTRE(LINE)) - MID - 100 RETURN 20441 CONTINUE GOTO 20421 20422 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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) 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. 20450 CONTINUE 20451 CONTINUE CALL DISPRM READ(5,'(A2)')COMM IF(COMM .NE. 'a ')GOTO 20471 CALL AGAN GOTO 20461 20471 IF(COMM .NE. 'ac')GOTO 20481 CALL ADDCT GOTO 20461 20481 IF(COMM .NE. 'b ')GOTO 20491 CALL BLOWUP GOTO 20461 20491 IF(COMM .NE. 'z ')GOTO 20501 CALL ZROPLT GOTO 20461 20501 IF(COMM .NE. 'cc')GOTO 20511 CALL DELCNT(FOUND) IF(.NOT.(FOUND))GOTO 20531 CALL ADDCT 20531 CONTINUE GOTO 20461 20511 IF(COMM .NE. 'dc')GOTO 20541 CALL DELCNT(FOUND) GOTO 20461 20541 IF(COMM .NE. 'cp')GOTO 20551 CALL CONPLT GOTO 20461 20551 IF(COMM .NE. 'fc')GOTO 20561 CALL CONFIT GOTO 20461 20561 IF(COMM .NE. 'nf')GOTO 20571 CALL DTTODT GOTO 20461 20571 IF(COMM .NE. 'ml')GOTO 20581 CALL MRKLIN GOTO 20461 20581 IF(COMM .NE. 'op')GOTO 20591 CALL OVRPDAT GOTO 20461 20591 IF(COMM .NE. 'ds')GOTO 20601 CNPLTG = .FALSE. ISHIFT = -100 RETURN GOTO 20461 20601 IF(COMM .NE. 'ew')GOTO 20611 CALL MEASFET GOTO 20461 20611 IF(COMM .NE. 'fl')GOTO 20621 CALL PLFLSP GOTO 20461 20621 IF(COMM .NE. 'ha')GOTO 20631 CALL PAPCPY GOTO 20461 20631 IF(COMM .NE. 'r ')GOTO 20641 CALL REJECT GOTO 20461 20641 IF(COMM .NE. 'rm')GOTO 20651 CALL RMEASLN GOTO 20461 20651 IF(COMM .NE. 'p ')GOTO 20661 CALL PNT GOTO 20461 20661 IF(COMM .NE. 'pb')GOTO 20671 ISHIFT = - 200 RETURN GOTO 20461 20671 IF(COMM .NE. 'pl')GOTO 20681 CALL OPSYNF(W0,WSTEP) CALL PLTSYN(W0,WSTEP,PAPER) CLOSE(UNIT=13) GOTO 20461 20681 IF(COMM .NE. 'nn')GOTO 20691 ISHIFT = 10000 RETURN GOTO 20461 20691 IF(COMM .NE. 'n ')GOTO 20701 CALL PLNXTL(ISHIFT) RETURN GOTO 20461 20701 IF(COMM .NE. 'l ')GOTO 20711 CALL PLLSTL(ISHIFT) RETURN GOTO 20461 20711 IF(COMM .NE. 'll')GOTO 20721 IF(IPLOT .NE. 0)GOTO 20741 GOTO 20451 20741 CONTINUE IPLOT = IPLOT - 2 IF(IPLOT .GE. 0)GOTO 20761 IPLOT = 0 20761 CONTINUE RETURN GOTO 20461 20721 IF(COMM .NE. 'c ')GOTO 20771 RETURN GOTO 20461 20771 IF(COMM .NE. 'q ')GOTO 20781 IPLOT = 100 RETURN GOTO 20461 20781 IF(COMM .NE. 'sg')GOTO 20791 NGAUSS = 1 CALL INMLGS(NGAUSS) GOTO 20461 20791 IF(COMM .NE. 'dg')GOTO 20801 NGAUSS = 2 CALL INMLGS(NGAUSS) GOTO 20461 20801 IF(COMM .NE. 'tg')GOTO 20811 NGAUSS = 3 CALL INMLGS(NGAUSS) GOTO 20461 20811 IF(COMM .NE. 'sl')GOTO 20821 CALL DSPLUS(I) GOTO 20461 20821 IF(COMM .NE. 'v ')GOTO 20831 CALL SETVSNI GOTO 20461 20831 IF(COMM .NE. 'ab')GOTO 20841 STOP 20841 CONTINUE 20461 CONTINUE GOTO 20451 20452 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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) 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 20861 CALL RPLTCT CALL DCRONP GOTO 20871 20861 CONTINUE CALL PLDTAY(ISTART,IEND) CALL PLTCTM(ISTART,IEND) CALL REPSYN(PAPER) 20871 CONTINUE 20851 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 20880 I=1 GOTO 20883 20881 I=I+1 20883 IF((I).GT.(NOLINES))GOTO 20882 IF(WAVELN(I) .LT. XMIN .OR. WAVELN(I) .GT. XMAX)GOTO 20901 CALL PGP_MOVEA(WAVELN(I),BOTTOM) CALL PGP_DRAWA(WAVELN(I),TOP) CALL PTLINL(WAVELN(I),YTEXT,LINEID(I)) 20901 CONTINUE GOTO 20881 20882 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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) 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 20921 CALL DCRONP GOTO 20931 20921 CONTINUE CALL PLDTAY(ISTART,IEND) CALL REPSYN(PAPER) 20931 CONTINUE 20911 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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) INTEGER ICHAR LOGICAL PAPER PAPER = .FALSE. CALL PGP_SEEDW(XMIN,XMAX,YMIN,YMAX) CALL PGP_VCURSR(ICHAR,X1,Y1) IF(ICHAR .NE. 121)GOTO 20951 CALL PGP_VCURSR(ICHAR,X2,Y2) IF(Y1 .LE. Y2)GOTO 20971 YMIN = Y2 YMAX = Y1 GOTO 20961 20971 IF(Y2 .LE. Y1)GOTO 20981 YMIN = Y1 YMAX = Y2 GOTO 20991 20981 CONTINUE RETURN 20991 CONTINUE 20961 CONTINUE GOTO 20941 20951 IF(ICHAR .NE. 120)GOTO 21001 CALL PGP_VCURSR(ICHAR,X2,Y2) IF(X1 .LE. X2)GOTO 21021 XMIN = X2 XMAX = X1 GOTO 21011 21021 IF(X2 .LE. X1)GOTO 21031 XMIN = X1 XMAX = X2 GOTO 21041 21031 CONTINUE RETURN 21041 CONTINUE 21011 CONTINUE GOTO 20941 21001 IF(ICHAR .NE. 101)GOTO 21051 CALL PGP_VCURSR(ICHAR,X2,Y2) IF(X1 .LE. X2)GOTO 21071 XMIN = X2 XMAX = X1 GOTO 21061 21071 IF(X2 .LE. X1)GOTO 21081 XMIN = X1 XMAX = X2 21081 CONTINUE 21061 CONTINUE IF(Y1 .LE. Y2)GOTO 21101 YMIN = Y2 YMAX = Y1 GOTO 21091 21101 IF(Y2 .LE. Y1)GOTO 21111 YMIN = Y1 YMAX = Y2 21111 CONTINUE 21091 CONTINUE IF(X1 .NE. X2 .OR. Y1 .NE. Y2)GOTO 21131 RETURN 21131 CONTINUE GOTO 21141 21051 CONTINUE CALL DISPRM WRITE(6,21150) 21150 FORMAT('MUST ENTER x OR y OR e') RETURN 21141 CONTINUE 20941 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 21171 CALL DCRONP GOTO 21181 21171 CONTINUE CALL PLDTAY(ISTART,IEND) CALL REPSYN(PAPER) 21181 CONTINUE 21161 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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 21201 CALL DISPRM WRITE(6,21210) 21210 FORMAT('NO CONTINUUM FOUND') RETURN 21201 CONTINUE CALL DISPRM WRITE(6,21220) 21220 FORMAT('ENTER BOUNDS') CALL PGP_VCURSR(ICHAR,X1,Y1) CALL PGP_VCURSR(ICHAR,X2,Y2) IF(X2 .GE. X1)GOTO 21241 XTEMP = X2 X2 = X1 X1 = XTEMP 21241 CONTINUE X1 = NINT(CHANNEL(X1)) X2 = NINT(CHANNEL(X2)) IF(.NOT.(CNTIOO(X1,X2,ICONT)))GOTO 21261 CALL DISPRM WRITE(6,21270) 21270 FORMAT('BAD CONTINUUM ORDER') RETURN 21261 CONTINUE OLEFT = CONLFT(ICONT) ORIGHT = CONRHT(ICONT) OSIZE = CONSIZE(ICONT) CONLFT(ICONT) = X1 CONRHT(ICONT) = X2 CONSIZE(ICONT) = X2-X1+1.0 IF(.NOT.(CNTBAD(ICONT)))GOTO 21291 CALL DISPRM WRITE(6,21300) 21300 FORMAT('BAD DIODES IN RANGE') CONLFT(ICONT) = OLEFT CONRHT(ICONT) = ORIGHT CONSIZE(ICONT) = OSIZE RETURN 21291 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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,21310) 21310 FORMAT('ENTER BOUNDS') CALL PGP_VCURSR(ICHAR,X1,Y1) CALL PGP_VCURSR(ICHAR,X2,Y2) IF(X2 .GE. X1)GOTO 21331 XTEMP = X2 X2 = X1 X1 = XTEMP 21331 CONTINUE IX1 = NINT(CHANNEL(X1)) IX2 = NINT(CHANNEL(X2)) IF(IX1 .GE. 1)GOTO 21351 IX1 = 1 21351 CONTINUE IF(IX2 .LE. NPTS)GOTO 21371 IX2 = NPTS 21371 CONTINUE IF((IX2 .GE. 1) .AND. (IX1 .LE. NPTS))GOTO 21391 CALL DISPRM WRITE(6,21400) 21400 FORMAT('WARNING: OUT OF BOUNDS; NO CONTINUUM ADDED ') RETURN 21391 CONTINUE NOCONT = NOCONT + 1 CONLFT(NOCONT) = IX1 CONRHT(NOCONT) = IX2 CONSIZE(NOCONT) = IX2-IX1+1 IF(.NOT.(CNTBAD(NOCONT)))GOTO 21421 CALL DISPRM WRITE(6,21430) 21430 FORMAT('WARNING: TOO MANY BAD DIODES; NO CONTINUUM ADDED') NOCONT = NOCONT - 1 RETURN 21421 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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 21440 K=CONLFT(ICONT) GOTO 21443 21441 K=K+1 21443 IF((K).GT.(CONRHT(ICONT)))GOTO 21442 IF(.NOT.(.NOT. BADIOD(K)))GOTO 21461 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 21461 CONTINUE GOTO 21441 21442 CONTINUE AVG = SXIWI/SNSIG SNSIG = 1.D0/DSQRT(SNSIG) IF(CONSIZE(ICONT) .LE. 1)GOTO 21481 CSIG = DMYSQ( ( SXI2 - (SXI**2)/ANUM )/(ANUM-1.0) ) CSIG = CSIG/DMYSQ(ANUM) 21481 CONTINUE CONFLUX(ICONT) = AVG SIGFLUX(ICONT) = CSIG IF(CSIG .GE. AVG*SNSIG)GOTO 21501 SIGFLUX(ICONT) = AVG*SNSIG 21501 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL FOUND FOUND = .FALSE. 21510 I=1 GOTO 21513 21511 I=I+1 21513 IF((I).GT.(NOCONT))GOTO 21512 DX = DBLE(CONSIZE(I))/2.0D0 IF(CONCENT(I) + DX .LT. X)GOTO 21531 IF(CONCENT(I) - DX .GT. X)GOTO 21551 ICONT = I FOUND = .TRUE. 21551 CONTINUE RETURN 21531 CONTINUE GOTO 21511 21512 CONTINUE RETURN END SUBROUTINE DCRONP IMPLICIT REAL*8(A-H,O-Z) REAL*4 XLOWER(1000),XUPPER(1000),YPLOT(1000) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM 21560 I=1 GOTO 21563 21561 I=I+1 21563 IF((I).GT.(NOCONT))GOTO 21562 DX = DBLE(CONSIZE(I))/2.0D0 XLOWER(I) = WAV(CONCENT(I)-DX) XUPPER(I) = WAV(CONCENT(I)+DX) YPLOT(I) = CONFLUX(I) GOTO 21561 21562 CONTINUE CALL PGERRX(NOCONT,XLOWER,XUPPER,YPLOT,3.0) 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM CNTIOO = .FALSE. XAVG = (X1+X2)/2.0 IF(ICONT .NE. 1)GOTO 21581 IF(NOCONT .NE. 1)GOTO 21601 RETURN 21601 CONTINUE IF(XAVG .LE. CONCENT(ICONT+1))GOTO 21621 CNTIOO = .TRUE. 21621 CONTINUE RETURN 21581 CONTINUE IF(ICONT .NE. NOCONT)GOTO 21641 IF(XAVG .GE. CONCENT(ICONT-1))GOTO 21661 CNTIOO = .TRUE. 21661 CONTINUE RETURN 21641 CONTINUE IF((XAVG .GE. CONCENT(ICONT-1)) .AND. (XAVG .LE. CONCENT(ICONT+1)) *)GOTO 21681 CNTIOO = .TRUE. 21681 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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 21701 CALL DISPRM WRITE(6,21710) 21710 FORMAT('NO CONTINUUM FOUND') RETURN 21701 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) CNPLTG = .TRUE. ISTART = 1 IEND = NPTS XMIN = WAV(DBLE(ISTART)) XMAX = WAV(DBLE(IEND)) IF(NOCONT .LT. 1)GOTO 21731 YMIN = CONFLUX(1) YMAX = CONFLUX(1) IF(NOCONT .LT. 2)GOTO 21751 21760 I=2 GOTO 21763 21761 I=I+1 21763 IF((I).GT.(NOCONT))GOTO 21762 IF(CONFLUX(I) .LE. YMAX)GOTO 21781 YMAX = CONFLUX(I) GOTO 21771 21781 IF(CONFLUX(I) .GE. YMIN)GOTO 21791 YMIN = CONFLUX(I) 21791 CONTINUE 21771 CONTINUE GOTO 21761 21762 CONTINUE 21751 CONTINUE YMIN = YMIN - 0.03 YMAX = YMAX + 0.03 GOTO 21801 21731 CONTINUE YMIN = 0.93 YMAX = 1.07 21801 CONTINUE 21721 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 21821 CALL DISPRM WRITE(6,21830) 21830 FORMAT('ONLY 7 SYNTHESIS FILES ALLOWED') RETURN 21821 CONTINUE CALL DISPRM WRITE(6,21840) 21840 FORMAT('ENTER FILENAME') CALL DISPRM NFILE = NFILE + 1 READ(5,'(A7)')FILES(NFILE) CALL DISPRM WRITE(6,21850) 21850 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 21871 W = W0 READ(13,*,END=21880)(FLUX(J),J=1,10) 21890 CONTINUE 21891 CONTINUE 21900 I=1 GOTO 21903 21901 I=I+1 21903 IF((I).GT.(10))GOTO 21902 IF(W .GT. XMAX .OR. W .LT. XMIN)GOTO 21921 Y = (1.0-FLUX(I))*CONTUM(CHANNEL(W)) IF(.NOT.(FIRST))GOTO 21941 IF(.NOT.(PAPER))GOTO 21961 WRITE(11,21970) 21970 FORMAT('COLOR BLACK') WRITE(11,21980) 21980 FORMAT('NOMARKER') WRITE(11,21990) 21990 FORMAT('DASHEDLINE 4') GOTO 22001 21961 CONTINUE CALL PGP_MOVEA(W,Y) 22001 CONTINUE 21951 CONTINUE FIRST = .FALSE. GOTO 22011 21941 CONTINUE IF(.NOT.(PAPER))GOTO 22031 WRITE(11,22040)W,Y 22040 FORMAT (F10.3,2X,F10.6) GOTO 22051 22031 CONTINUE CALL PGP_DRAWA(W,Y) 22051 CONTINUE 22021 CONTINUE 22011 CONTINUE 21931 CONTINUE 21921 CONTINUE W = W + WSTEP GOTO 21901 21902 CONTINUE READ(13,*,END=21880)(FLUX(J),J=1,10) IF(W .GT. XMAX)GOTO 21892 GOTO 21891 21892 CONTINUE RETURN 21880 CONTINUE IMAX = J - 1 22060 I=1 GOTO 22063 22061 I=I+1 22063 IF((I).GT.(IMAX))GOTO 22062 IF(W .GT. XMAX .OR. W .LT. XMIN)GOTO 22081 Y = (1.0-FLUX(I))*CONTUM(CHANNEL(W)) IF(.NOT.(FIRST))GOTO 22101 IF(.NOT.(PAPER))GOTO 22121 WRITE(11,22130) 22130 FORMAT('COLOR BLACK') WRITE(11,22140) 22140 FORMAT('NOMARKER') WRITE(11,22150) 22150 FORMAT('DASHEDLINE 4') GOTO 22161 22121 CONTINUE CALL PGP_MOVEA(W,Y) FIRST = .FALSE. 22161 CONTINUE 22111 CONTINUE GOTO 22171 22101 CONTINUE IF(.NOT.(PAPER))GOTO 22191 WRITE(11,22200)W,Y 22200 FORMAT (F10.3,2X,F10.6) GOTO 22211 22191 CONTINUE CALL PGP_DRAWA(W,Y) 22211 CONTINUE 22181 CONTINUE 22171 CONTINUE 22091 CONTINUE 22081 CONTINUE W = W + WSTEP GOTO 22061 22062 CONTINUE 21871 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 22231 RETURN 22231 CONTINUE 22240 I=1 GOTO 22243 22241 I=I+1 22243 IF((I).GT.(NFILE))GOTO 22242 OPEN(UNIT=13,FILE=FILES(I),STATUS='OLD') REWIND 13 CALL PLTSYN(WZERO(I),WINC(I),PAPER) CLOSE(UNIT=13) GOTO 22241 22242 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 22261 XLEFT = X1 XRIGHT = X2 GOTO 22271 22261 CONTINUE XLEFT = X2 XRIGHT = X1 22271 CONTINUE 22251 CONTINUE IF(XLEFT .GE. XMIN)GOTO 22291 XLEFT = XMIN 22291 CONTINUE IF(XRIGHT .LE. XMAX)GOTO 22311 XRIGHT = XMAX 22311 CONTINUE CALL INTEGRT(XLEFT,XRIGHT,AREA) A1 = SPEC(NINT(XLEFT)) A2 = DNINT(XLEFT) 22320 I=NINT(XLEFT)+1 GOTO 22323 22321 I=I+1 22323 IF((I).GT.(INT(XRIGHT)))GOTO 22322 IF(SPEC(I) .GE. A1)GOTO 22341 A1 = SPEC(I) A2 = DBLE(I) 22341 CONTINUE GOTO 22321 22322 CONTINUE A1 = 1.0 - SPEC(INT(A2))/CONTUM(A2) A3 = AREA/(A1*DMYSQ(PI)) 22350 I=1 GOTO 22353 22351 I=I+1 22353 IF((I).GT.(9))GOTO 22352 22360 J=1 GOTO 22363 22361 J=J+1 22363 IF((J).GT.(9))GOTO 22362 COV(I,J) = 0.0D0 GOTO 22361 22362 CONTINUE COV(I,I) = 1.0D0 SW(I) = 0.0D0 GOTO 22351 22352 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 22381 ISTART = ISTART + 1 FRAC1 = DBLE(ISTART) - XMIN 22381 CONTINUE FRAC2 = XMAX - DBLE(IEND) N = IEND - ISTART + 1 IF(N .GT. 1)GOTO 22401 SUM = 0.0 GOTO 22391 22401 IF(N .NE. 2)GOTO 22411 I = ISTART SUM = 1.0-(SPEC(I)/CONTUM(DBLE(I))+SPEC(IEND)/CONTUM(DBLE(IEND)))/ *2.0 GOTO 22421 22411 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 22441 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 22461 SUM5 = 0.0 GOTO 22471 22461 CONTINUE SUM5=2.0-SPEC(I+3)/CONTUM(DBLE(I+3))-SPEC(IEND)/CONTUM(DBLE(IEND)) * 22471 CONTINUE 22451 CONTINUE IZERO = 3 22441 CONTINUE 22480 I=ISTART+IZERO+1 GOTO 22483 22481 I=I+(2) 22483 IF((2)*((I)-(IEND-1)).GT.0)GOTO 22482 SUM2 = SUM2 + 4.0*(1.0-SPEC(I)/CONTUM(DBLE(I))) GOTO 22481 22482 CONTINUE 22490 I=ISTART+IZERO+2 GOTO 22493 22491 I=I+(2) 22493 IF((2)*((I)-(IEND-2)).GT.0)GOTO 22492 SUM3 = SUM3 + 2.0*(1.0-SPEC(I)/CONTUM(DBLE(I))) GOTO 22491 22492 CONTINUE SUM = SUM1 + (SUM2 + SUM3 + SUM5)/3.0 22421 CONTINUE 22391 CONTINUE IF(FRAC1 .EQ. 0.0)GOTO 22511 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 22511 CONTINUE IF(FRAC2 .EQ. 0.0)GOTO 22531 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 22531 CONTINUE IF(N .GT. 0)GOTO 22551 I = ISTART SUM4 = -1.0+(SPEC(I)/CONTUM(DBLE(I))+SPEC(IEND)/CONTUM(DBLE(IEND)) *)/2.0 + SUM4 22551 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,22560) 22560 FORMAT(' REJECT LINE. ARE YOU SURE?') CALL DISPRM READ(5,'(A1)')CHAR IF(CHAR .EQ. 'Y' .OR. CHAR .EQ. 'y')GOTO 22581 RETURN 22581 CONTINUE CALL FINDLN(CHANNEL(X),LINE) IF(LINE .NE. 0)GOTO 22601 RETURN 22601 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,22610)XCHAN 22610 FORMAT(' DIODE ',F7.2) CALL DISPRM WRITE(6,22620)X 22620 FORMAT(' WAVE ',F8.3) RETURN END SUBROUTINE FINDLN(CENT,LINE) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK 22630 LINE=1 GOTO 22633 22631 LINE=LINE+1 22633 IF((LINE).GT.(NOLINES))GOTO 22632 WAVE = WAV(CENT) IF((DABS(WAVELN(LINE)-WAVE) .GT. 2.0*DISP) .AND. (DABS(WAVELN(LINE *)-WAVE) .GT. 0.04))GOTO 22651 IF(LINE .GE. NOLINES)GOTO 22671 IF(DABS(WAVELN(LINE)-WAVE) .GT. DABS(WAVELN(LINE+1)-WAVE))GOTO 226 *91 RETURN 22691 CONTINUE GOTO 22701 22671 CONTINUE RETURN 22701 CONTINUE 22661 CONTINUE 22651 CONTINUE GOTO 22631 22632 CONTINUE LINE = 0 RETURN END SUBROUTINE CONFIT IMPLICIT REAL*8(A-H,O-Z) REAL*8 X(1000),Y(1000),SIGMA(1000),ADUM(50),COVAR(50,50) REAL ACHISQ,SMEAN,PDEV COMMON/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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM COMMON/CPARMS/A,B,C REAL*8 A,B,C COMMON/CMANDS/ LINENO,ICOL INTEGER LINENO,ICOL CALL DISPRM WRITE(6,22710) 22710 FORMAT(' ENTER ORDER OF POLYNOMIAL') LINENO = LINENO - 1 CALL DISPRM READ(5,'(I2)')IORD IF(NOCONT .GE. IORD)GOTO 22731 CALL DISPRM WRITE(6,22740) 22740 FORMAT('ORDER TOO BIG') RETURN 22731 CONTINUE FITCON = .TRUE. IF(NOCONT .LT. 1)GOTO 22761 SMEAN = 0.0 22770 J=1 GOTO 22773 22771 J=J+1 22773 IF((J).GT.(NOCONT))GOTO 22772 Y(J) = CONFLUX(J) X(J) = CONCENT(J) SIGMA(J) = SIGFLUX(J) SMEAN = SMEAN + 1.0/SIGMA(J)**2 GOTO 22771 22772 CONTINUE CALL POLYLIN(X,Y,SIGMA,IORD,ADUM,COVAR,CHISQ,NOCONT) CONORD(CURIMR) = IORD 22780 ITERM=1 GOTO 22783 22781 ITERM=ITERM+1 22783 IF((ITERM).GT.(IORD))GOTO 22782 ACON(ITERM,CURIMR) = ADUM(ITERM) GOTO 22781 22782 CONTINUE CALL RPLTCT ACHISQ = REAL(CHISQ/DBLE(NOCONT-IORD)) PDEV = 100.0 * (SQRT(ACHISQ) / SQRT(SMEAN))/CONFLUX(NOCONT/2) CALL DISPRM WRITE(6,22790)ACHISQ 22790 FORMAT('Chi2/Ndf = ',F8.3) CALL DISPRM WRITE(6,22800)PDEV 22800 FORMAT('wrms dev.% =',F7.3) GOTO 22811 22761 CONTINUE CONORD(CURIMR) = 1 ACON(1,CURIMR) = 1.0 22811 CONTINUE 22751 CONTINUE RETURN END SUBROUTINE DTTODT IMPLICIT REAL*8 (A-H,O-Z) COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(100),DW(100),PIX1(100) 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 22820 I=1 GOTO 22823 22821 I=I+1 22823 IF((I).GT.(9))GOTO 22822 A(I) = 0.0D0 IF(I .GT. 3*NGAUSS)GOTO 22841 SWITCH(I) = 1.0 SWDUMMY(I) = 1.0 GOTO 22851 22841 CONTINUE SWITCH(I) = 0.0 SWDUMMY(I) = 0.0 22851 CONTINUE 22831 CONTINUE GOTO 22821 22822 CONTINUE 22860 I=1 GOTO 22863 22861 I=I+1 22863 IF((I).GT.(NGAUSS))GOTO 22862 CALL PRMCAD(A(3*I-1),A(3*I-2),SWITCH,I) GOTO 22861 22862 CONTINUE CALL PRMBOU(LEFT,RIGHT,SWITCH,NGAUSS) IF(LEFT .NE. 0 .OR. RIGHT .NE. 0)GOTO 22881 RETURN 22881 CONTINUE CALL SETUPTS(X,LEFT,RIGHT,N) 22890 I=1 GOTO 22893 22891 I=I+1 22893 IF((I).GT.(NGAUSS))GOTO 22892 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 22911 A(3*I) = 0.5*( X(2*N-1) - X(1) )/3.0 22911 CONTINUE IF(SWITCH(3*I) .NE. 1.0 .OR. A(3*I) .GE. 2.0)GOTO 22931 A(3*I) = 2.0 22931 CONTINUE GOTO 22891 22892 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) 22940 POSN=START + 0.25 GOTO 22943 22941 POSN=POSN+(0.25) 22943 IF((0.25)*((POSN)-(END)).GT.0)GOTO 22942 FLUX = 0.0 FLUX = PROFILE(POSN, A, SWDUMMY, VSINI) FLUX = (1.0-FLUX)*CONTUM(POSN) CALL PGP_DRAWA(WAV(POSN),FLUX) GOTO 22941 22942 CONTINUE 22950 I=1 GOTO 22953 22951 I=I+1 22953 IF((I).GT.(NGAUSS))GOTO 22952 CALL REPLEW(A(3*I-2),A(3*I-1),A(3*I),COV,SWITCH,I) GOTO 22951 22952 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,22960) 22960 FORMAT(12HENTER BOUNDS) CALL PGP_VCURSR(ICHAR1,X1,Y1) CALL PGP_VCURSR(ICHAR2,X2,Y2) IF(X1 .LE. X2)GOTO 22981 LEFT = NINT(CHANNEL(X2)) RIGHT= NINT(CHANNEL(X1)) GOTO 22991 22981 CONTINUE RIGHT = NINT(CHANNEL(X2)) LEFT = NINT(CHANNEL(X1)) 22991 CONTINUE 22971 CONTINUE NPOINT = 0 23000 I=1 GOTO 23003 23001 I=I+1 23003 IF((I).GT.(3*NGAUSS))GOTO 23002 NPOINT = INT(SWITCH(I)) + NPOINT GOTO 23001 23002 CONTINUE IF(RIGHT - LEFT + 1 .GE. NPOINT)GOTO 23021 CALL DISPRM WRITE(6,23030) 23030 FORMAT(19HINSUFFICIENT POINTS) LEFT = 0 RIGHT = 0 23021 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,23040) 23040 FORMAT(13HSET LINE APEX) CALL PGP_VCURSR(ICHAR,X,Y) CENTRE = CHANNEL(X) DEPTH = 1.0 - Y/CONTUM(CENTRE) IF(ICHAR .NE. 102)GOTO 23061 CALL DISPRM WRITE(6,23070) 23070 FORMAT(' FIX DEPTH ?') LINENO = LINENO - 1 CALL DISPRM READ(5,'(A1)')ANS IF(ANS .NE. 'y')GOTO 23091 SWITCH(3*NGAUSS-2) = 0.0 23091 CONTINUE CALL DISPRM WRITE(6,23100) 23100 FORMAT(' FIX CENTRE?') LINENO = LINENO - 1 CALL DISPRM READ(5,'(A1)')ANS IF(ANS .NE. 'y')GOTO 23121 SWITCH(3*NGAUSS-1) = 0.0 23121 CONTINUE CALL DISPRM WRITE(6,23130) 23130 FORMAT(' FIX FWHM ?') LINENO = LINENO - 1 CALL DISPRM READ(5,'(A1)')ANS IF(ANS .NE. 'y')GOTO 23151 SWITCH(3*NGAUSS) = 0.0 23151 CONTINUE 23061 CONTINUE RETURN END SUBROUTINE SETVSNI IMPLICIT REAL*8 (A-H,O-Z) COMMON/ROTCOM/ VSINI REAL*8 VSINI CALL DISPRM WRITE(6,23160) 23160 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL REAL*8 ADEPTH,SIGMA,SWITCH IF(SWITCH .NE. 0.0)GOTO 23181 CALL GTBSFW(W,ADEPTH,WIDTH,SIGWDTH) IF((NOGDLN .NE. 0 .OR. .NOT.(.NOT. FIXFWHM)) .AND. (WIDTH .NE. 0.0 *))GOTO 23201 CALL DISPRM WRITE(6,23210) 23210 FORMAT(19HNO MEAN FWHM EXISTS) SWITCH = 1.0 23201 CONTINUE SIGMA = WIDTH*0.60056121 23181 CONTINUE RETURN END SUBROUTINE REPLEW(A1,A2,A3,COV,SWITCH,N) IMPLICIT REAL*8(A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 23231 CALL DISPRM WRITE(6,23240) 23240 FORMAT (16HLINE NOT ON LIST) CALL DISPRM WRITE(6,23250)AREA 23250 FORMAT(4HEW =,F7.2,2HMA) CALL DISPRM WRITE(6,23260)WAVE 23260 FORMAT(7HWAVE = ,F8.2,1HA) GOTO 23271 23231 CONTINUE WAVE2 = WAV(CENTRE(LINE)) CALL DISPRM WRITE(6,23280)AREA 23280 FORMAT(8HNEW EW =,F7.2,2HMA) CALL DISPRM WRITE(6,23290)WAVE 23290 FORMAT(7HWAVE = ,F8.2,1HA) CALL DISPRM WRITE(6,23300)EW(LINE) 23300 FORMAT(8HOLD EW =,F7.2,2HMA) CALL DISPRM WRITE(6,23310)WAVE2 23310 FORMAT(7HWAVE = ,F8.2,1HA) CALL DISPRM WRITE(6,23320) 23320 FORMAT(15HREPLACE OLD EW?) CALL DISPRM READ(5,'(A1)')ANS IF((ANS .NE. 'Y') .AND. (ANS .NE. 'y'))GOTO 23341 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,23350)DELTEW(LINE) 23350 FORMAT(7HD_EW = ,F7.2,2HMA) FWHM(LINE) = DABS(A3)/0.60056121 23341 CONTINUE 23271 CONTINUE 23221 CONTINUE RETURN END SUBROUTINE CPDELE(A1,A3,COV,SWITCH,N,LINE) IMPLICIT REAL*8 (A-H,O-Z) COMMON /LINID/LINEID CHARACTER*(10) LINEID(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) 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 23371 IF(SWITCH(NW) .NE. 1.0)GOTO 23391 DELTA = COV(NW,NW)/A3**2 + COV(ND,ND)/A1**2 + 2.0*COV(ND,NW)/(A3* *A1) GOTO 23401 23391 CONTINUE DELTA = COV(ND,ND)/A1**2 DELTA = DELTA + (0.60056121*SIGWDTH/A3)**2 23401 CONTINUE 23381 CONTINUE GOTO 23361 23371 IF(SWITCH(NW) .NE. 1.0)GOTO 23411 DELTA = COV(NW,NW)/A3**2 GOTO 23421 23411 CONTINUE DELTA = (0.60056121*SIGWDTH/A3)**2 23421 CONTINUE 23361 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 23441 CALL PGP_DRAWA(WAV(POSN),FLUX) GOTO 23431 23441 IF(FLUX .GE. YMIN)GOTO 23451 CALL PGP_DRAWA(WAV(POSN),YMIN) GOTO 23461 23451 CONTINUE CALL PGP_DRAWA(WAV(POSN),YMAX) 23461 CONTINUE 23431 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 23481 SPEC = 0.0 GOTO 23491 23481 CONTINUE SPEC = SPCTRUM(I) 23491 CONTINUE 23471 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL INTEGER I IF(.NOT.(.NOT.VARFIL))GOTO 23511 IF(SPEC(I)/CONTUM(DBLE(I)) .LE. 0.0)GOTO 23531 SNR = SN * DSQRT( SPEC(I)/CONTUM(DBLE(I)) ) GOTO 23541 23531 CONTINUE SNR = 0.0 23541 CONTINUE 23521 CONTINUE GOTO 23501 23511 IF((I .GT. 0) .AND. (I .LE. NPTS))GOTO 23551 SNR = 0.0 GOTO 23501 23551 IF(VARSPEC(I) .GT. 0.0)GOTO 23561 SNR = 0.0 GOTO 23571 23561 CONTINUE SNR = DSQRT( VARSPEC(I) ) 23571 CONTINUE 23501 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(100),DW(100),PIX1(100) 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 23591 CONTUM = 1.0 RETURN 23591 CONTINUE IF(.NOT.(TELSET))GOTO 23611 CONTUM = 1.0 RETURN 23611 CONTINUE X=DIODE IF((DIODE .LT. CONCENT(1) .OR. DIODE .GT. CONCENT(NOCONT)) .AND. ( *.NOT.(OLD_CONTUM)))GOTO 23631 IF(CONORD(CURIMR) .LE. 0)GOTO 23651 C = 0.0 23660 I=1 GOTO 23663 23661 I=I+1 23663 IF((I).GT.(CONORD(CURIMR)))GOTO 23662 C = C + ACON(I,CURIMR)*X**(I-1) GOTO 23661 23662 CONTINUE CONTUM = C GOTO 23641 23651 IF(CFLAG .NE. 1)GOTO 23671 CONTUM = A*X*X + B*X +C GOTO 23641 23671 IF(CFLAG .NE. 2)GOTO 23681 CONTUM = A*X + B GOTO 23641 23681 IF(CFLAG .NE. 3)GOTO 23691 CONTUM = A GOTO 23641 23691 IF(CFLAG .NE. 4)GOTO 23701 CALL FNDCNT(DIODE,BLUE,RED) CALL POLATE(BLUE,RED,DIODE,VALUE) CONTUM = VALUE GOTO 23641 23701 IF(CFLAG .NE. 5)GOTO 23711 CALL FNDCNT(DIODE,BLUE,RED) CONTUM = (CONFLUX(BLUE)+CONFLUX(RED))/2.0 23711 CONTINUE 23641 CONTINUE RETURN 23631 CONTINUE IF(CONORD(CURIMR) .LE. 0)GOTO 23731 IF(DIODE .GE. CONCENT(1))GOTO 23751 X = CONCENT(1) C = 0.0 23760 I=1 GOTO 23763 23761 I=I+1 23763 IF((I).GT.(CONORD(CURIMR)))GOTO 23762 C = C + ACON(I,CURIMR)*X**(I-1) GOTO 23761 23762 CONTINUE CONTUM = C GOTO 23741 23751 IF(DIODE .LE. CONCENT(NOCONT))GOTO 23771 X = CONCENT(NOCONT) C = 0.0 23780 I=1 GOTO 23783 23781 I=I+1 23783 IF((I).GT.(CONORD(CURIMR)))GOTO 23782 C = C + ACON(I,CURIMR)*X**(I-1) GOTO 23781 23782 CONTINUE CONTUM = C 23771 CONTINUE 23741 CONTINUE RETURN 23731 CONTINUE IF(DIODE .GE. CONCENT(1))GOTO 23801 I1=1 I2=2 GOTO 23791 23801 IF(DIODE .LE. CONCENT(NOCONT))GOTO 23811 I1=NOCONT-1 I2=NOCONT 23811 CONTINUE 23791 CONTINUE IF(EFLAG .NE. 1)GOTO 23831 CALL POLATE(I1,I2,DIODE,CONTUM) GOTO 23821 23831 IF(EFLAG .NE. 2 .OR. I1 .NE. 1)GOTO 23841 CONTUM = CONFLUX(I1) GOTO 23821 23841 IF(EFLAG .NE. 2)GOTO 23851 CONTUM = CONFLUX(I2) GOTO 23821 23851 IF(EFLAG .NE. 3)GOTO 23861 CONTUM = A*X + B 23861 CONTINUE 23821 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM INTEGER BLUE,RED REAL*8 DIODE BLUE=0 RED=0 23870 I=1 GOTO 23873 23871 I=I+1 23873 IF((I).GT.(NOCONT-1))GOTO 23872 IF(DIODE .LT. CONCENT(I) .OR. DIODE .GT. CONCENT(I+1))GOTO 23891 BLUE=I RED=I+1 GOTO 23872 23891 CONTINUE GOTO 23871 23872 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL WRITE(1,23900)CURSPC,CURORD 23900 FORMAT (/,'RESULTS FOR SPECTRUM ',I3,' ORDER ',I3,1H:) WRITE(1,23910)CURIMR 23910 FORMAT ('CURRENT IMAGE ROW ',I3,/) IF(.NOT.(.NOT.NRMLSD))GOTO 23931 WRITE(1,23940) 23940 FORMAT(' CONTINUUM FLUX VALUES ',/) WRITE(1,23950)(CONFLUX(I),I=1,NOCONT) 23950 FORMAT(8F10.6) WRITE(1,23960) 23960 FORMAT(//,' CONTINUUM WAVELENGTHS ',/) WRITE(1,23970)(WAV(CONCENT(I)),I=1,NOCONT) 23970 FORMAT(8F10.2) WRITE(1,23980)CONORD(CURIMR) 23980 FORMAT(//,'ORDER OF POLYNOMIAL FIT = ',I4) WRITE(1,23990) 23990 FORMAT(/,'POLYNOMIAL COEFFICIENTS: ') WRITE(1,24000)( ACON(ITERM,CURIMR),ITERM=1,CONORD(CURIMR)) 24000 FORMAT (5(G16.9,1X)) GOTO 24011 23931 CONTINUE WRITE(1,24020) 24020 FORMAT('NORMALISED CONTINUUM AT 1.00 USED THROUGHOUT') 24011 CONTINUE 23921 CONTINUE 24030 IPAGE=1 GOTO 24033 24031 IPAGE=IPAGE+1 24033 IF((IPAGE).GT.(100))GOTO 24032 N = (IPAGE-1)*50 WRITE(1,24040) 24040 FORMAT (///, ' LINE ID WAVELENGTH LEFT RIGHT DEPTH CENTRE F %WHM EW(MA) +/-EW'//) 24050 I=N+1 GOTO 24053 24051 I=I+1 24053 IF((I).GT.(N+50))GOTO 24052 IF(I .LE. NOLINES)GOTO 24071 RETURN 24071 CONTINUE WRITE(1,24080)LINEID(I),WAVELN(I),LFTDIO(I),RHTDIO(I),DEPTH(I), CE *NTRE(I),FWHM(I),EW(I),DELTEW(I) 24080 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 24052 GOTO 24051 24052 CONTINUE WRITE(1,24090) 24090 FORMAT(1H1) IF(I .GE. NOLINES)GOTO 24032 GOTO 24031 24032 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(100),DW(100),PIX1(100) 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=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 24100 CONTINUE NITER = 1 NZERO = 0 NU = 1000.0 24110 J=1 GOTO 24113 24111 J=J+1 24113 IF((J).GT.(9))GOTO 24112 ANEW(J) = AOLD(J) GOTO 24111 24112 CONTINUE CALL INITPA(V,X,XBEST,N,AOLD,F,SIGMA,PHOTONS,SWITCH,COV,NPARAM) IF(N-NZERO .GE. NPARAM)GOTO 24131 IF(N .NE. 1)GOTO 24151 IF(SWITCH(1) .NE. 1.0)GOTO 24171 AOLD(1) = 0.0 GOTO 24161 24171 IF(SWITCH(4) .NE. 1.0)GOTO 24181 AOLD(4) = 0.0 GOTO 24161 24181 IF(SWITCH(7) .NE. 1.0)GOTO 24191 AOLD(7) = 0.0 24191 CONTINUE 24161 CONTINUE RETURN 24151 CONTINUE WRITE(8,24200) 24200 FORMAT (' INSUFFICIENT NUMBER OF POINTS IN GAUSS FIT ') WRITE(8,24210)SWITCH,X 24210 FORMAT (' SWITCH ',9F3.0,/,' X VALUES ',20(8E15.6,/),/) RETURN 24131 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) 24220 CONTINUE 24221 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 24241 NU = NU/10.0 GOTO 24251 24241 CONTINUE NU = 10.0*NU 24260 J=1 GOTO 24263 24261 J=J+1 24263 IF((J).GT.(9))GOTO 24262 AOLD(J) = ANEW(J) 24270 JJ=1 GOTO 24273 24271 JJ=JJ+1 24273 IF((JJ).GT.(9))GOTO 24272 COVOLD(J,JJ) = COV(J,JJ) GOTO 24271 24272 CONTINUE GOTO 24261 24262 CONTINUE 24280 JJ=1 GOTO 24283 24281 JJ=JJ+1 24283 IF((JJ).GT.(N))GOTO 24282 WOLD(JJ) = W(JJ) PHIOLD(JJ) = PHI(JJ) GOTO 24281 24282 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) 24251 CONTINUE 24231 CONTINUE NITER = NITER + 1 IF(CONVRG(AOLD,ANEW,DELTA,SWITCH) .OR. NITER .GT. 16)GOTO 24222 GOTO 24221 24222 CONTINUE IF(N .LE. NPARAM)GOTO 24301 FACTOR = 0.0 24310 I=1 GOTO 24313 24311 I=I+1 24313 IF((I).GT.(N))GOTO 24312 FACTOR = FACTOR + WOLD(I)*PHIOLD(I)**2 GOTO 24311 24312 CONTINUE FACTOR = FACTOR/DBLE(N-NPARAM) 24301 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 24320 I=1 GOTO 24323 24321 I=I+1 24323 IF((I).GT.(9))GOTO 24322 24330 II=1 GOTO 24333 24331 II=II+1 24333 IF((II).GT.(9))GOTO 24332 COV(I,II) = 0.0 GOTO 24331 24332 CONTINUE GOTO 24321 24322 CONTINUE 24340 I=1 GOTO 24343 24341 I=I+1 24343 IF((I).GT.(2*N))GOTO 24342 V(I) = 0.0 XBEST(I) = X(I) GOTO 24341 24342 CONTINUE NPARAM = 0 24350 J=1 GOTO 24353 24351 J=J+1 24353 IF((J).GT.(9))GOTO 24352 IF(SW(J) .NE. 1.0)GOTO 24371 NPARAM = NPARAM + 1 24371 CONTINUE GOTO 24351 24352 CONTINUE 24380 I=1 GOTO 24383 24381 I=I+1 24383 IF((I).GT.(N))GOTO 24382 F(I) = PROFILE(X(2*I-1),A,SW,VSINI) - X(2*I) GOTO 24381 24382 CONTINUE IF(N .LE. 1)GOTO 24401 DELTA = X(3) - X(1) GOTO 24411 24401 CONTINUE DELTA = 1.0 24411 CONTINUE 24391 CONTINUE IF(PHOTONS .NE. 0.0)GOTO 24431 PHOTONS = 1.0 24431 CONTINUE 24440 J=1 GOTO 24443 24441 J=J+(2) 24443 IF((2)*((J)-(2*N-1)).GT.0)GOTO 24442 SIGMA(J) = DELTA**2/(12.0*(1.0-X(J+1))*PHOTONS) SIGMA(J+1) = ( 1.0 - X(J+1) )/PHOTONS GOTO 24441 24442 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 24450 I=2 GOTO 24453 24451 I=I+(2) 24453 IF((2)*((I)-(2*N)).GT.0)GOTO 24452 IF(X(I) .GT. 0.0)GOTO 24471 NZERO = NZERO + 1 24471 CONTINUE GOTO 24451 24452 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 24491 24500 IPAR=1 GOTO 24503 24501 IPAR=IPAR+1 24503 IF((IPAR).GT.(9))GOTO 24502 ADUM(IPAR) = A(IPAR) GOTO 24501 24502 CONTINUE 24510 I=1 GOTO 24513 24511 I=I+1 24513 IF((I).GT.(N))GOTO 24512 K = 1 24520 ISW=1 GOTO 24523 24521 ISW=ISW+1 24523 IF((ISW).GT.(9))GOTO 24522 IF(SW(ISW) .NE. 1.0)GOTO 24541 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) 24541 CONTINUE GOTO 24521 24522 CONTINUE GOTO 24511 24512 CONTINUE J = 1 24550 I=1 GOTO 24553 24551 I=I+1 24553 IF((I).GT.(N))GOTO 24552 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 24551 24552 CONTINUE GOTO 24561 24491 CONTINUE CALL GEXDER(XBEST,FA,FX,W,SIGMA,N,A,SW) 24561 CONTINUE 24481 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 24570 I=1 GOTO 24573 24571 I=I+1 24573 IF((I).GT.(N))GOTO 24572 K = 1 IF(SW(1) .NE. 1.0)GOTO 24591 FA(I,K) = MYEXP(-((XBEST(2*I-1)-A(2))/A(3))**2) K = K + 1 24591 CONTINUE IF(SW(2) .NE. 1.0)GOTO 24611 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 24611 CONTINUE IF(SW(3) .NE. 1.0)GOTO 24631 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 24631 CONTINUE IF(SW(4) .NE. 1.0)GOTO 24651 FA(I,K) = MYEXP(-((XBEST(2*I-1)-A(5))/A(6))**2) K = K + 1 24651 CONTINUE IF(SW(5) .NE. 1.0)GOTO 24671 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 24671 CONTINUE IF(SW(6) .NE. 1.0)GOTO 24691 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 24691 CONTINUE IF(SW(7) .NE. 1.0)GOTO 24711 FA(I,K) = MYEXP(-((XBEST(2*I-1)-A(8))/A(9))**2) K = K + 1 24711 CONTINUE IF(SW(8) .NE. 1.0)GOTO 24731 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 24731 CONTINUE IF(SW(9) .NE. 1.0)GOTO 24751 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 24751 CONTINUE GOTO 24571 24572 CONTINUE 24760 I=1 GOTO 24763 24761 I=I+1 24763 IF((I).GT.(N))GOTO 24762 24770 J=1 GOTO 24773 24771 J=J+1 24773 IF((J).GT.(2*N))GOTO 24772 FX(I,J) = 0.0 GOTO 24771 24772 CONTINUE GOTO 24761 24762 CONTINUE J=1 24780 I=1 GOTO 24783 24781 I=I+1 24783 IF((I).GT.(N))GOTO 24782 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 24801 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) 24801 CONTINUE IF((SW(7) .NE. 1.0) .AND. ((SW(8) .NE. 1.0) .AND. (SW(9) .NE. 1.0) *))GOTO 24821 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) 24821 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 24781 24782 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 24830 I=1 GOTO 24833 24831 I=I+1 24833 IF((I).GT.(NGAUSS(SW)))GOTO 24832 IF(VSINI .GE. 0.1D0)GOTO 24851 DUMMY = DUMMY + GAUSPRF(X, A, I) GOTO 24861 24851 CONTINUE DUMMY = DUMMY + ROTPROF(X, A, I, VSINI) 24861 CONTINUE 24841 CONTINUE GOTO 24831 24832 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 24881 NGAUSS = 1 24881 CONTINUE IF(SW(4)+SW(5)+SW(6) .LT. 1.0)GOTO 24901 NGAUSS = 2 24901 CONTINUE IF(SW(7)+SW(8)+SW(9) .LT. 1.0)GOTO 24921 NGAUSS = 3 24921 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 24941 XSTEP = XSTEPR 24941 CONTINUE XSTEP = 0.05 NLAM = 2*INT(DPIXL/XSTEP) + 1 DPIX = -DPIXL 24950 I=1 GOTO 24953 24951 I=I+1 24953 IF((I).GT.(NLAM))GOTO 24952 F(I) = H(PIX-DPIX,COEFF)*G(DPIX,DPIXL,DLAML,LAMC) X(I) = DPIX DPIX = -DPIXL + DBLE(I)*XSTEP GOTO 24951 24952 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 24971 G = 0.0D0 GOTO 24981 24971 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) 24981 CONTINUE 24961 CONTINUE RETURN END REAL*8 FUNCTION MYEXP(ARG) IMPLICIT REAL*8(A-H,O-Z) REAL*8 ARG IF(ARG .GE. -150.D0)GOTO 25001 MYEXP = 0.0D0 GOTO 25011 25001 CONTINUE MYEXP = DEXP(ARG) 25011 CONTINUE 24991 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 25020 J=1 GOTO 25023 25021 J=J+1 25023 IF((J).GT.(N))GOTO 25022 PHI(J) = 0.0 25030 I=1 GOTO 25033 25031 I=I+(2) 25033 IF((2)*((I)-(2*N-1)).GT.0)GOTO 25032 PHI(J) = PHI(J) - FX(J,I)*V(I) GOTO 25031 25032 CONTINUE PHI(J) = PHI(J) + F(J) GOTO 25021 25022 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 25040 I=1 GOTO 25043 25041 I=I+1 25043 IF((I).GT.(N))GOTO 25042 S = S + PHI(I)**2 * W(I) GOTO 25041 25042 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 25050 I=1 GOTO 25053 25051 I=I+1 25053 IF((I).GT.(9))GOTO 25052 25060 J=1 GOTO 25063 25061 J=J+1 25063 IF((J).GT.(9))GOTO 25062 MINV(I,J) = 0.0 GOTO 25061 25062 CONTINUE GOTO 25051 25052 CONTINUE 25070 I=1 GOTO 25073 25071 I=I+1 25073 IF((I).GT.(NPARAM))GOTO 25072 25080 J=1 GOTO 25083 25081 J=J+1 25083 IF((J).GT.(NPARAM))GOTO 25082 M(I,J) = 0.0 25090 K=1 GOTO 25093 25091 K=K+1 25093 IF((K).GT.(N))GOTO 25092 M(I,J) = M(I,J) + W(K)*FA(K,I)*FA(K,J) GOTO 25091 25092 CONTINUE GOTO 25081 25082 CONTINUE GOTO 25071 25072 CONTINUE 25100 I=1 GOTO 25103 25101 I=I+1 25103 IF((I).GT.(NPARAM))GOTO 25102 M(I,I) = M(I,I)*(1.0+1.0/NU) GOTO 25101 25102 CONTINUE CALL LINV2F(M,NPARAM,NINE,MINV,IDIGIT,WKAREA,IER) 25110 J=1 GOTO 25113 25111 J=J+1 25113 IF((J).GT.(NPARAM))GOTO 25112 COL(J) = 0.0 25120 I=1 GOTO 25123 25121 I=I+1 25123 IF((I).GT.(N))GOTO 25122 COL(J) = COL(J) + W(I)*PHI(I)*FA(I,J) GOTO 25121 25122 CONTINUE GOTO 25111 25112 CONTINUE 25130 J=1 GOTO 25133 25131 J=J+1 25133 IF((J).GT.(NPARAM))GOTO 25132 DELTA(J) = 0.0 25140 I=1 GOTO 25143 25141 I=I+1 25143 IF((I).GT.(NPARAM))GOTO 25142 DELTA(J) = DELTA(J) - MINV(J,I)*COL(I) GOTO 25141 25142 CONTINUE GOTO 25131 25132 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 25161 WRITE(8,25170)IER 25170 FORMAT (/' IMSL ERROR NUMBER ',I3) WRITE(8,25180)A 25180 FORMAT (' A VALUES: ',/,3(3E15.6,/)) WRITE(8,25190)(X(I),I=1,2*N) 25190 FORMAT(' X VALUES: ',/,25(8E15.6,/)) 25161 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 25200 I=1 GOTO 25203 25201 I=I+1 25203 IF((I).GT.(N))GOTO 25202 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 25201 25202 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 25210 I=1 GOTO 25213 25211 I=I+1 25213 IF((I).GT.(2*N))GOTO 25212 XBEST(I) = X(I) + V(I) GOTO 25211 25212 CONTINUE J = 0 25220 I=1 GOTO 25223 25221 I=I+1 25223 IF((I).GT.(9))GOTO 25222 IF(SW(I) .NE. 1.0)GOTO 25241 J = J + 1 A(I) = A(I) + DELTA(J) 25241 CONTINUE GOTO 25221 25222 CONTINUE 25250 I=1 GOTO 25253 25251 I=I+1 25253 IF((I).GT.(N))GOTO 25252 F(I) = PROFILE(X(2*I-1),A,SW,VSINI) - X(2*I) GOTO 25251 25252 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 25260 I=1 GOTO 25263 25261 I=I+1 25263 IF((I).GT.(9))GOTO 25262 IF(SWITCH(I) .NE. 1.0)GOTO 25281 K = K + 1 IF(DLOG10(DABS(DELTA(K))) .GE. -60.0)GOTO 25301 CONVRG = .TRUE. GOTO 25291 25301 IF(DABS( ANEW(I) ) .LE. 30000.0)GOTO 25311 CONVRG = .TRUE. WRITE(8,25320) 25320 FORMAT(' GAUSSIAN FIT DIVERGING, ITERATIONS ABANDONED ') GOTO 25262 GOTO 25291 25311 IF(DABS( AOLD(I)/DELTA(K) ) .LE. 10000.0)GOTO 25331 CONVRG = .TRUE. GOTO 25341 25331 CONTINUE CONVRG = .FALSE. GOTO 25262 25341 CONTINUE 25291 CONTINUE 25281 CONTINUE GOTO 25261 25262 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 25361 RETURN 25361 CONTINUE 24100 CONTINUE 25370 I=1 GOTO 25373 25371 I=I+1 25373 IF((I).GT.(NGAUSS(SWITCH)-1))GOTO 25372 IF(AOLD(3*(I-1)+2) .LE. AOLD(3*I+2))GOTO 25391 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. 25391 CONTINUE GOTO 25371 25372 CONTINUE IF(AOLD(2) .LE. AOLD(5))GOTO 25411 GOTO 24100 25411 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 25420 I=1 GOTO 25423 25421 I=I+1 25423 IF((I).GT.(N))GOTO 25422 YRES = PROFILE(X(2*I-1),A,SW,VSINI) - X(2*I) CHISQ = CHISQ + YRES**2/SIGMA(2*I) GOTO 25421 25422 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 25430 I=1 GOTO 25433 25431 I=I+1 25433 IF((I).GT.(9))GOTO 25432 IPARAM(I) = 0 IF(SWITCH(I) .NE. 1.0)GOTO 25451 IC = IC + 1 IPARAM(I) = IC 25451 CONTINUE GOTO 25431 25432 CONTINUE 25460 I=1 GOTO 25463 25461 I=I+1 25463 IF((I).GT.(9))GOTO 25462 25470 J=1 GOTO 25473 25471 J=J+1 25473 IF((J).GT.(9))GOTO 25472 IF(SWITCH(I) .NE. 1.0 .OR. SWITCH(J) .NE. 1.0)GOTO 25491 COV(I,J) = FACTOR * COVOLD( IPARAM(I),IPARAM(J) ) GOTO 25501 25491 CONTINUE COV(I,J) = 0.0 25501 CONTINUE 25481 CONTINUE GOTO 25471 25472 CONTINUE GOTO 25461 25462 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(100),DW(100),PIX1(100) 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,25510) 25510 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 25531 WRITE(6,25540)WSTD 25540 FORMAT(32H Cannot locate standard line at ,F10.3) STOP 25531 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 *561 WRITE(6,'(55H WARNING: Standard line within 350 Km/s of spectrum e %nd)') GOTO 25551 25561 IF(WSTART .GT. WSTD-0.7 .OR. WEND .LT. WSTD+0.7)GOTO 25571 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 25591 ISTART=1 25591 CONTINUE IF(IEND .LE. NPTS)GOTO 25611 IEND=NPTS 25611 CONTINUE FMIN = 1.0 25620 I=ISTART GOTO 25623 25621 I=I+1 25623 IF((I).GT.(IEND))GOTO 25622 IF(SPEC(I) .GE. FMIN)GOTO 25641 FMIN = SPEC(I) PMIN = DBLE(I) 25641 CONTINUE GOTO 25621 25622 CONTINUE GOTO 25651 25571 CONTINUE WRITE(6,'(43H end of spectrum too close to standard line)') STOP 25651 CONTINUE 25551 CONTINUE CALL GTSTDMIN(PMIN,FMIN,CENTER) SHIFTSTD = ( WSTART + (CENTER-1.0)*DW(STDORDER) ) / WSTD 25660 J=1 GOTO 25663 25661 J=J+1 25663 IF((J).GT.(100))GOTO 25662 READ(14,*,END=24100)WREF(J) GOTO 25661 25662 CONTINUE 24100 CONTINUE REWIND(UNIT=14) CLOSE(UNIT=14) NREF = J - 1 WRONG = 0 RVT = 0.0 RVT2 = 0.0 25670 J=1 GOTO 25673 25671 J=J+1 25673 IF((J).GT.(NREF))GOTO 25672 CALL FNDORD(WREF(J),NEWORD) IF(NEWORD .NE. 0)GOTO 25691 CALL RMRVRF(WREF,J,NREF) J = J - 1 GOTO 25671 25691 CONTINUE IF(NEWORD .EQ. CURORD)GOTO 25711 CALL RDSPEC(NEWORD) 25711 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 25671 25672 CONTINUE CALL GTMEDN2(RVI,WREF,NREF,RVMED) 25720 J=1 GOTO 25723 25721 J=J+1 25723 IF((J).GT.(NREF))GOTO 25722 DVLIMIT = 25.0 IF(DABS(RVI(J)-RVMED) .LE. DVLIMIT)GOTO 25741 IF(J .GE. NREF)GOTO 25761 25770 JJ=J GOTO 25773 25771 JJ=JJ+1 25773 IF((JJ).GT.(NREF-1))GOTO 25772 WREF(JJ) = WREF(JJ+1) RVI(JJ) = RVI(JJ+1) GOTO 25771 25772 CONTINUE 25761 CONTINUE NREF = NREF - 1 J = J - 1 GOTO 25721 GOTO 25781 25741 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) 25781 CONTINUE 25731 CONTINUE IF(J.GE.NREF)GOTO 25722 GOTO 25721 25722 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 25801 RV = RVMED WRITE(6,'(16H MEDIAN RV USED )') 25801 CONTINUE RETURN END SUBROUTINE RMRVRF(WREF,J,NREF) REAL*8 WREF(100) INTEGER NREF,J,I 25810 I=J GOTO 25813 25811 I=I+1 25813 IF((I).GT.(NREF-1))GOTO 25812 WREF(I) = WREF(I+1) GOTO 25811 25812 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 25820 I=1 GOTO 25823 25821 I=I+1 25823 IF((I).GT.(50))GOTO 25822 IF(1.0 - SPEC(ICENT-I) .GE. 0.5*(1.0-FMIN) .OR. ILEFT .NE. 0)GOTO *25841 ILEFT = ICENT - I 25841 CONTINUE IF(1.0 - SPEC(ICENT+I) .GE. 0.5*(1.0-FMIN) .OR. IRIGHT .NE. 0)GOTO * 25861 IRIGHT = ICENT + I 25861 CONTINUE GOTO 25821 25822 CONTINUE IF((ILEFT .NE. 0) .AND. (IRIGHT .NE. 0))GOTO 25881 WRITE(6,25890) 25890 FORMAT(67H CANNOT DEFINE STD LINE - half depth not within 50 pixel *s of center) STOP 25881 CONTINUE II = 0 25900 I=ILEFT GOTO 25903 25901 I=I+1 25903 IF((I).GT.(IRIGHT))GOTO 25902 II = II + 1 X(II) = DBLE(I) Y(II) = SPEC(I) GOTO 25901 25902 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 25910 I=1 GOTO 25913 25911 I=I+1 25913 IF((I).GT.(3))GOTO 25912 SINGLE(I) = 1.0 GOTO 25911 25912 CONTINUE 25920 I=4 GOTO 25923 25921 I=I+1 25923 IF((I).GT.(9))GOTO 25922 SINGLE(I) = 0.0 GOTO 25921 25922 CONTINUE NSIG = 1.8 JMIN = J-2 FMIN = SPEC(JMIN) 25930 I=J-2 GOTO 25933 25931 I=I+1 25933 IF((I).GT.(J+2))GOTO 25932 IF(SPEC(I) .GE. FMIN)GOTO 25951 FMIN = SPEC(I) JMIN = I 25951 CONTINUE GOTO 25931 25932 CONTINUE DFMIN = NSIG * DMYSQ(FMIN)/SNR(NINT(CENTER)) RIGHT = .FALSE. LEFT = .FALSE. 25960 I=1 GOTO 25963 25961 I=I+1 25963 IF((I).GT.(15))GOTO 25962 IF(.NOT.(.NOT.RIGHT) .OR. JMIN+I .GT. NPTS)GOTO 25981 DFR = NSIG * DMYSQ(SPEC(JMIN+I))/SNR(JMIN+I) IF(SPEC(JMIN+I) .LE. FMIN+DFMIN+DFR)GOTO 26001 RIGHT = .TRUE. IRIGHT = I + JMIN 26001 CONTINUE 25981 CONTINUE IF(.NOT.(.NOT.LEFT) .OR. JMIN-I .LT. 1)GOTO 26021 DFL = NSIG * DMYSQ(SPEC(JMIN-I))/SNR(JMIN-I) IF(SPEC(JMIN-I) .LE. FMIN+DFMIN+DFR)GOTO 26041 LEFT = .TRUE. ILEFT = JMIN-I 26041 CONTINUE 26021 CONTINUE IF(.NOT.(LEFT) .OR. .NOT.(RIGHT))GOTO 26061 GOTO 26070 26061 CONTINUE GOTO 25961 25962 CONTINUE WRITE(6,'(44H COULD NOT FIND MINIMUM FOR LINE NEAR PIXEL ,I6)')J CENTER = DBLE(J) RETURN 26070 CONTINUE N = IRIGHT - ILEFT + 1 INDEX = ILEFT 26080 I=1 GOTO 26083 26081 I=I+(2) 26083 IF((2)*((I)-(2*N-1)).GT.0)GOTO 26082 X(I) = DBLE(INDEX) X(I+1) = 1.0 - SPEC(INDEX) INDEX = INDEX + 1 GOTO 26081 26082 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 26101 PHOTONS = SNR(JMIN)**2/FMIN GOTO 26111 26101 CONTINUE PHOTONS = 0.0D0 26111 CONTINUE 26091 CONTINUE CALL GAUSFT(X,A,N,PHOTONS,COV,SINGLE,CHISQ) IF(A(2)-DBLE(J) .GE. 8)GOTO 26131 CENTER = A(2) GOTO 26141 26131 CONTINUE CENTER = DBLE(J) 26141 CONTINUE 26121 CONTINUE RETURN END SUBROUTINE GTMEDN2(RVI,WREF,N,RVMED) REAL*8 RVI(100),WREF(100),RVMED,DUMMY INTEGER N 26150 J=1 GOTO 26153 26151 J=J+1 26153 IF((J).GT.(N-1))GOTO 26152 K = N - J 26160 I=1 GOTO 26163 26161 I=I+1 26163 IF((I).GT.(K))GOTO 26162 IF(RVI(I) .GE. RVI(I+1))GOTO 26181 DUMMY = RVI(I+1) RVI(I+1) = RVI(I) RVI(I) = DUMMY DUMMY = WREF(I+1) WREF(I+1) = WREF(I) WREF(I) = DUMMY 26181 CONTINUE GOTO 26161 26162 CONTINUE GOTO 26151 26152 CONTINUE N2 = N/2 IODD = N - 2*N2 IF(IODD .NE. 0)GOTO 26201 RVMED = RVI(N2) GOTO 26191 26201 IF(N .LE. 1)GOTO 26211 RVMED = ( RVI(N2) + RVI(N2+1) )/2.0 GOTO 26221 26211 CONTINUE RVMED = RVI(1) 26221 CONTINUE 26191 CONTINUE RETURN END SUBROUTINE GTMEDN(RVI,N,RVMED) REAL*8 RVI(100),RVMED,DUMMY INTEGER N 26230 J=1 GOTO 26233 26231 J=J+1 26233 IF((J).GT.(N-1))GOTO 26232 K = N - J 26240 I=1 GOTO 26243 26241 I=I+1 26243 IF((I).GT.(K))GOTO 26242 IF(RVI(I) .GE. RVI(I+1))GOTO 26261 DUMMY = RVI(I+1) RVI(I+1) = RVI(I) RVI(I) = DUMMY 26261 CONTINUE GOTO 26241 26242 CONTINUE GOTO 26231 26232 CONTINUE N2 = N/2 IODD = N - 2*N2 IF(IODD .NE. 0)GOTO 26281 RVMED = RVI(N2) GOTO 26271 26281 IF(N .LE. 1)GOTO 26291 RVMED = ( RVI(N2) + RVI(N2+1) )/2.0 GOTO 26301 26291 CONTINUE RVMED = RVI(1) 26301 CONTINUE 26271 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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL INTEGER IORDER IORDER = 0 NPTS = AXLEN(1) 26310 I=1 GOTO 26313 26311 I=I+1 26313 IF((I).GT.(NORD))GOTO 26312 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 26331 X1 = 1.0 + (W-WSTART)/DW(I) IORDER = I GOTO 26312 26331 CONTINUE GOTO 26311 26312 CONTINUE IF(I .GE. NORD)GOTO 26351 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 26371 X2 = 1.0 + (W-WSTART)/DW(I+1) IF(DABS(X1-DBLE(NPTS)/2.0) .LE. DABS(X2-DBLE(NPTS)/2.0))GOTO 26391 * IORDER = I + 1 26391 CONTINUE 26371 CONTINUE 26351 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(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) 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(100),DW(100),PIX1(100) REAL*8 W1,DW,PIX1 COMMON/IRAFLO/VARFIL LOGICAL VARFIL CHARACTER*10 ID,LINE*80 REAL*8 WAV1,WAV2,NPX INTEGER SEARCH,ISIZE I=0 NOCONT = 0 NOBAD = 0 NPTS = AXLEN(1) WSTART = WAV(1.0D+00) WEND = WAV(DBLE(NPTS)) 26400 CONTINUE 26401 CONTINUE I=I+1 READ(4,'(A80)',END=11680)LINE IF(ID .NE. 'CONTINUUM ')GOTO 26421 READ(LINE,'(A10,3D10.3))',END=11680)ID,WAV1,WAV2,NPX I = I - 1 WAV1 = WAV1 WAV2 = WAV2 IF(WAV1 .GE. WEND .OR. WAV2 .LE. WSTART)GOTO 26441 NOCONT = NOCONT + 1 CONLFT(NOCONT) = NINT(CHANNEL(WAV1)) CONRHT(NOCONT) = NINT(CHANNEL(WAV2)) IF(CONLFT(NOCONT) .GE. 1)GOTO 26461 CONLFT(NOCONT) = 1 26461 CONTINUE IF(CONRHT(NOCONT) .LE. NPTS)GOTO 26481 CONRHT(NOCONT) = NPTS 26481 CONTINUE ISIZE = CONRHT(NOCONT) - CONLFT(NOCONT) + 1 IF(NPX .NE. 0.0)GOTO 26501 CONSIZE(NOCONT) = ISIZE GOTO 26511 26501 CONTINUE CONSIZE(NOCONT) = NINT(NPX) 26511 CONTINUE 26491 CONTINUE IF(CONSIZE(NOCONT) .LE. ISIZE)GOTO 26531 CONSIZE(NOCONT) = ISIZE 26531 CONTINUE 26441 CONTINUE GOTO 26401 GOTO 26411 26421 IF(ID .NE. 'FITCONTIN')GOTO 26541 FITCON = .TRUE. I = I - 1 GOTO 26401 GOTO 26411 26541 IF(ID .NE. 'AUTOCONTIN')GOTO 26551 AUTOCON = .TRUE. I = I - 1 CONRHT(1) = INT(WAV1) CONLFT(1) = 1 CONSIZE(1) = INT(WAV2) GOTO 26401 GOTO 26411 26551 IF(ID .NE. 'NORMALISED')GOTO 26561 NRMLSD = .TRUE. I = I - 1 GOTO 26401 GOTO 26411 26561 IF(ID .NE. 'BADDIODE ')GOTO 26571 IF(INT(NPX) .NE. CURIMR)GOTO 26591 IF(NOBAD .NE. 300)GOTO 26611 WRITE(8,26620) 26620 FORMAT('MAXIMUM NUMBER OF BAD DIODE REGIONS EXCEEDED') RETURN 26611 CONTINUE NOBAD = NOBAD + 1 I = I - 1 IBADL(NOBAD) = INT( WAV1 ) IBADR(NOBAD)= INT( WAV2 ) 26591 CONTINUE GOTO 26401 26571 CONTINUE 26411 CONTINUE GOTO 26401 26402 CONTINUE 11680 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(500) COMMON /LINO/NOLINES,NOGDLN,NORFLN,GOOD,NREDO, ILEFT,IRIGHT,BLEND INTEGER NOLINES,NOGDLN,NORFLN,GOOD(500), ILEFT(500),IRIGHT(500),BL *END(500),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(500),FWHM(500),CENTRE(500), DELTRV(500),DEPTH *(500),LFTDIO(500), RHTDIO(500), EW(500),INCPT,SLOPE,SIGFWHM,SIGFRA *C,DISP,OFFSET,PIX_OFFSET, REDO(100),GF(500),EPLOW(500),ATOM(500),D *ISP1,DISP2,LLIMIT, ULIMIT, DELTEW(500) COMMON/LOGLIN/WEAK(500) LOGICAL WEAK COMMON /CBLK1/NOCONT,CONORD, CONRHT,CONLFT,CONSIZE INTEGER NOCONT,CONSIZE(1000),CONORD(100), CONRHT(1000),CONLFT(1000 *) COMMON/CBLK2/CONFLUX,SIGFLUX,CONCENT,ACON,CHI_SCALE REAL*8 CONFLUX(1000),SIGFLUX(1000), CONCENT(1000),ACON(50,100),CHI *_SCALE COMMON/CBLK3/NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_CONTUM LOGICAL NRMLSD,AUTOCON,FITCON,PLOTCON,OLD_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(300),NPLOTR(300), NPLOTS,SCLEFT,SCRGHT COMMON/RPLOT/ WPLOTL,WPLOTR REAL*8 WPLOTL(300),WPLOTR(300) 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(100),DW(100),PIX1(100) 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)) 26630 CONTINUE 26631 CONTINUE READ(4,'(A80)',END=11680)LINE IF(LINE(:9) .NE. 'OLDCONTIN')GOTO 26651 GOTO 26631 26651 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 26671 GOTO 26631 GOTO 26661 26671 IF(LINEID(I+1) .NE. 'FITCONTIN')GOTO 26681 GOTO 26631 GOTO 26661 26681 IF(LINEID(I+1) .NE. 'AUTOCONTIN')GOTO 26691 GOTO 26631 GOTO 26661 26691 IF(LINEID(I+1) .NE. 'NORMALISED')GOTO 26701 GOTO 26631 GOTO 26661 26701 IF(LINEID(I+1)(:5) .NE. 'FOCUS')GOTO 26711 READ(LINE(6:10),'(F5.1)')XROW IROW = NINT(XROW) IF(IROW .LE. 0)GOTO 26731 FOCUS_PARS(IROW) = .TRUE. READ(LINE(11:),'(7F10.5)')WFC(IROW),(A_FOCUS(IROW,IPAR),IPAR=1,6) GOTO 26741 26731 CONTINUE GLOBAL_FOCUS = .TRUE. READ(LINE(11:),'(7F10.5)')GLOBAL_WFC,(GLOBAL_A(IPAR),IPAR=1,6) 26741 CONTINUE 26721 CONTINUE GOTO 26631 GOTO 26661 26711 IF(LINEID(I+1) .NE. 'INST_PROF ')GOTO 26751 INST_PROF = .TRUE. GOTO 26631 GOTO 26661 26751 IF(LINEID(I+1) .NE. 'BOUNDS ')GOTO 26761 GOTO 26631 GOTO 26661 26761 IF(LINEID(I+1) .NE. 'PLOT ')GOTO 26771 GOTO 26631 GOTO 26661 26771 IF(LINEID(I+1) .NE. 'PLOTALL ')GOTO 26781 GOTO 26631 GOTO 26661 26781 IF(LINEID(I+1) .NE. 'PLOTCONTIN')GOTO 26791 GOTO 26631 GOTO 26661 26791 IF(LINEID(I+1) .NE. 'BADDIODE ')GOTO 26801 IF(INT(EPLOW(I+1)) .NE. CURIMR)GOTO 26821 IF(NOBAD .NE. 300)GOTO 26841 WRITE(8,26850) 26850 FORMAT('MAXIMUM NUMBER OF BAD DIODE REGIONS EXCEEDED') RETURN 26841 CONTINUE NOBAD = NOBAD + 1 IBADL(NOBAD) = INT( WAVELN(I+1) ) IBADR(NOBAD)= INT( ATOM(I+1) ) 26821 CONTINUE GOTO 26631 GOTO 26661 26801 IF(LINEID(I+1) .NE. 'LLIMIT ')GOTO 26861 GOTO 26631 GOTO 26661 26861 IF(LINEID(I+1) .NE. 'ULIMIT ')GOTO 26871 GOTO 26631 GOTO 26661 26871 IF(LINEID(I+1) .NE. 'FWHM ')GOTO 26881 GOTO 26631 26881 CONTINUE 26661 CONTINUE IF(IGOOD .NE. 999)GOTO 26901 I = I + 1 NOGDLN = NOGDLN + 1 GOOD(NOGDLN) = I IGOOD = 0 26901 CONTINUE IF(I.GE.500 .OR. NOCONT.GE.1000)GOTO 26632 GOTO 26631 26632 CONTINUE WRITE(8,26910) 26910 FORMAT(' LINE OR CONTINUUM BUFFER MAXIMUM REACHED') WRITE(8,26920)I,500 26920 FORMAT(I3,1X,27H LINES USED, MAX ALLOWED IS,1X,I3) WRITE(8,26930)NOCONT,1000 26930 FORMAT (I3,1X,30H CONTINUA USED, MAX ALLOWED IS,1X,I3) 11680 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 26951 DMYSQ = 0.0 GOTO 26961 26951 CONTINUE DMYSQ = DSQRT(X) 26961 CONTINUE 26941 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