SUBROUTINE ZYFND C C Module Number: 13.3.3 C C Module Name: ZYFND C C Keyphrase: C ---------- C Determine y-deflections of the HRS spectral orders C C Description: C ------------ C Using a y-scan of an HRS sepctrum, the y-deflection locations C of each order of the spectrum is determined using the following C procedure: C C 1) The total counts in each input fram(or bin) of data between C diodes DFIRST to DLAST is tabulated versus y-deflection. C 2) the table of total counts/y-deflection is sorted into ascending C y-deflection order. C 3) Approximate y-deflections for every order between M1 and M2 C are computed using previous y-deflection calibration in C table cctabin by the function: C C yapp = a + b*w + c*w*w + d*m*w C where: C a,b,c,d are coef. stored in cctabin in columns C lit_a, lit_b, lit_c, and lit_d C m - is the spectral order. C w is the wavelength computed by the equation C C w = A/m + sin((C-carpos)/B) C C carpos - is the carrousel position of the y-scan C A,B,C are carrousel calibration coefficients C stored in cctabin. C C 4) The peak of the spectral order is found by searching C the total counts in the range yapp-YTOL to yapp+YTOL. C the minimum total counts in the same range is also C determined. C 5) A more precise location of the peak is determined by C taking the average of the two positions y1 and y2 C where the total counts equals one half the peak counts C plus the minumum counts in the range. Linear interpolation C in the table of total counts versus y-deflection is used C to determine y1 and y2 to a fraction of a data point. C The y-deflection of the order is then computed as the\ C average of y1 and y2. c 6) The order is reported as not found if either the maximum in C the range yapp-ytol to yapp+ytol is less then thresh times C the minimum in the range, or the found position is greater C then ytol from yapp. C FORTRAN Name: zyfnd.for C C C Keywords of Accessed Files : C -------------------------- C input input input y-scan files all at same carrousel pos. C cctab input input carrousel calibration table file C ypostab output y-position table name C profile output table containing y-deflection profile C C Modules Called: C --------------- C CDBS: C zmfind C SDAS: * uclgs* , umsput * uttinn, utppti, utcdef, utrpt*, utcpt*, uthad*, uttclo, utccre * uttopn, utpgti, utcfnd, utrgt*, utcgt*, uthgt*, uttclo * uimotp, uimxtp, uimctp, uimopn, uimgid, uimclo, uhdgs* uimclo * C C History: C -------- C Version Date Author Description C 1 Oct 86 D. Lindler Design and coded C 2 Dec 87 D. Lindler New sdas i/o and standards * 2.1 Jan 92 S. Hulbert New grating values C------------------------------------------------------------------------ C Data Declaration C C INCLUDE FILE FOR THE IRAF77 FORTRAN INTERFACE TO THE IRAF VOS C C C FILE I/O ACCESS MODES C INTEGER RDONLY PARAMETER (RDONLY = 1) INTEGER RDWRIT PARAMETER (RDWRIT = 2) INTEGER WRONLY PARAMETER (WRONLY = 3) INTEGER APPEND PARAMETER (APPEND = 4) C C CODES FOR DATA TYPES C INTEGER TYBOOL PARAMETER (TYBOOL = 1) INTEGER TYCHAR PARAMETER (TYCHAR = 2) 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 UHDAS HEADER PARM TYPES -- CB, DAO, 5-SEP-87 C INTEGER GENHDR PARAMETER (GENHDR = 0) INTEGER IMSPEC PARAMETER (IMSPEC = 1) 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 END IRAF77.INC C C ERROR PROCESSING PARAMETERS C INTEGER STATUS,ISTAT,ISTATS(11) C ---> STATUS INDICATOR CHARACTER*130 CONTXT C ---> STATUS MESSAGE C C KEYWORD PARAMETERS C INTEGER DFIRST,DLAST C ---> DIODE RANGE INTEGER M1,M2 C --->SPECTRAL ORDER RANGE DOUBLE PRECISION YTOL,THRESH C --->Y-DEFLECTION SEARCH TOLERANCE C C INPUT FILE I/O C CHARACTER*130 INPUT,NAME INTEGER IDTEMP,IDIN,NAXIS,DTYPE,DIMEN(8) DOUBLE PRECISION DATA(512) C C INPUT CCTAB PARAMETERS C CHARACTER*64 CCTAB INTEGER COLID1(8) CHARACTER*8 COL1(8) DOUBLE PRECISION COEF(7) INTEGER NROWS LOGICAL NULLS(7) C C OUTPUT YPOS TABLE C CHARACTER*64 YPOSTB INTEGER IDOUT,COLIDS(3),CTYPE2(3) CHARACTER*8 COL2(3),CFORM(3),CUNITS(3) LOGICAL NEWTAB C C OUTPUT PROFILE TABLE C CHARACTER*64 PROFIL CHARACTER*8 COL3(2) INTEGER CTYPE3(2) C C OTHER LOCAL VARIABLES C DOUBLE PRECISION YDEFS(1000),TOTAL(1000) C ---> TABLE OF Y-DEF AND COUNTS DOUBLE PRECISION TOT,YPOS INTEGER ORDER(50),CPOS(50) DOUBLE PRECISION YPOSS(50),YDEF CHARACTER*5 GRAT1,GRAT C ---> GRATING MODE DOUBLE PRECISION CARPOS,CARPS1 C ---> CAROUSEL POSITIONS INTEGER NFOUND C ---> NUMBER OF FOUND POSITIONS INTEGER M C ---> SPECTRAL ORDER LOGICAL FIRST C ---> FIRST OBSERVATION? INTEGER I,N,ROW1,ROW2 C C IMAGE HEADER PARAMETERS C CHARACTER*8 KEYWRD(3) C C DATA DECLARATIONS C DATA COL1/'GRATING','CAP_A','CAP_B','CAP_C','LIT_A', * 'LIT_B','LIT_C','LIT_D'/ DATA COL2/'CARPOS','ORDER','YDEF'/ DATA CFORM/' ',' ',' '/ DATA CUNITS/' ',' ',' '/ DATA CTYPE2/TYINT,TYINT,TYDOUB/ DATA CTYPE3/2*TYREAL/ DATA COL3/'YDEF','TOTAL'/ DATA KEYWRD/'GRATING','YDEF','CARPOS'/ C---------------------------------------------------------------------------- C C GET INPUT CL PARAMETERS C CALL UCLGST('input',INPUT,ISTATS(1)) CALL UCLGST('cctab',CCTAB,ISTATS(2)) CALL UCLGST('profile',PROFIL,ISTATS(3)) CALL UCLGST('ypostab',YPOSTB,ISTATS(4)) CALL UCLGSB('newtable',NEWTAB,ISTATS(5)) CALL UCLGSD('ytol',YTOL,ISTATS(6)) CALL UCLGSI('dfirst',DFIRST,ISTATS(7)) CALL UCLGSI('dlast',DLAST,ISTATS(8)) CALL UCLGSI('m1',M1,ISTATS(9)) CALL UCLGSI('m2',M2,ISTATS(10)) CALL UCLGSD('thresh',THRESH,ISTATS(11)) DO 10 I=1,11 IF(ISTATS(I).NE.0)THEN CONTXT='Error reading CL parameter' GO TO 999 ENDIF 10 CONTINUE IF(DFIRST.GT.DLAST) THEN CONTXT='dfirst can not be greater than dlast' GO TO 999 ENDIF IF(M1.GT.M2)THEN CONTXT='m1 can not be greater than m2' GO TO 999 ENDIF C C INITIALIZATION OF OBSERVATION LOOP C FIRST=.TRUE. N=0 C C OPEN TEMPALTE C CALL UIMOTP(INPUT,IDTEMP,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening input filename template '//INPUT GO TO 999 ENDIF C C GET NEXT FILE NAME C 20 CALL UIMXTP(IDTEMP,NAME,ISTAT) IF(ISTAT.LT.0)GO TO 100 IF(ISTAT.NE.0)THEN CONTXT='Error getting filename from template '//INPUT GO TO 999 ENDIF 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).NE.500))THEN CONTXT='Input data must be 500 point vectors' GO TO 999 ENDIF C C READ DATA C CALL UIGL1D(IDIN,DATA,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading input file '//NAME GO TO 999 ENDIF C C GET HEADER INFORMATION C CALL UHDGST(IDIN,'grating',GRAT,ISTATS(1)) CALL UHDGSD(IDIN,'ydef',YDEF,ISTATS(2)) CALL UHDGSD(IDIN,'carpos',CARPOS,ISTATS(3)) DO 30 I=1,3 IF(ISTATS(I).NE.0)THEN CONTXT='Error reading header value '//KEYWRD(I)// * ' From input file'//NAME GO TO 999 ENDIF 30 CONTINUE C C CHECK CONSISTENCY C IF(FIRST)THEN GRAT1=GRAT C C SET DEFAULTS BY GRATING MODE FOR M1 AND M2 IF NOT SUPPLIED C IF(M1.EQ.0)THEN M1=1 C --->FIRST ORDER GRATINGS G-1 TO G-5 M2=1 IF(GRAT1.EQ.'ECH-A')THEN C --->ECHELLE A M1=33 M2=50 ENDIF IF(GRAT1.EQ.'ECH-B')THEN C --->ECHELLE B M1=17 M2=33 ENDIF ENDIF CARPS1=CARPOS FIRST=.FALSE. ENDIF IF(CARPOS.NE.CARPS1)THEN CONTXT='All observations must have carrousel position' GO TO 999 ENDIF C C COMPUTE TOTAL COUNTS FOR DIODES DFIRST-DLAST ON THE MAIN DIODE ARRAY C TOT=0.0 DO 50 I=DFIRST,DLAST TOT=TOT+DATA(I) 50 CONTINUE C C ADD TO TABLE C N=N+1 YDEFS(N)=YDEF TOTAL(N)=TOT C C CLOSE IMAGE C CALL UIMCLO(IDIN,ISTAT) C C GO GET NEXT IMAGE C GO TO 20 100 CONTINUE C C DONE READING INPUT DATA ------------------------------------------------ C C C SORT DATA BY Y-DEFLECTION C CALL ZPKSR2(N,YDEFS,TOTAL) C C READ INPUT CCTAB (FIND ROW WITH CORRECT GRATING MODE --------------------- C CALL UTTOPN(CCTAB,RDONLY,IDIN,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening input CCTAB '//CCTAB GO TO 999 ENDIF CALL UTPGTI(IDIN,TBNROW,NROWS,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading input table '//CCTAB GO TO 999 ENDIF CALL UTCFND(IDIN,COL1,8,COLID1,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error locating correct columns in '//CCTAB GO TO 999 ENDIF C C LOOP ON ROWS UNTIL CORRECT GRATING FOUND C DO 500 I=1,NROWS CALL UTRGTT(IDIN,COLID1,1,I,GRAT,NULLS,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading input table '//CCTAB GO TO 999 ENDIF IF(GRAT.EQ.GRAT1) GO TO 550 C --->FOUND? 500 CONTINUE C C IF WE MADE IT HERE, WE DID NOT FIND GRATING MATCH C CONTXT='Grating '//GRAT1//' not found in '//CCTAB GO TO 999 C C READ COEFFICIENTS C 550 CALL UTRGTD(IDIN,COLID1(2),7,I,COEF,NULLS,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading from input table '//CCTAB GO TO 999 ENDIF CALL UTTCLO(IDIN,ISTAT) C C WRITE OUTPUT PROFILE TABLE ------------------------------------------ C C OPEN OUTPUT TABLE C CALL UTTINN(PROFIL,IDOUT,ISTATS(1)) CALL UTPPTI(IDOUT,TBWTYP,TBTYPC,ISTATS(2)) CALL UTPPTI(IDOUT,TBALLR,N,ISTATS(3)) CALL UTCDEF(IDOUT,COL3,CUNITS,CFORM,CTYPE3,2,COLIDS,ISTATS(4)) CALL UTTCRE(IDOUT,ISTATS(5)) DO 200 I=1,5 IF(ISTATS(I).NE.0)THEN CONTXT='Error creating profile table '//PROFIL GO TO 999 ENDIF 200 CONTINUE C C COPY RESULTS TO TABLE C CALL UTCPTD(IDOUT,COLIDS(1),1,N,YDEFS,ISTATS(1)) CALL UTCPTD(IDOUT,COLIDS(2),1,N,TOTAL,ISTATS(2)) DO 210 I=1,2 IF(ISTATS(I).NE.0)THEN CONTXT='Error writing to output table'//PROFIL GO TO 999 ENDIF 210 CONTINUE CALL UTTCLO(IDOUT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error closing output table '//PROFIL GO TO 999 ENDIF C C LOOP ON SPECTRAL ORDERS AND LOCATE THEM------------------------------- C NFOUND=0 C --->COUNTER OF FOUND POSITIONS DO 600 M=M1,M2 C C FIND POSITION OF ORDER C CALL ZMFIND(N,YDEFS,TOTAL,COEF,GRAT,CARPOS,M,YTOL, & THRESH,NFOUND,YPOS,STATUS) IF(STATUS.EQ.0)THEN ORDER(NFOUND)=M YPOSS(NFOUND)=YPOS CPOS(NFOUND)=CARPOS ENDIF 600 CONTINUE C C CHECK IF AT LEAST ONE ORDER FOUND C IF(NFOUND.EQ.0)THEN CONTXT='NO ORDERS FOUND' GO TO 999 ENDIF C C WRITE RESULTS TO OUTPUT YPOSTAB ------------------------------------ C C CREATE OUTPUT OR APPEND TO EXISTING TABLE C IF(NEWTAB)THEN C C CREATE NEW TABLE C CALL UTTINN(YPOSTB,IDOUT,ISTATS(1)) CALL UTPPTI(IDOUT,TBRLEN,4,ISTATS(2)) CALL UTPPTI(IDOUT,TBMXCL,3,ISTATS(3)) CALL UTCDEF(IDOUT,COL2,CUNITS,CFORM,CTYPE2,3, * COLIDS,ISTATS(4)) CALL UTTCRE(IDOUT,ISTATS(5)) DO 700 I=1,5 IF(ISTATS(I).NE.0)THEN CONTXT='Error creating output table '//YPOSTB GO TO 999 ENDIF 700 CONTINUE ROW1=1 C C ADD GRATING MODE TO TABLE PARAMETERS C CALL UTHADT(IDOUT,'GRATING',GRAT1,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error writing grating mode to '//YPOSTB GO TO 999 ENDIF ELSE CALL UTTOPN(YPOSTB,RDWRIT,IDOUT,ISTATS(1)) CALL UTPGTI(IDOUT,TBNROW,NROWS,ISTATS(2)) CALL UTCFND(IDOUT,COL2,3,COLIDS,ISTATS(3)) DO 710 I=1,3 IF(ISTATS(I).NE.0)THEN CONTXT='Error reading table '//YPOSTB GO TO 999 ENDIF 710 CONTINUE ROW1=NROWS+1 C C CHECK FOR GRATING MODE CONSISTENCY C CALL UTHGTT(IDOUT,'GRATING',GRAT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading grating mode from '//YPOSTB GO TO 999 ENDIF IF(GRAT.NE.GRAT1)THEN CONTXT='Existing output table '//YPOSTB// * 'is for wrong grating' GO TO 999 ENDIF ENDIF C C COPY RESULTS TO TABLE C ROW2=ROW1+NFOUND-1 CALL UTCPTI(IDOUT,COLIDS(1),ROW1,ROW2,CPOS,ISTATS(1)) CALL UTCPTI(IDOUT,COLIDS(2),ROW1,ROW2,ORDER,ISTATS(2)) CALL UTCPTD(IDOUT,COLIDS(3),ROW1,ROW2,YPOSS,ISTATS(3)) DO 730 I=1,3 IF(ISTATS(I).NE.0)THEN CONTXT='Error writing to output table'//YPOSTB GO TO 999 ENDIF 730 CONTINUE CALL UTTCLO(IDOUT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error closing output table '//YPOSTB GO TO 999 ENDIF C C DONE C GO TO 1000 999 CALL UMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT) 1000 CALL UIMCTP(IDTEMP,ISTAT) END