SUBROUTINE ZAPOFF * * Module number: * * Module name: zapoff * * Keyphrase: * ---------- * Offset wavelengths for object not centered in the target aperture. * * Description: * ------------ * This routine computes the wavelength offsets for an object not * centered in the large (lsa) or small (ssa) science aperture. * The routine uses the positions of the object in the target aperture * and the positions of the spectral cal. lamp apertures (sc1 and sc2) * computed by routine TAMODE. The position of the object within the * target aperture is computed by taking the difference of the position * from the spectral calibration lamp apertures and subtracting this * from the nominal difference for the center of the aperture. * The wavelength offset is then computed by: * M*DW = (off_0 + off_1*carpos + off_2*M + off_3*sample)*DX * where; * M - is the spectral order * DW is the wavelength offset * carpos is the carrousel position of the spectral observation * sample is the sample position (one per data point) * DX is the offset in X from the target aperture center in * deflection units. * * FORTRAN name: zapoff * * Keywords of accessed files and tables: * -------------------------------------- * Name I/O Description / Comments * * input I Input wavelength vector * table1 I Input aperture position table * (normally computed by TAMODE) * Columns required: * APERTURE - aperture (ssa, lsa, * sc1, or sc2) * X_CENTER - aperture position in * deflection units * header parameter GRATING giving * the target acquisition element is * also required. * table2 I Aperture separation table giving * the separation of the target aperture * from sc1 and sc2. * Required columns are: * GRATING - target acquisition element. * (MIRROR-A1, MIRROR-A2, * MIRROR-N1, or MIRROR-N2) * APERTURE - target aperture (ssa or * lsa) * DX_SC1 - nominal aperture speration * from sc1. (target position minus * sc1 position) * DX_SC2 - same for sc2. * table3 I Wavelength offset coefficients. * containing columns: * GRATING - grating mode (G140M, G160M, * G200M, G270M, G140L, * ECH-A, or ECH-B) * OFF_0, OFF_1, OFF_3, and OFF_3- * offset coefficients. * output O Output corrected wavelength vector. * * Subroutines Called: * ------------------- * * uclgs* , umsput * uttopn, utpgti, utcfnd, utrgt*, utcgt*, uthgt*, uttclo * uimopn, uimgid, uimclo, uhdgs* uimclo * * History: * -------- * Version Date Author Description * 1 Oct 1988 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) C C UMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87 C INTEGER STDOUT PARAMETER (STDOUT = 1) INTEGER STDERR PARAMETER (STDERR = 2) C C UHDAS HEADER PARM TYPES -- CB, DAO, 5-SEP-87 C INTEGER GENHDR PARAMETER (GENHDR = 0) C C THIS SECTION IS FOR PARAMETERS RELEVANT TO TABLE I/O. C C C NUMBER OF ROWS WRITTEN TO INTEGER TBNROW PARAMETER (TBNROW = 21) C END IRAF77.INC C C INPUT WAVELENGTH FILE C CHARACTER*130 INPUT INTEGER IDIN,NAXIS,DTYPE,DIMEN(8) DOUBLE PRECISION WAVE(2000),SAMPLE,DELTAS INTEGER NS,CARPOS,M,BINID CHARACTER*5 GRAT CHARACTER*3 APER CHARACTER*8 HEADER(6) C C OUTPUT WAVELENGTH FILE C CHARACTER*130 OUTPUT INTEGER IDOUT C C INPUT APERTURE POSITION TABLE C CHARACTER*130 TABLE1 INTEGER NROWS,IROW,ID CHARACTER*20 COL1(2) CHARACTER*3 APER1 CHARACTER*9 TAMOD1 DOUBLE PRECISION XTARG,XSC1,XSC2,XPOS INTEGER NXTARG,NXSC1,NXSC2 LOGICAL NULL C C INPUT APERTURE SEPARATION TABLE C CHARACTER*130 TABLE2 CHARACTER*20 COL2(4) DOUBLE PRECISION DXSC1,DXSC2 CHARACTER*3 APER2 CHARACTER*9 TAMOD2 C C INPUT OFFSET COEFFICIENT TABLE C CHARACTER*130 TABLE3 CHARACTER*20 COL3(5) INTEGER COLIDS(5) LOGICAL NULLS(5) CHARACTER*5 GRAT3 DOUBLE PRECISION OFF(4) C C OTHER LOCAL PARAMETERS C CHARACTER*130 CONTXT INTEGER ISTATS(20),ISTAT,I DOUBLE PRECISION S,XOFF1,XOFF2,XOFF,DW C C DATA DECLARATIONS C DATA HEADER/'GRATING','SAMPLE','DELTAS','BINID', * 'CARPOS','ORDER'/ DATA COL1/'APERTURE','X_CENTER'/ DATA COL2/'GRATING','APERTURE','DX_SC1','DX_SC2'/ DATA COL3/'GRATING','OFF_0','OFF_1','OFF_2','OFF_3'/ C C============================================================================= C-----------------------------------------------------------------CL PARAMETERS C GET CL PARAMETERS C CALL UCLGST('input',INPUT,ISTATS(1)) CALL UCLGST('table1',TABLE1,ISTATS(2)) CALL UCLGST('table2',TABLE2,ISTATS(3)) CALL UCLGST('table3',TABLE3,ISTATS(4)) CALL UCLGST('output',OUTPUT,ISTATS(5)) DO 10 I=1,5 IF(ISTATS(I).NE.0)THEN CONTXT='Error reading cl parameter' GO TO 999 ENDIF 10 CONTINUE C C READ INPUT WAVELENGTH VECTOR ---------------------------------------- INPUT C C C OPEN INPUT FILE C CALL UIMOPN(INPUT,RDONLY,IDIN,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening file '//INPUT 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 '//INPUT GO TO 999 ENDIF C C CHECK FOR VALID DATA C IF((NAXIS.NE.1).OR.(DIMEN(1).GT.2000))THEN CONTXT='Input data must be vector with 2000 or fewer points' GO TO 999 ENDIF NS=DIMEN(1) C C READ DATA C CALL UIGL1D(IDIN,WAVE,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading input file '//INPUT GO TO 999 ENDIF C C GET HEADER PARAMETERS C CALL UHDGST(IDIN,'GRATING',GRAT,ISTATS(1)) CALL UHDGSD(IDIN,'SAMPLE',SAMPLE,ISTATS(2)) CALL UHDGSD(IDIN,'DELTAS',DELTAS,ISTATS(3)) CALL UHDGSI(IDIN,'BINID',BINID,ISTATS(4)) CALL UHDGSI(IDIN,'CARPOS',CARPOS,ISTATS(5)) CALL UHDGSI(IDIN,'ORDER',M,ISTATS(6)) DO 50 I=1,6 IF(ISTATS(I).NE.0)THEN CONTXT='ERROR: '//HEADER(I)//' missing from input heaer' GO TO 999 ENDIF 50 CONTINUE C C DETERMINE TARGET APERTURE C IF((BINID.NE.1).AND.(BINID.NE.2))THEN CONTXT='Error: invalid BINID in input, must be 1 or 2' GO TO 999 ENDIF IF(BINID.EQ.1)APER='ssa' IF(BINID.EQ.2)APER='lsa' C -------------------------------------------------------------------- table 1 C READ INPUT APERTURE POSITION TABLE AND COMPUTE AVERAGES WHEN MULTIPLE C ROWS HAVE VALUES FOR THE SAME APERTURE. C NXSC1=0 NXSC2=0 NXTARG=0 XSC1=0.0 XSC2=0.0 XTARG=0.0 C C OPEN TABLE C CALL UTTOPN(TABLE1,RDONLY,ID,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening input table1' GO TO 999 ENDIF CALL UTPGTI(ID,TBNROW,NROWS,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error getting number of rows from table1' GO TO 999 ENDIF C C LOCATE DESIRED COLUMNS C CALL UTCFND(ID,COL1,2,COLIDS,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error locating correct columns in table1' GO TO 999 ENDIF C C GET TARGET ACQUISTION ELEMENT NAME C CALL UTHGTT(ID,'GRATING',TAMOD1,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error getting GRATING from table1 header' GO TO 999 ENDIF C C LOOP ON ROWS AND ACCUMULATE APERTURE POSITIONS C DO 100 IROW=1,NROWS CALL UTRGTT(ID,COLIDS(1),1,IROW,APER1,NULL,ISTATS(1)) CALL UTRGTD(ID,COLIDS(2),1,IROW,XPOS,NULL,ISTATS(2)) IF((ISTATS(1).NE.0).OR.(ISTATS(2).NE.0))THEN CONTXT='Error reading input table1' GO TO 999 ENDIF IF (.NOT.NULL)THEN IF(APER1.EQ.APER)THEN XTARG=XTARG+XPOS NXTARG=NXTARG+1 ENDIF IF(APER1.EQ.'sc1')THEN XSC1=XSC1+XPOS NXSC1=NXSC1+1 ENDIF IF(APER1.EQ.'sc2')THEN XSC2=XSC2+XPOS NXSC2=NXSC2+1 ENDIF ENDIF 100 CONTINUE C C CLOSE TABLE AND VERIFY WE GOT ENOUGH DATA C CALL UTTCLO(ID,ISTAT) IF(NXTARG.EQ.0)THEN CONTXT='No aperture position for '//APER// * ' was found in table1' GO TO 999 ENDIF IF((NXSC1+NXSC2).EQ.0)THEN CONTXT='No spectral lamp aperture positions '// * ' found in table1' GO TO 999 ENDIF C C COMPUTE AVERAGE C XTARG=XTARG/NXTARG IF(NXSC1.GT.0)XSC1=XSC1/NXSC1 IF(NXSC2.GT.0)XSC2=XSC2/NXSC2 C C ------------------------------------------------------------------- TABLE 2 C C READ NOMINAL APERTURE POSITION RELATIVE TO THE SPECTRAL LAMP POSITIONS C FOR THE TARGET ACQUISITION MODE FROM TABLE1. C C C OPEN TABLE C CALL UTTOPN(TABLE2,RDONLY,ID,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening input table2' GO TO 999 ENDIF CALL UTPGTI(ID,TBNROW,NROWS,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error getting number of rows from table2' GO TO 999 ENDIF C C LOCATE DESIRED COLUMNS C CALL UTCFND(ID,COL2,4,COLIDS,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error locating correct columns in table2' GO TO 999 ENDIF C C LOOP ON ROWS UNTIL CORRECT TA ELEMENT AND APERTURE FOUND C DO 200 IROW=1,NROWS CALL UTRGTT(ID,COLIDS(1),1,IROW,TAMOD2,NULL,ISTATS(1)) CALL UTRGTT(ID,COLIDS(2),1,IROW,APER2,NULL,ISTATS(2)) IF((ISTATS(1).NE.0).OR.(ISTATS(2).NE.0))THEN CONTXT='Error reading input table2' GO TO 999 ENDIF IF((TAMOD2.EQ.TAMOD1).AND.(APER2.EQ.APER))THEN CALL UTRGTD(ID,COLIDS(3),1,IROW,DXSC1,NULL,ISTATS(1)) CALL UTRGTD(ID,COLIDS(4),1,IROW,DXSC2,NULL,ISTATS(2)) IF((ISTATS(1).NE.0).OR.(ISTATS(2).NE.0))THEN CONTXT='Error reading input table2' GO TO 999 ENDIF GO TO 250 ENDIF 200 CONTINUE C C IF WE MADE IT HERE, WE DID NOT FIND A VALID ROW C CONTXT='Error: no row found in table2 for '//TAMOD1//' '//APER GO TO 999 C C CLOSE TABLE C 250 CALL UTTCLO(ID,ISTAT) C C---------------------------------------------------------------------- TABLE 3 C C READ OFFSET COEFFICIENTS FOR THE GRATING CORRECT GRATING MODE C C C OPEN TABLE C CALL UTTOPN(TABLE3,RDONLY,ID,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening input table3' GO TO 999 ENDIF CALL UTPGTI(ID,TBNROW,NROWS,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error getting number of rows from table3' GO TO 999 ENDIF C C LOCATE DESIRED COLUMNS C CALL UTCFND(ID,COL3,5,COLIDS,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error locating correct columns in table3' GO TO 999 ENDIF C C LOOP ON ROWS UNTIL CORRECT GRATING MODE IS LOCATED C DO 300 IROW=1,NROWS CALL UTRGTT(ID,COLIDS(1),1,IROW,GRAT3,NULL,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading table3' GO TO 999 ENDIF IF(GRAT3.EQ.GRAT)THEN CALL UTRGTD(ID,COLIDS(2),4,IROW,OFF,NULLS,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading table3' GO TO 999 ENDIF GO TO 350 ENDIF 300 CONTINUE C C IF WE MADE IT HERE WE DID NOT FIND VALID ROW C CONTXT='Error: no row found in table3 for grating '//GRAT GO TO 999 C 350 CALL UTTCLO(ID,ISTAT) C C--------------------------------------------------------------------- COMPUTE C AT LAST C ---> READY TO DO SOME REAL WORK C C COMPUTE OFFSETS FOR APERTURE CENTER FOR EACH LAMP AND AVERAGE C FOR THE TWO LAMPS C IF(NXSC1.GT.0)THEN XOFF1=(XTARG-XSC1)-DXSC1 WRITE(CONTXT,99)XOFF1 99 FORMAT(' X-offset (def. units) from aperture center', * ' using sc1=',F10.1) CALL UMSPUT(CONTXT,STDOUT,0,ISTAT) XOFF=XOFF1 ENDIF IF(NXSC2.GT.0)THEN XOFF2=(XTARG-XSC2)-DXSC2 WRITE(CONTXT,199)XOFF2 199 FORMAT(' X-offset (def. units) from aperture center', * ' using sc2=',F10.1) CALL UMSPUT(CONTXT,STDOUT,0,ISTAT) XOFF=XOFF2 ENDIF IF( (NXSC1.GT.0).AND.(NXSC2.GT.0) ) XOFF=(XOFF1+XOFF2)/2.0 C C COMPUTE WAVELENGTH OFFSETS FOR EACH DATA POINT C DO 500 I=1,NS S=SAMPLE+(I-1)*DELTAS DW=(OFF(1)+OFF(2)*CARPOS+OFF(3)*M+OFF(4)*S)*XOFF/M WAVE(I)=WAVE(I)+DW 500 CONTINUE C C----------------------------------------------------------------- OUTPUT C C OPEN OUTPUT FILE USING INPUT FILE AS TEMPLATE C CALL UIMOPC(OUTPUT,IDIN,IDOUT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening output file' GO TO 999 ENDIF C C WRITE DATA INTO IT C CALL UIPL1D(IDOUT,WAVE,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error writing data to output file' GO TO 999 ENDIF C C ADD SOME HISTORY C WRITE(CONTXT,299)XOFF,APER 299 FORMAT('Wavelength offset for target ',F9.2,' xdef. units', * ' from ',A3,' center') CALL UHDAST(IDOUT,'HISTORY',' ',CONTXT,GENHDR,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error writing to output header' GO TO 999 ENDIF C C CLOSE FILES C CALL UIMCLO(IDIN,ISTAT) CALL UIMCLO(IDOUT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error closing output file' GO TO 999 ENDIF C C DONE C GO TO 1000 999 CALL UMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT) 1000 RETURN END