SUBROUTINE ZAFITE * * Module Number: 13.10.4 * * Module Name: ZAFITE * * Keyphrase: * ---------- * Fit HRS sensitivity curve * * Description: * ------------ * A least squares cubic spline with specified node positions * supplied by innodes. If then input node (innodes) is not suppied * (i.e. " ") then numnodes equally * spaced nodes is used to fit the raw input wavelength versus sens. * If innodes = " " and the number of nodes is not supplied (i.e. zero). * then the output will be a cubic spline passing throuhg all input * data points in the input data. * * Fortran Name: zafite * * Keywords of accessed files and tables: * -------------------------------------- * table input name of table containing raw sens. versus * wavelength. * outnodes output table of node position of the least squares * cubic spline. * WAVE output output wavelength vector file name * SENS output output sensitivity file name containing a vector * with the same length as WAVE. * NUMNODES input input parameter giving the number of nodes in * least squares spline (ignored if innodes is * supplied). * INNODES input input table giving the node positions (in the * wavelength column) if unequally spaced nodes * are desired) * DELW input input parameter giving the wavelength spacing * in WAVE. If not supplied the wavelengths in * the input RATIO table are used. * WFIRST input input parameter giving the first wavelength in * WAVE. Ignored if DELW is not supplied. * WLAST input input parameter giving the max. wavelenght in * WAVE. Ignored if DELW is not supplied. * * Subroutines Called: * ------------------- * CDBS: * zsplin, zspfit, ztplat * 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 * * History: * -------- * version date Author Description * 1 3/1/87 D. Lindler Designed and coded * 2 Dec 87 D. Lindler New sdas i/o and standards * 2.1 Jan 92 S. Hulbert New grating values *------------------------------------------------------------------------- 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(20) CHARACTER*130 CONTXT C C KEYWORD PARAMETERS C DOUBLE PRECISION DELW,W1,W2 C --->OUTPUT WAVELENGTH RANGE AND DELTA INTEGER NODES C --->NUMBER OF EQUALLY SPACED NODES CHARACTER*64 WTEMP,STEMP C --->TEMPLATE FILE NAMES CHARACTER*64 INNODE C --->OPTIONAL INPUT NODE TABLE NAME CHARACTER*64 WNAME,SNAME C --->OUTPUT FILE NAMES INTEGER NITER C --->NUMBER OF ITERATIONS OF FIT ROUTINE C C INPUT TABLE VARIABLES C CHARACTER*64 TABLE INTEGER IDIN,COLIDS(2) CHARACTER*16 COLNAM(2) DOUBLE PRECISION WAVE(2000),VALUES(2000) INTEGER NROWS,NS LOGICAL NULLS(2000) CHARACTER*5 GRAT CHARACTER*4 APER C C OUTPUT NODE TABLE C CHARACTER*64 OUTNOD DOUBLE PRECISION WNODES(200),VNODES(200) CHARACTER*8 CUNITS(2),CFORM(2) INTEGER IDOUT,CTYPE(2) C C FIT ROUTINE PARAMETERS C DOUBLE PRECISION FIT(2000) C C OTHER LOCAL VARIABLES C INTEGER I DOUBLE PRECISION DIF C C DATA DECLARATIONS C DATA COLNAM/'WAVELENGTH','VALUE'/ DATA CUNITS/2*' '/ DATA CFORM/2*' '/ DATA CTYPE/2*TYDOUB/ C----------------------------------------------------------------------- C C GET INPUT CL PARAMETERS C CALL UCLGST('table',TABLE,ISTATS(1)) CALL UCLGST('wave',WNAME,ISTATS(2)) CALL UCLGST('sens',SNAME,ISTATS(3)) CALL UCLGST('innodes',INNODE,ISTATS(4)) CALL UCLGST('outnodes',OUTNOD,ISTATS(5)) CALL UCLGSI('numnodes',NODES,ISTATS(6)) CALL UCLGSD('delw',DELW,ISTATS(7)) CALL UCLGSD('wfirst',W1,ISTATS(8)) CALL UCLGSD('wlast',W2,ISTATS(9)) CALL UCLGST('wtemplate',WTEMP,ISTATS(10)) CALL UCLGST('stemplate',STEMP,ISTATS(11)) CALL UCLGSI('niter',NITER,ISTATS(12)) DO 10 I=1,12 IF(ISTATS(I).NE.0)THEN CONTXT='Error getting CL parameter' GO TO 999 ENDIF 10 CONTINUE C C READ INPUT TABLE OF WAVELENGTH VERSUS RAW SENSITIVITY VALUES---------- C CALL UTTOPN(TABLE,RDONLY,IDIN,ISTAT) C --->open table IF(ISTAT.NE.0)THEN CONTXT='Error opening input table '//TABLE GO TO 999 ENDIF CALL UTPGTI(IDIN,TBNROW,NROWS,ISTAT) C --->get number of rows IF(ISTAT.NE.0)THEN CONTXT='Error reading input table '//TABLE GO TO 999 ENDIF IF(NROWS.GT.2000)THEN CONTXT='Max. of 2000 rows allowed in sens. table '//TABLE GO TO 999 ENDIF CALL UTCFND(IDIN,COLNAM,2,COLIDS,ISTAT) C --->locate columns IF(ISTAT.NE.0)THEN CONTXT='Error locating columns in sens. table '//TABLE GO TO 999 ENDIF C C READ TABLE DATA C NS=NROWS CALL UTCGTD(IDIN,COLIDS(1),1,NS,WAVE,NULLS,ISTATS(1)) CALL UTCGTD(IDIN,COLIDS(2),1,NS,VALUES,NULLS,ISTATS(2)) IF((ISTATS(1).NE.0).OR.(ISTATS(2).NE.0))THEN CONTXT='Error reading input table '//TABLE GO TO 999 ENDIF C C GET GRATING MODE AND APERTURE C CALL UTHGTT(IDIN,'GRATING',GRAT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error: grating mode parameter missing from '// * TABLE GO TO 999 ENDIF CALL UTHGTT(IDIN,'APERTURE',APER,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error: aperture parameter missing from '// * TABLE GO TO 999 ENDIF CALL UTTCLO(IDIN,ISTAT) C C READ INPUT NODE TABLE (IF NOT SUPPLIED) USE NUMBER OF NODES TO COMPUTE ----- C EQUALLY SPACED NODE POSITIONS C IF(INNODE.NE.' ')THEN CALL UTTOPN(INNODE,RDONLY,IDIN,ISTAT) C --->open table IF(ISTAT.NE.0)THEN CONTXT='Error opening input table '//INNODE GO TO 999 ENDIF CALL UTPGTI(IDIN,TBNROW,NODES,ISTAT) C --->get number of rows IF(ISTAT.NE.0)THEN CONTXT='Error reading input table '//INNODE GO TO 999 ENDIF IF((NODES.GT.30).OR.(NODES.LT.2))THEN CONTXT='Error: '//INNODE//' Must have between 2 and '// * '30 node positions' GO TO 999 ENDIF CALL UTCFND(IDIN,COLNAM,1,COLIDS,ISTAT) C --->locate column IF(ISTAT.NE.0)THEN CONTXT='Error locating wavelength column in sens. table ' * //INNODE GO TO 999 ENDIF C C READ TABLE DATA C CALL UTCGTD(IDIN,COLIDS(1),1,NODES,WNODES,NULLS,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading input table '//INNODE GO TO 999 ENDIF CALL UTTCLO(IDIN,ISTAT) CALL UMSPUT('Input node positions taken from table '// * INNODE,STDOUT,0,ISTAT) ELSE C C USE EQUALLY SPACED NODES (UNLESS NODES EQUAL 0, WHERE NO FIT IS DONE) C IF(NODES.GT.1)THEN DIF=WAVE(NS)-WAVE(1) DIF=DIF/(NODES-1) DO 20 I=1,NODES WNODES(I)=WAVE(1)+DIF*(I-1) 20 CONTINUE ENDIF ENDIF C C IF NODES IS GREATER THAN 1 THEN PERFORM LEAST SQUARES FIT TO FIND C SPLINE NODES AND VALUES. OTHERWISE, USE INPUT WAVE AND RATIO C AS SPLINE NODES. C IF(NODES.GT.1) THEN CALL ZSPFIT(WAVE,VALUES,NS,WNODES,VNODES,NODES,NITER, * FIT,STATUS) IF(STATUS.NE.0)THEN CONTXT='ERROR DOING LEAST SQUARES SPLINE FIT' GO TO 999 ENDIF ELSE C C JUST COMPUTE SPLINE RUNNING THROUGH INPUT DATA C IF(NS.GT.100)THEN CONTXT='INPUT DATA MUST HAVE 100 OR FEWER '// * ' TO GENERATE SPLINE CURVE' GO TO 999 ENDIF NODES=NS DO 50 I=1,NS WNODES(I)=WAVE(I) VNODES(I)=VALUES(I) 50 CONTINUE ENDIF C C COMPUTE OUTPUT WAVELENGTH ARRAY IF DELW IS SUPPLIED, OTHERWISE C OUTPUT WAVELENGTHS ARE THE SAME AS THE ONES IN THE INPUT SENS. C TABLE. C IF (DELW.NE.0.0)THEN IF(W1.EQ.0.0)W1=WAVE(1) IF(W2.EQ.0.0)W2=WAVE(NROWS) NS=(W2-W1)/DELW IF(NS.GT.2000)THEN CONTXT='TOO MANY POINTS IN OUTPUT SENSITIVITY'// * ' CURVE, DELW IS TOO SMALL' GO TO 999 ENDIF DO 80 I=1,NS WAVE(I)=W1+(I-1)*DELW 80 CONTINUE ENDIF C C COMPUTE SPLINE CURVE AT POINTS IN WAVE C CALL ZSPLIN(WAVE,NS,WNODES,VNODES,NODES,FIT,STATUS) IF(STATUS.NE.0)THEN CONTXT='ERROR COMPUTING SPLINE FUNCTION' GO TO 999 ENDIF C C WRITE OUTPUT TABLE OF NODES ------------------------------------------- C CALL UTTINN(OUTNOD,IDOUT,ISTATS(1)) CALL UTPPTI(IDOUT,TBWTYP,TBTYPC,ISTATS(2)) CALL UTPPTI(IDOUT,TBMXCL,2,ISTATS(3)) CALL UTPPTI(IDOUT,TBALLR,NODES,ISTATS(4)) CALL UTCDEF(IDOUT,COLNAM,CUNITS,CFORM,CTYPE,2,COLIDS,ISTATS(5)) CALL UTTCRE(IDOUT,ISTATS(6)) DO 200 I=1,6 IF(ISTATS(I).NE.0)THEN CONTXT='Error creating output table '//OUTNOD GO TO 999 ENDIF 200 CONTINUE C C COPY RESULTS TO TABLE C CALL UTCPTD(IDOUT,COLIDS(1),1,NODES,WNODES,ISTATS(1)) CALL UTCPTD(IDOUT,COLIDS(2),1,NODES,VNODES,ISTATS(2)) DO 210 I=1,2 IF(ISTATS(I).NE.0)THEN CONTXT='Error writing to output node table' GO TO 999 ENDIF 210 CONTINUE CALL UTTCLO(IDOUT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error closing output table '//OUTNOD GO TO 999 ENDIF C C WRITE OUTPUT REFERENCE FILES USING INPUT TEMPLATE FILES C CALL ZTPLAT(WTEMP,WNAME,WAVE,NS,IDOUT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Unable to write output wavelength file' GO TO 999 ENDIF CALL UHDPST(IDOUT,'grating',GRAT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error writing grating mode to header of '// * WNAME GO TO 999 ENDIF CALL UHDPST(IDOUT,'APERTURE',APER,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error writing aperture to header of '// * WNAME GO TO 999 ENDIF CALL UIMCLO(IDOUT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error closing file '//WNAME GO TO 999 ENDIF CALL ZTPLAT(STEMP,SNAME,FIT,NS,IDOUT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Unable to write output sensitivity file' GO TO 999 ENDIF CALL UHDPST(IDOUT,'grating',GRAT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error writing grating mode to header of '// * SNAME GO TO 999 ENDIF CALL UHDPST(IDOUT,'APERTURE',APER,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error writing aperture to header of '// * SNAME GO TO 999 ENDIF CALL UIMCLO(IDOUT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error closing file '//SNAME GO TO 999 ENDIF C C DONE C CALL UMSPUT('ABSFITZ completed normally',STDOUT,0,ISTAT) GO TO 1000 999 CALL UMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT) 1000 RETURN END