SUBROUTINE ZWSHFT * * Module number: * * Module name: zwshft * * Keyphrase: * ---------- * Compute wavelength offset * * Description: * ------------ * This routine computes the offset of a model spectral * line template from its nominal position in an HRS * spectrum using cross correlation. * * FORTRAN name: zwshft.for * * Keywords of accessed files and tables: * -------------------------------------- * Name I/O Description / Comments * input I input flux array * wave I input wavelength array * intable I input line template containing * columns WAVELENGTH and * INTENSITY. * outtable O output table of offsets * maxdev I maximum deviation to search (integer) * tabstat I output table status append or write * Subroutines Called: * ------------------- * CDBS: * zcorel, zshft * SDAS: * uclgs* , umsput * uttinn, utppti, utcdef, utrpt*, utcpt*, uthad*, uttclo, utccre * uttopn, utpgti, utcfnd, utrgt*, utcgt*, uthgt*, uttclo * uimopn, uimgid, uimclo, uhdgs* uimclo * * Others: * * * History: * -------- * Version Date Author Description * 1 Aug 88 D. Lindler Designed and coded * 1.1 Jan 92 S. Hulbert New grating values *------------------------------------------------------------------------------- C C FILE I/O ACCESS MODES C INTEGER RDONLY PARAMETER (RDONLY = 1) INTEGER RDWRIT PARAMETER (RDWRIT = 2) C C CODES FOR DATA TYPES C INTEGER TYINT PARAMETER (TYINT = 4) INTEGER TYREAL PARAMETER (TYREAL = 6) INTEGER TYDOUB PARAMETER (TYDOUB = 7) C C UMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87 C INTEGER STDOUT PARAMETER (STDOUT = 1) INTEGER STDERR PARAMETER (STDERR = 2) C C THIS SECTION IS FOR PARAMETERS RELEVANT TO TABLE I/O. C C THESE MAY BE SET BY UTPPTI AND/OR READ BY UTPGTI: C C LENGTH OF ROW (UNIT = SIZE OF REAL) INTEGER TBRLEN PARAMETER (TBRLEN = 1) C INCREASE ROW LENGTH INTEGER TBIRLN PARAMETER (TBIRLN = 2) C NUMBER OF ROWS TO ALLOCATE INTEGER TBALLR PARAMETER (TBALLR = 3) C INCREASE ALLOC NUM OF ROWS INTEGER TBIALR PARAMETER (TBIALR = 4) C WHICH TYPE OF TABLE? (ROW OR COLUMN) INTEGER TBWTYP PARAMETER (TBWTYP = 5) C MAXIMUM NUMBER OF USER PARAMETERS INTEGER TBMXPR PARAMETER (TBMXPR = 6) C MAXIMUM NUMBER OF COLUMNS INTEGER TBMXCL PARAMETER (TBMXCL = 7) C TYPE = ROW-ORDERED TABLE INTEGER TBTYPR PARAMETER (TBTYPR = 11) C TYPE = COLUMN-ORDERED TABLE INTEGER TBTYPC PARAMETER (TBTYPC = 12) C C THESE MAY BE READ BY UTPGTI BUT MAY NOT BE SET: C C NUMBER OF ROWS WRITTEN TO INTEGER TBNROW PARAMETER (TBNROW = 21) C C INPUT FILE I/O C CHARACTER*64 NAME,WNAME C --->FILE NAMES INTEGER IDIN C --->FILE IDS INTEGER NAXIS,DTYPE,DIMEN(8),NS C --->DATA DESCRIPTIONS DOUBLE PRECISION FLUX(2000),WAVE(2000) C --->DATA BUFFERS C C INPUT TABLE PARAMETERS C CHARACTER*64 INTAB INTEGER NROWS CHARACTER*20 COLIN(2) LOGICAL NULLS(1000) DOUBLE PRECISION WPROF(1000),PROF(1000) C --->LINE TEMPLATE C C OUTPUT TABLE PARAMETERS C CHARACTER*64 TABLE INTEGER COLIDS(6),IDOUT,CTYPE(6) CHARACTER*20 COLNAM(6),CUNITS(6),CFORM(6) CHARACTER*5 GRAT INTEGER CARPOS,ORDER DOUBLE PRECISION WCENT,OFFSET,WOFF C C OTHER INPUT CL PARAMETERS C CHARACTER*6 TBSTAT INTEGER MAXDEV C C INTERPOLATED TEMPLATE PARAMETERS C C C ERROR PROCESSING PARAMETERS C INTEGER ISTATS(10),ISTAT CHARACTER*130 CONTXT C C OTHER LOCAL VARIABLES C INTEGER I C C INPUT TABLE DATA C DATA COLIN/'WAVELENGTH','INTENSITY'/ C C OUTPUT TABLE DATA C DATA COLNAM/'GRATING','CARPOS','ORDER','WAVELENGTH', * 'DELTAS','DELTAW'/ DATA CFORM/' ','I8','I3','F10.3','F7.3','F8.4'/ DATA CTYPE/-3,TYINT,TYINT,TYDOUB,TYREAL,TYREAL/ DATA CUNITS/6*' '/ C----------------------------------------------------------------------------- C C GET INPUT CL PARAMETERS C CALL UCLGST('input',NAME,ISTATS(1)) CALL UCLGST('wave',WNAME,ISTATS(2)) CALL UCLGST('intable',INTAB,ISTATS(3)) CALL UCLGST('outtable',TABLE,ISTATS(4)) CALL UCLGSI('maxdev',MAXDEV,ISTATS(5)) CALL UCLGST('tabstat',TBSTAT,ISTATS(6)) DO 10 I=1,6 IF(ISTATS(I).NE.0)THEN CONTXT='ERROR getting cl parameter' GO TO 999 ENDIF 10 CONTINUE C C READ INPUT FLUX ARRAY C C C OPEN INPUT FILE C CALL UIMOPN(NAME,RDONLY,IDIN,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening file '//NAME GO TO 999 ENDIF C C READ IMAGE INFO C CALL UIMGID(IDIN,DTYPE,NAXIS,DIMEN,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading input file '//NAME GO TO 999 ENDIF C C CHECK FOR VALID DATA C IF((NAXIS.NE.1).OR.(DIMEN(1).GT.2000))THEN CONTXT='Input must be vector with 2000 or fewer points' GO TO 999 ENDIF NS=DIMEN(1) C C READ DATA C CALL UIGL1D(IDIN,FLUX,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading input file '//NAME GO TO 999 ENDIF C----------------------------------------------------------------------- C C GET HEADER PARAMETERS C CALL UHDGST(IDIN,'GRATING',GRAT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='ERROR: GRATING missing from input header' GO TO 999 ENDIF CALL UHDGSI(IDIN,'CARPOS',CARPOS,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='ERROR: CARPOS missing from input header' GO TO 999 ENDIF CALL UHDGSI(IDIN,'SPORDER',ORDER,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='ERROR: SPORDER missing from input header' GO TO 999 ENDIF C C CLOSE IMAGE C CALL UIMCLO(IDIN,ISTAT) C---------------------------------------------------------------------- C READ INPUT WAVE ARRAY C C C OPEN INPUT FILE C CALL UIMOPN(WNAME,RDONLY,IDIN,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening file '//WNAME GO TO 999 ENDIF C C READ IMAGE INFO C CALL UIMGID(IDIN,DTYPE,NAXIS,DIMEN,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading input file '//WNAME GO TO 999 ENDIF C C CHECK FOR VALID DATA C IF((NAXIS.NE.1).OR.(DIMEN(1).NE.NS))THEN CONTXT='wavelength vector inconsistent with flux vector' GO TO 999 ENDIF C C READ DATA C CALL UIGL1D(IDIN,WAVE,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading input file '//WNAME GO TO 999 ENDIF C C CLOSE FILE C CALL UIMCLO(IDIN,ISTAT) C--------------------------------------------------------------------------- C C READ INPUT PROFILE TABLE C CALL UTTOPN(INTAB,RDONLY,IDIN,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening input table '//INTAB GO TO 999 ENDIF CALL UTPGTI(IDIN,TBNROW,NROWS,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading input table '//INTAB GO TO 999 ENDIF C C LOCATE COLUMNS C CALL UTCFND(IDIN,COLIN,2,COLIDS,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error locating correct columns in '//INTAB GO TO 999 ENDIF C C READ TABLE C CALL UTCGTD(IDIN,COLIDS(1),1,NROWS,WPROF,NULLS,ISTATS(1)) CALL UTCGTD(IDIN,COLIDS(2),1,NROWS,PROF,NULLS,ISTATS(2)) IF((ISTATS(1).NE.0).OR.(ISTATS(2).NE.0))THEN CONTXT='Error reading input table '//INTAB GO TO 999 ENDIF WCENT=(WPROF(1)+WPROF(NROWS))/2.0 CALL UTTCLO(IDIN,ISTAT) C---------------------------------------------------------------------- C C DO SOMETHING USEFUL C CALL ZSHFT(WAVE,FLUX,NS,WPROF,PROF,NROWS,MAXDEV,OFFSET, * WOFF,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='No results written' GO TO 999 ENDIF C----------------------------------------------------------------------- C C CREATE OUTPUT OR APPEND TO EXISTING TABLE C IF(TBSTAT.NE.'append')THEN C C CREATE NEW TABLE C CALL UTTINN(TABLE,IDOUT,ISTATS(1)) CALL UTPPTI(IDOUT,TBMXCL,6,ISTATS(2)) CALL UTCDEF(IDOUT,COLNAM,CUNITS,CFORM,CTYPE,6, * COLIDS,ISTATS(3)) CALL UTTCRE(IDOUT,ISTATS(4)) DO 200 I=1,4 IF(ISTATS(I).NE.0)THEN CONTXT='Error creating output table '//TABLE GO TO 999 ENDIF 200 CONTINUE NROWS=1 ELSE CALL UTTOPN(TABLE,RDWRIT,IDOUT,ISTATS(1)) CALL UTPGTI(IDOUT,TBNROW,NROWS,ISTATS(2)) CALL UTCFND(IDOUT,COLNAM,6,COLIDS,ISTATS(3)) DO 300 I=1,3 IF(ISTATS(I).NE.0)THEN CONTXT='Error reading table '//NAME GO TO 999 ENDIF 300 CONTINUE NROWS=NROWS+1 ENDIF C C COPY RESULTS TO TABLE C CALL UTRPTT(IDOUT,COLIDS(1),1,NROWS,GRAT,ISTATS(1)) CALL UTRPTI(IDOUT,COLIDS(2),1,NROWS,CARPOS,ISTATS(2)) CALL UTRPTI(IDOUT,COLIDS(3),1,NROWS,ORDER,ISTATS(3)) CALL UTRPTD(IDOUT,COLIDS(4),1,NROWS,WCENT,ISTATS(4)) CALL UTRPTD(IDOUT,COLIDS(5),1,NROWS,OFFSET,ISTATS(5)) CALL UTRPTD(IDOUT,COLIDS(6),1,NROWS,WOFF,ISTATS(6)) DO 210 I=1,6 IF(ISTATS(I).NE.0)THEN CONTXT='Error writing to output table' GO TO 999 ENDIF 210 CONTINUE CALL UTTCLO(IDOUT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error closing output table '//TABLE GO TO 999 ENDIF C C DONE ------------------------------------------------------------------- C GO TO 1000 999 CALL UMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT) 1000 RETURN END